unikernel/duniverse/ocaml-tls/eio/dune

@@ -0,0 +1,5 @@
+(library
+ (name tls_eio)
+ (public_name tls-eio)
+ (wrapped false)
+ (libraries tls eio ptime.clock.os))

unikernel/duniverse/ocaml-tls/eio/tests/dune

@@ -0,0 +1,30 @@
+(copy_files ../../certificates/*.crt)
+(copy_files ../../certificates/*.key)
+(copy_files ../../certificates/*.pem)
+
+(mdx
+  (package tls-eio)
+  (deps
+    server.pem
+    server.key
+    server-ec.pem
+    server-ec.key
+    (package tls-eio)
+    (package mirage-crypto-rng)
+    (package eio_main)))
+
+; "dune runtest" just does a quick run with random inputs.
+;
+; To run with afl-fuzz instead (make sure you have a compiler with the afl option on!):
+;
+; dune runtest
+; mkdir input
+; echo hi > input/foo
+; cp certificates/server.{key,pem} .
+; afl-fuzz -m 1000 -i input -o output ./_build/default/eio/tests/fuzz.exe @@
+(test
+  (package tls-eio)
+  (libraries crowbar tls-eio eio.mock logs logs.fmt)
+  (deps server.pem server.key)
+  (name fuzz)
+  (action (run %{test} --repeat 200)))

unikernel/duniverse/ocaml-tls/eio/tests/fuzz.ml

@@ -0,0 +1,297 @@
+(* Fuzz testing for tls-eio.
+
+   This code picks two random strings, one for the client to send and one for
+   the server. It then starts a send and receive fiber for each end.
+
+   A dispatcher fiber then sends commands to these worker fibers
+   (see [action] for the possible actions).
+
+   This is intended to check for bugs in the Eio wrapper (rather than in Tls itself).
+   At the moment, it's just checking that tls-eio works when used correctly.
+   Each endpoint overlaps reads with writes (but not reads with other reads or
+   writes with other writes).
+
+   Some possible future improvements:
+
+   - It currently only checks the basic read/write/close operations.
+     It should be extended to check [reneg], etc too.
+
+   - Currently, cancelling a read operation marks the Tls flow as broken.
+     We should allow resuming after a cancelled read, and test that here.
+
+   - We should try injecting faults and make sure they're handled sensibly.
+
+   - It would be good to get coverage reports for these tests.
+     However, this requires changes to crowbar:
+     https://github.com/stedolan/crowbar/issues/4#issuecomment-1310277551
+     (a patched version reported 54% coverage of Tls_eio.ml) *)
+
+open Eio.Std
+
+let src = Logs.Src.create "fuzz" ~doc:"Fuzz tests"
+module Log = (val Logs.src_log src : Logs.LOG)
+
+module W = Eio.Buf_write
+
+type transmit_amount = Mock_socket.transmit_amount
+
+type op =
+  | Send of int                   (* The application sends some bytes to Tls *)
+  | Transmit of transmit_amount   (* The network sends some types to the peer *)
+  | Recv                          (* The application tries to read some data *)
+  | Shutdown_send                 (* The application shuts down the sending side *)
+
+let label name gen =
+  Crowbar.with_printer Fmt.(const string name) gen
+
+let op =
+  Crowbar.choose @@ [
+    Crowbar.(map [range 4096]) (fun n -> Send n);
+    Crowbar.(map [range ~min:1 4096]) (fun n -> Transmit (`Bytes n));
+    label "recv" @@ Crowbar.const Recv;
+    label "shutdown-send" @@ Crowbar.const Shutdown_send;
+  ]
+
+type dir = To_client | To_server
+
+let pp_dir f = function
+  | To_server -> Fmt.string f "client-to-server"
+  | To_client -> Fmt.string f "server-to-client"
+
+let dir =
+  Crowbar.choose [
+    label "server-to-client" @@ Crowbar.const To_client;
+    label "client-to-server" @@ Crowbar.const To_server;
+  ]
+
+(* A test case is a random sequence of [action]s, followed by party shutting
+   down the sending side of the connection (if it hasn't already done so) and
+   the network draining any queued traffic.
+
+   Once all fibers have finished, we check that what was sent matches the data
+   that has been received. *)
+   
+let action =
+  Crowbar.option (Crowbar.pair dir op)  (* None means yield *)
+
+(* A [Path] is one direction (either server-to-client or client-to-server).
+   The two paths can be tested mostly independently (except for shutdown at the moment). *)
+module Path : sig
+  type t
+
+  val create :
+    sender:(Tls_eio.t, exn) result Promise.t ->
+    receiver:(Tls_eio.t, exn) result Promise.t ->
+    transmit:(transmit_amount -> unit) ->
+    dir -> string -> t
+  (** Create a test driver for one direction, from [sender] to [receiver].
+      [transmit n] causes [n] bytes to be transferred over the mock network. *)
+
+  val close : t -> unit
+  (** [close t] causes the sender to close the socket for sending.
+      Futher send operations will be ignored. *)
+
+  val run : t -> unit
+  (** Run the send and receive fibers. Returns once the receiver has read EOF. *)
+
+  val enqueue : t -> op -> unit
+  (** Send a command to the send or receive fiber (depending on [op]). *)
+end = struct
+  type t = {
+    dir : dir;
+    message : string;   (* The complete message to be transmitted over this path. *)
+    (* We need to construct [t] before the handshake is done, so these are promises: *)
+    sender : Tls_eio.t Promise.or_exn;
+    receiver : Tls_eio.t Promise.or_exn;
+    mutable sent : int; (* Bytes of [message] sent so far *)
+    mutable recv : int; (* Bytes of [message] received so far *)
+    send_commands : [`Send of int | `Exit] Eio.Stream.t;  (* Commands for the sending fiber *)
+    recv_commands : [`Recv | `Drain] Eio.Stream.t;        (* Commands for the receiving fiber *)
+    transmit : transmit_amount -> unit;
+  }
+
+  let pp_dir f t =
+    pp_dir f t.dir
+
+  let create ~sender ~receiver ~transmit dir message =
+    let send_commands = Eio.Stream.create max_int in
+    let recv_commands = Eio.Stream.create max_int in
+    { dir; message; sender; receiver; sent = 0; recv = 0;
+      send_commands; recv_commands; transmit }
+
+  let shutdown t =
+    Eio.Stream.add t.send_commands `Exit
+
+  let close t =
+    shutdown t;                           (* Sender stops sending *)
+    t.transmit `Drain;                    (* Network transmits everything *)
+    Eio.Stream.add t.recv_commands `Drain (* Receiver reads everything *)
+
+  let run_send_thread t =
+    let sender = Promise.await_exn t.sender in
+    Logs.info (fun f -> f "%a: sender ready" pp_dir t);
+    let rec aux () =
+      match Eio.Stream.take t.send_commands with
+      | `Exit ->
+        Log.info (fun f -> f "%a: shutdown send (Tls level)" pp_dir t);
+        Eio.Flow.shutdown sender `Send
+      | `Send len ->
+        let available = String.length t.message - t.sent in
+        let len = min len available in
+        if len > 0 then (
+          let msg = Cstruct.of_string ~off:t.sent ~len t.message in
+          t.sent <- t.sent + len;
+          Log.info (fun f -> f "%a: sending %S" pp_dir t (Cstruct.to_string msg));
+          Eio.Flow.write sender [msg];
+        );
+        aux ()
+    in
+    aux()
+
+  let run_recv_thread t =
+    let recv = Promise.await_exn t.receiver in
+    Logs.info (fun f -> f "%a: receiver ready" pp_dir t);
+    try
+      let drain = ref false in
+      while true do
+        if !drain = false then (
+          begin match Eio.Stream.take t.recv_commands with
+            | `Recv -> ()
+            | `Drain -> drain := true
+          end
+        );
+        let buf = Cstruct.create 4096 in
+        let got = Eio.Flow.single_read recv buf in
+        let received = Cstruct.to_string buf ~len:got in
+        Log.info (fun f -> f "%a: received %S" pp_dir t received);
+        let expected = String.sub t.message t.recv got in
+        if received <> expected then
+          Fmt.failwith "%a: excepted %S but got %S!" pp_dir t expected received;
+        t.recv <- t.recv + got
+      done
+    with End_of_file ->
+      if t.recv <> t.sent then (
+        Fmt.failwith "%a: Sender sent %d bytes, but receiver got EOF after reading only %d"
+          pp_dir t
+          t.sent
+          t.recv
+      );
+      Log.info (fun f -> f "%a: recv thread done (got EOF)" pp_dir t)
+
+  let run t =
+    Fiber.both
+      (fun () -> run_send_thread t)
+      (fun () -> run_recv_thread t)
+
+  let pp_amount f = function
+    | `Bytes n -> Fmt.pf f "%d bytes" n
+    | `Drain -> Fmt.string f "all bytes"
+
+  let enqueue t = function
+    | Send i->
+      Log.info (fun f -> f "%a: enqueue send %d bytes of plaintext" pp_dir t i);
+      Eio.Stream.add t.send_commands @@ `Send i;
+    | Recv ->
+      Log.info (fun f -> f "%a: enqueue read from Tls" pp_dir t);
+      Eio.Stream.add t.recv_commands @@ `Recv;
+    | Transmit i ->
+      Log.info (fun f -> f "%a: enqueue transmit %a over network" pp_dir t pp_amount i);
+      t.transmit i
+    | Shutdown_send ->
+      Log.info (fun f -> f "%a: enqueue shutdown send" pp_dir t);
+      shutdown t
+end
+
+module Config : sig
+  val client : Tls.Config.client
+  val server : Tls.Config.server
+end = struct
+  let null_auth ?ip:_ ~host:_ _ = Ok None
+
+  let client =
+    Result.get_ok (Tls.Config.client ~authenticator:null_auth ())
+
+  let read_file path =
+    let ch = open_in_bin path in
+    let len = in_channel_length ch in
+    let data = really_input_string ch len in
+    close_in ch;
+    data
+
+  let server =
+    let certs = Result.get_ok (X509.Certificate.decode_pem_multiple (read_file "server.pem")) in
+    let pk = Result.get_ok (X509.Private_key.decode_pem (read_file "server.key")) in
+    let certificates = `Single (certs, pk) in
+    Result.get_ok Tls.Config.(server ~version:(`TLS_1_0, `TLS_1_3) ~certificates ~ciphers:Ciphers.supported ())
+end
+
+let dispatch_commands ~to_server ~to_client actions =
+  let rec aux = function
+    | [] -> 
+      Log.info (fun f -> f "dispatch_commands: done");
+      Path.close to_client;
+      Path.close to_server
+    | None :: xs ->
+      Fiber.yield (); aux xs
+    | Some (dir, op) :: xs ->
+      let path =
+        match dir with
+        | To_server-> to_server
+        | To_client -> to_client
+      in
+      Path.enqueue path op;
+      aux xs
+  in
+  aux actions
+
+(* In some runs we automatically perform these actions first, which allows the handshake to complete.
+   This lets the fuzz tester get to the interesting cases more quickly. *)
+let quickstart_actions = [
+  Some (To_server, Transmit (`Bytes 4096));
+  None; (* Client sends handshake *)
+  None; (* Server reads handshake *)
+  Some (To_client, Transmit (`Bytes 4096));
+  None; (* Server replies to handshake *)
+  None; (* Client reads reply *)
+  Some (To_server, Transmit (`Bytes 4096));
+  None; (* Client sends final part *)
+  None; (* Server receives it *)
+  Some (To_client, Recv);
+  Some (To_server, Recv);
+]
+
+let main client_message server_message quickstart actions =
+  let actions =
+    if quickstart then quickstart_actions @ actions
+    else actions
+  in
+  Eio_mock.Backend.run @@ fun () ->
+  Switch.run @@ fun sw ->
+  let insecure_test_rng = Mirage_crypto_rng.create (module Test_rng) in
+  Mirage_crypto_rng.set_default_generator insecure_test_rng;
+  let client_socket, server_socket = Mock_socket.create_pair () in
+  let server_flow = Fiber.fork_promise ~sw (fun () -> Tls_eio.server_of_flow Config.server server_socket) in
+  let client_flow = Fiber.fork_promise ~sw (fun () -> Tls_eio.client_of_flow Config.client client_socket) in
+  let to_server =
+    Path.create
+      ~sender:client_flow
+      ~receiver:server_flow
+      ~transmit:(Mock_socket.transmit client_socket)
+      To_server client_message in
+  let to_client =
+    Path.create
+      ~sender:server_flow
+      ~receiver:client_flow
+      ~transmit:(Mock_socket.transmit server_socket)
+      To_client server_message
+  in
+  Fiber.all [
+    (fun () -> dispatch_commands actions ~to_server ~to_client);
+    (fun () -> Path.run to_server);
+    (fun () -> Path.run to_client);
+  ]
+
+let () =
+  Logs.set_level (Some Warning);
+  Logs.set_reporter (Logs_fmt.reporter ());
+  Crowbar.(add_test ~name:"random ops" [bytes; bytes; bool; list action] main)

unikernel/duniverse/ocaml-tls/eio/tests/mock_socket.ml

@@ -0,0 +1,94 @@
+open Eio.Std
+
+module W = Eio.Buf_write
+
+let src = Logs.Src.create "mock-socket" ~doc:"Test socket"
+module Log = (val Logs.src_log src : Logs.LOG)
+
+type transmit_amount = [`Bytes of int | `Drain]
+
+type ty = [`Mock_tls | Eio.Flow.two_way_ty | Eio.Resource.close_ty]
+type t = ty r
+
+let rec takev len = function
+  | [] -> []
+  | x :: xs ->
+    if len = 0 then []
+    else if Cstruct.length x >= len then [Cstruct.sub x 0 len]
+    else x :: takev (len - Cstruct.length x) xs
+
+module Impl = struct
+  type t = {
+    to_peer : W.t;
+    from_peer : W.t;
+    label : string;
+    output_sizes : transmit_amount Eio.Stream.t;
+  }
+
+  let create ~to_peer ~from_peer label = {
+    to_peer;
+    from_peer;
+    label;
+    output_sizes = Eio.Stream.create max_int;
+  }
+
+  let transmit t x =
+    Eio.Stream.add t.output_sizes x
+
+  let single_write t bufs =
+    let size =
+      match Eio.Stream.take t.output_sizes with
+      | `Drain -> Eio.Stream.add t.output_sizes `Drain; Cstruct.lenv bufs
+      | `Bytes size -> size
+    in
+    let bufs = takev size bufs in
+    List.iter (W.cstruct t.to_peer) bufs;
+    let len = Cstruct.lenv bufs in
+    Log.info (fun f -> f "%s: wrote %d bytes to network" t.label len);
+    len
+
+  let copy t ~src = Eio.Flow.Pi.simple_copy ~single_write t ~src
+
+  let single_read t buf =
+    let batch = W.await_batch t.from_peer in
+    let got, _ = Cstruct.fillv ~src:batch ~dst:buf in
+    Log.info (fun f -> f "%s: read %d bytes from network" t.label got);
+    W.shift t.from_peer got;
+    got
+
+  let shutdown t = function
+    | `Send -> 
+      Log.info (fun f -> f "%s: close writer" t.label);
+      W.close t.to_peer
+    | _ -> failwith "Not implemented"
+
+  let close t =
+    Log.info (fun f -> f "%s: close connection" t.label)
+
+  let read_methods = []
+
+  type (_, _, _) Eio.Resource.pi += Raw : ('t, 't -> t, ty) Eio.Resource.pi
+  let raw (Eio.Resource.T (t, ops)) = Eio.Resource.get ops Raw t
+end
+
+let handler =
+  Eio.Resource.handler (
+    H (Impl.Raw, Fun.id) ::
+    H (Eio.Resource.Close, Impl.close) ::
+    Eio.Resource.bindings (Eio.Flow.Pi.two_way (module Impl))
+  )
+
+let transmit t x =
+  let t = Impl.raw t in
+  Impl.transmit t x
+
+let create ~from_peer ~to_peer label =
+  let t = Impl.create ~from_peer ~to_peer label in
+  Eio.Resource.T (t, handler)
+
+let create_pair () =
+  let to_a = W.create 100 in
+  let to_b = W.create 100 in
+  let a = create ~from_peer:to_a ~to_peer:to_b "client" in
+  let b = create ~from_peer:to_b ~to_peer:to_a "server" in
+  a, b

unikernel/duniverse/ocaml-tls/eio/tests/mock_socket.mli

@@ -0,0 +1,13 @@
+open Eio.Std
+
+type transmit_amount = [
+  | `Bytes of int   (* Send the next n bytes of data *)
+  | `Drain          (* Transmit all data immediately from now on *)
+]
+
+type t = [`Mock_tls | Eio.Flow.two_way_ty | Eio.Resource.close_ty] r
+
+val create_pair : unit -> t * t
+(** Create a pair of sockets [client, server], such that writes to one can be read from the other. *)
+
+val transmit : t -> transmit_amount -> unit

unikernel/duniverse/ocaml-tls/eio/tests/test_rng.ml

@@ -0,0 +1,21 @@
+(* Insecure predictable RNG for fuzz testing. *)
+
+type g = int ref
+
+let block = 1
+
+let create ?time:_ () = ref 1234
+
+let generate_into ~g buf ~off n =
+  for i = off to off + n - 1 do
+    Bytes.set_uint8 buf i !g;
+    g := !g + 1
+  done
+
+let reseed ~g:_ _ = ()
+
+let accumulate ~g:_ _ = `Acc ignore
+
+let seeded ~g:_ = true
+
+let pools = 0

unikernel/duniverse/ocaml-tls/eio/tests/tls_eio.md

@@ -0,0 +1,114 @@
+```ocaml
+# #require "digestif.c";;
+# #require "eio_main";;
+# #require "tls-eio";;
+# #require "mirage-crypto-rng.unix";;
+```
+
+```ocaml
+open Eio.Std
+
+module Flow = Eio.Flow
+```
+
+## Test client
+
+```ocaml
+let null_auth ?ip:_ ~host:_ _ = Ok None
+
+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 ~net (host, service) =
+  match Eio.Net.getaddrinfo_stream net host ~service with
+  | [] -> failwith "No addresses found!"
+  | addr :: _ ->
+    let authenticator = null_auth in
+    Switch.run @@ fun sw ->
+    let socket = Eio.Net.connect ~sw net addr in
+    let flow =
+      let host =
+        Result.to_option
+          (Result.bind (Domain_name.of_string host) Domain_name.host)
+      in
+      Tls_eio.client_of_flow
+        (Result.get_ok Tls.Config.(client ~version:(`TLS_1_0, `TLS_1_3) ?cached_ticket:!mypsk ~ticket_cache ~authenticator ~ciphers:Ciphers.supported ()))
+        ?host socket
+    in
+    let req = String.concat "\r\n" [
+      "GET / HTTP/1.1" ; "Host: " ^ host ; "Connection: close" ; "" ; ""
+    ] in
+    Flow.copy_string req flow;
+    let r = Eio.Buf_read.of_flow flow ~max_size:max_int in
+    let line = Eio.Buf_read.take 3 r in
+    traceln "client <- %s" line;
+    Eio.Resource.close flow;
+    traceln "client done."
+```
+
+## Test server
+
+```ocaml
+let server_config dir =
+  let ( / ) = Eio.Path.( / ) in
+  let certificate =
+    X509_eio.private_of_pems
+      ~cert:(dir / "server.pem")
+      ~priv_key:(dir / "server.key")
+  in
+  let ec_certificate =
+    X509_eio.private_of_pems
+      ~cert:(dir / "server-ec.pem")
+      ~priv_key:(dir / "server-ec.key")
+  in
+  let certificates = `Multiple [ certificate ; ec_certificate ] in
+  Result.get_ok Tls.Config.(server ~version:(`TLS_1_0, `TLS_1_3) ~certificates ~ciphers:Ciphers.supported ())
+
+let serve_ssl ~config server_s callback =
+  Switch.run @@ fun sw ->
+  let client, addr = Eio.Net.accept ~sw server_s in
+  let flow = Tls_eio.server_of_flow config client in
+  traceln "server -> connect";
+  callback flow addr
+```
+
+## Test case
+
+```ocaml
+# Eio_main.run @@ fun env ->
+  let net = env#net in
+  let certificates_dir = env#cwd in
+  Mirage_crypto_rng_unix.use_default ();
+  Switch.run @@ fun sw ->
+  let addr = `Tcp (Eio.Net.Ipaddr.V4.loopback, 4433) in
+  let listening_socket = Eio.Net.listen ~sw net ~backlog:5 ~reuse_addr:true addr in
+  (* Eio.Time.with_timeout_exn env#clock 0.1 @@ fun () -> *)
+  Fiber.both
+    (fun () ->
+       traceln "server -> start @@ %a" Eio.Net.Sockaddr.pp addr;
+       let config = server_config certificates_dir in
+       serve_ssl ~config listening_socket @@ fun flow _addr ->
+       traceln "handler accepted";
+       let r = Eio.Buf_read.of_flow flow ~max_size:max_int in
+       let line = Eio.Buf_read.line r in
+       traceln "handler + %s" line;
+       Flow.copy_string line flow
+    )
+    (fun () ->
+       test_client ~net ("127.0.0.1", "4433")
+    )
+  ;;
++server -> start @ tcp:127.0.0.1:4433
++server -> connect
++handler accepted
++handler + GET / HTTP/1.1
++client <- GET
++client done.
+- : unit = ()
+```

unikernel/duniverse/ocaml-tls/eio/tls_eio.ml

@@ -0,0 +1,250 @@
+open Eio.Std
+
+module Flow = Eio.Flow
+
+exception Tls_alert   of Tls.Packet.alert_type
+exception Tls_failure of Tls.Engine.failure
+
+type Eio.Exn.Backend.t += Tls_socket_closed
+let () = Eio.Exn.Backend.register_pp (fun f -> function
+    | Tls_socket_closed -> Fmt.pf f "TLS_socket_closed"; true
+    | _ -> false
+  )
+
+type ty = [ `Tls | Eio.Flow.two_way_ty | Eio.Resource.close_ty ]
+type t = ty r
+
+module Raw = struct
+
+  (* We could replace [`Eof] with [`Error End_of_file] and then use
+     a regular [result] type here. *)
+  type t = {
+    flow           : [Flow.two_way_ty | Eio.Resource.close_ty] r;
+    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 : Cstruct.t option ;
+    recv_buf       : Cstruct.t ;
+  }
+
+  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 write_t t s =
+    try Flow.copy_string s t.flow
+    with exn ->
+      (match t.state with
+       | `Error _ -> ()
+       | _ -> t.state <- `Error exn) ;
+      raise exn
+
+  let try_write_t t cs =
+    try write_t t cs
+    with _ -> Eio.Fiber.check ()      (* Error is in [t.state] *)
+
+  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' ;
+          Option.iter (try_write_t t) resp;
+          Option.map Cstruct.of_string data
+
+      | Error (fail, `Response resp) ->
+          t.state <- `Error (match fail with `Alert a -> Tls_alert a | f -> Tls_failure f) ;
+          write_t t resp; read_react t
+    in
+
+    match t.state with
+    | `Error e  -> raise e
+    | `Closed
+    | `Read_closed _ -> raise End_of_file
+    | _ ->
+        match Flow.single_read t.flow t.recv_buf with
+          | exception End_of_file ->
+            t.state <- half_close t.state `read;
+            raise End_of_file
+          | exception exn ->
+            (match t.state with
+             | `Error _ -> ()
+             | _ -> t.state <- `Error exn) ;
+            raise exn
+          | n ->
+            match t.state with
+            | `Error e -> raise e
+            | `Active tls | `Read_closed tls | `Write_closed tls ->
+              handle tls (Cstruct.to_string t.recv_buf ~off:0 ~len:n)
+            | `Closed -> raise End_of_file
+
+  let rec single_read t buf =
+
+    let writeout res =
+      let open Cstruct in
+      let rlen = length res in
+      let n    = min (length buf) rlen in
+      blit res 0 buf 0 n ;
+      t.linger <-
+        (if n < rlen then Some (sub res n (rlen - n)) else None) ;
+      n in
+
+    match t.linger with
+    | Some res -> writeout res
+    | None     ->
+        match read_react t with
+          | None     -> single_read t buf
+          | Some res -> writeout res
+
+  let writev t css =
+    match t.state with
+    | `Error err  -> raise err
+    | `Write_closed _ | `Closed -> raise (Eio.Net.err (Connection_reset Tls_socket_closed))
+    | `Active tls | `Read_closed tls ->
+        let css = List.map Cstruct.to_string css in
+        match Tls.Engine.send_application_data tls css with
+        | Some (tls, tlsdata) ->
+            ( t.state <- inject_state tls t.state ; write_t t tlsdata )
+        | None -> invalid_arg "tls: write: socket not ready"
+
+  let single_write t bufs =
+    writev t bufs;
+    Cstruct.lenv bufs
+
+  (*
+   * 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 (Cstruct.append l cs)
+    in
+    match t.state with
+    | `Active tls when not (Tls.Engine.handshake_in_progress tls) ->
+        t
+    | _ ->
+        let cs = read_react t in
+        push_linger t cs; drain_handshake t
+
+  let reneg ?authenticator ?acceptable_cas ?cert ?(drop = true) t =
+    match t.state with
+    | `Error err  -> raise err
+    | `Closed | `Read_closed _ | `Write_closed _ -> invalid_arg "tls: closed socket"
+    | `Active tls ->
+        match Tls.Engine.reneg ?authenticator ?acceptable_cas ?cert tls with
+        | None -> invalid_arg "tls: can't renegotiate"
+        | Some (tls', buf) ->
+           if drop then t.linger <- None ;
+           t.state <- inject_state tls' t.state ;
+           write_t t buf;
+           ignore (drain_handshake t : t)
+
+  let key_update ?request t =
+    match t.state with
+    | `Error err  -> raise err
+    | `Write_closed _ | `Closed -> invalid_arg "tls: closed socket"
+    | `Active tls | `Read_closed tls ->
+      match Tls.Engine.key_update ?request tls with
+      | Error f -> Fmt.invalid_arg "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 = function
+    | `Receive -> ()
+    | `Send | `All ->
+      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
+      | _ -> ()
+
+  let server_of_flow config flow =
+    drain_handshake {
+      state    = `Active (Tls.Engine.server config) ;
+      flow     = (flow :> [Flow.two_way_ty | Eio.Resource.close_ty] r) ;
+      linger   = None ;
+      recv_buf = Cstruct.create 4096
+    }
+
+  let client_of_flow config ?host flow =
+    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 ;
+      flow     = (flow :> [Flow.two_way_ty | Eio.Resource.close_ty] r);
+      linger   = None ;
+      recv_buf = Cstruct.create 4096
+    } in
+    write_t t init;
+    drain_handshake t
+
+
+  let epoch t =
+    match t.state with
+    | `Active tls | `Read_closed tls | `Write_closed tls -> Tls.Engine.epoch tls
+    | `Closed | `Error _ -> Error ()
+
+  let copy t ~src = Eio.Flow.Pi.simple_copy ~single_write t ~src
+
+  let read_methods = []
+
+  let close t = Eio.Resource.close t.flow
+
+  type (_, _, _) Eio.Resource.pi += T : ('t, 't -> t, ty) Eio.Resource.pi
+end
+
+let raw (Eio.Resource.T (t, ops)) = Eio.Resource.get ops Raw.T t
+
+let handler =
+  Eio.Resource.handler [
+    H (Eio.Flow.Pi.Source, (module Raw));
+    H (Eio.Flow.Pi.Sink, (module Raw));
+    H (Eio.Flow.Pi.Shutdown, (module Raw));
+    H (Eio.Resource.Close, Raw.close);
+    H (Raw.T, Fun.id);
+  ]
+
+let of_t t = Eio.Resource.T (t, handler)
+
+let server_of_flow config       flow = Raw.server_of_flow config       flow |> of_t
+let client_of_flow config ?host flow = Raw.client_of_flow config ?host flow |> of_t
+
+let reneg ?authenticator ?acceptable_cas ?cert ?drop (t:t) = Raw.reneg ?authenticator ?acceptable_cas ?cert ?drop (raw t)
+let key_update ?request (t:t) = Raw.key_update ?request (raw t)
+let epoch (t:t) = Raw.epoch (raw t)
+
+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/eio/tls_eio.mli

@@ -0,0 +1,59 @@
+(** Effectful operations using Eio for pure TLS.
+
+    The pure TLS is state and buffer in, state and buffer out.  This
+    module uses Eio for communication over the network. *)
+
+open Eio.Std
+
+(** [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
+
+type t = [ `Tls | Eio.Flow.two_way_ty | Eio.Resource.close_ty ] r
+
+(** {2 Constructors} *)
+
+(** [server_of_flow server flow] is [t], after server-side TLS
+    handshake of [flow] using [server] configuration.
+
+    You must ensure a RNG is installed while using TLS, e.g. using [Mirage_crypto_rng_unix.use_default ()].
+    Ideally, this would be part of the [server] config so you couldn't forget it,
+    but for now you'll get a runtime error if you forget. *)
+val server_of_flow :
+  Tls.Config.server ->
+  [> Eio.Flow.two_way_ty | Eio.Resource.close_ty] r -> t
+
+(** [client_of_flow client ~host fd] is [t], after client-side
+    TLS handshake of [flow] using [client] configuration and [host].
+
+    You must ensure a RNG is installed while using TLS, e.g. using [Mirage_crypto_rng_unix.use_default ()].
+    Ideally, this would be part of the [client] config so you couldn't forget it,
+    but for now you'll get a runtime error if you forget. *)
+val client_of_flow :
+  Tls.Config.client -> ?host:[ `host ] Domain_name.t ->
+  [> Eio.Flow.two_way_ty | Eio.Resource.close_ty] r -> t
+
+(** {2 Control of TLS features} *)
+
+(** [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
+
+(** [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
+
+(** [epoch t] returns [epoch], which contains information of the
+    active session. *)
+val epoch : t -> (Tls.Core.epoch_data, unit) result

unikernel/duniverse/ocaml-tls/eio/x509_eio.ml

@@ -0,0 +1,89 @@
+open Eio.Std
+
+module Path = Eio.Path
+
+let (</>) = Path.( / )
+
+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 =
+  let certs =
+    try
+      let pem = Path.load cert in
+      match X509.Certificate.decode_pem_multiple pem with
+      | Ok cs -> cs
+      | Error (`Msg m) -> invalid_arg ("failed to parse certificates " ^ m)
+    with Invalid_argument m ->
+      Fmt.failwith "Private certificates %a: %s" Path.pp cert m
+  in
+  let pk =
+    try
+      let pem = Path.load priv_key in
+      match X509.Private_key.decode_pem pem with
+      | Ok key -> key
+      | Error (`Msg m) -> invalid_arg ("failed to parse private key " ^ m)
+    with Invalid_argument m ->
+      Fmt.failwith "Private key (%a): %s" Path.pp priv_key m
+  in
+  (certs, pk)
+
+let certs_of_pem path =
+  try
+    let pem = Path.load path in
+    match X509.Certificate.decode_pem_multiple pem with
+    | Ok cs -> cs
+    | Error (`Msg m) -> invalid_arg ("failed to parse certificates " ^ m)
+  with Invalid_argument m ->
+    Fmt.failwith "Certificates in %a: %s" Path.pp path m
+
+let certs_of_pem_dir path =
+  Path.read_dir path
+  |> List.filter (fun file -> extension file = Some "crt")
+  |> Fiber.List.map (fun file -> certs_of_pem (path </> file))
+  |> List.concat
+
+let crl_of_pem path =
+  try
+    let data = Path.load path in
+    match X509.CRL.decode_der data with
+    | Ok cs -> cs
+    | Error (`Msg m) -> invalid_arg ("failed to parse CRL " ^ m)
+  with Invalid_argument m ->
+    Fmt.failwith "CRL in %a: %s" Path.pp path m
+
+let crls_of_pem_dir path =
+  Path.read_dir path
+  |> Fiber.List.map (fun file -> crl_of_pem (path </> file))
+
+(* Would be better to take an Eio.Time.clock here, but that API is likely to change soon. *)
+let authenticator ?allowed_hashes ?crls param =
+  let time () = Some (Ptime_clock.now ()) in
+  let of_cas cas =
+    let crls = Option.map crls_of_pem_dir crls in
+    X509.Authenticator.chain_of_trust ?allowed_hashes ?crls ~time cas
+  and dotted_hex_to_cs hex =
+    Cstruct.to_string (Cstruct.of_hex (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) -> fingerp hash fp
+  | `Hex_key_fingerprint (hash, fp) ->
+    let fp = dotted_hex_to_cs fp in
+    fingerp hash fp
+  | `Cert_fingerprint (hash, fp) -> cert_fingerp hash fp
+  | `Hex_cert_fingerprint (hash, fp) ->
+    let fp = dotted_hex_to_cs fp in
+    cert_fingerp hash fp

unikernel/duniverse/ocaml-tls/eio/x509_eio.mli

@@ -0,0 +1,26 @@
+(** X.509 certificate handling using Eio. *)
+
+(** [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:_ Eio.Path.t -> priv_key:_ Eio.Path.t -> Tls.Config.certchain
+
+(** [certs_of_pem file] is [certificates], which are read from the
+    PEM-encoded [file]. *)
+val certs_of_pem     : _ Eio.Path.t -> X509.Certificate.t list
+
+(** [certs_of_pem_dir dir] is [certificates], which are read from all
+    PEM-encoded files in [dir]. *)
+val certs_of_pem_dir : _ Eio.Path.t -> X509.Certificate.t list
+
+(** [authenticator methods] constructs an [authenticator] using the
+    specified method and data. *)
+val authenticator : ?allowed_hashes:Digestif.hash' list -> ?crls:_ Eio.Path.t ->
+  [ `Ca_file of _ Eio.Path.t
+  | `Ca_dir  of _ Eio.Path.t
+  | `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