unikernel/duniverse/ocaml-tls/mirage/dune

@@ -0,0 +1,5 @@
+(library
+ (name tls_mirage)
+ (public_name tls-mirage)
+ (wrapped false)
+ (libraries tls lwt ptime mirage-flow mirage-kv mirage-ptime mirage-crypto mirage-crypto-pk))

unikernel/duniverse/ocaml-tls/mirage/example/.gitignore

@@ -0,0 +1 @@
+/static?.ml*

unikernel/duniverse/ocaml-tls/mirage/example/config.ml

@@ -0,0 +1,32 @@
+open Mirage
+
+let secrets_dir = "sekrit"
+
+let build =
+  try
+    match Sys.getenv "BUILD" with
+    | "client" -> `Client
+    | _ -> `Server
+  with Not_found -> `Server
+
+let disk = generic_kv_ro secrets_dir
+
+let stack = generic_stackv4 default_network
+
+let packages = [
+  package ~sublibs:["mirage"] "tls" ;
+  package ~sublibs:["lwt"] "logs"
+]
+
+let server =
+  foreign ~deps:[abstract nocrypto] ~packages "Unikernel.Server" @@ stackv4 @-> kv_ro @-> pclock @-> job
+
+let client =
+  foreign ~deps:[abstract nocrypto] ~packages "Unikernel.Client" @@ stackv4 @-> kv_ro @-> pclock @-> job
+
+let () =
+  match build with
+  | `Server ->
+      register "tls-server" [ server $ stack $ disk $ default_posix_clock ]
+  | `Client ->
+      register "tls-client" [ client $ stack $ disk $ default_posix_clock ]

unikernel/duniverse/ocaml-tls/mirage/example/sekrit/server.key

@@ -0,0 +1,15 @@
+-----BEGIN RSA PRIVATE KEY-----
+MIICXQIBAAKBgQC2QEje5rwhlD2iq162+Ng3AH9BfA/jNJLDqi9VPk1eMUNGicJv
+K+aOANKIsOOr9v4RiEXZSYmFEvGSy+Sf1bCDHwHLLSdNs6Y49b77POgatrVZOTRE
+BE/t1soVT3a/vVJWCLtVCjm70u0S5tcfn4S6IapeIYAVAmcaqwSa+GQNoQIDAQAB
+AoGAd/CShG8g/JBMh9Nz/8KAuKHRHc2BvysIM1C62cSosgaFmdRrazJfBrEv3Nlc
+2/0uc2dVYIxuvm8bIFqi2TWOdX9jWJf6oXwEPXCD0SaDbJTaoh0b+wjyHuaGlttY
+Ztvmf8mK1BOhyl3vNMxh/8Re0dGvGgPZHpn8zanaqfGVz+ECQQDngieUpwzxA0QZ
+GZKRYhHoLEaPiQzBaXphqWcCLLN7oAKxZlUCUckxRRe0tKINf0cB3Kr9gGQjPpm0
+YoqXo8mNAkEAyYgdd+JDi9FH3Cz6ijvPU0hYkriwTii0V09+Ar5DvYQNzNEIEJu8
+Q3Yte/TPRuK8zhnp97Bsy9v/Ji/LSWbtZQJBAJe9y8u3otfmWCBLjrIUIcCYJLe4
+ENBFHp4ctxPJ0Ora+mjkthuLF+BfdSZQr1dBcX1a8giuuvQO+Bgv7r9t75ECQC7F
+omEyaA7JEW5uGe9/Fgz0G2ph5rkdBU3GKy6jzcDsJu/EC6UfH8Bgawn7tSd0c/E5
+Xm2Xyog9lKfeK8XrV2kCQQCTico5lQPjfIwjhvn45ALc/0OrkaK0hQNpXgUNFJFQ
+tuX2WMD5flMyA5PCx5XBU8gEMHYa8Kr5d6uoixnbS0cZ
+-----END RSA PRIVATE KEY-----

unikernel/duniverse/ocaml-tls/mirage/example/sekrit/server.pem

@@ -0,0 +1,15 @@
+-----BEGIN CERTIFICATE-----
+MIICYzCCAcwCCQDLbE6ES1ih1DANBgkqhkiG9w0BAQUFADB2MQswCQYDVQQGEwJB
+VTETMBEGA1UECAwKU29tZS1TdGF0ZTEhMB8GA1UECgwYSW50ZXJuZXQgV2lkZ2l0
+cyBQdHkgTHRkMRUwEwYDVQQDDAxZT1VSIE5BTUUhISExGDAWBgkqhkiG9w0BCQEW
+CW1lQGJhci5kZTAeFw0xNDAyMTcyMjA4NDVaFw0xNTAyMTcyMjA4NDVaMHYxCzAJ
+BgNVBAYTAkFVMRMwEQYDVQQIDApTb21lLVN0YXRlMSEwHwYDVQQKDBhJbnRlcm5l
+dCBXaWRnaXRzIFB0eSBMdGQxFTATBgNVBAMMDFlPVVIgTkFNRSEhITEYMBYGCSqG
+SIb3DQEJARYJbWVAYmFyLmRlMIGfMA0GCSqGSIb3DQEBAQUAA4GNADCBiQKBgQC2
+QEje5rwhlD2iq162+Ng3AH9BfA/jNJLDqi9VPk1eMUNGicJvK+aOANKIsOOr9v4R
+iEXZSYmFEvGSy+Sf1bCDHwHLLSdNs6Y49b77POgatrVZOTREBE/t1soVT3a/vVJW
+CLtVCjm70u0S5tcfn4S6IapeIYAVAmcaqwSa+GQNoQIDAQABMA0GCSqGSIb3DQEB
+BQUAA4GBAIo4ZppIlp3JRyltRC1/AyCC0tsh5TdM3W7258wdoP3lEe08UlLwpnPc
+aJ/cX8rMG4Xf4it77yrbVrU3MumBEGN5TW4jn4+iZyFbp6TT3OUF55nsXDjNHBbu
+deDVpGuPTI6CZQVhU5qEMF3xmlokG+VV+HCDTglNQc+fdLM0LoNF
+-----END CERTIFICATE-----

unikernel/duniverse/ocaml-tls/mirage/example/unikernel.ml

@@ -0,0 +1,96 @@
+open Lwt.Infix
+
+let escape_data buf = String.escaped (Cstruct.to_string buf)
+
+let make_tracer dump =
+  let traces = ref [] in
+  let trace sexp =
+    traces := Sexplib.Sexp.to_string_hum sexp :: !traces
+  and flush () =
+    let msgs = List.rev !traces in
+    traces := [] ;
+    Lwt_list.iter_s dump msgs in
+  (trace, flush)
+
+module Server (S  : Mirage_stack.V4)
+              (KV : Mirage_kv.RO)
+              (CL : Mirage_clock.PCLOCK) =
+struct
+
+  module TLS  = Tls_mirage.Make (S.TCPV4)
+  module X509 = Tls_mirage.X509 (KV) (CL)
+
+  let rec handle flush tls =
+    TLS.read tls >>= fun res ->
+    flush () >>= fun () ->
+    match res with
+    | Ok (`Data buf) ->
+      Logs_lwt.info (fun p -> p "recv %s" (escape_data buf)) >>= fun () ->
+      (TLS.write tls buf >>= function
+        | Ok () -> handle flush tls
+        | Error e -> Logs_lwt.err (fun p -> p "write error %a" TLS.pp_write_error e))
+    | Ok `Eof -> Logs_lwt.info (fun p -> p "eof from server")
+    | Error e -> Logs_lwt.err (fun p -> p "read error %a" TLS.pp_error e)
+
+  let accept conf k flow =
+    let trace, flush_trace =
+      make_tracer (fun s -> Logs_lwt.debug (fun p -> p "%s" s))
+    in
+    Logs_lwt.info (fun p -> p "accepted.") >>= fun () ->
+    TLS.server_of_flow ~trace conf flow >>= function
+    | Ok tls -> Logs_lwt.info (fun p -> p "shook hands") >>= fun () -> k flush_trace tls
+    | Error e -> Logs_lwt.err (fun p -> p "%a" TLS.pp_write_error e)
+
+  let start stack kv _ _ =
+    X509.certificate kv `Default >>= fun cert ->
+    let conf = Tls.Config.server ~certificates:(`Single cert) () in
+    S.listen_tcpv4 stack ~port:4433 (accept conf handle) ;
+    S.listen stack
+
+end
+
+module Client (S  : Mirage_stack.V4)
+              (KV : Mirage_kv.RO)
+              (CL : Mirage_clock.PCLOCK) =
+struct
+
+  module TLS  = Tls_mirage.Make (S.TCPV4)
+  module X509 = Tls_mirage.X509 (KV) (CL)
+
+  open Ipaddr
+
+  let peer = ((V4.of_string_exn "127.0.0.1", 4433), "localhost")
+  let peer = ((V4.of_string_exn "2.19.157.15", 443), "www.apple.com")
+  let peer = ((V4.of_string_exn "74.125.195.103", 443), "www.google.com")
+  let peer = ((V4.of_string_exn "10.0.0.1", 4433), "localhost")
+  let peer = ((V4.of_string_exn "23.253.164.126", 443), "tls.openmirage.org")
+  let peer = ((V4.of_string_exn "216.105.38.15", 443), "slashdot.org")
+  let peer = ((V4.of_string_exn "46.43.42.136", 443), "mirage.io")
+  let peer = ((V4.of_string_exn "198.167.222.205", 443), "hannes.nqsb.io")
+
+  let initial = Cstruct.of_string @@
+    "GET / HTTP/1.1\r\nConnection: Close\r\nHost: " ^ snd peer ^ "\r\n\r\n"
+
+  let chat tls =
+    let rec dump () =
+      TLS.read tls >>= function
+      | Ok (`Data buf) -> Logs_lwt.info (fun p -> p "recv %s" (escape_data buf)) >>= dump
+      | Ok `Eof -> Logs_lwt.info (fun p -> p "eof")
+      | Error e -> Logs_lwt.err (fun p -> p "chat err %a" TLS.pp_error e)
+    in
+    TLS.write tls initial >>= function
+    | Ok () -> dump ()
+    | Error e -> Logs_lwt.err (fun p -> p "write error %a" TLS.pp_write_error e)
+
+  let start stack kv _clock _ =
+    X509.authenticator kv `CAs >>= fun authenticator ->
+    let conf = Tls.Config.client ~authenticator () in
+    S.TCPV4.create_connection (S.tcpv4 stack) (fst peer)
+    >>= function
+    | Error e -> Logs_lwt.err (fun p -> p "%a" S.TCPV4.pp_error e)
+    | Ok tcp  ->
+      TLS.client_of_flow conf ~host:(snd peer) tcp >>= function
+      | Ok tls -> chat tls
+      | Error e -> Logs_lwt.err (fun p -> p "%a" TLS.pp_write_error e)
+
+end

