unikernel/duniverse/ocaml-tls/lwt/dune

@@ -0,0 +1,5 @@
+(library
+ (name tls_lwt)
+ (public_name tls-lwt)
+ (wrapped false)
+ (libraries tls lwt lwt.unix ptime.clock.os mirage-crypto-rng.unix))

unikernel/duniverse/ocaml-tls/lwt/examples/dune

@@ -0,0 +1,69 @@
+(library
+ (name ex_common)
+ (libraries lwt lwt.unix tls tls-lwt cmdliner fmt.cli logs.fmt fmt.tty logs.cli)
+ (modules ex_common))
+
+(executable
+ (name starttls_server)
+ (modules starttls_server)
+ (libraries tls-lwt lwt.unix ex_common))
+
+(executable
+ (name echo_server)
+ (modules echo_server)
+ (libraries tls-lwt lwt.unix ex_common))
+
+(executable
+ (name echo_server_sni)
+ (modules echo_server_sni)
+ (libraries tls-lwt lwt.unix ex_common))
+
+(executable
+ (name echo_server_alpn)
+ (modules echo_server_alpn)
+ (libraries tls-lwt lwt.unix ex_common))
+
+(executable
+ (name echo_client)
+ (modules echo_client)
+ (libraries tls-lwt lwt.unix ex_common))
+
+(executable
+ (name echo_client_alpn)
+ (modules echo_client_alpn)
+ (libraries tls-lwt lwt.unix ex_common))
+
+(executable
+ (name test_server)
+ (modules test_server)
+ (libraries tls-lwt lwt.unix ex_common))
+
+(executable
+ (name test_client)
+ (modules test_client)
+ (libraries tls-lwt lwt.unix ex_common))
+
+(executable
+ (name tls_over_tls)
+ (modules tls_over_tls)
+ (libraries tls-lwt lwt lwt.unix ex_common))
+
+(executable
+ (name http_client)
+ (modules http_client)
+ (libraries tls-lwt lwt.unix ex_common))
+
+(executable
+ (name fuzz_server)
+ (modules fuzz_server)
+ (libraries tls-lwt lwt.unix ex_common))
+
+(executable
+ (name resume_client)
+ (modules resume_client)
+ (libraries tls-lwt lwt.unix ex_common))
+
+(executable
+ (name resume_echo_server)
+ (modules resume_echo_server)
+ (libraries randomconv tls-lwt lwt.unix ex_common))

unikernel/duniverse/ocaml-tls/lwt/examples/echo_client.ml

