diff --git a/async/dune b/async/dune index d80ffcb7..f2f77e5c 100644 --- a/async/dune +++ b/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)) diff --git a/async/examples/test_server.ml b/async/examples/test_server.ml index a0e28946..af9aa835 100644 --- a/async/examples/test_server.ml +++ b/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.( diff --git a/async/session.mli b/async/session.mli index 88a17ac1..98477dfc 100644 --- a/async/session.mli +++ b/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 diff --git a/async/tls_async.ml b/async/tls_async.ml index e29743f5..92a08b8a 100644 --- a/async/tls_async.ml +++ b/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 diff --git a/async/tls_async.mli b/async/tls_async.mli index 568ec675..9f3ce20e 100644 --- a/async/tls_async.mli +++ b/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 *) diff --git a/async/x509_async.ml b/async/x509_async.ml new file mode 100644 index 00000000..0a5c1b91 --- /dev/null +++ b/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 diff --git a/async/x509_async.mli b/async/x509_async.mli new file mode 100644 index 00000000..62ec949b --- /dev/null +++ b/async/x509_async.mli @@ -0,0 +1,224 @@ +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: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 -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 + -> Authenticator.t Deferred.Or_error.t + end +end + +module Private_key : sig + include module type of struct + include Private_key + end + + val sign + : Mirage_crypto.Hash.hash + -> ?scheme:Key_type.signature_scheme + -> t + -> [ `Digest of Cstruct.t | `Message of Cstruct.t ] + -> 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 + : Mirage_crypto.Hash.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:Mirage_crypto.Hash.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:Mirage_crypto.Hash.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:Mirage_crypto.Hash.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:Mirage_crypto.Hash.hash list -> string -> t Or_error.t + val decode_pem : string -> t Or_error.t + + val create + : Distinguished_name.t + -> ?digest:Mirage_crypto.Hash.hash + -> ?extensions:Ext.t + -> Private_key.t + -> t Or_error.t + + val sign + : ?allowed_hashes:Mirage_crypto.Hash.hash list + -> ?digest:Mirage_crypto.Hash.hash + -> ?serial:Z.t + -> ?extensions:Extension.t + -> t + -> Private_key.t + -> Distinguished_name.t + -> valid_from:Ptime.t + -> valid_until:Ptime.t + -> Certificate.t Or_error.t +end diff --git a/tls-async.opam b/tls-async.opam index 7e4d04e6..4d68eb6d 100644 --- a/tls-async.opam +++ b/tls-async.opam @@ -20,6 +20,7 @@ depends: [ "x509" {>= "0.13.0"} "ptime" {>= "0.8.1"} "async" {>= "v0.14"} + "async_find" {>= "v0.14"} "async_unix" {>= "v0.14"} "core" {>= "v0.14"} "cstruct-async"