unikernel/duniverse/ocaml-tls/mirage/example2/config.ml

@@ -0,0 +1,17 @@
+open Mirage
+
+let secrets_dir = "sekrit"
+
+let disk  = direct_kv_ro secrets_dir
+and stack = generic_stackv4 default_network
+
+let packages = [
+  package "cohttp-mirage" ;
+  package ~min:"0.99" "cohttp-lwt" ;
+  package ~sublibs:["mirage"] "tls" ;
+  package "tcpip" ;
+]
+let server = foreign ~deps:[abstract nocrypto] ~packages "Unikernel.Main" @@ stackv4 @-> kv_ro @-> pclock @-> job
+
+let () =
+  register "tls-server" [ server $ stack $ disk $ default_posix_clock ]

unikernel/duniverse/ocaml-tls/mirage/example2/sekrit/server.key

@@ -0,0 +1,15 @@
+-----BEGIN RSA PRIVATE KEY-----
+MIICXQIBAAKBgQC2QEje5rwhlD2iq162+Ng3AH9BfA/jNJLDqi9VPk1eMUNGicJv
+K+aOANKIsOOr9v4RiEXZSYmFEvGSy+Sf1bCDHwHLLSdNs6Y49b77POgatrVZOTRE
+BE/t1soVT3a/vVJWCLtVCjm70u0S5tcfn4S6IapeIYAVAmcaqwSa+GQNoQIDAQAB
+AoGAd/CShG8g/JBMh9Nz/8KAuKHRHc2BvysIM1C62cSosgaFmdRrazJfBrEv3Nlc
+2/0uc2dVYIxuvm8bIFqi2TWOdX9jWJf6oXwEPXCD0SaDbJTaoh0b+wjyHuaGlttY
+Ztvmf8mK1BOhyl3vNMxh/8Re0dGvGgPZHpn8zanaqfGVz+ECQQDngieUpwzxA0QZ
+GZKRYhHoLEaPiQzBaXphqWcCLLN7oAKxZlUCUckxRRe0tKINf0cB3Kr9gGQjPpm0
+YoqXo8mNAkEAyYgdd+JDi9FH3Cz6ijvPU0hYkriwTii0V09+Ar5DvYQNzNEIEJu8
+Q3Yte/TPRuK8zhnp97Bsy9v/Ji/LSWbtZQJBAJe9y8u3otfmWCBLjrIUIcCYJLe4
+ENBFHp4ctxPJ0Ora+mjkthuLF+BfdSZQr1dBcX1a8giuuvQO+Bgv7r9t75ECQC7F
+omEyaA7JEW5uGe9/Fgz0G2ph5rkdBU3GKy6jzcDsJu/EC6UfH8Bgawn7tSd0c/E5
+Xm2Xyog9lKfeK8XrV2kCQQCTico5lQPjfIwjhvn45ALc/0OrkaK0hQNpXgUNFJFQ
+tuX2WMD5flMyA5PCx5XBU8gEMHYa8Kr5d6uoixnbS0cZ
+-----END RSA PRIVATE KEY-----

