Add x509-async module

async/dune

@@ -2,4 +2,4 @@
   (name        tls_async)
   (public_name tls-async)
   (preprocess (pps ppx_jane))
-  (libraries async core cstruct-async mirage-crypto-rng-async tls))
+  (libraries async async_find core cstruct-async mirage-crypto-rng-async tls))

async/examples/test_server.ml

@@ -4,34 +4,12 @@ open! Async
 let server_cert = "./certificates/server.pem"
 let server_key = "./certificates/server.key"
 
-module X509_async = struct
-  let lift_of_result_msg : ('a, [< `Msg of string ]) result -> 'a Or_error.t =
-    Result.map_error ~f:(fun (`Msg message) -> Error.of_string message)
-  ;;
-
-  let x509_of_pem pem =
-    Cstruct.of_string pem |> X509.Certificate.decode_pem_multiple |> lift_of_result_msg
-  ;;
-
-  let certs_of_pems ca_file = Reader.file_contents ca_file >>| x509_of_pem
-
-  let private_of_pems ~cert ~priv_key =
-    let open Deferred.Or_error.Let_syntax in
-    let%bind certs = certs_of_pems cert in
-    let%map priv_key =
-      let%bind priv =
-        Reader.file_contents priv_key |> Deferred.ok >>| Cstruct.of_string
-      in
-      X509.Private_key.decode_pem priv |> lift_of_result_msg |> Deferred.return
-    in
-    certs, priv_key
-  ;;
-end
-
 let serve_tls port handler =
-  let%bind certificate, priv_key =
-    X509_async.private_of_pems ~cert:server_cert ~priv_key:server_key
-    |> Deferred.Or_error.ok_exn
+  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 =
     Tls.Config.(

async/session.mli

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

async/tls_async.ml

@@ -1,6 +1,7 @@
 open! Core
 open! Async
 module Session = Session
+module X509_async = X509_async
 
 let try_to_close t =
   match%map Session.close_tls t with

async/tls_async.mli

@@ -5,6 +5,10 @@ open! Async
     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 *)

async/x509_async.ml

@@ -0,0 +1,272 @@
+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 options = Async_find.Options.ignore_errors in
+  let%bind files = Async_find.find_all ~options directory |> Deferred.ok in
+  Deferred.Or_error.List.map files ~f:(fun (file, (_ : Unix.Stats.t)) ->
+    let%bind contents = file_contents 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_cstruct f ~contents =
+    f (Cstruct.of_string contents) |> of_result_msg
+  ;;
+
+  let lift_asn_error_of_cstruct f ~contents =
+    f (Cstruct.of_string 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_cstruct 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_cstruct decode_pem_multiple
+  let decode_pem = Or_error.lift_result_msg_of_cstruct decode_pem
+  let decode_der = Or_error.lift_result_msg_of_cstruct 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 : Mirage_crypto.Hash.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_fingerprints of
+          Mirage_crypto.Hash.hash * ([ `host ] Domain_name.t * string) list
+
+    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_fingerprints hash fingerprints = Cert_fingerprints (hash, fingerprints)
+
+    let cleanup_fingerprint fingerprint =
+      let known_delimiters = [ ':'; ' ' ] in
+      String.filter fingerprint ~f:(fun c ->
+        not (List.exists known_delimiters ~f:(Char.equal c)))
+      |> Cstruct.of_hex
+    ;;
+
+    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 cert_fingerprint ~time hash fingerprints =
+      let fingerprints =
+        List.map fingerprints ~f:(Tuple.T2.map_snd ~f:cleanup_fingerprint)
+      in
+      X509.Authenticator.server_cert_fingerprint ~time ~hash ~fingerprints
+    ;;
+
+    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_fingerprints (hash, fingerprints) ->
+        cert_fingerprint ~time hash fingerprints |> Deferred.Or_error.return
+    ;;
+  end
+end
+
+module Distinguished_name = struct
+  include X509.Distinguished_name
+
+  let decode_der = Or_error.lift_result_msg_of_cstruct 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_cstruct 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_cstruct decode_der
+  end
+end
+
+module PKCS12 = struct
+  include X509.PKCS12
+
+  let decode_der = Or_error.lift_result_msg_of_cstruct 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
+    |> Or_error.map ~f:Cstruct.to_string
+  ;;
+
+  let decode_der = Or_error.lift_result_msg_of_cstruct decode_der
+  let decode_pem = Or_error.lift_result_msg_of_cstruct 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 =
+    let signature = Cstruct.of_string signature in
+    let data =
+      match data with
+      | `Digest data -> `Digest (Cstruct.of_string data)
+      | `Message data -> `Message (Cstruct.of_string data)
+    in
+    verify hash ?scheme ~signature key data |> Or_error.of_result_msg
+  ;;
+
+  let decode_der = Or_error.lift_result_msg_of_cstruct decode_der
+  let decode_pem = Or_error.lift_result_msg_of_cstruct decode_pem
+end
+
+module Signing_request = struct
+  include X509.Signing_request
+
+  let decode_der ?allowed_hashes der =
+    Cstruct.of_string der |> decode_der ?allowed_hashes |> Or_error.of_result_msg
+  ;;
+
+  let decode_pem pem = Cstruct.of_string pem |> decode_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