unikernel/duniverse/ocaml-tls/miou/dune

@@ -0,0 +1,4 @@
+(library
+ (name tls_miou_unix)
+ (public_name tls-miou-unix)
+ (libraries miou.unix tls))

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

@@ -0,0 +1,15 @@
+(test
+ (name fuzz)
+ (package tls-miou-unix)
+ (libraries
+   mirage-crypto-rng-miou-unix
+   ohex
+   rresult
+   ptime
+   ptime.clock.os
+   crowbar
+   hxd.core
+   hxd.string
+   tls-miou-unix)
+ (instrumentation
+  (backend bisect_ppx)))

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

@@ -0,0 +1,339 @@
+let rec random_path ?(tries = 10) fmt =
+  if tries <= 0 then failwith "Impossible to generate an available random path";
+  let res = Bytes.create 6 in
+  for i = 0 to Bytes.length res - 1 do
+    let chr =
+      match Random.int (10 + 26 + 26) with
+      | n when n < 10 -> Char.chr (Char.code '0' + n)
+      | n when n < 10 + 26 -> Char.chr (Char.code 'a' + n - 10)
+      | n -> Char.chr (Char.code 'A' + n - 10 - 26)
+    in
+    Bytes.set res i chr
+  done;
+  let path = Fmt.str fmt (Bytes.unsafe_to_string res) in
+  if Sys.file_exists path then random_path ~tries:(pred tries) fmt else path
+
+let unlink_if_exists path =
+  try Unix.unlink path with Unix.Unix_error (Unix.ENOENT, _, _) -> ()
+
+let bind_and_listen ?(backlog = 16) () =
+  let tmp = random_path "socket-%s.socket" in
+  unlink_if_exists tmp;
+  let socket = Unix.socket ~cloexec:true Unix.PF_UNIX Unix.SOCK_STREAM 0 in
+  let addr = Unix.ADDR_UNIX tmp in
+  Unix.bind socket addr;
+  Unix.listen socket backlog;
+  (Miou_unix.of_file_descr ~non_blocking:true socket, addr, tmp)
+
+module Ca = struct
+  open Rresult
+
+  let prefix =
+    X509.Distinguished_name.
+      [ Relative_distinguished_name.singleton (CN "Fuzzer") ]
+
+  let cacert_dn =
+    X509.Distinguished_name.(
+      prefix
+      @ [ Relative_distinguished_name.singleton (CN "Ephemeral CA for fuzzer") ])
+
+  let cacert_lifetime = Ptime.Span.v (365, 0L)
+  let _10s = Ptime.Span.of_int_s 10
+
+  let make domain_name seed =
+    let valid_from = Option.get Ptime.(sub_span (v (Ptime_clock.now_d_ps ())) _10s) in
+    Domain_name.of_string domain_name >>= Domain_name.host
+    >>= fun domain_name ->
+    let private_key =
+      let seed = Base64.decode_exn ~pad:false seed in
+      let g = Mirage_crypto_rng.(create ~seed (module Fortuna)) in
+      Mirage_crypto_pk.Rsa.generate ~g ~bits:2048 ()
+    in
+    Ptime.add_span valid_from cacert_lifetime
+    |> Option.to_result ~none:(R.msgf "End time out of range")
+    >>= fun valid_until ->
+    X509.Signing_request.create cacert_dn (`RSA private_key) >>= fun ca_csr ->
+    let extensions =
+      let open X509.Extension in
+      let key_id =
+        X509.Public_key.id X509.Signing_request.((info ca_csr).public_key)
+      in
+      empty
+      |> add Subject_alt_name
+           ( true,
+             X509.General_name.(
+               singleton DNS [ Domain_name.to_string domain_name ]) )
+      |> add Basic_constraints (true, (false, None))
+      |> add Key_usage
+           (true, [ `Digital_signature; `Content_commitment; `Key_encipherment ])
+      |> add Subject_key_id (false, key_id)
+    in
+    X509.Signing_request.sign ~valid_from ~valid_until ~extensions
+      ca_csr (`RSA private_key) cacert_dn
+    |> R.reword_error (R.msgf "%a" X509.Validation.pp_signature_error)
+    >>= fun certificate ->
+    let fingerprint = X509.Certificate.fingerprint `SHA256 certificate in
+    let time () = Some (Ptime_clock.now ()) in
+    let authenticator =
+      X509.Authenticator.cert_fingerprint ~time ~hash:`SHA256
+        ~fingerprint
+    in
+    Ok (certificate, `RSA private_key, authenticator)
+end
+
+let fuzz_coop = "fuzz.coop"
+let mutex = Miou.Mutex.create ()
+let epr fmt = Miou.Mutex.protect mutex @@ fun () -> Fmt.epr fmt
+
+type operation =
+  | Send of string
+  | Recv of int
+  | Shutdown of [ `read | `write ]
+  | Close
+  | Noop
+
+module Stop = struct
+  type t = {
+    mutex : Miou.Mutex.t;
+    condition : Miou.Condition.t;
+    mutable stop : bool;
+  }
+
+  let create () =
+    let mutex = Miou.Mutex.create () in
+    let condition = Miou.Condition.create () in
+    { mutex; condition; stop = false }
+
+  let stop t =
+    Miou.Mutex.protect t.mutex @@ fun () ->
+    t.stop <- true;
+    Miou.Condition.broadcast t.condition
+
+  let wait t =
+    Miou.Mutex.protect t.mutex @@ fun () ->
+    while t.stop = false do
+      Miou.Condition.wait t.condition t.mutex
+    done
+end
+
+let inhibit fn = try fn () with _exn -> ()
+
+let run ~role:_ actions tls =
+  let rec go buf tls = function
+    | [] -> Buffer.contents buf
+    | Noop :: actions ->
+        Miou.yield ();
+        go buf tls actions
+    | Send str :: actions ->
+        Tls_miou_unix.write tls str;
+        go buf tls actions
+    | Close :: actions ->
+        Tls_miou_unix.close tls;
+        go buf tls actions
+    | Shutdown cmd :: actions ->
+        Tls_miou_unix.shutdown tls (cmd :> [ `read | `write | `read_write ]);
+        go buf tls actions
+    | Recv len :: actions ->
+        let tmp = Bytes.make len '\000' in
+        Tls_miou_unix.really_read tls tmp;
+        Buffer.add_subbytes buf tmp 0 len;
+        go buf tls actions
+  in
+  let buf = Buffer.create 0x100 in
+  try go buf tls actions with
+  | End_of_file | Tls_miou_unix.Closed_by_peer | Tls_miou_unix.Tls_alert _
+  | Tls_miou_unix.Tls_failure _ ->
+      inhibit (fun () -> Miou_unix.close (Tls_miou_unix.file_descr tls));
+      Buffer.contents buf
+  | exn ->
+      inhibit (fun () -> Miou_unix.close (Tls_miou_unix.file_descr tls));
+      raise exn
+
+let run_client ~to_client:actions cfg addr =
+  let domain = Unix.domain_of_sockaddr addr in
+  let socket = Unix.socket ~cloexec:true domain Unix.SOCK_STREAM 0 in
+  Unix.connect socket addr;
+  let fd = Miou_unix.of_file_descr ~non_blocking:true socket in
+  let tls = Tls_miou_unix.client_of_fd cfg fd in
+  let finally () =
+    inhibit (fun () -> Unix.close socket)
+  in
+  Fun.protect ~finally @@ fun () -> run ~role:"client" actions tls
+
+let rec cleanup orphans clients =
+  match Miou.care orphans with
+  | None | Some None -> clients
+  | Some (Some prm) ->
+      let clients = Miou.await prm :: clients in
+      cleanup orphans clients
+
+let rec terminate orphans clients =
+  match Miou.care orphans with
+  | None -> List.rev clients
+  | Some None ->
+      Miou.yield ();
+      terminate orphans clients
+  | Some (Some prm) ->
+      let clients = Miou.await prm :: clients in
+      terminate orphans clients
+
+exception Stop
+
+let run_server ~to_server:actions ~stop fd cfg =
+  let rec go orphans clients =
+    let clients = cleanup orphans clients in
+    let accept = Miou.async @@ fun () -> Miou_unix.accept ~cloexec:true fd in
+    let stop =
+      Miou.async @@ fun () ->
+      Stop.wait stop;
+      raise Stop
+    in
+    match Miou.await_first [ accept; stop ] with
+    | Error _ ->
+        inhibit (fun () -> Miou_unix.close fd);
+        terminate orphans clients
+    | Ok (fd, _) ->
+        ignore
+          ( Miou.async ~orphans @@ fun () ->
+            match Tls_miou_unix.server_of_fd cfg fd with
+            | tls ->
+                let str = run ~role:"server" actions tls in
+                inhibit (fun () -> Miou_unix.close fd); str
+            | exception _ ->
+                Miou_unix.close fd;
+                String.empty );
+        go orphans clients
+  in
+  go (Miou.orphans ()) []
+
+let compile to_client to_server =
+  let close_client close = function
+    | Close -> close lor 0b1100
+    | Shutdown `read -> close lor 0b1000
+    | Shutdown `write -> close lor 0b0100
+    | _ -> close
+  in
+  let close_server close = function
+    | Close -> close lor 0b0011
+    | Shutdown `read -> close lor 0b0010
+    | Shutdown `write -> close lor 0b0001
+    | _ -> close
+  in
+  let client = Buffer.create 0x100 in
+  let server = Buffer.create 0x100 in
+  let rec go close to_client to_server =
+    match (close, to_client, to_server) with
+    | _, [], _ | _, _, [] -> ()
+    | close, ((Shutdown _ | Close) as operation) :: to_client, _ ->
+        go (close_client close operation) to_client to_server
+    | close, _, ((Shutdown _ | Close) as operation) :: to_server ->
+        go (close_server close operation) to_client to_server
+    | close, Noop :: to_client, to_server | close, to_client, Noop :: to_server
+      ->
+        go close to_client to_server
+    | close, Send str :: to_client, Recv n :: to_server ->
+        assert (String.length str = n);
+        if close land 0b0100 = 0 && close land 0b0010 = 0 then
+          Buffer.add_string server str;
+        if close land 0b0100 = 0 && close land 0b0010 = 0 then
+          go close to_client to_server
+    | close, Recv n :: to_client, Send str :: to_server ->
+        assert (String.length str = n);
+        if close land 0b1000 = 0 && close land 0b0001 = 0 then
+          Buffer.add_string client str;
+        if close land 0b1000 = 0 && close land 0b0001 = 0 then
+          go close to_client to_server
+    | _, Send _ :: _, Send _ :: _ | _, Recv _ :: _, Recv _ :: _ ->
+        assert false (* GADT? *)
+  in
+  go 0x0 to_client to_server;
+  (Buffer.contents client, Buffer.contents server)
+
+let pp_exn ppf exn = Fmt.string ppf (Printexc.to_string exn)
+let pp_str ppf str = Hxd_string.pp Hxd.default ppf str
+
+let run seed operations =
+  Miou_unix.run ~domains:1 @@ fun () ->
+  let rng = Mirage_crypto_rng_miou_unix.(initialize (module Pfortuna)) in
+  let fd, addr, path = bind_and_listen () in
+  let finally () = Unix.unlink path in
+  Fun.protect ~finally @@ fun () ->
+  let cert, pk, authenticator =
+    Rresult.R.failwith_error_msg (Ca.make fuzz_coop seed)
+  in
+  let cfg_server =
+    Result.get_ok (Tls.Config.server ~certificates:(`Single ([ cert ], pk)) ())
+  in
+  let cfg_client = Result.get_ok (Tls.Config.client ~authenticator ()) in
+  let to_client, to_server = List.split operations in
+  let stop = Stop.create () in
+  let prm0 = Miou.async @@ fun () -> run_server ~to_server ~stop fd cfg_server in
+  let prm1 =
+    Miou.async @@ fun () ->
+    let finally () = Stop.stop stop in
+    Fun.protect ~finally @@ fun () -> run_client ~to_client cfg_client addr
+  in
+  let send_to_client, send_to_server = compile to_client to_server in
+  match (Miou.await prm0, Miou.await prm1) with
+  | Ok [ Ok send_to_server' ], Ok send_to_client' ->
+      Crowbar.check (String.equal send_to_client send_to_client');
+      Crowbar.check (String.equal send_to_server send_to_server');
+      let n = String.length send_to_client in
+      let m = String.length send_to_server in
+      Mirage_crypto_rng_miou_unix.kill rng;
+      epr "[%a] %db %db transmitted\n%!" Fmt.(styled `Green string) "OK" n m
+  | a, b ->
+      Mirage_crypto_rng_miou_unix.kill rng;
+      Crowbar.failf "[%a] Unexpected result: %a & %a\n%!"
+        Fmt.(styled `Red string) "ERROR"
+        Fmt.(Dump.result ~error:pp_exn ~ok:Fmt.(Dump.list (Dump.result ~error:pp_exn ~ok:pp_str))) a
+        Fmt.(Dump.result ~error:pp_exn ~ok:pp_str) b
+
+let label name gen = Crowbar.with_printer Fmt.(const string name) gen
+
+let direction =
+  let open Crowbar in
+  choose
+    [
+      label "server-to-client" (const `To_client);
+      label "client-to-server" (const `To_server);
+    ]
+
+let shutdown =
+  let open Crowbar in
+  choose
+    [
+      label "close" (const Close);
+      label "shutdown-recv" (const (Shutdown `read));
+      label "shutdown-send" (const (Shutdown `write));
+      label "noop" (const Noop);
+    ]
+
+let operation =
+  let open Crowbar in
+  map [ direction; bytes ] @@ fun direction str ->
+  match (direction, str) with
+  | _, "" -> (Noop, Noop)
+  | `To_server, str -> (Send str, Recv (String.length str))
+  | `To_client, str -> (Recv (String.length str), Send str)
+
+let counter = Atomic.make 0
+
+let operations =
+  let open Crowbar in
+  fix @@ fun m ->
+  let continue (to_client, to_server) =
+    if Atomic.fetch_and_add counter 1 >= 4 then const [ (Close, Close) ]
+    else map [ m ] @@ fun ops -> (to_client, to_server) :: ops
+  in
+  map
+    [ list1 operation; dynamic_bind (pair shutdown shutdown) continue ]
+    List.rev_append
+
+let seed = Crowbar.(map [ bytes ] Base64.encode_exn)
+
+let () =
+  Sys.set_signal Sys.sigpipe Sys.Signal_ignore;
+  Crowbar.add_test ~name:"run" Crowbar.[ seed; operations ] @@ fun seed operations ->
+  run seed operations;
+  Atomic.set counter 0

unikernel/duniverse/ocaml-tls/miou/tls_miou_unix.ml

@@ -0,0 +1,332 @@
+(* NOTE: the unix/tls_unix.ml is mostly copied from here, so any change should be synchronized. *)
+
+let src = Logs.Src.create "tls-miou"
+
+module Log = (val Logs.src_log src : Logs.LOG)
+
+external reraise : exn -> 'a = "%reraise"
+
+let ( $ ) f x = f x
+
+exception Tls_alert of Tls.Packet.alert_type
+exception Tls_failure of Tls.Engine.failure
+exception Closed_by_peer
+
+let () =
+  Printexc.register_printer @@ function
+  | Closed_by_peer -> Some "Connection closed by peer"
+  | Tls_alert alert -> Some (Tls.Packet.alert_type_to_string alert)
+  | Tls_failure failure -> Some (Tls.Engine.string_of_failure failure)
+  | _ -> None
+
+type state =
+  [ `Active of Tls.Engine.state
+  | `Read_closed of Tls.Engine.state
+  | `Write_closed of Tls.Engine.state
+  | `Closed
+  | `Error of exn ]
+
+type t = {
+  role : [ `Server | `Client ];
+  fd : Miou_unix.file_descr;
+  mutable state : state;
+  mutable linger : string option;
+  read_buffer_size : int;
+  buf : bytes;
+  mutable rd_closed : bool;
+}
+
+let file_descr { fd; _ } = fd
+
+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 = Tls_alert a
+let tls_fail f = Tls_failure f
+let inhibit fn v = try fn v with _ -> ()
+
+let write flow str =
+  Log.debug (fun m -> m "try to write %d byte(s)" (String.length str));
+  try Miou_unix.write flow.fd str with
+  | Unix.Unix_error ((Unix.EPIPE | Unix.ECONNRESET), _, _) ->
+      flow.state <- half_close flow.state `write;
+      raise Closed_by_peer
+  | Unix.Unix_error (_, _, _) as exn ->
+      flow.state <- `Error exn;
+      reraise exn
+
+let handle flow tls str =
+  match Tls.Engine.handle_tls tls str with
+  | Ok (state, eof, `Response resp, `Data data) ->
+      Log.debug (fun m -> m "We handled %d byte(s)" (String.length str));
+      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;
+      let to_close = flow.state = `Closed in
+      Option.iter (inhibit $ write flow) resp;
+      (* NOTE(dinosaure): [write flow] can set [flow.state]. So we must
+         check if the actual [flow.state] or the [flow.state] after [write flow]
+         want to close the underlying file-descriptor. *)
+      if to_close || flow.state = `Closed then Miou_unix.close flow.fd;
+      data
+  | Error (fail, `Response resp) ->
+      let exn = match fail with
+        | `Alert a -> tls_alert a | f -> tls_fail f in
+      flow.state <- `Error exn;
+      let _ = inhibit (write flow) resp in
+      raise exn
+
+let read flow =
+  match Miou_unix.read flow.fd flow.buf ~off:0 ~len:(Bytes.length flow.buf) with
+  | 0 -> Ok String.empty
+  | len -> Ok (Bytes.sub_string flow.buf 0 len)
+  | exception Unix.Unix_error (Unix.ECONNRESET, _, _) -> Ok String.empty
+  | exception exn -> Error exn
+
+let not_errored = function `Error _ -> false | _ -> true
+
+let garbage flow = match flow.linger with
+  | Some "" | None -> false
+  | _ -> true
+
+let read_react flow =
+  match flow.state with
+  | `Error exn -> raise exn
+  | `Read_closed _ | `Closed when garbage flow ->
+    (* XXX(dinosaure): [`Closed] can appear "at the same time" than some
+       application-data. In that case, we stored them into [t.linger]. Depending
+       on who closed the connection, [read_react] gives this /garbage/ in any
+       situation (even if the user closed the connection).
+
+       An extra layer with [read] below check if [`Read_closed]/[`Close] comes
+       from the network (the peer closed the connection) or the user. In the
+       first case, we must give pending application-data. In the second case,
+       we must return [0] (or raise [End_of_file]). *)
+    let mbuf = flow.linger in
+    flow.linger <- None;
+    mbuf
+  | `Read_closed _ | `Closed ->
+    (* XXX(dinosaure): the goal of [read_react] is to read some encrypted bytes
+       and try to decrypt them with [handle]. If the linger is empty, this means
+       that we're trying to get more data (to decrypt) when we can't get any
+       more. From this point of view, it's an error that needs to be notified.
+       However, this error can be interpreted in 2 ways:
+       - we want to have more data decrypted. In this case, this error is
+         expected and may result in the user being told that there is nothing
+         left to read (for example, returning 0).
+       - we attempt a handshake. In this case, we are dealing with an unexpected
+         error. *)
+    raise End_of_file
+  | `Active _ | `Write_closed _ ->
+    Log.debug (fun m -> m "read something from the TLS session");
+    match read flow with
+    | Error exn ->
+      if not_errored flow.state then flow.state <- `Error exn;
+      raise exn
+    | Ok "" ->
+      (* XXX(dinosaure): see [`Read_closed _ | `Closed] case. *)
+      raise End_of_file 
+    | Ok str ->
+      Log.debug (fun m -> m "got %d byte(s)" (String.length str));
+      match flow.state with
+      | `Active tls | `Read_closed tls | `Write_closed tls -> handle flow tls str
+      | `Closed -> raise End_of_file
+      | `Error exn -> raise exn
+[@@ocamlformat "disable"]
+
+let rec read_in flow ?(off= 0) ?len buf =
+  let len = Option.value ~default:(Bytes.length buf - off) len in
+  let write_in res =
+    let rlen = String.length res in
+    let mlen = min len rlen in
+    Bytes.blit_string res 0 buf off mlen;
+    let linger = if mlen < rlen
+      then Some (String.sub res mlen (rlen - mlen))
+      else None in
+    flow.linger <- linger; mlen
+  in
+  match flow.linger with
+  | Some res -> write_in res
+  | None -> (
+      match read_react flow with
+      | None -> read_in ~off ~len flow buf
+      | Some res -> write_in res)
+
+let writev flow bufs =
+  match flow.state with
+  | `Closed | `Write_closed _ -> raise Closed_by_peer
+  | `Error exn -> reraise exn
+  | `Active tls | `Read_closed tls -> (
+      match Tls.Engine.send_application_data tls bufs with
+      | Some (tls, answer) ->
+          flow.state <- inject_state tls flow.state;
+          write flow answer
+      | None -> assert false)
+
+let rec drain_handshake flow =
+  let push_linger flow mcs =
+    match (mcs, flow.linger) with
+    | None, _ -> ()
+    | scs, None -> flow.linger <- scs
+    | Some cs, Some l -> flow.linger <- Some (l ^ cs)
+  in
+  match flow.state with
+  | `Active tls when not (Tls.Engine.handshake_in_progress tls) -> flow
+  | (`Read_closed _ | `Closed) when garbage flow -> flow
+  | _ ->
+      Log.debug (fun m -> m "start to read something from the TLS session");
+      let mcs = read_react flow in
+      push_linger flow mcs;
+      drain_handshake flow
+
+let close flow =
+  match flow.state with
+  | `Active tls | `Read_closed tls ->
+      let tls, str = Tls.Engine.send_close_notify tls in
+      flow.rd_closed <- true;
+      flow.state <- inject_state tls flow.state;
+      flow.state <- `Closed;
+      inhibit (write flow) str;
+      Miou_unix.close flow.fd
+  | `Write_closed _ ->
+      flow.rd_closed <- true;
+      flow.state <- `Closed;
+      Miou_unix.close flow.fd
+  | `Closed -> flow.rd_closed <- true
+  | `Error _ ->
+      flow.rd_closed <- true;
+      Miou_unix.close flow.fd
+
+let closed_by_user flow = function
+  | `read | `read_write -> flow.rd_closed <- true
+  | `write -> ()
+
+let shutdown flow mode =
+  closed_by_user flow mode;
+  match (flow.state, mode) with
+  | `Active tls, `read ->
+      Log.debug (fun m -> m "shutdown `read");
+      flow.state <- inject_state tls (half_close flow.state mode)
+  | (`Active tls | `Read_closed tls), (`write | `read_write) ->
+      let tls, str = Tls.Engine.send_close_notify tls in
+      flow.state <- inject_state tls (half_close flow.state mode);
+      (* NOTE(dinosaure): [write flow] can set [flow.state]. So we must
+         check if the actual [flow.state] or the [flow.state] after [write flow]
+         want to close the underlying file-descriptor. *)
+      let to_close = flow.state = `Closed in
+      inhibit (write flow) str;
+      if to_close || flow.state = `Closed then Miou_unix.close flow.fd
+  | `Write_closed tls, (`read | `read_write) ->
+      flow.state <- inject_state tls (half_close flow.state mode);
+      if flow.state = `Closed then Miou_unix.close flow.fd
+  | `Error _, _ -> Miou_unix.close flow.fd
+  | `Read_closed _, `read -> ()
+  | `Write_closed _, `write -> ()
+  | `Closed, _ -> ()
+
+let client_of_fd conf ?(read_buffer_size = 0x1000) ?host fd =
+  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;
+      fd;
+      state = `Active tls;
+      linger = None;
+      read_buffer_size;
+      buf = Bytes.make read_buffer_size '\000';
+      rd_closed = false;
+    }
+  in
+  write tls_flow init;
+  drain_handshake tls_flow
+
+let server_of_fd conf ?(read_buffer_size = 0x1000) fd =
+  let tls = Tls.Engine.server conf in
+  let tls_flow =
+    {
+      role = `Server;
+      fd;
+      state = `Active tls;
+      linger = None;
+      read_buffer_size;
+      buf = Bytes.make read_buffer_size '\000';
+      rd_closed = false;
+    }
+  in
+  drain_handshake tls_flow
+
+let write flow ?(off = 0) ?len str =
+  let len = Option.value ~default:(String.length str - off) len in
+  if off < 0 || len < 0 || off > String.length str - len
+  then invalid_arg "Tls_miou.write";
+  if len > 0 then writev flow [ String.sub str off len ]
+
+let read t ?(off= 0) ?len buf =
+  let len = Option.value ~default:(Bytes.length buf - off) len in
+  if off < 0 || len < 0 || off > Bytes.length buf - len
+  then invalid_arg "Tls_miou.read";
+  if t.rd_closed then 0
+  else try read_in t ~off ~len buf with End_of_file -> 0
+
+let rec really_read_go t off len buf =
+  let len' = read t buf ~off ~len in
+  if len' == 0 then raise End_of_file
+  else if len - len' > 0
+  then really_read_go t (off + len') (len - len') buf
+
+let really_read t ?(off= 0) ?len buf =
+  let len = Option.value ~default:(Bytes.length buf - off) len in
+  if off < 0 || len < 0 || off > Bytes.length buf - len
+  then invalid_arg "Tls_miou.really_read";
+  if len > 0 then really_read_go t off len buf
+
+let resolve host service =
+  let tcp = Unix.getprotobyname "tcp" in
+  match Unix.getaddrinfo host service [ AI_PROTOCOL tcp.p_proto ] with
+  | [] -> Fmt.invalid_arg "No address for %s:%s" host service
+  | ai :: _ -> ai.ai_addr
+
+let connect authenticator (v, port) =
+  let conf =
+    match Tls.Config.client ~authenticator () with
+    | Ok config -> config
+    | Error `Msg msg -> Fmt.invalid_arg "Configuration failure: %s" msg
+  in
+  let addr = resolve v (string_of_int port) in
+  let fd =
+    match addr with
+    | Unix.ADDR_UNIX _ -> invalid_arg "Tls_miou.connect: Invalid UNIX socket"
+    | Unix.ADDR_INET (inet_addr, _) ->
+        if Unix.is_inet6_addr inet_addr then Miou_unix.tcpv6 ()
+        else Miou_unix.tcpv4 ()
+  in
+  let host = Result.to_option Domain_name.(Result.bind (of_string v) host) in
+  match Miou_unix.connect fd addr with
+  | () -> client_of_fd conf ?host fd
+  | exception exn ->
+      Miou_unix.close fd;
+      raise exn
+
+let epoch flow = match flow.state with
+  | `Active tls | `Read_closed tls | `Write_closed tls ->
+    ( match Tls.Engine.epoch tls with
+    | Error () -> assert false
+    | Ok data -> Some data )
+  | _ -> None

unikernel/duniverse/ocaml-tls/miou/tls_miou_unix.mli

@@ -0,0 +1,96 @@
+(** Effectful operations using Miou for pure TLS.
+
+    The pure TLS is state and buffer in, state and buffer out. This module uses
+    Miou (and its Unix layer) for communication over the network. *)
+
+exception Tls_alert of Tls.Packet.alert_type
+exception Tls_failure of Tls.Engine.failure
+exception Closed_by_peer
+
+type t
+(** Abstract type of a session. *)
+
+val file_descr : t -> Miou_unix.file_descr
+(** [file_descr] returns the underlying file-descriptor used by the given
+    TLS {i socket}. *)
+
+val read : t -> ?off:int -> ?len:int -> bytes -> int
+(** [read fd buf ~off ~len] reads up to [len] bytes (defaults to
+    [Bytes.length buf - off] from the given TLS {i socket} [fd], storing them in
+    byte sequence [buf], starting at position [off] in [buf] (defaults to [0]).
+    It returns the actual number of characters read, between 0 and [len]
+    (inclusive).
+
+    @raise Unix_error raised by the system call {!val:Unix.read}. The function
+    handles {!val:Unix.EINTR}, {!val:Unix.EAGAIN} and {!val:Unix.EWOULDBLOCK}
+    exceptions and redo the system call.
+
+    @raise Invalid_argument if [off] and [len] do not designate a valid range of
+    [buf]. *)
+
+val really_read : t -> ?off:int -> ?len:int -> bytes -> unit
+(** [really_read fd buf ~off ~len] reads [len] bytes (defaults to
+    [Bytes.length buf - off]) from the given TLS {i socket} [fd], storing them
+    in byte sequence [buf], starting at position [off] in [buf] (defaults to
+    [0]). If [len = 0], [really_read] does nothing.
+
+    @raise Unix_error raised by the system call {!val:Unix.read}. The function
+    handles {!val:Unix.EINTR}, {!val:Unix.EAGAIN} and {!val:Unix.EWOULDBLOCK}
+    exceptions and redo the system call.
+
+    @raise End_of_file if {!val:Unix.read} returns [0] before [len] characters
+    have been read.
+
+    @raise Invalid_argument if [off] and [len] do not designate a valid range of
+    [buf]. *)
+
+val write : t -> ?off:int -> ?len:int -> string -> unit
+(** [write t str ~off ~len] writes [len] bytes (defaults to
+    [String.length str - off]) from byte sequence [str], starting at offset
+    [off] (defaults to [0]), to the given TLS {i socket} [fd].
+
+    @raise Unix_error raised by the syscall call {!val:Unix.write}. The function
+    handles {!val:Unix.EINTR}, {!val:Unix.EAGAIN} and {!val:Unix.EWOULDBLOCK}
+    exceptions and redo the system call.
+
+    @raise Closed_by_peer if [t] is connected to a peer whose reading end is
+    closed. Similar to the {!val:EPIPE} error for pipe/socket connected.
+
+    @raise Invalid_argument if [off] and [len] do not designate a valid range of
+    [buf]. *)
+
+val close : t -> unit
+(** [close flow] closes the TLS session and the underlying file-descriptor. *)
+
+val shutdown : t -> [ `read | `write | `read_write ] -> unit
+(** [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 client_of_fd :
+  Tls.Config.client ->
+  ?read_buffer_size:int ->
+  ?host:[ `host ] Domain_name.t ->
+  Miou_unix.file_descr ->
+  t
+(** [client_of_flow client ~host fd] is [t], after client-side TLS handshake of
+    [fd] using [client] configuration and [host].
+
+    @raise End_of_file if we are not able to complete the handshake. *)
+
+val server_of_fd :
+  Tls.Config.server -> ?read_buffer_size:int -> Miou_unix.file_descr -> t
+(** [server_of_fd server fd] is [t], after server-side TLS handshake of [fd]
+    using [server] configuration.
+
+    @raise End_of_file if we are not able to complete the handshake. *)
+
+val connect : X509.Authenticator.t -> string * int -> t
+(** [connect authenticator (host, port)] is [t], a connected TLS connection
+    to [host] on [port] using the default configuration and the
+    [authenticator]. *)
+
+val epoch : t -> Tls.Core.epoch_data option
+(** [epoch t] returns [epoch], which contains information of the active
+    session. *)