unikernel/duniverse/ocaml-tls/mirage/example2/sekrit/server.pem

@@ -0,0 +1,15 @@
+-----BEGIN CERTIFICATE-----
+MIICYzCCAcwCCQDLbE6ES1ih1DANBgkqhkiG9w0BAQUFADB2MQswCQYDVQQGEwJB
+VTETMBEGA1UECAwKU29tZS1TdGF0ZTEhMB8GA1UECgwYSW50ZXJuZXQgV2lkZ2l0
+cyBQdHkgTHRkMRUwEwYDVQQDDAxZT1VSIE5BTUUhISExGDAWBgkqhkiG9w0BCQEW
+CW1lQGJhci5kZTAeFw0xNDAyMTcyMjA4NDVaFw0xNTAyMTcyMjA4NDVaMHYxCzAJ
+BgNVBAYTAkFVMRMwEQYDVQQIDApTb21lLVN0YXRlMSEwHwYDVQQKDBhJbnRlcm5l
+dCBXaWRnaXRzIFB0eSBMdGQxFTATBgNVBAMMDFlPVVIgTkFNRSEhITEYMBYGCSqG
+SIb3DQEJARYJbWVAYmFyLmRlMIGfMA0GCSqGSIb3DQEBAQUAA4GNADCBiQKBgQC2
+QEje5rwhlD2iq162+Ng3AH9BfA/jNJLDqi9VPk1eMUNGicJvK+aOANKIsOOr9v4R
+iEXZSYmFEvGSy+Sf1bCDHwHLLSdNs6Y49b77POgatrVZOTREBE/t1soVT3a/vVJW
+CLtVCjm70u0S5tcfn4S6IapeIYAVAmcaqwSa+GQNoQIDAQABMA0GCSqGSIb3DQEB
+BQUAA4GBAIo4ZppIlp3JRyltRC1/AyCC0tsh5TdM3W7258wdoP3lEe08UlLwpnPc
+aJ/cX8rMG4Xf4it77yrbVrU3MumBEGN5TW4jn4+iZyFbp6TT3OUF55nsXDjNHBbu
+deDVpGuPTI6CZQVhU5qEMF3xmlokG+VV+HCDTglNQc+fdLM0LoNF
+-----END CERTIFICATE-----

