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