unikernel/duniverse/ocaml-tls/async/dune

@@ -0,0 +1,5 @@
+(library
+  (name        tls_async)
+  (public_name tls-async)
+  (preprocess (pps ppx_jane))
+  (libraries async core cstruct-async mirage-crypto-rng mirage-crypto-rng.unix tls))

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

@@ -0,0 +1,15 @@
+(executable
+  (name    test_client)
+  (modules test_client)
+  (public_name tls-test-client)
+  (package tls-async)
+  (preprocess (pps ppx_jane))
+  (libraries async core core_unix.command_unix tls-async))
+
+(executable
+  (name    test_server)
+  (modules test_server)
+  (public_name tls-test-server)
+  (package tls-async)
+  (preprocess (pps ppx_jane))
+  (libraries async core core_unix.command_unix tls-async))

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

@@ -0,0 +1,34 @@
+open! Core
+open! Async
+open Deferred.Or_error.Let_syntax
+
+let config = match Tls.Config.client ~authenticator:(fun ?ip:_ ~host:_ _ -> Ok None) () with
+  | Ok cfg -> cfg
+  | Error `Msg msg -> invalid_arg msg
+
+let test_client () =
+  let host = "127.0.0.1" in
+  let port = 8443 in
+  let hnp = Host_and_port.create ~host ~port in
+  let%bind (_ : Tls_async.Session.t), rd, wr =
+    (* we can't build a [[ `host ] Domain_name.t] from an IP address *)
+    let host = None in
+    Tls_async.connect config (Tcp.Where_to_connect.of_host_and_port hnp) ~host
+  in
+  let req =
+    String.concat
+      ~sep:"\r\n"
+      [ "GET / HTTP/1.1"; "Host: " ^ host; "Connection: close"; ""; "" ]
+  in
+  Writer.write wr req;
+  let%bind () = Writer.flushed wr |> Deferred.ok in
+  let%bind () =
+    match%map Reader.read_line rd |> Deferred.ok with
+    | `Ok str -> print_endline str
+    | `Eof -> print_endline "Eof reached"
+  in
+  Writer.close wr |> Deferred.ok
+;;
+
+let cmd = Command.async_or_error ~summary:"test client" (Command.Param.return test_client)
+let () = Command_unix.run cmd

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