unikernel/duniverse/ocaml-tls/mirage/example2/unikernel.ml

@@ -0,0 +1,41 @@
+open Lwt.Infix
+
+module Main (S  : Mirage_stack.V4)
+            (KV : Mirage_kv.RO)
+            (CL : Mirage_clock.PCLOCK) =
+struct
+
+  module TLS  = Tls_mirage.Make (S.TCPV4)
+  module X509 = Tls_mirage.X509 (KV) (CL)
+  module Http = Cohttp_mirage.Server (TLS)
+
+  module Body = Cohttp_lwt.Body
+
+  let callback _conn req body =
+    let resp = Cohttp.Response.make ~status:`OK () in
+    (match Cohttp.Request.meth req with
+     | `POST ->
+       Body.to_string body >|= fun contents ->
+       "<pre>" ^ contents ^ "</pre>"
+     | _     -> Lwt.return "") >|= fun inlet ->
+    let body = Body.of_string @@
+    "<html><head><title>ohai</title></head> \
+     <body><h3>Secure CoHTTP on-line.</h3>"
+    ^ inlet ^ "</body></html>\r\n"
+    in
+    (resp, body)
+
+  let upgrade conf tcp =
+    TLS.server_of_flow conf tcp >>= function
+    | Error _  -> Lwt.fail (Failure "tls init")
+    | Ok tls  ->
+      let t = Http.make ~callback () in
+      Http.listen t tls
+
+  let start stack kv _ _ =
+    X509.certificate kv `Default >>= fun cert ->
+    let conf = Tls.Config.server ~certificates:(`Single cert) () in
+    S.listen_tcpv4 stack ~port:4433 (upgrade conf) ;
+    S.listen stack
+
+end

