Helpers for common Async functions

async/authenticator.ml

@@ -0,0 +1,72 @@
+open! Core
+open! Async
+open! Import
+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

async/authenticator.mli

@@ -0,0 +1,41 @@
+open! Core
+open! Async
+open! Import
+
+include module type of struct
+  include X509.Authenticator
+end
+
+module Param : sig
+  type t
+
+  val ca_file
+    :  ?allowed_hashes:Mirage_crypto.Hash.hash list
+    -> ?crls:Filename.t
+    -> Filename.t
+    -> unit
+    -> t
+
+  val ca_dir
+    :  ?allowed_hashes:Mirage_crypto.Hash.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_fingerprints
+    :  Mirage_crypto.Hash.hash
+    -> ([ `host ] Domain_name.t * string) list
+    -> 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
+    -> X509.Authenticator.t Deferred.Or_error.t
+end

async/cRL.ml

@@ -0,0 +1,26 @@
+open! Core
+open! Async
+open! Import
+include X509.CRL
+
+let decode_der = Or_error.lift_result_msg_of_cstruct decode_der
+let verification_error_to_string = Fmt.to_to_string pp_verification_error
+let sexp_of_verification_error e = sexp_of_string (verification_error_to_string e)
+
+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)
+;;

async/cRL.mli

@@ -0,0 +1,39 @@
+open! Core
+open! Async
+open! Import
+
+include module type of struct
+  include X509.CRL
+end
+
+val decode_der : contents:string -> t Or_error.t
+val verification_error_to_string : verification_error -> string
+val sexp_of_verification_error : verification_error -> Sexp.t
+
+val revoke
+  :  ?digest:Mirage_crypto.Hash.hash
+  -> issuer:X509.Distinguished_name.t
+  -> this_update:Ptime.t
+  -> ?next_update:Ptime.t
+  -> ?extensions:X509.Extension.t
+  -> revoked_cert list
+  -> X509.Private_key.t
+  -> t Or_error.t
+
+val revoke_certificate
+  :  revoked_cert
+  -> this_update:Ptime.t
+  -> ?next_update:Ptime.t
+  -> t
+  -> X509.Private_key.t
+  -> t Or_error.t
+
+val revoke_certificates
+  :  revoked_cert list
+  -> this_update:Ptime.t
+  -> ?next_update:Ptime.t
+  -> t
+  -> X509.Private_key.t
+  -> t Or_error.t
+
+val of_pem_dir : directory:Filename.t -> t list Deferred.Or_error.t

async/certificate.ml

@@ -0,0 +1,20 @@
+open! Core
+open! Async
+open! Import
+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
+;;

async/certificate.mli

@@ -0,0 +1,13 @@
+open! Core
+open! Async
+open! Import
+
+include module type of struct
+  include X509.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

async/distinguished_name.ml

@@ -0,0 +1,7 @@
+open! Core
+open! Async
+open! Import
+include X509.Distinguished_name
+
+let to_string = Fmt.to_to_string pp
+let decode_der = Or_error.lift_result_msg_of_cstruct decode_der

async/distinguished_name.mli

@@ -0,0 +1,10 @@
+open! Core
+open! Async
+open! Import
+
+include module type of struct
+  include X509.Distinguished_name
+end
+
+val to_string : t -> string
+val decode_der : contents:string -> t Or_error.t

async/dune

@@ -0,0 +1,6 @@
+(library
+ (name x509_async)
+ (public_name x509-async)
+ (preprocess (pps ppx_jane))
+ (libraries async async_find core x509))
+

async/extension.ml

@@ -0,0 +1,6 @@
+open! Core
+open! Async
+open! Import
+include X509.Extension
+
+let to_string = Fmt.to_to_string pp

async/extension.mli

@@ -0,0 +1,9 @@
+open! Core
+open! Async
+open! Import
+
+include module type of struct
+  include X509.Extension
+end
+
+val to_string : t -> string

async/import.ml

@@ -0,0 +1,31 @@
+open! Core
+open! Async
+open Deferred.Or_error.Let_syntax
+
+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
+
+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 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)
+;;

async/oCSP.ml

@@ -0,0 +1,41 @@
+open! Core
+open! Async
+open! Import
+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

async/oCSP.mli

@@ -0,0 +1,42 @@
+open! Core
+open! Async
+open! Import
+
+include module type of struct
+  include X509.OCSP
+end
+
+module Request : sig
+  include module type of struct
+    include X509.OCSP.Request
+  end
+
+  val create
+    :  ?certs:X509.Certificate.t list
+    -> ?digest:Mirage_crypto.Hash.hash
+    -> ?requestor_name:X509.General_name.b
+    -> ?key:X509.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 X509.OCSP.Response
+  end
+
+  val create_success
+    :  ?digest:Mirage_crypto.Hash.hash
+    -> ?certs:X509.Certificate.t list
+    -> ?response_extensions:X509.Extension.t
+    -> X509.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

async/pKCS12.ml

@@ -0,0 +1,7 @@
+open! Core
+open! Async
+open! Import
+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