@@ -0,0 +1,64 @@
+open! Core
+open! Async
+
+let server_cert = "./certificates/server.pem"
+let server_key = "./certificates/server.key"
+
+let serve_tls ~low_level port handler =
+  let%bind certificate =
+    Tls_async.X509_async.Certificate.of_pem_file server_cert |> Deferred.Or_error.ok_exn
+  in
+  let%bind priv_key =
+    Tls_async.X509_async.Private_key.of_pem_file server_key |> Deferred.Or_error.ok_exn
+  in
+  let config =
+    match Tls.Config.(
+        server
+          ~version:(`TLS_1_0, `TLS_1_2)
+          ~certificates:(`Single (certificate, priv_key))
+          ~ciphers:Ciphers.supported
+          ())
+    with
+    | Ok cfg -> cfg
+    | Error `Msg msg -> invalid_arg msg
+  in
+  let where_to_listen = Tcp.Where_to_listen.of_port port in
+  let on_handler_error = `Ignore in
+  if low_level then
+    Tcp.Server.create
+      ~on_handler_error
+      where_to_listen
+      (fun sa ->
+        printf !"connection establised from %{Socket.Address.Inet} starting TLS\n" sa;
+        Tls_async.upgrade_server_handler ~config (handler sa))
+  else
+    Tls_async.listen ~on_handler_error config where_to_listen handler
+;;
+
+let test_server ~low_level port =
+  let handler (_ : Socket.Address.Inet.t) (_ : Tls_async.Session.t) rd wr =
+    let pipe = Reader.pipe rd in
+    let rec read_from_pipe () =
+      (match%map Pipe.read pipe with
+       | `Ok line -> Writer.write wr line
+       | `Eof -> ())
+      >>= read_from_pipe
+    in
+    read_from_pipe ()
+  in
+  serve_tls ~low_level port handler
+;;
+
+let cmd =
+  let open Command.Let_syntax in
+  Command.async
+    ~summary:"test server"
+    (let%map_open port = anon ("PORT" %: int)
+    and low_level = flag "-low-level" no_arg ~doc:"set up Tcp.server directly" in
+     fun () ->
+       let open Deferred.Let_syntax in
+       let%bind server = test_server ~low_level port in
+       Tcp.Server.close_finished server)
+;;
+
+let () = Command_unix.run cmd

unikernel/duniverse/ocaml-tls/async/io.ml

@@ -0,0 +1,200 @@
+open! Core
+open! Async
+include Io_intf
+
+module Tls_error = struct
+  module Alert = struct
+    type t = Tls.Packet.alert_type
+    let sexp_of_t a =
+      Sexplib.Sexp.Atom (Tls.Packet.alert_type_to_string a)
+  end
+  module Fail = struct
+    type t = Tls.Engine.failure
+    let sexp_of_t a =
+      Sexplib.Sexp.Atom (Tls.Engine.string_of_failure a)
+  end
+  type t =
+    | Tls_alert of Alert.t
+    (** [Tls_alert] exception received from the other endpoint *)
+    | Tls_failure of Fail.t
+    (** [Tls_failure] exception while processing incoming data *)
+    | Connection_closed
+    | Connection_not_ready
+    | Unexpected_eof
+    | Unable_to_renegotiate
+    | Unable_to_update_key
+  [@@deriving sexp_of]
+end
+
+module Make (Fd : Fd) : S with module Fd := Fd = struct
+  open Deferred.Or_error.Let_syntax
+
+  module State = struct
+    type t =
+      | Active of Tls.Engine.state
+      | Eof
+      | Error of Tls_error.t
+  end
+
+  type t =
+    { fd : Fd.t
+    ; mutable state : State.t
+    ; mutable linger : string option
+    ; recv_buf : bytes
+    }
+
+  let tls_error = Fn.compose Deferred.Or_error.error_s Tls_error.sexp_of_t
+
+  let rec read_react t =
+    let handle tls buf =
+      match Tls.Engine.handle_tls tls buf with
+      | Ok (state, eof, `Response resp, `Data data) ->
+        t.state
+        <- (match eof with
+          | None -> Active state
+          | Some `Eof -> Eof);
+        let%map () =
+          match resp with
+          | None -> return ()
+          | Some resp -> Fd.write_full t.fd resp
+        in
+        `Ok data
+      | Error (alert, `Response resp) ->
+        t.state <- Error (match alert with `Alert a -> Tls_alert a | f -> Tls_failure f);
+        let%bind () = Fd.write_full t.fd resp in
+        read_react t
+    in
+    match t.state with
+    | Error e -> tls_error e
+    | Eof -> return `Eof
+    | Active _ ->
+      let%bind n = Fd.read t.fd t.recv_buf in
+      (match t.state, n with
+       | Active _, `Eof ->
+         t.state <- Eof;
+         return `Eof
+       | Active tls, `Ok n -> handle tls (Stdlib.Bytes.sub_string t.recv_buf 0 n)
+       | Error e, _ -> tls_error e
+       | Eof, _ -> return `Eof)
+  ;;
+
+  let rec read t buf =
+    let writeout res =
+      let rlen = String.length res in
+      let n = min (Bytes.length buf) rlen in
+      Stdlib.Bytes.blit_string res 0 buf 0 n;
+      t.linger <- (if n < rlen then Some (Stdlib.String.sub res n (rlen - n)) else None);
+      return n
+    in
+    match t.linger with
+    | Some res -> writeout res
+    | None ->
+      (match%bind read_react t with
+       | `Eof -> return 0
+       | `Ok None -> read t buf
+       | `Ok (Some res) -> writeout res)
+  ;;
+
+  let writev t css =
+    match t.state with
+    | Error err -> tls_error err
+    | Eof -> tls_error Connection_closed
+    | Active tls ->
+      (match Tls.Engine.send_application_data tls css with
+       | Some (tls, tlsdata) ->
+         t.state <- Active tls;
+         Fd.write_full t.fd tlsdata
+       | None -> tls_error Connection_not_ready)
+  ;;
+
+  (*
+   * XXX bad XXX
+   * This is a point that should particularly be protected from concurrent r/w.
+   * Doing this before a `t` is returned is safe; redoing it during rekeying is
+   * not, as the API client already sees the `t` and can mistakenly interleave
+   * writes while this is in progress.
+   * *)
+  let rec drain_handshake t =
+    let push_linger t mcs =
+      match mcs, t.linger with
+      | None, _ -> ()
+      | scs, None -> t.linger <- scs
+      | Some cs, Some l -> t.linger <- Some (l ^ cs)
+    in
+    match t.state with
+    | Active tls when not (Tls.Engine.handshake_in_progress tls) -> return t
+    | _ ->
+      (match%bind read_react t with
+       | `Eof -> tls_error Unexpected_eof
+       | `Ok cs ->
+         push_linger t cs;
+         drain_handshake t)
+  ;;
+
+  let reneg ?authenticator ?acceptable_cas ?cert ?(drop = true) t =
+    match t.state with
+    | Error err -> tls_error err
+    | Eof -> tls_error Connection_closed
+    | Active tls ->
+      (match Tls.Engine.reneg ?authenticator ?acceptable_cas ?cert tls with
+       | None -> tls_error Unable_to_renegotiate
+       | Some (tls', buf) ->
+         if drop then t.linger <- None;
+         t.state <- Active tls';
+         let%bind () = Fd.write_full t.fd buf in
+         let%bind _ = drain_handshake t in
+         return ())
+  ;;
+
+  let key_update ?request t =
+    match t.state with
+    | Error err -> tls_error err
+    | Eof -> tls_error Connection_closed
+    | Active tls ->
+      (match Tls.Engine.key_update ?request tls with
+       | Error _ -> tls_error Unable_to_update_key
+       | Ok (tls', buf) ->
+         t.state <- Active tls';
+         Fd.write_full t.fd buf)
+  ;;
+
+  let close_tls t =
+    match t.state with
+    | Active tls ->
+      let _, buf = Tls.Engine.send_close_notify tls in
+      t.state <- Eof;
+      Fd.write_full t.fd buf
+    | _ -> return ()
+  ;;
+
+  let server_of_fd config fd =
+    drain_handshake
+      { state = Active (Tls.Engine.server config)
+      ; fd
+      ; linger = None
+      ; recv_buf = Bytes.create 4096
+      }
+  ;;
+
+  let client_of_fd config ?host fd =
+    let config' =
+      match host with
+      | None -> config
+      | Some host -> Tls.Config.peer config host
+    in
+    let t = { state = Eof; fd; linger = None; recv_buf = Bytes.create 4096 } in
+    let tls, init = Tls.Engine.client config' in
+    let t = { t with state = Active tls } in
+    let%bind () = Fd.write_full t.fd init in
+    drain_handshake t
+  ;;
+
+  let epoch t =
+    match t.state with
+    | Active tls -> (match Tls.Engine.epoch tls with
+       | Ok _ as o -> o
+       | Error () -> Or_error.error_string "no TLS state available yet")
+    | Eof -> Or_error.error_string "TLS state is end of file"
+    | Error _ -> Or_error.error_string "TLS state is error"
+  ;;
+end

unikernel/duniverse/ocaml-tls/async/io.mli

@@ -0,0 +1,6 @@
+open! Core
+
+module type Fd = Io_intf.Fd
+module type S = Io_intf.S
+
+module Make (Fd : Fd) : S with module Fd := Fd

unikernel/duniverse/ocaml-tls/async/io_intf.ml

@@ -0,0 +1,64 @@
+open! Core
+open! Async
+
+module type Fd = sig
+  type t
+
+  val read : t -> bytes -> [ `Ok of int | `Eof ] Deferred.Or_error.t
+  val write_full : t -> string -> unit Deferred.Or_error.t
+end
+
+module type S = sig
+  module Fd : Fd
+
+  (** Abstract type of a session *)
+  type t
+
+  (** {2 Constructors} *)
+
+  (** [server_of_fd server fd] is [t], after server-side TLS
+      handshake of [fd] using [server] configuration. *)
+  val server_of_fd : Tls.Config.server -> Fd.t -> t Deferred.Or_error.t
+
+  (** [client_of_fd client ~host fd] is [t], after client-side
+      TLS handshake of [fd] using [client] configuration and [host]. *)
+  val client_of_fd
+    :  Tls.Config.client
+    -> ?host:[ `host ] Domain_name.t
+    -> Fd.t
+    -> t Deferred.Or_error.t
+
+  (** {2 Common stream operations} *)
+
+  (** [read t buffer] is [length], the number of bytes read into
+      [buffer]. *)
+  val read : t -> bytes -> int Deferred.Or_error.t
+
+  (** [writev t buffers] writes the [buffers] to the session. *)
+  val writev : t -> string list -> unit Deferred.Or_error.t
+
+  (** [close t] closes the TLS session by sending a close notify to the peer. *)
+  val close_tls : t -> unit Deferred.Or_error.t
+
+  (** [reneg ~authenticator ~acceptable_cas ~cert ~drop t] renegotiates the
+      session, and blocks until the renegotiation finished.  Optionally, a new
+      [authenticator] and [acceptable_cas] can be used.  The own certificate can
+      be adjusted by [cert]. If [drop] is [true] (the default),
+      application data received before the renegotiation finished is dropped. *)
+  val reneg
+    :  ?authenticator:X509.Authenticator.t
+    -> ?acceptable_cas:X509.Distinguished_name.t list
+    -> ?cert:Tls.Config.own_cert
+    -> ?drop:bool
+    -> t
+    -> unit Deferred.Or_error.t
+
+  (** [key_update ~request t] updates the traffic key and requests a traffic key
+      update from the peer if [request] is provided and [true] (the default).
+      This is only supported in TLS 1.3. *)
+  val key_update : ?request:bool -> t -> unit Deferred.Or_error.t
+
+  (** [epoch t] returns [epoch], which contains information of the
+      active session. *)
+  val epoch : t -> Tls.Core.epoch_data Or_error.t
+end

unikernel/duniverse/ocaml-tls/async/session.ml

@@ -0,0 +1,27 @@
+open! Core
+open! Async
+
+module Fd = struct
+  type t = Reader.t * Writer.t
+
+  let read (reader, (_ : Writer.t)) buf =
+    Deferred.Or_error.try_with (fun () -> Reader.read reader buf)
+  ;;
+
+  let write ((_ : Reader.t), writer) buf =
+    Deferred.Or_error.try_with (fun () ->
+      Writer.write writer buf;
+      Writer.flushed writer)
+  ;;
+
+  let rec write_full fd buf =
+    let open Deferred.Or_error.Let_syntax in
+    match String.length buf with
+    | 0 -> return ()
+    | len ->
+      let%bind () = write fd buf in
+      write_full fd (String.sub buf ~pos:len ~len:(String.length buf - len))
+  ;;
+end
+
+include Io.Make (Fd)

unikernel/duniverse/ocaml-tls/async/session.mli

@@ -0,0 +1,3 @@
+open! Core
+open! Async
+include Io.S with type Fd.t = Reader.t * Writer.t

unikernel/duniverse/ocaml-tls/async/tls_async.ml

@@ -0,0 +1,154 @@
+open! Core
+open! Async
+module Session = Session
+module X509_async = X509_async
+
+let try_to_close t =
+  match%map Session.close_tls t with
+  | Ok () -> ()
+  | Error tls_close_error -> Log.Global.error_s [%sexp (tls_close_error : Error.t)]
+;;
+
+let pipe t =
+  let b_reader = Bytes.create 0x8000 in
+  let rec f_reader writer =
+    match%bind Session.read t b_reader with
+    | Ok 0 ->
+      Pipe.close writer;
+      return ()
+    | Ok len ->
+      let%bind () = Pipe.write writer (Stdlib.Bytes.sub_string b_reader 0 len) in
+      f_reader writer
+    | Error read_error ->
+      Log.Global.error_s [%sexp (read_error : Error.t)];
+      Pipe.close writer;
+      return ()
+  in
+  let rec f_writer reader =
+    let%bind pipe_read = Pipe.read reader in
+    match pipe_read with
+    | `Ok s ->
+      (match%bind Session.writev t [ s ] with
+       | Ok () -> f_writer reader
+       | Error (_ : Error.t) -> try_to_close t)
+    | `Eof -> try_to_close t
+  in
+  Pipe.create_reader ~close_on_exception:false f_reader, Pipe.create_writer f_writer
+;;
+
+let upgrade_connection tls_session ((_ : Reader.t), outer_writer) =
+  let pipe_r, pipe_w = pipe tls_session in
+  let%bind inner_reader = Reader.of_pipe (Info.of_string "tls_reader") pipe_r in
+  let%map inner_writer, `Closed_and_flushed_downstream inner_cafd =
+    Writer.of_pipe (Info.of_string "tls_writer") pipe_w
+  in
+  Writer.set_raise_when_consumer_leaves inner_writer false;
+  let outer_cafd =
+    (* Ordering is important here to ensure no data is lost during the session shutdown *)
+    let%bind () = Writer.close_finished inner_writer in
+    let%bind () = inner_cafd in
+    let%bind () = try_to_close tls_session in
+    Writer.flushed outer_writer
+  in
+  tls_session, inner_reader, inner_writer, `Tls_closed_and_flushed_downstream outer_cafd
+;;
+
+let upgrade_server_reader_writer_to_tls config rw =
+  let open Deferred.Or_error.Let_syntax in
+  let%bind tls_session = Session.server_of_fd config rw in
+  upgrade_connection tls_session rw |> Deferred.ok
+;;
+
+let upgrade_client_reader_writer_to_tls ?host config rw =
+  let open Deferred.Or_error.Let_syntax in
+  let%bind tls_session = Session.client_of_fd ?host config rw in
+  upgrade_connection tls_session rw |> Deferred.ok
+;;
+
+type 'a io_handler = Reader.t -> Writer.t -> 'a Deferred.t
+type 'a tls_handler = Session.t -> 'a io_handler
+
+let upgrade_server_handler ~config handle_client outer_reader outer_writer =
+  let%bind ( tls_session
+           , inner_reader
+           , inner_writer
+           , `Tls_closed_and_flushed_downstream inner_cafd )
+    =
+     upgrade_server_reader_writer_to_tls config (outer_reader, outer_writer)
+     |> Deferred.Or_error.ok_exn
+  in
+  Monitor.protect
+    (fun () -> handle_client tls_session inner_reader inner_writer)
+    ~finally:(fun () ->
+      Deferred.all_unit
+        [ Reader.close inner_reader; Writer.close inner_writer; inner_cafd ])
+;;
+
+let listen
+      ?buffer_age_limit
+      ?max_connections
+      ?max_accepts_per_batch
+      ?backlog
+      ?socket
+      ~on_handler_error
+      config
+      where_to_listen
+      handle_client
+  =
+  Tcp.Server.create
+    ?buffer_age_limit
+    ?max_connections
+    ?max_accepts_per_batch
+    ?backlog
+    ?socket
+    ~on_handler_error
+    where_to_listen
+    (fun sock ->
+      upgrade_server_handler ~config (handle_client sock))
+;;
+
+let upgrade_client_to_tls config ~host outer_reader outer_writer =
+  let open Deferred.Or_error.Let_syntax in
+  let%bind ( tls_session
+           , inner_reader
+           , inner_writer
+           , `Tls_closed_and_flushed_downstream inner_cafd )
+    =
+    upgrade_client_reader_writer_to_tls ?host config (outer_reader, outer_writer)
+  in
+  don't_wait_for
+    (let%bind.Deferred () = inner_cafd in
+     Deferred.all_unit [ Writer.close outer_writer; Reader.close outer_reader ]);
+  return (tls_session, inner_reader, inner_writer)
+;;
+
+let connect
+      ?socket
+      ?buffer_age_limit
+      ?interrupt
+      ?reader_buffer_size
+      ?writer_buffer_size
+      ?timeout
+      ?time_source
+      config
+      where_to_connect
+      ~host
+  =
+  let open Deferred.Or_error.Let_syntax in
+  let%bind (_ : ([ `Active ], 'a) Socket.t), outer_reader, outer_writer =
+    Tcp.connect
+      ?socket
+      ?buffer_age_limit
+      ?interrupt
+      ?reader_buffer_size
+      ?writer_buffer_size
+      ?timeout
+      ?time_source
+      where_to_connect
+    |> Deferred.ok
+  in
+  upgrade_client_to_tls ~host config outer_reader outer_writer
+;;
+
+(* initialized RNG early to maximise available entropy. *)
+let () = Mirage_crypto_rng_unix.use_default ()

unikernel/duniverse/ocaml-tls/async/tls_async.mli

@@ -0,0 +1,74 @@
+open! Core
+open! Async
+
+(** Low-level API for working with TLS sessions.
+    Most applications should use the high-level API below *)
+module Session = Session
+
+(** Helper functions for [Async_unix]-specific IO operations commonly used with X509
+    certificates, such as loading from a Unix filesystem *)
+module X509_async = X509_async
+
+(** [listen] creates a [Tcp.Server.t] with the requested parameters, including those
+    specified in [Tls.Config.server]. The handler function exposes the low-level
+    [Session.t] to accommodate cases like interrogating a client certificate *)
+val listen
+  :  ?buffer_age_limit:Writer.buffer_age_limit
+  -> ?max_connections:int (** defaults to [10_000]. *)
+  -> ?max_accepts_per_batch:int (** defaults to [1]. *)
+  -> ?backlog:int (** defaults to [64]. *)
+  -> ?socket:([ `Unconnected ], ([< Socket.Address.t ] as 'address)) Socket.t
+  -> on_handler_error:[ `Call of 'address -> exn -> unit | `Ignore | `Raise ]
+  -> Tls.Config.server
+  -> ('address, 'listening_on) Tcp.Where_to_listen.t
+  -> ('address -> Session.t -> Reader.t -> Writer.t -> unit Deferred.t)
+  -> ('address, 'listening_on) Tcp.Server.t Deferred.t
+
+type 'a io_handler = Reader.t -> Writer.t -> 'a Deferred.t
+type 'a tls_handler = Session.t -> 'a io_handler
+
+(** [upgrade_server_handler] is what [listen] calls to handle each client.
+    It is exposed so that low-level end-users of the library can use tls-async
+    inside of code that manages Tcp services directly.
+
+    The [tls_handler] argument will be called with the client Tls session,
+    reader and writer to be used for cleartext data.
+
+    The outer [reader] and [writer] will read encrypted data from and write
+    encrypted data to the connected socket. *)
+val upgrade_server_handler
+  : config:Tls.Config.server
+  -> 'a tls_handler
+  -> 'a io_handler
+
+(** [connect] behaves similarly to [Tcp.connect], exposing a cleartext reader and writer.
+    Callers should ensure they close the [Writer.t] and wait for the [unit Deferred.t]
+    returned by [`Closed_and_flushed_downstream] to completely shut down the TLS connection
+
+    [host] is used for peer name verification and should generally be provided. Passing
+    [None] will disable peer name verification unless [peer_name] was provided in the
+    [Tls.Config.client]. If both are present [host] overwrites [peer_name].
+*)
+val connect
+  :  ?socket:([ `Unconnected ], 'addr) Socket.t
+  -> (Tls.Config.client
+      -> 'addr Tcp.Where_to_connect.t
+      -> host:[ `host ] Domain_name.t option
+      -> (Session.t * Reader.t * Writer.t) Deferred.Or_error.t)
+       Tcp.Aliases.with_connect_options
+
+(** [upgrade_client_to_tls] upgrades an existing reader/writer to TLS,
+    returning a cleartext reader and writer.
+    Callers should ensure they close the [Writer.t] and wait for the [unit Deferred.t]
+    returned by [`Closed_and_flushed_downstream] to completely shut down the TLS connection
+
+    [host] is used for peer name verification and should generally be provided. Passing
+    [None] will disable peer name verification unless [peer_name] was provided in the
+    [Tls.Config.client]. If both are present [host] overwrites [peer_name].
+*)
+val upgrade_client_to_tls
+  :  Tls.Config.client
+  -> host:[ `host ] Domain_name.t option
+  -> Reader.t
+  -> Writer.t
+  -> (Session.t * Reader.t * Writer.t) Deferred.Or_error.t

unikernel/duniverse/ocaml-tls/async/x509_async.ml

@@ -0,0 +1,271 @@
+open! Core
+open! Async
+
+let file_contents file =
+  Deferred.Or_error.try_with ~name:(sprintf "read %s" file) (fun () ->
+    Reader.file_contents file)
+;;
+
+let load_all_in_directory ~directory ~f =
+  let open Deferred.Or_error.Let_syntax in
+  let%bind files = Deferred.Or_error.try_with (fun () -> Sys.ls_dir directory) in
+  Deferred.Or_error.List.map ~how:`Sequential files ~f:(fun file ->
+    let%bind contents = file_contents (directory ^/ file) in
+    f ~contents)
+;;
+
+module Or_error = struct
+  include Or_error
+
+  let of_result ~to_string = Result.map_error ~f:(Fn.compose Error.of_string to_string)
+  let of_result_msg x = of_result x ~to_string:(fun (`Msg msg) -> msg)
+
+  let lift_result_msg_of_string f ~contents =
+    f contents |> of_result_msg
+  ;;
+
+  let lift_asn_error_of_string f ~contents =
+    f contents |> of_result ~to_string:(fun (`Parse msg) -> msg)
+  ;;
+end
+
+module CRL = struct
+  include X509.CRL
+
+  let decode_der = Or_error.lift_result_msg_of_string decode_der
+
+  let revoke ?digest ~issuer ~this_update ?next_update ?extensions revoked_certs key =
+    revoke ?digest ~issuer ~this_update ?next_update ?extensions revoked_certs key
+    |> Or_error.of_result_msg
+  ;;
+
+  let revoke_certificate revoked ~this_update ?next_update crl key =
+    revoke_certificate revoked ~this_update ?next_update crl key |> Or_error.of_result_msg
+  ;;
+
+  let revoke_certificates revoked ~this_update ?next_update crl key =
+    revoke_certificates revoked ~this_update ?next_update crl key
+    |> Or_error.of_result_msg
+  ;;
+
+  let of_pem_dir ~directory =
+    load_all_in_directory ~directory ~f:(fun ~contents ->
+      decode_der ~contents |> Deferred.return)
+  ;;
+end
+
+module Certificate = struct
+  include X509.Certificate
+  open Deferred.Or_error.Let_syntax
+
+  let decode_pem_multiple = Or_error.lift_result_msg_of_string decode_pem_multiple
+  let decode_pem = Or_error.lift_result_msg_of_string decode_pem
+  let decode_der = Or_error.lift_result_msg_of_string decode_der
+
+  let of_pem_file ca_file =
+    let%bind contents = file_contents ca_file in
+    decode_pem_multiple ~contents |> Deferred.return
+  ;;
+
+  let of_pem_directory ~directory =
+    load_all_in_directory ~directory ~f:(fun ~contents ->
+      decode_pem_multiple ~contents |> Deferred.return)
+    >>| List.concat
+  ;;
+end
+
+module Authenticator = struct
+  include X509.Authenticator
+
+  module Param = struct
+    module Chain_of_trust = struct
+      type t =
+        { trust_anchors : [ `File of Filename.t | `Directory of Filename.t ]
+        ; allowed_hashes : Digestif.hash' list option
+        ; crls : Filename.t option
+        }
+
+      let to_certs = function
+        | `File file -> Certificate.of_pem_file file
+        | `Directory directory -> Certificate.of_pem_directory ~directory
+      ;;
+    end
+
+    type t =
+      | Chain_of_trust of Chain_of_trust.t
+      | Cert_fingerprint of Digestif.hash' * string
+      | Key_fingerprint of Digestif.hash' * string
+
+    let ca_file ?allowed_hashes ?crls filename () =
+      let trust_anchors = `File filename in
+      Chain_of_trust { trust_anchors; allowed_hashes; crls }
+    ;;
+
+    let ca_dir ?allowed_hashes ?crls directory_name () =
+      let trust_anchors = `Directory directory_name in
+      Chain_of_trust { trust_anchors; allowed_hashes; crls }
+    ;;
+
+    let cert_fingerprint hash fingerprint = Cert_fingerprint (hash, fingerprint)
+
+    let key_fingerprint hash fingerprint = Key_fingerprint (hash, fingerprint)
+
+    let cleanup_fingerprint fingerprint =
+      let known_delimiters = [ ':'; ' ' ] in
+      String.filter fingerprint ~f:(fun c ->
+        not (List.exists known_delimiters ~f:(Char.equal c)))
+      |> Ohex.decode
+    ;;
+
+    let of_cas ~time ({ trust_anchors; allowed_hashes; crls } : Chain_of_trust.t) =
+      let open Deferred.Or_error.Let_syntax in
+      let%bind cas = Chain_of_trust.to_certs trust_anchors in
+      let%map crls =
+        match crls with
+        | Some directory ->
+          let%map crls = CRL.of_pem_dir ~directory in
+          Some crls
+        | None -> return None
+      in
+      X509.Authenticator.chain_of_trust ?allowed_hashes ?crls ~time cas
+    ;;
+
+    let of_cert_fingerprint ~time hash fingerprint =
+      let fingerprint = cleanup_fingerprint fingerprint in
+      X509.Authenticator.cert_fingerprint ~time ~hash ~fingerprint
+    ;;
+
+    let of_key_fingerprint ~time hash fingerprint =
+      let fingerprint = cleanup_fingerprint fingerprint in
+      X509.Authenticator.key_fingerprint ~time ~hash ~fingerprint
+    ;;
+
+    let time = Fn.compose Ptime.of_float_s Unix.gettimeofday
+
+    let to_authenticator ~time param =
+      match param with
+      | Chain_of_trust chain_of_trust -> of_cas ~time chain_of_trust
+      | Cert_fingerprint (hash, fingerprint) ->
+        of_cert_fingerprint ~time hash fingerprint |> Deferred.Or_error.return
+      | Key_fingerprint (hash, fingerprint) ->
+        of_key_fingerprint ~time hash fingerprint |> Deferred.Or_error.return
+    ;;
+  end
+end
+
+module Distinguished_name = struct
+  include X509.Distinguished_name
+
+  let decode_der = Or_error.lift_result_msg_of_string decode_der
+end
+
+module OCSP = struct
+  include X509.OCSP
+
+  module Request = struct
+    include Request
+
+    let create ?certs ?digest ?requestor_name ?key cert_ids =
+      create ?certs ?digest ?requestor_name ?key cert_ids |> Or_error.of_result_msg
+    ;;
+
+    let decode_der = Or_error.lift_asn_error_of_string decode_der
+  end
+
+  module Response = struct
+    include Response
+
+    let create_success
+          ?digest
+          ?certs
+          ?response_extensions
+          private_key
+          responderID
+          producedAt
+          responses
+      =
+      create_success
+        ?digest
+        ?certs
+        ?response_extensions
+        private_key
+        responderID
+        producedAt
+        responses
+      |> Or_error.of_result_msg
+    ;;
+
+    let responses t = responses t |> Or_error.of_result_msg
+    let decode_der = Or_error.lift_asn_error_of_string decode_der
+  end
+end
+
+module PKCS12 = struct
+  include X509.PKCS12
+
+  let decode_der = Or_error.lift_result_msg_of_string decode_der
+  let verify password t = verify password t |> Or_error.of_result_msg
+end
+
+module Private_key = struct
+  include X509.Private_key
+
+  let sign hash ?scheme key data =
+    sign hash ?scheme key data
+    |> Or_error.of_result_msg
+  ;;
+
+  let decode_der = Or_error.lift_result_msg_of_string decode_der
+  let decode_pem = Or_error.lift_result_msg_of_string decode_pem
+
+  let of_pem_file file =
+    let%map contents = Reader.file_contents file in
+    decode_pem ~contents
+  ;;
+end
+
+module Public_key = struct
+  include X509.Public_key
+
+  let verify hash ?scheme ~signature key data =
+    verify hash ?scheme ~signature key data |> Or_error.of_result_msg
+  ;;
+
+  let decode_der = Or_error.lift_result_msg_of_string decode_der
+  let decode_pem = Or_error.lift_result_msg_of_string decode_pem
+end
+
+module Signing_request = struct
+  include X509.Signing_request
+
+  let decode_der ?allowed_hashes der =
+    decode_der ?allowed_hashes der |> Or_error.of_result_msg
+  ;;
+
+  let decode_pem pem = decode_pem pem |> Or_error.of_result_msg
+
+  let create subject ?digest ?extensions key =
+    create subject ?digest ?extensions key |> Or_error.of_result_msg
+  ;;
+
+  let sign
+        ?allowed_hashes
+        ?digest
+        ?serial
+        ?extensions
+        t
+        key
+        issuer
+        ~valid_from
+        ~valid_until
+    =
+    sign ?allowed_hashes ?digest ?serial ?extensions t key issuer ~valid_from ~valid_until
+    |> Or_error.of_result ~to_string:(Fmt.to_to_string X509.Validation.pp_signature_error)
+  ;;
+end
+
+module Extension = X509.Extension
+module General_name = X509.General_name
+module Host = X509.Host
+module Key_type = X509.Key_type
+module Validation = X509.Validation

unikernel/duniverse/ocaml-tls/async/x509_async.mli

@@ -0,0 +1,231 @@
+open! Core
+open! Async
+
+include module type of struct
+  include X509
+end
+
+module Authenticator : sig
+  include module type of struct
+    include Authenticator
+  end
+
+  module Param : sig
+    type t
+
+    val ca_file
+      :  ?allowed_hashes:Digestif.hash' list
+      -> ?crls:Filename.t
+      -> Filename.t
+      -> unit
+      -> t
+
+    val ca_dir
+      :  ?allowed_hashes:Digestif.hash' list
+      -> ?crls:Filename.t
+      -> Filename.t
+      -> unit
+      -> t
+
+    (** The fingerprint can be collected from a browser or by invoking an openssl command
+        like 'openssl x509 -in <pem_file> -noout -fingerprint -sha256' *)
+    val cert_fingerprint
+      :  Digestif.hash'
+      -> string
+      -> t
+
+    (** The fingerprint can be collected from a browser or by invoking an openssl command
+        like 'openssl x509 -in <pem_file> -noout -pubkey | openssl pkey -pubin -outform DER | openssl dgst -sha256' *)
+    val key_fingerprint
+      :  Digestif.hash'
+      -> string
+      -> t
+
+    (** Async programs often don't use [Ptime_clock], so this is provided as a convenience
+        function. Relies on [Unix.gettimeofday]. *)
+    val time : unit -> Ptime.t option
+
+    val to_authenticator
+      :  time:(unit -> Ptime.t option)
+      -> t
+      -> Authenticator.t Deferred.Or_error.t
+  end
+end
+
+module Private_key : sig
+  include module type of struct
+    include Private_key
+  end
+
+  val sign
+    :  Digestif.hash'
+    -> ?scheme:Key_type.signature_scheme
+    -> t
+    -> [ `Digest of string | `Message of string ]
+    -> string Or_error.t
+
+  val decode_der : contents:string -> t Or_error.t
+  val decode_pem : contents:string -> t Or_error.t
+  val of_pem_file : Filename.t -> t Deferred.Or_error.t
+end
+
+module Public_key : sig
+  include module type of struct
+    include Public_key
+  end
+
+  val verify
+    :  Digestif.hash'
+    -> ?scheme:Key_type.signature_scheme
+    -> signature:string
+    -> t
+    -> [ `Digest of string | `Message of string ]
+    -> unit Or_error.t
+
+  val decode_der : contents:string -> t Or_error.t
+  val decode_pem : contents:string -> t Or_error.t
+end
+
+module Certificate : sig
+  include module type of struct
+    include Certificate
+  end
+
+  val decode_pem_multiple : contents:string -> t list Or_error.t
+  val decode_pem : contents:string -> t Or_error.t
+  val decode_der : contents:string -> t Or_error.t
+  val of_pem_file : Filename.t -> t list Deferred.Or_error.t
+  val of_pem_directory : directory:Filename.t -> t list Deferred.Or_error.t
+end
+
+module Distinguished_name : sig
+  include module type of struct
+    include Distinguished_name
+  end
+
+  val decode_der : contents:string -> t Or_error.t
+end
+
+module CRL : sig
+  include module type of struct
+    include CRL
+  end
+
+  val decode_der : contents:string -> t Or_error.t
+
+  val revoke
+    :  ?digest:Digestif.hash'
+    -> issuer:Distinguished_name.t
+    -> this_update:Ptime.t
+    -> ?next_update:Ptime.t
+    -> ?extensions:Extension.t
+    -> revoked_cert list
+    -> Private_key.t
+    -> t Or_error.t
+
+  val revoke_certificate
+    :  revoked_cert
+    -> this_update:Ptime.t
+    -> ?next_update:Ptime.t
+    -> t
+    -> Private_key.t
+    -> t Or_error.t
+
+  val revoke_certificates
+    :  revoked_cert list
+    -> this_update:Ptime.t
+    -> ?next_update:Ptime.t
+    -> t
+    -> Private_key.t
+    -> t Or_error.t
+
+  val of_pem_dir : directory:Filename.t -> t list Deferred.Or_error.t
+end
+
+module OCSP : sig
+  include module type of struct
+    include OCSP
+  end
+
+  module Request : sig
+    include module type of struct
+      include Request
+    end
+
+    val create
+      :  ?certs:Certificate.t list
+      -> ?digest:Digestif.hash'
+      -> ?requestor_name:General_name.b
+      -> ?key:Private_key.t
+      -> cert_id list
+      -> t Or_error.t
+
+    val decode_der : contents:string -> t Or_error.t
+  end
+
+  module Response : sig
+    include module type of struct
+      include Response
+    end
+
+    val create_success
+      :  ?digest:Digestif.hash'
+      -> ?certs:Certificate.t list
+      -> ?response_extensions:Extension.t
+      -> Private_key.t
+      -> responder_id
+      -> Ptime.t
+      -> single_response list
+      -> t Or_error.t
+
+    val responses : t -> single_response list Or_error.t
+    val decode_der : contents:string -> t Or_error.t
+  end
+end
+
+module PKCS12 : sig
+  include module type of struct
+    include PKCS12
+  end
+
+  val decode_der : contents:string -> t Or_error.t
+
+  val verify
+    :  string
+    -> t
+    -> [ `Certificate of Certificate.t
+       | `Crl of CRL.t
+       | `Decrypted_private_key of Private_key.t
+       | `Private_key of Private_key.t
+       ]
+         list
+         Or_error.t
+end
+
+module Signing_request : sig
+  include module type of struct
+    include Signing_request
+  end
+
+  val decode_der : ?allowed_hashes:Digestif.hash' list -> string -> t Or_error.t
+  val decode_pem : string -> t Or_error.t
+
+  val create
+    :  Distinguished_name.t
+    -> ?digest:Digestif.hash'
+    -> ?extensions:Ext.t
+    -> Private_key.t
+    -> t Or_error.t
+
+  val sign
+    :  ?allowed_hashes:Digestif.hash' list
+    -> ?digest:Digestif.hash'
+    -> ?serial:string
+    -> ?extensions:Extension.t
+    -> t
+    -> Private_key.t
+    -> Distinguished_name.t
+    -> valid_from:Ptime.t
+    -> valid_until:Ptime.t
+    -> Certificate.t Or_error.t
+end