unikernel/duniverse/ocaml-tls/mirage/tls_mirage.ml

@@ -0,0 +1,299 @@
+open Lwt.Infix
+
+module Make (F : Mirage_flow.S) = struct
+
+  type error  = [ `Tls_alert   of Tls.Packet.alert_type
+                | `Tls_failure of Tls.Engine.failure
+                | `Read of F.error
+                | `Write of F.write_error ]
+
+  type write_error = [ Mirage_flow.write_error | error ]
+
+  let pp_error ppf = function
+    | `Tls_failure f -> Tls.Engine.pp_failure ppf f
+    | `Tls_alert a   -> Fmt.string ppf @@ Tls.Packet.alert_type_to_string a
+    | `Read  e       -> F.pp_error ppf e
+    | `Write e       -> F.pp_write_error ppf e
+
+  let pp_write_error ppf = function
+    | #Mirage_flow.write_error as e -> Mirage_flow.pp_write_error ppf e
+    | #error as e                   -> pp_error ppf e
+
+  type flow = {
+    role           : [ `Server | `Client ] ;
+    flow           : F.flow ;
+    mutable state  : [ `Active of Tls.Engine.state
+                     | `Read_closed of Tls.Engine.state
+                     | `Write_closed of Tls.Engine.state
+                     | `Closed
+                     | `Error of error ] ;
+    mutable linger : string list ;
+  }
+
+  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 tls_alert a = `Error (`Tls_alert a)
+  let tls_fail f  = `Error (`Tls_failure f)
+
+  let write_flow flow buf =
+    F.write flow.flow (Cstruct.of_string buf) >>= function
+    | Ok _ as o -> Lwt.return o
+    | Error `Closed ->
+      flow.state <- half_close flow.state `write;
+      Lwt.return (Error (`Write `Closed))
+    | Error e ->
+      flow.state <- `Error (`Write e);
+      Lwt.return (Error (`Write e))
+
+  let read_react flow =
+    let handle tls buf =
+      match Tls.Engine.handle_tls tls buf with
+      | Ok (state, eof, `Response resp, `Data data) ->
+        let state = inject_state state flow.state in
+        let state = Option.(value ~default:state (map (fun `Eof -> half_close state `read) eof)) in
+        flow.state <- state;
+        ( match resp with
+          | None     -> Lwt.return @@ Ok ()
+          | Some buf -> write_flow flow buf) >>= fun _ ->
+        Lwt.return @@ `Ok (Option.map Cstruct.of_string data)
+      | Error (fail, `Response resp) ->
+        let reason = match fail with
+          | `Alert a -> tls_alert a
+          | f -> tls_fail f
+        in
+        flow.state <- reason ;
+        F.write flow.flow (Cstruct.of_string resp) >>= fun _ ->
+        Lwt.return reason
+    in
+    match flow.state with
+    | `Error _ as e -> Lwt.return e
+    | `Read_closed _ | `Closed -> Lwt.return `Eof
+    | `Active _ | `Write_closed _ ->
+      F.read flow.flow >>= function
+      | Error e ->
+        flow.state <- `Error (`Read e);
+        Lwt.return (`Error (`Read e))
+      | Ok `Eof ->
+        flow.state <- half_close flow.state `read;
+        Lwt.return `Eof
+      | Ok `Data buf -> match flow.state with
+        | `Active tls | `Write_closed tls -> handle tls (Cstruct.to_string buf)
+        | `Read_closed _ | `Closed -> Lwt.return `Eof
+        | `Error _ as e -> Lwt.return e
+
+  let rec read flow =
+    match flow.linger with
+    | [] ->
+      ( read_react flow >>= function
+          | `Ok None       -> read flow
+          | `Ok (Some buf) -> Lwt.return @@ Ok (`Data buf)
+          | `Eof           -> Lwt.return @@ Ok `Eof
+          | `Error e       -> Lwt.return @@ Error e )
+    | bufs ->
+      flow.linger <- [] ;
+      let str = String.concat "" (List.rev bufs) in
+      Lwt.return @@ Ok (`Data (Cstruct.of_string str))
+
+  let writev flow bufs =
+    match flow.state with
+    | `Closed | `Write_closed _ -> Lwt.return @@ Error `Closed
+    | `Error e -> Lwt.return @@ Error (e :> write_error)
+    | `Active tls | `Read_closed tls ->
+        let bufs = List.map Cstruct.to_string bufs in
+        match Tls.Engine.send_application_data tls bufs with
+        | Some (tls, answer) ->
+            flow.state <- `Active tls ;
+            write_flow flow answer
+        | None ->
+            (* "Impossible" due to handshake draining. *)
+            assert false
+
+  let write flow buf = writev flow [buf]
+
+  (*
+   * 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 flow =
+    match flow.state with
+    | `Active tls when not (Tls.Engine.handshake_in_progress tls) ->
+        Lwt.return @@ Ok flow
+    | _ ->
+      (* read_react re-throws *)
+        read_react flow >>= function
+        | `Ok mbuf ->
+            flow.linger <- Option.(to_list (map Cstruct.to_string mbuf)) @ flow.linger ;
+            drain_handshake flow
+        | `Error e -> Lwt.return @@ Error (e :> write_error)
+        | `Eof     -> Lwt.return @@ Error `Closed
+
+  type wr_or_msg = [ write_error | `Msg of string ]
+
+  let underlying flow = flow.flow
+
+  let reneg ?authenticator ?acceptable_cas ?cert ?(drop = true) flow =
+    match flow.state with
+    | `Closed | `Write_closed _ | `Read_closed _ -> Lwt.return @@ Error `Closed
+    | `Error e    -> Lwt.return @@ Error (e :> wr_or_msg)
+    | `Active tls ->
+        match Tls.Engine.reneg ?authenticator ?acceptable_cas ?cert tls with
+        | None             -> Lwt.return (Error (`Msg "Renegotiation already in progress"))
+        | Some (tls', buf) ->
+            if drop then flow.linger <- [] ;
+            flow.state <- `Active tls' ;
+            write_flow flow buf >>= fun _ ->
+            drain_handshake flow >|= function
+            | Ok _    -> Ok ()
+            | Error e -> Error (e :> wr_or_msg)
+
+  let key_update ?request flow =
+    match flow.state with
+    | `Closed | `Write_closed _ -> Lwt.return @@ Error `Closed
+    | `Error e    -> Lwt.return @@ Error (e :> wr_or_msg)
+    | `Active tls | `Read_closed tls ->
+      match Tls.Engine.key_update ?request tls with
+      | Error _ -> Lwt.return (Error (`Msg "Key update failed"))
+      | Ok (tls', buf) ->
+        flow.state <- `Active tls' ;
+        write_flow flow buf >|= function
+        | Ok _ as o -> o
+        | Error e   -> Error (e :> wr_or_msg)
+
+  let close flow =
+    (match flow.state with
+     | `Active tls | `Read_closed tls ->
+       let tls, buf = Tls.Engine.send_close_notify tls in
+       flow.state <- inject_state tls flow.state;
+       flow.state <- `Closed;
+       write_flow flow buf >|= fun _ ->
+       ()
+     | `Write_closed _ ->
+       flow.state <- `Closed;
+       Lwt.return_unit
+     | _ -> Lwt.return_unit) >>= fun () ->
+    F.close flow.flow
+
+  let shutdown flow mode =
+    match flow.state with
+    | `Active tls | `Read_closed tls | `Write_closed tls ->
+      let tls, buf =
+        match flow.state, mode with
+        | (`Active tls | `Read_closed tls), (`write | `read_write) ->
+          let tls, buf = Tls.Engine.send_close_notify tls in
+          tls, Some buf
+        | _, _ -> tls, None
+      in
+      flow.state <- inject_state tls (half_close flow.state mode);
+      (* as outlined above, this may fail since the TCP flow may already be (half-)closed *)
+      Option.fold
+        ~none:Lwt.return_unit
+        ~some:(fun b -> write_flow flow b >|= fun _ -> ())
+        buf >>= fun () ->
+      (match flow.state with
+       | `Closed -> F.close flow.flow
+       | _ -> Lwt.return_unit)
+    | `Error _ | `Closed ->
+      F.close flow.flow
+
+  let client_of_flow conf ?host flow =
+    let conf' = match host with
+      | None      -> conf
+      | Some host -> Tls.Config.peer conf host
+    in
+    let (tls, init) = Tls.Engine.client conf' in
+    let tls_flow = {
+      role   = `Client ;
+      flow   = flow ;
+      state  = `Active tls ;
+      linger = [] ;
+    } in
+    write_flow tls_flow init >>= fun _ ->
+    drain_handshake tls_flow
+
+  let server_of_flow conf flow =
+    let tls_flow = {
+      role   = `Server ;
+      flow   = flow ;
+      state  = `Active (Tls.Engine.server conf) ;
+      linger = [] ;
+    } in
+    drain_handshake tls_flow
+
+  let epoch flow =
+    match flow.state with
+    | `Closed | `Error _ -> Error ()
+    | `Active tls | `Read_closed tls | `Write_closed tls -> Tls.Engine.epoch tls
+
+(*   let create_connection t tls_params host (addr, port) =
+    |+ XXX addr -> (host : string) +|
+    TCP.create_connection t (addr, port) >>= function
+      | `Error _ as e -> return e
+      | `Ok flow      -> client_of_tcp_flow tls_params host flow *)
+
+(*   let listen_ssl t cert ~port callback =
+    let cb flow =
+      server_of_tcp_flow cert flow >>= callback in
+    TCP.input t ~listeners:(fun p -> if p = port then Some cb else None) *)
+
+end
+
+module X509 (KV : Mirage_kv.RO) = struct
+
+  let ca_roots_file = Mirage_kv.Key.v "ca-roots.crt"
+  let default_cert  = "server"
+
+  let err_fail pp = function
+    | Ok x -> Lwt.return x
+    | Error e -> Fmt.kstr Lwt.fail_with "%a" pp e
+
+  let pp_msg ppf = function `Msg m -> Fmt.string ppf m
+
+  let decode_or_fail f cs = err_fail pp_msg (f cs)
+
+  let read kv name =
+    KV.get kv name >>= err_fail KV.pp_error >|= Cstruct.of_string
+
+  let read_crl kv = function
+    | None -> Lwt.return None
+    | Some filename ->
+      read kv (Mirage_kv.Key.v filename) >>= fun data ->
+      err_fail pp_msg (X509.CRL.decode_der (Cstruct.to_string data)) >|= fun crl ->
+      Some [ crl ]
+
+  let authenticator ?allowed_hashes ?crl kv =
+    let time () = Some (Mirage_ptime.now ()) in
+    let now = Mirage_ptime.now () in
+    read kv ca_roots_file >|= Cstruct.to_string >>=
+    decode_or_fail X509.Certificate.decode_pem_multiple >>= fun cas ->
+    let ta = X509.Validation.valid_cas ~time:now cas in
+    read_crl kv crl >|= fun crls ->
+    X509.Authenticator.chain_of_trust ?crls ?allowed_hashes ~time ta
+
+  let certificate kv =
+    let read name =
+      read kv (Mirage_kv.Key.v (name ^ ".pem")) >|= Cstruct.to_string >>=
+      decode_or_fail X509.Certificate.decode_pem_multiple >>= fun certs ->
+      read kv (Mirage_kv.Key.v (name ^ ".key")) >|= Cstruct.to_string >>=
+      decode_or_fail X509.Private_key.decode_pem >|= fun pk ->
+      (certs, pk)
+    in function | `Default   -> read default_cert
+                | `Name name -> read name
+end