@@ -0,0 +1,73 @@
+
+open Ex_common
+open Lwt
+
+let cached_session : Tls.Core.epoch_data =
+  let hex = Ohex.decode in
+  {
+    Tls.Core.side = `Client ;
+    protocol_version = `TLS_1_3 ;
+    ciphersuite = `DHE_RSA_WITH_AES_128_GCM_SHA256 ;
+    peer_random = hex "000102030405060708090a0b0c0d0e0f101112131415161718191a1b1c1d1e1f" ;
+    peer_certificate = None ;
+    peer_certificate_chain = [] ;
+    peer_name = None ;
+    trust_anchor = None ;
+    received_certificates = [] ;
+    own_random = hex "000102030405060708090a0b0c0d0e0f101112131415161718191a1b1c1d1e1f" ;
+    own_certificate = [] ;
+    own_private_key = None ;
+    own_name = None ;
+    master_secret = hex "000102030405060708090a0b0c0d0e0f101112131415161718191a1b1c1d1e1f" ;
+    exporter_master_secret = "" ;
+    session_id = "" ;
+    extended_ms = true ;
+    alpn_protocol = None ;
+    state = `Established ;
+    tls_unique = None ;
+  }
+
+let echo_client ?ca hostname port =
+  let open Lwt_io in
+  auth ?ca () >>= fun authenticator ->
+  X509_lwt.private_of_pems
+    ~cert:server_cert
+    ~priv_key:server_key >>= fun certificate ->
+  Tls_lwt.connect_ext
+    (get_ok Tls.Config.(client ~authenticator ~cached_session ~certificates:(`Single certificate) ~ciphers:Ciphers.supported ()))
+    (hostname, port) >>= fun (ic, oc) ->
+  Lwt.join [
+    lines ic    |> Lwt_stream.iter_s (printf "+ %s\n%!") ;
+    lines stdin |> Lwt_stream.iter_s (write_line oc)
+  ]
+
+let jump _ port host ca =
+  try
+    Lwt_main.run (echo_client ?ca host port)
+  with
+  | Tls_lwt.Tls_alert alert as exn ->
+    print_alert "remote end" alert ; raise exn
+  | Tls_lwt.Tls_failure alert as exn ->
+    print_fail "our end" alert ; raise exn
+
+open Cmdliner
+
+let port =
+  let doc = "Port to connect to" in
+  Arg.(value & opt int 443 & info [ "port" ] ~doc)
+
+let host =
+  let doc = "Host to connect to" in
+  Arg.(value & opt string "" & info [ "host" ] ~doc)
+
+let trust =
+  let doc = "Trust anchor" in
+  Arg.(value & opt (some string) None & info [ "trust" ] ~doc)
+
+let cmd =
+  let term = Term.(const jump $ setup_log $ port $ host $ trust)
+  and info = Cmd.info "echo_client" ~version:"2.0.3"
+  in
+  Cmd.v info term
+
+let () = exit (Cmd.eval cmd)

unikernel/duniverse/ocaml-tls/lwt/examples/echo_client_alpn.ml

@@ -0,0 +1,22 @@
+
+open Ex_common
+open Lwt
+
+let echo_client host port =
+  let open Lwt_io in
+  let port = int_of_string port in
+  let authenticator = null_auth in
+  Tls_lwt.Unix.connect
+    (get_ok Tls.Config.(client ~authenticator ~alpn_protocols:["http/1.1"; "h2"] ()))
+    (host, port) >>= fun t ->
+  match Tls_lwt.Unix.epoch t with
+  | Error () -> printl "Error"
+  | Ok epoch -> (
+    match epoch.Tls.Core.alpn_protocol with
+      | None -> printl "No protocol selected"
+      | Some protocol -> printl ("Selected protocol: " ^ protocol)
+  )
+    >>= fun () -> Tls_lwt.Unix.close t
+
+let () =
+  Lwt_main.run (echo_client "127.0.0.1" "4433")

unikernel/duniverse/ocaml-tls/lwt/examples/echo_server.ml

@@ -0,0 +1,75 @@
+open Lwt
+open Ex_common
+
+let string_of_unix_err err f p =
+  Printf.sprintf "Unix_error (%s, %s, %s)"
+    (Unix.error_message err) f p
+
+let serve_ssl port callback =
+
+  let tag = "server" in
+
+  X509_lwt.private_of_pems
+    ~cert:server_cert
+    ~priv_key:server_key >>= fun cert ->
+
+  let server_s () =
+    let open Lwt_unix in
+    let s = socket PF_INET SOCK_STREAM 0 in
+    setsockopt s SO_REUSEADDR true ;
+    bind s (ADDR_INET (Unix.inet_addr_any, port)) >|= fun () ->
+    listen s 10 ;
+    s in
+
+  let handle channels addr =
+    async @@ fun () ->
+      Lwt.catch (fun () -> callback channels addr >>= fun () -> yap ~tag "<- handler done")
+        (function
+          | Tls_lwt.Tls_alert a ->
+            yap ~tag @@ "handler: " ^ Tls.Packet.alert_type_to_string a
+          | Tls_lwt.Tls_failure a ->
+            yap ~tag @@ "handler: " ^ Tls.Engine.string_of_failure a
+          | Unix.Unix_error (e, f, p) ->
+            yap ~tag @@ "handler: " ^ (string_of_unix_err e f p)
+          | _exn -> yap ~tag "handler: exception")
+  in
+
+  yap ~tag ("-> start @ " ^ string_of_int port) >>= fun () ->
+  let rec loop s =
+    let authenticator = null_auth in
+    let config = get_ok (Tls.Config.server ~version:(`TLS_1_0, `TLS_1_3) ~ciphers:Tls.Config.Ciphers.supported ~reneg:true ~certificates:(`Single cert) ~authenticator ()) in
+    (Lwt.catch
+       (fun () -> Tls_lwt.accept_ext config s >|= fun r -> `R r)
+       (function
+         | Unix.Unix_error (e, f, p) -> return (`L (string_of_unix_err e f p))
+         | Tls_lwt.Tls_alert a -> return (`L (Tls.Packet.alert_type_to_string a))
+         | Tls_lwt.Tls_failure f -> return (`L (Tls.Engine.string_of_failure f))
+         | exn -> return (`L ("loop: exception: " ^ Printexc.to_string exn)))) >>= function
+    | `R (channels, addr) ->
+      yap ~tag "-> connect" >>= fun () -> ( handle channels addr ; loop s )
+    | `L (msg) ->
+      yap ~tag ("server socket: " ^ msg) >>= fun () -> loop s
+    in
+    server_s () >>= fun s ->
+    loop s
+
+let echo_server _ port =
+  Lwt_main.run (
+    serve_ssl port @@ fun (ic, oc) _addr ->
+    lines ic |> Lwt_stream.iter_s (fun line ->
+        yap ~tag:"handler" ("+ " ^ line) >>= fun () ->
+        Lwt_io.write_line oc line))
+
+open Cmdliner
+
+let port =
+  let doc = "Port to connect to" in
+  Arg.(value & opt int 4433 & info [ "port" ] ~doc)
+
+let cmd =
+  let term = Term.(ret (const echo_server $ setup_log $ port))
+  and info = Cmd.info "echo_server" ~version:"2.0.3"
+  in
+  Cmd.v info term
+
+let () = exit (Cmd.eval cmd)

unikernel/duniverse/ocaml-tls/lwt/examples/echo_server_alpn.ml

@@ -0,0 +1,68 @@
+
+open Lwt
+open Ex_common
+
+let split_on_char sep s =
+  let r = ref [] in
+  let j = ref (String.length s) in
+  for i = String.length s - 1 downto 0 do
+    if s.[i] = sep then begin
+      r := String.sub s (i + 1) (!j - i - 1) :: !r;
+      j := i
+    end
+  done;
+  String.sub s 0 !j :: !r
+
+let serve_ssl alpn_protocols port callback =
+
+  let tag = "server" in
+
+  X509_lwt.private_of_pems
+    ~cert:server_cert
+    ~priv_key:server_key >>= fun certificate ->
+
+  let server_s =
+    let open Lwt_unix in
+    let s = socket PF_INET SOCK_STREAM 0 in
+    bind s (ADDR_INET (Unix.inet_addr_any, port)) >|= fun () ->
+    listen s 10 ;
+    s in
+
+  let handle ep channels addr =
+    let alpn = match ep with
+      | Ok data -> (match data.Tls.Core.alpn_protocol with
+          | Some a -> a
+          | None -> "no alpn")
+      | Error () -> "no session"
+    in
+    async @@ fun () ->
+    Lwt.catch (fun () -> callback alpn channels addr >>= fun () -> yap ~tag "<- handler done")
+      (function
+        | Tls_lwt.Tls_alert a ->
+          yap ~tag @@ "handler: " ^ Tls.Packet.alert_type_to_string a
+        | exn -> yap ~tag "handler: exception" >>= fun () -> fail exn)
+  in
+
+  let ps = string_of_int port in
+  yap ~tag ("-> start @ " ^ ps ^ " (use `openssl s_client -connect host:" ^ ps ^ " -alpn <proto>`), available protocols: " ^ String.concat "," alpn_protocols) >>= fun () ->
+  let rec loop () =
+    let config = get_ok (Tls.Config.server ~certificates:(`Single certificate) ~alpn_protocols ()) in
+    server_s >>= fun s ->
+    Tls_lwt.Unix.accept config s >>= fun (t, addr) ->
+    yap ~tag "-> connect" >>= fun () ->
+    ( handle (Tls_lwt.Unix.epoch t) (Tls_lwt.of_t t) addr ; loop () )
+  in
+  loop ()
+
+
+let echo_server protocols port =
+  serve_ssl protocols port @@ fun alpn (ic, oc) _addr ->
+    lines ic |> Lwt_stream.iter_s (fun line ->
+      yap ~tag:("handler alpn: " ^ alpn) ("+ " ^ line) >>= fun () ->
+      Lwt_io.write_line oc line)
+
+let () =
+  let protocols =
+    try split_on_char ',' Sys.argv.(1) with _ -> [ "h2" ; "http/1.1" ]
+  in
+  Lwt_main.run (echo_server protocols 4433)

unikernel/duniverse/ocaml-tls/lwt/examples/echo_server_sni.ml

@@ -0,0 +1,61 @@
+
+open Lwt
+open Ex_common
+
+let serve_ssl port callback =
+
+  let tag = "server" in
+
+  X509_lwt.private_of_pems
+    ~cert:(ca_cert_dir ^ "/bar.pem")
+    ~priv_key:server_key >>= fun barcert ->
+
+  X509_lwt.private_of_pems
+    ~cert:(ca_cert_dir ^ "/foo.pem")
+    ~priv_key:server_key >>= fun foocert ->
+
+  let server_s =
+    let open Lwt_unix in
+    let s = socket PF_INET SOCK_STREAM 0 in
+    bind s (ADDR_INET (Unix.inet_addr_any, port)) >|= fun () ->
+    listen s 10 ;
+    s in
+
+  let handle ep channels addr =
+    let host = match ep with
+      | Ok data -> ( match data.Tls.Core.own_name with
+          | Some n -> Domain_name.to_string n
+          | None -> "no name" )
+      | Error () -> "no session"
+    in
+    async @@ fun () ->
+    Lwt.catch (fun () -> callback host channels addr >>= fun () -> yap ~tag "<- handler done")
+      (function
+        | Tls_lwt.Tls_alert a ->
+          yap ~tag @@ "handler: " ^ Tls.Packet.alert_type_to_string a
+        | exn -> yap ~tag "handler: exception" >>= fun () -> fail exn)
+  in
+
+  let ps = string_of_int port in
+  yap ~tag ("-> start @ " ^ ps ^ " (use `openssl s_client -connect host:" ^ ps ^ " -servername foo` (or -servername bar))") >>= fun () ->
+  let rec loop () =
+    let config = get_ok (Tls.Config.server ~certificates:(`Multiple [barcert ; foocert]) ()) in
+    server_s >>= fun s ->
+    Tls_lwt.Unix.accept config s >>= fun (t, addr) ->
+    yap ~tag "-> connect" >>= fun () ->
+    ( handle (Tls_lwt.Unix.epoch t) (Tls_lwt.of_t t) addr ; loop () )
+  in
+  loop ()
+
+
+let echo_server port =
+  serve_ssl port @@ fun host (ic, oc) _addr ->
+    lines ic |> Lwt_stream.iter_s (fun line ->
+      yap ~tag:("handler " ^ host) ("+ " ^ line) >>= fun () ->
+      Lwt_io.write_line oc line)
+
+let () =
+  let port =
+    try int_of_string Sys.argv.(1) with _ -> 4433
+  in
+  Lwt_main.run (echo_server port)

unikernel/duniverse/ocaml-tls/lwt/examples/ex_common.ml

@@ -0,0 +1,55 @@
+
+open Lwt
+
+let o f g x = f (g x)
+
+let ca_cert_dir = "./certificates"
+let server_cert = "./certificates/server.pem"
+let server_key  = "./certificates/server.key"
+let server_ec_cert = "./certificates/server-ec.pem"
+let server_ec_key  = "./certificates/server-ec.key"
+
+let yap ~tag msg = Lwt_io.printf "(%s %s)\n%!" tag msg
+
+let lines ic =
+  Lwt_stream.from @@ fun () ->
+    Lwt_io.read_line_opt ic >>= function
+      | None -> Lwt_io.close ic >>= fun () -> return_none
+      | line -> return line
+
+let print_alert where alert =
+    Printf.eprintf "(TLS ALERT (%s): %s)\n%!"
+      where (Tls.Packet.alert_type_to_string alert)
+
+let print_fail where fail =
+  Printf.eprintf "(TLS FAIL (%s): %s)\n%!"
+    where (Tls.Engine.string_of_failure fail)
+
+let null_auth ?ip:_ ~host:_ _ = Ok None
+
+let auth ?ca ?fp () =
+  match ca with
+  | Some "NONE" when fp = None -> Lwt.return null_auth
+  | _ ->
+    let a = match ca, fp with
+      | None, Some fp  -> `Hex_key_fingerprint (`SHA256, fp)
+      | None, _ -> `Ca_dir ca_cert_dir
+      | Some f, _ -> `Ca_file f
+    in
+    X509_lwt.authenticator a
+
+let setup_log style_renderer level =
+  Fmt_tty.setup_std_outputs ?style_renderer ();
+  Logs.set_level level;
+  Logs.set_reporter (Logs_fmt.reporter ~dst:Format.std_formatter ())
+
+open Cmdliner
+
+let setup_log =
+  Term.(const setup_log
+        $ Fmt_cli.style_renderer ()
+        $ Logs_cli.level ())
+
+let get_ok = function
+  | Ok cfg -> cfg
+  | Error `Msg msg -> invalid_arg msg

unikernel/duniverse/ocaml-tls/lwt/examples/fuzz_server.ml

@@ -0,0 +1,101 @@
+open Lwt
+open Ex_common
+
+let string_of_unix_err err f p =
+  Printf.sprintf "Unix_error (%s, %s, %s)"
+    (Unix.error_message err) f p
+
+let add_to_cache, find_in_cache =
+  let c = ref [] in
+  (fun ticket session ->
+     let id = ticket.Tls.Core.identifier in
+     Logs.info (fun m -> m "adding id %a to cache" Ohex.pp id) ;
+     c := (id, (ticket, session)) :: !c),
+  (fun id -> match List.find_opt (fun (id', _) -> String.compare id id' = 0) !c with
+     | None -> None
+     | Some (_, ep) -> Some ep)
+
+let ticket_cache = {
+  Tls.Config.lookup = find_in_cache ;
+  ticket_granted = add_to_cache ;
+  lifetime = 300l ;
+  timestamp = Ptime_clock.now
+}
+
+let serve_ssl port callback =
+
+  let tag = "server" in
+
+  X509_lwt.private_of_pems
+    ~cert:server_cert
+    ~priv_key:server_key >>= fun cert ->
+
+  let server_s () =
+    let open Lwt_unix in
+    let s = socket PF_INET SOCK_STREAM 0 in
+    setsockopt s SO_REUSEADDR true ;
+    bind s (ADDR_INET (Unix.inet_addr_any, port)) >|= fun () ->
+    listen s 10 ;
+    s in
+
+  let handle channels addr =
+    async @@ fun () ->
+      Lwt.catch (fun () -> callback channels addr >>= fun () -> yap ~tag "<- handler done")
+        (function
+          | Tls_lwt.Tls_alert a ->
+            yap ~tag @@ "handler: " ^ Tls.Packet.alert_type_to_string a
+          | Tls_lwt.Tls_failure a ->
+            yap ~tag @@ "handler: " ^ Tls.Engine.string_of_failure a
+          | Unix.Unix_error (e, f, p) ->
+            yap ~tag @@ "handler: " ^ (string_of_unix_err e f p)
+          | _exn -> yap ~tag "handler: exception")
+  in
+
+  yap ~tag ("-> start @ " ^ string_of_int port) >>= fun () ->
+  let rec loop s =
+    let config = get_ok (Tls.Config.server ~ticket_cache ~reneg:true ~certificates:(`Single cert) ~version:(`TLS_1_2, `TLS_1_3) ~zero_rtt:32768l ()) in
+    (Lwt.catch
+       (fun () -> Tls_lwt.Unix.accept config s >|= fun r -> `R r)
+       (function
+         | Unix.Unix_error (e, f, p) -> return (`L (string_of_unix_err e f p))
+         | Tls_lwt.Tls_alert a -> return (`L (Tls.Packet.alert_type_to_string a))
+         | Tls_lwt.Tls_failure f -> return (`L (Tls.Engine.string_of_failure f))
+         | exn -> let str = Printexc.to_string exn in return (`L ("loop: exception " ^ str)))) >>= function
+    | `R (t, addr) ->
+      let channels = Tls_lwt.of_t t in
+      yap ~tag "-> connect" >>= fun () -> ( handle channels addr ; loop s )
+    | `L (msg) ->
+      yap ~tag ("server socket: " ^ msg) >>= fun () -> loop s
+    in
+    server_s () >>= fun s ->
+    loop s
+
+let echo_server port =
+  serve_ssl port @@ fun (ic, oc) _addr ->
+    yap ~tag:"handler" "accepted" >>= fun () ->
+    let out = "HTTP/1.1 404 Not Found\r\n\r\n" in
+    Lwt_io.write_from_string_exactly oc out 0 (String.length out) >>= fun () ->
+    (*    Lwt_io.close oc *)
+    let rec loop () =
+      Lwt_io.read_line ic >>= fun line ->
+      yap ~tag:"handler" ("+ " ^ line) >>= fun () ->
+      loop ()
+    in
+    loop ()
+
+let jump _ port =
+  Lwt_main.run (echo_server port)
+
+open Cmdliner
+
+let port =
+  let doc = "Port to connect to" in
+  Arg.(value & opt int 4433 & info [ "port" ] ~doc)
+
+let cmd =
+  let term = Term.(ret (const jump $ setup_log $ port))
+  and info = Cmd.info "fuzz_server" ~version:"2.0.3"
+  in
+  Cmd.v info term
+
+let () = exit (Cmd.eval cmd)

unikernel/duniverse/ocaml-tls/lwt/examples/http_client.ml

@@ -0,0 +1,29 @@
+
+open Lwt
+open Ex_common
+
+let http_client ?ca ?fp hostname port =
+  let port          = int_of_string port in
+  auth ?ca ?fp () >>= fun authenticator ->
+  Tls_lwt.connect_ext
+    (get_ok (Tls.Config.client ~authenticator ()))
+    (hostname, port) >>= fun (ic, oc) ->
+  let req = String.concat "\r\n" [
+    "GET / HTTP/1.1" ; "Host: " ^ hostname ; "Connection: close" ; "" ; ""
+  ] in
+  Lwt_io.(write oc req >>= fun () -> read ic >>= print >>= fun () -> printf "++ done.\n%!")
+
+let () =
+  try
+    match Sys.argv with
+    | [| _ ; host ; port ; "FP" ; fp |] -> Lwt_main.run (http_client host port ~fp)
+    | [| _ ; host ; port ; trust |] -> Lwt_main.run (http_client host port ~ca:trust)
+    | [| _ ; host ; port |]         -> Lwt_main.run (http_client host port)
+    | [| _ ; host |]                -> Lwt_main.run (http_client host "443")
+    | args                          -> Printf.eprintf "%s <host> <port>\n%!" args.(0)
+  with
+  | Tls_lwt.Tls_alert alert as exn ->
+      print_alert "remote end" alert ; raise exn
+  | Tls_lwt.Tls_failure fail as exn ->
+      print_fail "our end" fail ; raise exn
+

unikernel/duniverse/ocaml-tls/lwt/examples/resume_client.ml

@@ -0,0 +1,39 @@
+
+open Lwt
+open Ex_common
+
+let http_client ?ca ?fp hostname port =
+  let port          = int_of_string port in
+  auth ?ca ?fp () >>= fun authenticator ->
+  let config = get_ok (Tls.Config.client ~authenticator ()) in
+  Tls_lwt.Unix.connect config (hostname, port) >>= fun t ->
+  Tls_lwt.Unix.write t "foo\n" >>= fun () ->
+  let cs = Bytes.create 4 in
+  Tls_lwt.Unix.read t cs >>= fun _len ->
+  let cached_session = match Tls_lwt.Unix.epoch t with
+    | Ok e -> e
+    | Error () -> invalid_arg "error retrieving epoch"
+  in
+  Tls_lwt.Unix.close t >>= fun () ->
+  Printf.printf "closed session\n" ;
+  let config = get_ok (Tls.Config.client ~authenticator ~cached_session ()) in
+  Tls_lwt.connect_ext config (hostname, port) >>= fun (ic, oc) ->
+  let req = String.concat "\r\n" [
+    "GET / HTTP/1.1" ; "Host: " ^ hostname ; "Connection: close" ; "" ; ""
+  ] in
+  Lwt_io.(write oc req >>= fun () -> read ic >>= print >>= fun () -> printf "++ done.\n%!")
+
+let () =
+  try
+    match Sys.argv with
+    | [| _ ; host ; port ; "FP" ; fp |] -> Lwt_main.run (http_client host port ~fp)
+    | [| _ ; host ; port ; trust |] -> Lwt_main.run (http_client host port ~ca:trust)
+    | [| _ ; host ; port |]         -> Lwt_main.run (http_client host port)
+    | [| _ ; host |]                -> Lwt_main.run (http_client host "443")
+    | args                          -> Printf.eprintf "%s <host> <port>\n%!" args.(0)
+  with
+  | Tls_lwt.Tls_alert alert as exn ->
+      print_alert "remote end" alert ; raise exn
+  | Tls_lwt.Tls_failure fail as exn ->
+      print_fail "our end" fail ; raise exn
+

unikernel/duniverse/ocaml-tls/lwt/examples/resume_echo_server.ml

@@ -0,0 +1,123 @@
+open Lwt
+open Ex_common
+
+let string_of_unix_err err f p =
+  Printf.sprintf "Unix_error (%s, %s, %s)"
+    (Unix.error_message err) f p
+
+
+module HT = Hashtbl.Make (Tls.Core.PreSharedKeyID)
+let cache_psk, psk_cache =
+  let cache = HT.create 7 in
+  ((fun psk ed -> HT.add cache psk.Tls.Core.identifier (psk, ed)),
+   HT.find_opt cache)
+
+let ticket_cache = {
+  Tls.Config.lookup = psk_cache ;
+  ticket_granted = cache_psk ;
+  lifetime = 300l ;
+  timestamp = Ptime_clock.now
+}
+
+let serve_ssl port callback =
+
+  let tag = "server" in
+
+  X509_lwt.private_of_pems
+    ~cert:server_cert
+    ~priv_key:server_key >>= fun cert ->
+
+  let hex = Ohex.decode in
+  let epoch =
+    {
+      Tls.Core.side = `Client ;
+      state = `Established ;
+      protocol_version = `TLS_1_3 ;
+      ciphersuite = `DHE_RSA_WITH_AES_128_GCM_SHA256 ;
+      peer_random = hex "000102030405060708090a0b0c0d0e0f101112131415161718191a1b1c1d1e1f" ;
+      peer_certificate_chain = [] ;
+      peer_certificate = None ;
+      peer_name = None ;
+      trust_anchor = None ;
+      received_certificates = [] ;
+      own_random = hex "000102030405060708090a0b0c0d0e0f101112131415161718191a1b1c1d1e1f" ;
+      own_certificate = fst cert ;
+      own_private_key = Some (snd cert) ;
+      own_name = Some Domain_name.(host_exn (of_string_exn "tls13test.nqsb.io")) ;
+      master_secret = hex "000102030405060708090a0b0c0d0e0f101112131415161718191a1b1c1d1e1f" ;
+      exporter_master_secret = "" ;
+      session_id = "" ;
+      extended_ms = true ;
+      alpn_protocol = None ;
+      tls_unique = None ;
+    }
+  and psk = {
+    Tls.Core.identifier = hex "0000" ;
+    obfuscation = Randomconv.int32 Mirage_crypto_rng.generate ;
+    secret = hex "000102030405060708090a0b0c0d0e0f101112131415161718191a1b1c1d1e1f" ;
+    lifetime = 300l ;
+    early_data = 0l ;
+    issued_at = Ptime_clock.now ();
+  }
+  in
+  cache_psk psk epoch ;
+
+  let server_s () =
+    let open Lwt_unix in
+    let s = socket PF_INET SOCK_STREAM 0 in
+    setsockopt s SO_REUSEADDR true ;
+    bind s (ADDR_INET (Unix.inet_addr_any, port)) >|= fun () ->
+    listen s 10 ;
+    s in
+
+  let handle channels =
+    async @@ fun () ->
+      Lwt.catch (fun () -> callback channels >>= fun () -> yap ~tag "<- handler done")
+        (function
+          | Tls_lwt.Tls_alert a ->
+            yap ~tag @@ "handler: " ^ Tls.Packet.alert_type_to_string a
+          | Tls_lwt.Tls_failure a ->
+            yap ~tag @@ "handler: " ^ Tls.Engine.string_of_failure a
+          | Unix.Unix_error (e, f, p) ->
+            yap ~tag @@ "handler: " ^ (string_of_unix_err e f p)
+          | _exn -> yap ~tag "handler: exception")
+  in
+
+  yap ~tag ("-> start @ " ^ string_of_int port) >>= fun () ->
+  let rec loop s =
+    let authenticator ?ip:_ ~host:_ _ = Ok None in
+    let config = get_ok (Tls.Config.server ~certificates:(`Single cert) ~ticket_cache ~authenticator ()) in
+    (Lwt.catch
+       (fun () ->
+          Lwt_unix.accept s >>= fun (s, addr) ->
+          let txt = Unix.(match addr with
+              | ADDR_UNIX x -> "unix-" ^ x
+              | ADDR_INET (ip, p) -> string_of_inet_addr ip ^ ":" ^ string_of_int p)
+          in
+          yap ~tag:"client-connect" txt >>= fun () ->
+          Tls_lwt.Unix.server_of_fd config s >|= fun t -> `R t)
+       (function
+         | Unix.Unix_error (e, f, p) -> return (`L (string_of_unix_err e f p))
+         | Tls_lwt.Tls_alert a -> return (`L (Tls.Packet.alert_type_to_string a))
+         | Tls_lwt.Tls_failure f -> return (`L (Tls.Engine.string_of_failure f))
+         | exn -> let str = Printexc.to_string exn in return (`L ("loop: exception " ^ str)))) >>= function
+    | `R t ->
+       yap ~tag "-> connect" >>= fun () ->
+       handle (Tls_lwt.of_t t); loop s
+    | `L msg ->
+        yap ~tag ("server socket: " ^ msg) >>= fun () -> loop s
+    in
+    server_s () >>= fun s ->
+    loop s
+
+let echo_server port =
+  serve_ssl port @@ fun (ic, oc) ->
+    lines ic |> Lwt_stream.iter_s (fun line ->
+      yap ~tag:"handler" ("+ " ^ string_of_int (String.length line)) >>= fun () ->
+      Lwt_io.write_line oc line)
+
+let () =
+  let port =
+    try int_of_string Sys.argv.(1) with _ -> 4433
+  in
+  Lwt_main.run (echo_server port)

unikernel/duniverse/ocaml-tls/lwt/examples/starttls_server.ml

@@ -0,0 +1,74 @@
+open Lwt.Infix
+open Ex_common
+
+let capability = "[CAPABILITY IMAP4rev1 LITERAL+ SASL-IR LOGIN-REFERRALS ID ENABLE IDLE STARTTLS AUTH=PLAIN] server ready.\r\n"
+
+let ok_starttls = "OK STARTTLS\r\n"
+
+let cert () =
+  X509_lwt.private_of_pems
+  ~cert:"./certificates/server.pem"
+  ~priv_key:"./certificates/server.key"
+
+let init_socket addr port =
+  let sockaddr = Unix.ADDR_INET (Unix.inet_addr_of_string addr, port) in
+  let socket = Lwt_unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in
+  Lwt_unix.setsockopt socket Unix.SO_REUSEADDR true;
+  Lwt_unix.bind socket sockaddr >|= fun () ->
+  socket
+
+let create_srv_socket addr port =
+  init_socket addr port >|= fun socket ->
+  Lwt_unix.listen socket 10;
+  socket
+
+let accept sock =
+  Lwt_unix.accept sock >>= fun (sock_cl, addr) ->
+  let ic = Lwt_io.of_fd ~close:(fun () -> Lwt.return_unit) ~mode:Lwt_io.input sock_cl in
+  let oc = Lwt_io.of_fd ~close:(fun () -> Lwt.return_unit) ~mode:Lwt_io.output sock_cl in
+  Lwt.return ((ic,oc), addr, sock_cl)
+
+let start_server () =
+  let write oc buff =
+    Lwt_io.write oc buff >>= fun () -> Lwt_io.flush oc
+  in
+  let read ic =
+    Lwt_io.read ic ~count:2048 >>= fun buff ->
+    Printf.printf "%s%!" buff;
+    Lwt.return buff
+  in
+  let parse buff =
+    match String.index buff ' ' with
+    | exception Not_found -> "", ""
+    | idx ->
+      let l = String.length buff in
+      String.sub buff 0 idx, String.sub buff (succ idx) (l - succ idx)
+  in
+  let rec wait_cmd sock_cl ic oc =
+    read ic >>= fun buff ->
+    let tag,cmd = parse buff in
+    match cmd with
+    | "CAPABILITY" ->
+      write oc ("* " ^ capability ^ tag ^ " OK CAPABILITY\r\n") >>= fun () ->
+      wait_cmd sock_cl ic oc
+    | "STARTTLS" ->
+      write oc (tag ^ ok_starttls) >>= fun () ->
+      Lwt_io.close ic >>= fun () ->
+      Lwt_io.close oc >>= fun () ->
+      cert () >>= fun cert ->
+      Tls_lwt.Unix.server_of_fd
+        (get_ok (Tls.Config.server ~certificates:(`Single cert) ())) sock_cl >>= fun s ->
+      let ic,oc = Tls_lwt.of_t s in
+      write oc ("* OK " ^ capability) >>= fun () ->
+      wait_cmd sock_cl ic oc
+    | _ ->
+      write oc ("BAD\r\n") >>= fun () ->
+      wait_cmd sock_cl ic oc
+  in
+  create_srv_socket "127.0.0.1" 143 >>= fun sock ->
+  accept sock >>= fun ((ic,oc), _addr, sock_cl) ->
+  write oc ("* OK " ^ capability) >>= fun () ->
+  wait_cmd sock_cl ic oc
+
+let () =
+  Lwt_main.run (start_server ())

unikernel/duniverse/ocaml-tls/lwt/examples/test_client.ml

@@ -0,0 +1,49 @@
+open Lwt
+open Ex_common
+
+let mypsk = ref None
+
+let ticket_cache = {
+  Tls.Config.lookup = (fun _ -> None) ;
+  ticket_granted = (fun psk epoch -> mypsk := Some (psk, epoch)) ;
+  lifetime = 0l ;
+  timestamp = Ptime_clock.now
+}
+
+let test_client _ =
+(*  X509_lwt.private_of_pems
+    ~cert:server_cert
+    ~priv_key:server_key >>= fun cert -> *)
+  let port = 4433 in
+  let host = "127.0.0.1" in
+  let authenticator = null_auth in
+  Tls_lwt.Unix.connect
+    (get_ok Tls.Config.(client ~version:(`TLS_1_0, `TLS_1_3) (* ~certificates:(`Single cert) *) ?cached_ticket:!mypsk ~ticket_cache ~authenticator ~ciphers:Ciphers.supported ()))
+    (host, port) >>= fun t ->
+  let (ic, oc) = Tls_lwt.of_t t in
+  let req = String.concat "\r\n" [
+    "GET / HTTP/1.1" ; "Host: " ^ host ; "Connection: close" ; "" ; ""
+  ] in
+  Lwt_io.(write oc req >>= fun () ->
+          read ~count:3 ic >>= print >>= fun () ->
+          close oc >>= fun () ->
+          printf "++ done.\n%!")
+
+let jump _ =
+  try
+    Lwt_main.run (test_client ()) ; `Ok ()
+  with
+  | Tls_lwt.Tls_alert alert as exn ->
+      print_alert "remote end" alert ; raise exn
+  | Tls_lwt.Tls_failure alert as exn ->
+      print_fail "our end" alert ; raise exn
+
+open Cmdliner
+
+let cmd =
+  let term = Term.(ret (const jump $ setup_log))
+  and info = Cmd.info "test_client" ~version:"2.0.3"
+  in
+  Cmd.v info term
+
+let () = exit (Cmd.eval cmd)

unikernel/duniverse/ocaml-tls/lwt/examples/test_server.ml

@@ -0,0 +1,47 @@
+
+open Lwt
+open Ex_common
+
+let serve_ssl port callback =
+
+  let tag = "server" in
+
+  X509_lwt.private_of_pems
+    ~cert:server_cert
+    ~priv_key:server_key >>= fun certificate ->
+  X509_lwt.private_of_pems
+    ~cert:server_ec_cert
+    ~priv_key:server_ec_key >>= fun ec_certificate ->
+  let certificates = `Multiple [ certificate ; ec_certificate ] in
+  let config =
+    get_ok (Tls.Config.(server ~version:(`TLS_1_0, `TLS_1_3) ~certificates ~ciphers:Ciphers.supported ()))
+  in
+
+  let server_s =
+    let open Lwt_unix in
+    let s = socket PF_INET SOCK_STREAM 0 in
+    setsockopt s Unix.SO_REUSEADDR true ;
+    bind s (ADDR_INET (Unix.inet_addr_any, port)) >|= fun () ->
+    listen s 10 ;
+    s in
+
+  yap ~tag ("-> start @ " ^ string_of_int port) >>= fun () ->
+  server_s >>= fun s ->
+  Tls_lwt.Unix.accept config s >>= fun (t, addr) ->
+  let channels = Tls_lwt.of_t t in
+  yap ~tag "-> connect" >>= fun () ->
+  callback channels addr >>= fun () ->
+  yap ~tag "<- handler done"
+
+let test_server port =
+  serve_ssl port @@ fun (ic, oc) _addr ->
+    yap ~tag:"handler" "accepted" >>= fun () ->
+    Lwt_io.read_line ic >>= fun line ->
+    yap ~tag:"handler" ("+ " ^ line) >>= fun () ->
+    Lwt_io.write_line oc line
+
+let () =
+  let port =
+    try int_of_string Sys.argv.(1) with _ -> 4433
+  in
+  Lwt_main.run (test_server port)

unikernel/duniverse/ocaml-tls/lwt/examples/tls_over_tls.ml

@@ -0,0 +1,70 @@
+open Lwt
+open Ex_common
+
+let hostname = "mirage.io"
+
+let proxy = "127.0.0.1", 3129
+
+(* To test TLS-over-TLS, the `squid` proxy can be installed locally and configured to support HTTPS:
+
+- Generate a certificate for localhost: https://gist.github.com/cecilemuller/9492b848eb8fe46d462abeb26656c4f8
+
+$ openssl req -x509 -nodes -new -sha256 -days 1024 -newkey rsa:2048 -keyout RootCA.key -out RootCA.pem -subj "/C=US/CN=Example-Root-CA"
+$ openssl x509 -outform pem -in RootCA.pem -out RootCA.crt
+$ cat <<EOF > domains.ext
+authorityKeyIdentifier=keyid,issuer
+basicConstraints=CA:FALSE
+keyUsage = digitalSignature, nonRepudiation, keyEncipherment, dataEncipherment
+subjectAltName = @alt_names
+[alt_names]
+DNS.1 = localhost
+EOF
+$ openssl req -new -nodes -newkey rsa:2048 -keyout localhost.key -out localhost.csr -subj "/C=US/ST=YourState/L=YourCity/O=Example-Certificates/CN=localhost.local"
+$ openssl x509 -req -sha256 -days 1024 -in localhost.csr -CA RootCA.pem -CAkey RootCA.key -CAcreateserial -extfile domains.ext -out localhost.crt
+
+- Configure squid by adding HTTPS support on port 3129 in /etc/squid/squid.conf :
+
+https_port 3129 tls-cert=/path/to/localhost.crt tls-key=/path/to/localhost.key
+
+*)
+
+let client = get_ok (Tls.Config.client ~authenticator:null_auth ())
+
+let string_prefix ~prefix msg =
+  let len = String.length prefix in
+  String.length msg >= len && String.sub msg 0 len = prefix
+
+let host = Result.get_ok (Domain_name.of_string hostname)
+let host = Result.get_ok (Domain_name.host host)
+
+let test_client _ =
+  (* Connect to proxy *)
+  Tls_lwt.Unix.connect client proxy >>= fun t ->
+  let (ic, oc) = Tls_lwt.of_t t in
+
+  (* Request proxy to connect to hostname *)
+  let req =
+    Printf.sprintf "CONNECT %s:443 HTTP/1.1\r\nHost: %s\r\n\r\n"
+      hostname hostname
+  in
+  Lwt_io.write oc req >>= fun () ->
+  Lwt_io.read ic ~count:1024 >>= fun msg ->
+  assert (string_prefix ~prefix:"HTTP/1.1 200 " msg) ;
+
+  (* TLS with hostname, over the TLS connection with the proxy *)
+  Tls_lwt.Unix.client_of_channels client ~host (ic, oc) >>= fun t ->
+  let (ic, oc) = Tls_lwt.of_t t in
+
+  (* Request homepage from host *)
+  let req =
+    Printf.sprintf "GET / HTTP/1.1\r\nHost: %s\r\nConnection: close\r\n\r\n"
+      hostname
+  in
+
+  Lwt_io.(write oc req >>= fun () ->
+          read ~count:1024 ic >>= print >>= fun () ->
+          read ~count:1024 ic >>= print >>= fun () ->
+          close oc >>= fun () ->
+          printf "++ done.\n%!")
+
+let () = Lwt_main.run (test_client ())

unikernel/duniverse/ocaml-tls/lwt/tls_lwt.ml

@@ -0,0 +1,364 @@
+open Lwt.Infix
+
+exception Tls_alert   of Tls.Packet.alert_type
+exception Tls_failure of Tls.Engine.failure
+
+(* This really belongs just about anywhere else: generic unix name resolution. *)
+let resolve host service =
+  let open Lwt_unix in
+  getprotobyname "tcp" >>= fun tcp ->
+  getaddrinfo host service [AI_PROTOCOL tcp.p_proto] >>= function
+  | []    ->
+      let msg = Printf.sprintf "no address for %s:%s" host service in
+      Lwt.reraise (Invalid_argument msg)
+  | ai::_ -> Lwt.return ai.ai_addr
+
+module Lwt_cs = struct
+
+  let naked ~name f fd cs off len =
+    f fd cs off len >>= fun res ->
+    match Lwt_unix.getsockopt_error fd with
+    | None     -> Lwt.return res
+    | Some err -> Lwt.reraise @@ Unix.Unix_error (err, name, "")
+
+  let write = naked ~name:"Tls_lwt.write" Lwt_unix.write
+  and read  = naked ~name:"Tls_lwt.read"  Lwt_unix.read
+
+  let rec write_full ?(off = 0) ?len fd buf =
+    let len = Option.value ~default:(String.length buf - off) len in
+    if len = 0 then
+      Lwt.return_unit
+    else
+      write fd (Bytes.unsafe_of_string buf) off len >>= fun written ->
+      write_full ~off:(off + written) ~len:(len - written) fd buf
+
+  let read fd buf = read fd buf 0 (Bytes.length buf)
+end
+
+module Lwt_fd = struct
+  type t = {
+    read  : bytes -> int Lwt.t ;
+    write : string -> unit Lwt.t ;
+    close : unit -> unit Lwt.t ;
+  }
+
+  let read t cs = t.read cs
+  let write t cs = t.write cs
+  let close t = t.close ()
+
+  let of_fd fd =
+    let close () =
+      (* (partially) avoid double-closes by checking if the fd has already been closed *)
+      match Lwt_unix.state fd with
+      | Lwt_unix.Closed -> Lwt.return_unit
+      | Lwt_unix.Opened | Lwt_unix.Aborted _ -> Lwt_unix.close fd
+    in
+    {
+      read  = Lwt_cs.read fd ;
+      write = Lwt_cs.write_full fd ;
+      close = close ;
+    }
+
+  let of_channels ic oc =
+    {
+      read  = (fun bs -> Lwt_io.read_into ic bs 0 (Bytes.length bs)) ;
+      write = (Lwt_io.write oc) ;
+      close = (fun () -> Lwt_io.close oc <&> Lwt_io.close ic) ;
+    }
+end
+
+module Unix = struct
+
+  type t = {
+    fd             : Lwt_fd.t ;
+    mutable state  : [ `Active of Tls.Engine.state
+                     | `Read_closed of Tls.Engine.state
+                     | `Write_closed of Tls.Engine.state
+                     | `Closed
+                     | `Error of exn ] ;
+    mutable linger : string option ;
+    recv_buf       : bytes ;
+  }
+
+  let half_close state mode =
+    match state, mode with
+    | `Active tls, `read -> `Read_closed tls
+    | `Active tls, `write -> `Write_closed tls
+    | `Active _, `read_write -> `Closed
+    | `Read_closed tls, `read -> `Read_closed tls
+    | `Read_closed _, (`write | `read_write) -> `Closed
+    | `Write_closed tls, `write -> `Write_closed tls
+    | `Write_closed _, (`read | `read_write) -> `Closed
+    | (`Closed | `Error _) as e, (`read | `write | `read_write) -> e
+
+  let inject_state tls = function
+    | `Active _ -> `Active tls
+    | `Read_closed _ -> `Read_closed tls
+    | `Write_closed _ -> `Write_closed tls
+    | (`Closed | `Error _) as e -> e
+
+  let safely th =
+    Lwt.catch
+      (fun () -> th >>= fun _ -> Lwt.return_unit)
+      (function
+        | Out_of_memory -> raise Out_of_memory
+        | _ -> Lwt.return_unit)
+
+  let (read_t, write_t) =
+    let recording_errors op t cs =
+      Lwt.catch
+        (fun () -> op t.fd cs)
+        (function
+          | Out_of_memory -> raise Out_of_memory
+          | exn -> (match t.state with
+              | `Error _ -> ()
+              | _ -> t.state <- `Error exn) ;
+            Lwt.reraise exn)
+    in
+    (recording_errors Lwt_fd.read, recording_errors Lwt_fd.write)
+
+  let when_some f = function None -> Lwt.return_unit | Some x -> f x
+
+  let rec read_react t =
+
+    let handle tls buf =
+      match Tls.Engine.handle_tls tls buf with
+      | Ok (state', eof, `Response resp, `Data data) ->
+          let state' = inject_state state' t.state in
+          let state' = Option.(value ~default:state' (map (fun `Eof -> half_close state' `read) eof)) in
+          t.state <- state' ;
+          safely (resp |> when_some (write_t t)) >|= fun () ->
+          `Ok data
+
+      | Error (fail, `Response resp) ->
+          t.state <- `Error (match fail with
+            | `Alert a -> Tls_alert a
+            | f -> Tls_failure f);
+          write_t t resp >>= fun () -> read_react t
+    in
+
+    match t.state with
+    | `Error e -> Lwt.reraise e
+    | `Closed
+    | `Read_closed _ -> Lwt.return `Eof
+    | _ ->
+        read_t t t.recv_buf >>= function
+        | 0 ->
+          t.state <- half_close t.state `read;
+          Lwt.return `Eof
+        | n ->
+          match t.state with
+          | `Error e -> Lwt.reraise e
+          | `Active tls | `Read_closed tls | `Write_closed tls ->
+            handle tls (String.sub (Bytes.unsafe_to_string t.recv_buf) 0 n)
+          | `Closed -> Lwt.return `Eof
+
+  let rec read t ?(off = 0) buf =
+    if off < 0 || off >= Bytes.length buf then
+      invalid_arg "offset must be >= 0 and < Bytes.length buf";
+
+    let writeout res =
+      let rlen = String.length res in
+      let n    = min (Bytes.length buf - off) rlen in
+      Bytes.blit_string res 0 buf off n ;
+      t.linger <-
+        (if n < rlen then Some (String.sub res n (rlen - n)) else None) ;
+      Lwt.return n in
+
+    match t.linger with
+    | Some res -> writeout res
+    | None     ->
+        read_react t >>= function
+          | `Eof           -> Lwt.return 0
+          | `Ok None       -> read t ~off buf
+          | `Ok (Some res) -> writeout res
+
+  let writev t css =
+    match t.state with
+    | `Error err  -> Lwt.reraise err
+    | `Write_closed _ | `Closed -> Lwt.reraise @@ Invalid_argument "tls: closed socket"
+    | `Active tls | `Read_closed tls ->
+        match Tls.Engine.send_application_data tls css with
+        | Some (tls, tlsdata) ->
+            ( t.state <- inject_state tls t.state ; write_t t tlsdata )
+        | None -> Lwt.reraise @@ Invalid_argument "tls: write: socket not ready"
+
+  let write t cs = writev t [cs]
+
+  (*
+   * XXX bad XXX
+   * This is a point that should particularly be protected from concurrent r/w.
+   * Doing this before a `t` is returned is safe; redoing it during rekeying is
+   * not, as the API client already sees the `t` and can mistakenly interleave
+   * writes while this is in progress.
+   * *)
+  let rec drain_handshake t =
+    let push_linger t mcs =
+      match (mcs, t.linger) with
+      | (None, _)         -> ()
+      | (scs, None)       -> t.linger <- scs
+      | (Some cs, Some l) -> t.linger <- Some (l ^ cs)
+    in
+    match t.state with
+    | `Active tls when not (Tls.Engine.handshake_in_progress tls) ->
+        Lwt.return t
+    | _ ->
+        read_react t >>= function
+          | `Eof     -> Lwt.reraise End_of_file
+          | `Ok cs   -> push_linger t cs ; drain_handshake t
+
+  let reneg ?authenticator ?acceptable_cas ?cert ?(drop = true) t =
+    match t.state with
+    | `Error err  -> Lwt.reraise err
+    | `Closed | `Read_closed _ | `Write_closed _ ->
+        Lwt.reraise @@ Invalid_argument "tls: closed socket"
+    | `Active tls ->
+        match Tls.Engine.reneg ?authenticator ?acceptable_cas ?cert tls with
+        | None -> Lwt.reraise @@ Invalid_argument "tls: can't renegotiate"
+        | Some (tls', buf) ->
+           if drop then t.linger <- None ;
+           t.state <- inject_state tls' t.state ;
+           write_t t buf >>= fun () ->
+           drain_handshake t >>= fun _ ->
+           Lwt.return_unit
+
+  let key_update ?request t =
+    match t.state with
+    | `Error err -> Lwt.reraise err
+    | `Write_closed _ | `Closed -> Lwt.reraise @@ Invalid_argument "tls: closed socket"
+    | `Active tls | `Read_closed tls ->
+      match Tls.Engine.key_update ?request tls with
+      | Error f -> Lwt.reraise @@ Invalid_argument (Format.asprintf "tls: can't update key: %a" Tls.Engine.pp_failure f)
+      | Ok (tls', buf) ->
+        t.state <- inject_state tls' t.state ;
+        write_t t buf
+
+  let shutdown t mode =
+    (match mode with
+     | `read -> Lwt.return_unit
+     | `write | `read_write ->
+       match t.state with
+       | `Active tls | `Read_closed tls ->
+         let tls', buf = Tls.Engine.send_close_notify tls in
+         t.state <- inject_state tls' (half_close t.state `write) ;
+         write_t t buf
+       | _ -> Lwt.return_unit) >>= fun () ->
+    t.state <- half_close t.state mode;
+    match t.state with
+    | `Closed | `Error _ -> safely (Lwt_fd.close t.fd)
+    | _ -> Lwt.return_unit
+
+  let close t = shutdown t `read_write
+
+  let server_of_fd config fd =
+    drain_handshake {
+      state    = `Active (Tls.Engine.server config) ;
+      fd       = fd ;
+      linger   = None ;
+      recv_buf = Bytes.create 4096
+    }
+
+  let server_of_channels config (ic, oc) =
+    server_of_fd config (Lwt_fd.of_channels ic oc)
+
+  let server_of_fd config fd =
+    server_of_fd config (Lwt_fd.of_fd fd)
+
+  let client_of_fd config ?host fd =
+    let config' = match host with
+      | None -> config
+      | Some host -> Tls.Config.peer config host
+    in
+    let (tls, init) = Tls.Engine.client config' in
+    let t = {
+      state    = `Active tls ;
+      fd       = fd ;
+      linger   = None ;
+      recv_buf = Bytes.create 4096
+    }
+    in
+    write_t t init >>= fun () ->
+    drain_handshake t
+
+  let client_of_channels config ?host (ic, oc) =
+    client_of_fd config ?host (Lwt_fd.of_channels ic oc)
+
+  let client_of_fd config ?host fd =
+    client_of_fd config ?host (Lwt_fd.of_fd fd)
+
+  let accept conf fd =
+    Lwt_unix.accept fd >>= fun (fd', addr) ->
+    Lwt.catch (fun () -> server_of_fd conf fd' >|= fun t -> (t, addr))
+      (function
+        | Out_of_memory -> raise Out_of_memory
+        | exn -> safely (Lwt_unix.close fd') >>= fun () -> Lwt.reraise exn)
+
+  let connect conf (host, port) =
+    resolve host (string_of_int port) >>= fun addr ->
+    let fd = Lwt_unix.(socket (Unix.domain_of_sockaddr addr) SOCK_STREAM 0) in
+    Lwt.catch (fun () ->
+      let host =
+        Result.to_option
+          (Result.bind (Domain_name.of_string host) Domain_name.host)
+      in
+      Lwt_unix.connect fd addr >>= fun () -> client_of_fd conf ?host fd)
+      (function
+        | Out_of_memory -> raise Out_of_memory
+        | exn -> safely (Lwt_unix.close fd) >>= fun () -> Lwt.reraise exn)
+
+  let read_bytes t bs off len =
+    let buf = Bytes.create len in
+    read t buf >|= fun n ->
+    let to_copy = min n len in
+    Lwt_bytes.blit_from_bytes buf 0 bs off to_copy;
+    to_copy
+
+  let write_bytes t bs off len =
+    let buf = Bytes.create len in
+    Lwt_bytes.blit_to_bytes bs off buf 0 len;
+    write t (Bytes.unsafe_to_string buf)
+
+  let epoch t =
+    match t.state with
+    | `Active tls | `Read_closed tls | `Write_closed tls -> Tls.Engine.epoch tls
+    | `Closed | `Error _ -> Error ()
+end
+
+type ic = Lwt_io.input_channel
+type oc = Lwt_io.output_channel
+
+let of_t ?close t =
+  let close = match close with
+    | Some f -> (fun () -> Unix.safely (f ()))
+    | None   -> (fun () -> Unix.(safely (close t)))
+  in
+  (Lwt_io.make ~close ~mode:Lwt_io.Input (Unix.read_bytes t)),
+  (Lwt_io.make ~close ~mode:Lwt_io.Output @@
+    fun a b c -> Unix.write_bytes t a b c >>= fun () -> Lwt.return c)
+
+let accept_ext conf fd =
+  Unix.accept conf fd >|= fun (t, peer) -> (of_t t, peer)
+
+and connect_ext conf addr =
+  Unix.connect conf addr >|= of_t
+
+let accept certificate fd =
+  match Tls.Config.server ~certificates:certificate () with
+  | Ok config -> accept_ext config fd >|= fun w -> Ok w
+  | Error _ as e -> Lwt.return e
+
+and connect authenticator addr =
+  match Tls.Config.client ~authenticator () with
+  | Ok config -> connect_ext config addr >|= fun w -> Ok w
+  | Error _ as e -> Lwt.return e
+
+(* Boot the entropy loop at module init time. *)
+let () = Mirage_crypto_rng_unix.use_default ()
+
+let () =
+  Printexc.register_printer (function
+      | Tls_alert typ ->
+        Some ("TLS alert from peer: " ^ Tls.Packet.alert_type_to_string typ)
+      | Tls_failure f ->
+        Some ("TLS failure: " ^ Tls.Engine.string_of_failure f)
+      | _ -> None)

unikernel/duniverse/ocaml-tls/lwt/tls_lwt.mli

@@ -0,0 +1,129 @@
+(** Effectful operations using Lwt for pure TLS.
+
+    The pure TLS is state and buffer in, state and buffer out.  This
+    module uses Lwt for communication over the network.
+
+    This module implements a high-level API and a low-level API (in
+    {!Unix}).  Most applications should use the high-level API described below. *)
+
+(** [Tls_alert] exception received from the other endpoint *)
+exception Tls_alert   of Tls.Packet.alert_type
+
+(** [Tls_failure] exception while processing incoming data *)
+exception Tls_failure of Tls.Engine.failure
+
+(** Low-level API *)
+module Unix : sig
+
+  (** {1 Unix API} *)
+
+  (** It is the responsibility of the client to handle error
+      conditions.  The underlying file descriptors are not closed. *)
+
+  (** Abstract type of a session *)
+  type t
+
+  (** {2 Constructors} *)
+
+  (** [server_of_fd server fd] is [t], after server-side TLS
+      handshake of [fd] using [server] configuration. *)
+  val server_of_fd : Tls.Config.server -> Lwt_unix.file_descr -> t Lwt.t
+
+  (** [server_of_channels server (ic, oc)] is [t], after server-side TLS
+      handshake on the input/output channels [ic, oc] using [server] configuration. *)
+  val server_of_channels : Tls.Config.server -> Lwt_io.input_channel * Lwt_io.output_channel -> t Lwt.t
+
+  (** [client_of_fd client ~host fd] is [t], after client-side
+      TLS handshake of [fd] using [client] configuration and [host]. *)
+  val client_of_fd : Tls.Config.client -> ?host:[ `host ] Domain_name.t -> Lwt_unix.file_descr -> t Lwt.t
+
+  (** [client_of_channels client ~host (ic, oc)] is [t], after client-side
+      TLS handshake over the input/output channels [ic, oc] using [client] configuration and [host]. *)
+  val client_of_channels : Tls.Config.client -> ?host:[ `host ] Domain_name.t -> Lwt_io.input_channel * Lwt_io.output_channel -> t Lwt.t
+
+  (** [accept server fd] is [t, sockaddr], after accepting a
+      client on [fd] and upgrading to a TLS connection. *)
+  val accept  : Tls.Config.server -> Lwt_unix.file_descr -> (t * Lwt_unix.sockaddr) Lwt.t
+
+  (** [connect client (host, port)] is [t], after successful
+      connection to [host] on [port] and TLS upgrade. *)
+  val connect : Tls.Config.client -> string * int -> t Lwt.t
+
+  (** {2 Common stream operations} *)
+
+  (** [read t ~off buffer] is [length], the number of bytes read into
+      [buffer]. It fills [buffer] starting at [off] (default is 0). *)
+  val read   : t -> ?off:int -> bytes -> int  Lwt.t
+
+  (** [write t buffer] writes the [buffer] to the session. *)
+  val write  : t -> string -> unit Lwt.t
+
+  (** [writev t buffers] writes the [buffers] to the session. *)
+  val writev : t -> string list -> unit Lwt.t
+
+  (** [read_bytes t bytes offset len] is [read_bytes], the amount of
+      bytes read. *)
+  val read_bytes  : t -> Lwt_bytes.t -> int -> int -> int  Lwt.t
+
+  (** [write_bytes t bytes offset length] writes [length] bytes of
+      [bytes] starting at [offset] to the session. *)
+  val write_bytes : t -> Lwt_bytes.t -> int -> int -> unit Lwt.t
+
+  (** [shutdown t direction] closes the [direction] of the TLS session [t].
+      If [`read_write] or [`write] is closed, a TLS close_notify is sent to the
+      other endpoint. If this results in a fully closed session (or an
+      errorneous session), the underlying file descriptor is closed. *)
+  val shutdown : t -> [ `read | `write | `read_write ] -> unit Lwt.t
+
+  (** [close t] closes the TLS session and the underlying file descriptor. *)
+  val close : t -> unit Lwt.t
+
+  (** [reneg ~authenticator ~acceptable_cas ~cert ~drop t] renegotiates the
+      session, and blocks until the renegotiation finished.  Optionally, a new
+      [authenticator] and [acceptable_cas] can be used.  The own certificate can
+      be adjusted by [cert]. If [drop] is [true] (the default),
+      application data received before the renegotiation finished is dropped. *)
+  val reneg : ?authenticator:X509.Authenticator.t ->
+    ?acceptable_cas:X509.Distinguished_name.t list -> ?cert:Tls.Config.own_cert ->
+    ?drop:bool -> t -> unit Lwt.t
+
+  (** [key_update ~request t] updates the traffic key and requests a traffic key
+      update from the peer if [request] is provided and [true] (the default).
+      This is only supported in TLS 1.3. *)
+  val key_update : ?request:bool -> t -> unit Lwt.t
+
+  (** [epoch t] returns [epoch], which contains information of the
+      active session. *)
+  val epoch  : t -> (Tls.Core.epoch_data, unit) result
+end
+
+(** {1 High-level API} *)
+
+type ic = Lwt_io.input_channel
+type oc = Lwt_io.output_channel
+
+(** [accept_ext server fd] is [(ic, oc), sockaddr], the input
+    and output channel from an accepted connection on the given [fd],
+    after upgrading to TLS using the [server] configuration. *)
+val accept_ext : Tls.Config.server -> Lwt_unix.file_descr ->
+  ((ic * oc) * Lwt_unix.sockaddr) Lwt.t
+
+(** [accept own_cert fd] is [(ic, oc), sockaddr], the input and
+    output channel from the accepted connection on [fd], using the
+    default configuration with the given [own_cert]. *)
+val accept : Tls.Config.own_cert -> Lwt_unix.file_descr ->
+  ((ic * oc) * Lwt_unix.sockaddr, [> `Msg of string]) result Lwt.t
+
+(** [connect_ext client (host, port)] is [ic, oc], the input
+    and output channel of a TLS connection to [host] on [port] using
+    the [client] configuration. *)
+val connect_ext : Tls.Config.client -> string * int -> (ic * oc) Lwt.t
+
+(** [connect authenticator (host, port)] is [ic, oc], the input
+    and output channel of a TLS connection to [host] on [port] using the
+    default configuration and the [authenticator]. *)
+val connect : X509.Authenticator.t -> string * int -> (ic * oc, [> `Msg of string ]) result Lwt.t
+
+(** [of_t t] is [ic, oc], the input and output channel.  [close]
+    defaults to [!Unix.close]. *)
+val of_t : ?close:(unit -> unit Lwt.t) -> Unix.t -> ic * oc

unikernel/duniverse/ocaml-tls/lwt/x509_lwt.ml

@@ -0,0 +1,109 @@
+open Lwt
+
+let failure msg = fail @@ Failure msg
+
+let catch_invalid_arg th h =
+  Lwt.catch (fun () -> th)
+    (function
+      | Invalid_argument msg -> h msg
+      | exn                  -> fail exn)
+
+let (</>) a b = a ^ "/" ^ b
+
+let o f g x = f (g x)
+
+let read_file path =
+  let open Lwt_io in
+  open_file ~mode:Input path >>= fun file ->
+  read file >>= fun cs ->
+  close file >|= fun () ->
+  cs
+
+let read_dir path =
+  let open Lwt_unix in
+  let rec collect acc d =
+    readdir_n d 10 >>= function
+      | [||] -> return acc
+      | xs   -> collect (Array.to_list xs @ acc) d in
+  opendir path >>= fun dir ->
+  collect [] dir >>= fun entries ->
+  closedir dir >|= fun () ->
+  entries
+
+let extension str =
+  let n = String.length str in
+  let rec scan = function
+    | i when i = 0 -> None
+    | i when str.[i - 1] = '.' ->
+        Some (String.sub str i (n - i))
+    | i -> scan (pred i) in
+  scan n
+
+
+let private_of_pems ~cert ~priv_key =
+  catch_invalid_arg
+    (read_file cert >|= fun pem ->
+     match X509.Certificate.decode_pem_multiple pem with
+     | Ok cs -> cs
+     | Error (`Msg m) -> invalid_arg ("failed to parse certificates " ^ m))
+    (o failure @@ Printf.sprintf "Private certificates (%s): %s" cert) >>= fun certs ->
+  catch_invalid_arg
+    (read_file priv_key >|= fun pem ->
+     match X509.Private_key.decode_pem pem with
+     | Ok key -> key
+     | Error (`Msg m) -> invalid_arg ("failed to parse private key " ^ m))
+    (o failure @@ Printf.sprintf "Private key (%s): %s" priv_key) >>= fun pk ->
+  return (certs, pk)
+
+let certs_of_pem path =
+  catch_invalid_arg
+    (read_file path >|= fun pem ->
+     match X509.Certificate.decode_pem_multiple pem with
+     | Ok cs -> cs
+     | Error (`Msg m) -> invalid_arg ("failed to parse certificates " ^ m))
+    (o failure @@ Printf.sprintf "Certificates in %s: %s" path)
+
+let certs_of_pem_dir path =
+  read_dir path
+  >|= List.filter (fun file -> extension file = Some "crt")
+  >>= Lwt_list.map_p (fun file -> certs_of_pem (path </> file))
+  >|= List.concat
+
+let crl_of_pem path =
+  catch_invalid_arg
+    (read_file path >|= fun data ->
+     match X509.CRL.decode_der data with
+     | Ok cs -> cs
+     | Error (`Msg m) -> invalid_arg ("failed to parse CRL " ^ m))
+    (o failure @@ Printf.sprintf "CRL in %s: %s" path)
+
+let crls_of_pem_dir = function
+  | None -> Lwt.return None
+  | Some path ->
+    read_dir path >>= fun files ->
+    Lwt_list.map_p (fun file -> crl_of_pem (path </> file)) files >|= fun crls ->
+    Some crls
+
+let authenticator ?allowed_hashes ?crls param =
+  let time () = Some (Ptime_clock.now ()) in
+  let of_cas cas =
+    crls_of_pem_dir crls >|= fun crls ->
+    X509.Authenticator.chain_of_trust ?allowed_hashes ?crls ~time cas
+  and dotted_hex_to_cs hex =
+    Ohex.decode (String.map (function ':' -> ' ' | x -> x) hex)
+  and fingerp hash fingerprint =
+    X509.Authenticator.key_fingerprint ~time ~hash ~fingerprint
+  and cert_fingerp hash fingerprint =
+    X509.Authenticator.cert_fingerprint ~time ~hash ~fingerprint
+  in
+  match param with
+  | `Ca_file path -> certs_of_pem path >>= of_cas
+  | `Ca_dir path  -> certs_of_pem_dir path >>= of_cas
+  | `Key_fingerprint (hash, fp) -> return (fingerp hash fp)
+  | `Hex_key_fingerprint (hash, fp) ->
+    let fp = dotted_hex_to_cs fp in
+    return (fingerp hash fp)
+  | `Cert_fingerprint (hash, fp) -> return (cert_fingerp hash fp)
+  | `Hex_cert_fingerprint (hash, fp) ->
+    let fp = dotted_hex_to_cs fp in
+    return (cert_fingerp hash fp)

unikernel/duniverse/ocaml-tls/lwt/x509_lwt.mli

@@ -0,0 +1,26 @@
+(** X.509 certificate handling using Lwt. *)
+
+(** [private_of_pems ~cert ~priv_key] is [priv], after reading the
+    private key and certificate chain from the given PEM-encoded
+    files. *)
+val private_of_pems : cert:Lwt_io.file_name -> priv_key:Lwt_io.file_name -> Tls.Config.certchain Lwt.t
+
+(** [certs_of_pem file] is [certificates], which are read from the
+    PEM-encoded [file]. *)
+val certs_of_pem     : Lwt_io.file_name -> X509.Certificate.t list Lwt.t
+
+(** [certs_of_pem_dir dir] is [certificates], which are read from all
+    PEM-encoded files in [dir]. *)
+val certs_of_pem_dir : Lwt_io.file_name -> X509.Certificate.t list Lwt.t
+
+(** [authenticator methods] constructs an [authenticator] using the
+    specified method and data. *)
+val authenticator : ?allowed_hashes:Digestif.hash' list -> ?crls:Lwt_io.file_name ->
+  [ `Ca_file of Lwt_io.file_name
+  | `Ca_dir  of Lwt_io.file_name
+  | `Key_fingerprint of Digestif.hash' * string
+  | `Hex_key_fingerprint of Digestif.hash' * string
+  | `Cert_fingerprint of Digestif.hash' * string
+  | `Hex_cert_fingerprint of Digestif.hash' * string
+  ]
+  -> X509.Authenticator.t Lwt.t