unikernel/duniverse/ocaml-tls/mirage/tls_mirage.mli

@@ -0,0 +1,70 @@
+(** Effectful operations using Mirage for pure TLS. *)
+
+(** TLS module given a flow *)
+module Make (F : Mirage_flow.S) : sig
+
+  (** possible errors: incoming alert, processing failure, or a
+      problem in the underlying flow. *)
+  type error  = [ `Tls_alert   of Tls.Packet.alert_type
+                | `Tls_failure of Tls.Engine.failure
+                | `Read of F.error
+                | `Write of F.write_error ]
+
+  type write_error = [ `Closed | error ]
+  (** The type for write errors. *)
+
+  (** we provide the FLOW interface *)
+  include Mirage_flow.S
+    with type error := error
+     and type write_error := write_error
+
+  (** [underlying t] returns the underlying flow. This is useful to extract
+      information such as [src] and [dst] of that flow. *)
+  val underlying : flow -> F.flow
+
+  (** [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 -> flow -> (unit, [ write_error | `Msg of string ]) result 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 -> flow -> (unit, [ write_error | `Msg of string ]) result Lwt.t
+
+  (** [client_of_flow client ~host flow] upgrades the existing connection
+      to TLS using the [client] configuration, using [host] as peer name. *)
+  val client_of_flow : Tls.Config.client -> ?host:[ `host ] Domain_name.t ->
+     F.flow -> (flow, write_error) result Lwt.t
+
+  (** [server_of_flow server flow] upgrades the flow to a TLS
+      connection using the [server] configuration. *)
+  val server_of_flow : Tls.Config.server -> F.flow ->
+    (flow, write_error) result Lwt.t
+
+  (** [epoch flow] extracts information of the established session. *)
+  val epoch : flow -> (Tls.Core.epoch_data, unit) result
+
+end
+
+(** X.509 handling given a key value store and a clock *)
+module X509 (KV : Mirage_kv.RO) : sig
+  (** [authenticator ~allowed_hashes ~crl store] creates an [authenticator],
+      using the given certificate authorities in the [store] as
+      value for key "ca_roots.crt". If [allowed_hashes] is provided,
+      only these hash algorithms are allowed for signatures of the certificate chain.
+      If [crl] is provided, the corresponding file is read and used as
+      revocation list (DER encoded). Both options only apply if [`CAs] is used.
+ *)
+  val authenticator : ?allowed_hashes:Digestif.hash' list -> ?crl:string ->
+    KV.t -> X509.Authenticator.t Lwt.t
+
+  (** [certificate store typ] unmarshals a certificate chain and
+      private key material from the [store]. *)
+  val certificate   : KV.t -> [< `Default | `Name of string ]
+    -> Tls.Config.certchain Lwt.t
+end