Merge pull request #404 from hannesm/x509.0.9.0

X509.0.9.0: hash_whitelist and expose crl support

.travis.yml

@@ -5,7 +5,6 @@ env:
   global:
     - PACKAGE="tls"
   matrix:
-    - OCAML_VERSION=4.04
     - OCAML_VERSION=4.05 DEPOPTS="lwt ptime"
     - OCAML_VERSION=4.06
     - OCAML_VERSION=4.07

_tags

@@ -17,7 +17,7 @@ true : package(cstruct cstruct-sexp nocrypto x509 sexplib domain-name fmt)
 
 <lwt/**/*> : package(lwt lwt.unix ptime.clock.os)
 <lwt> : include
-<lwt/examples/*> : package(nocrypto.lwt)
+<lwt/examples/*> : package(nocrypto.lwt), thread
 
 <mirage/*> : package(mirage-flow mirage-kv mirage-clock lwt ptime)
 

lib/config.ml

@@ -170,13 +170,14 @@ let non_overlapping cs =
   in
   let rec check = function
     | []    -> ()
-    | s::ss -> if not (List.for_all
-                         (fun ss' -> Domain_name.Set.is_empty (Domain_name.Set.inter s ss'))
-                         ss)
-               then
-                 invalid_arg "overlapping names in certificates"
-               else
-                 check ss
+    | s::ss ->
+      if not (List.for_all (fun ss' ->
+          X509.Certificate.Host_set.is_empty (X509.Certificate.Host_set.inter s ss'))
+          ss)
+      then
+        invalid_arg "overlapping names in certificates"
+      else
+        check ss
   in
   check namessets
 

lib/handshake_client.ml

@@ -150,11 +150,7 @@ let validate_keytype_usage certificate ciphersuite =
 
 let answer_certificate_RSA state session cs raw log =
   let cfg = state.config in
-  let peer_name = match host_name_opt cfg.peer_name with
-    | None -> None
-    | Some x -> Some (`Wildcard, x)
-  in
-  validate_chain cfg.authenticator cs peer_name >>= fun (peer_certificate, received_certificates, peer_certificate_chain, trust_anchor) ->
+  validate_chain cfg.authenticator cs (host_name_opt cfg.peer_name) >>= fun (peer_certificate, received_certificates, peer_certificate_chain, trust_anchor) ->
   validate_keytype_usage peer_certificate session.ciphersuite >>= fun () ->
   let session = { session with received_certificates ; peer_certificate ; peer_certificate_chain ; trust_anchor } in
   ( match session.client_version with
@@ -174,11 +170,8 @@ let answer_certificate_RSA state session cs raw log =
   ({ state with machina = Client machina }, [])
 
 let answer_certificate_DHE_RSA state session cs raw log =
-  let peer_name = match host_name_opt state.config.peer_name with
-    | None -> None
-    | Some x -> Some (`Wildcard, x)
-  in
-  validate_chain state.config.authenticator cs peer_name >>= fun (peer_certificate, received_certificates, peer_certificate_chain, trust_anchor) ->
+  let cfg = state.config in
+  validate_chain cfg.authenticator cs (host_name_opt cfg.peer_name) >>= fun (peer_certificate, received_certificates, peer_certificate_chain, trust_anchor) ->
   validate_keytype_usage peer_certificate session.ciphersuite >|= fun () ->
   let session = { session with received_certificates ; peer_certificate ; peer_certificate_chain ; trust_anchor } in
   let machina = AwaitServerKeyExchange_DHE_RSA (session, log @ [raw]) in

lib/handshake_server.ml

@@ -139,13 +139,11 @@ let rec find_matching host certs =
 
 let agreed_cert certs hostname =
   let match_host ?default host certs =
-     match find_matching (`Strict, host) certs with
-     | Some x -> return x
-     | None   -> match find_matching (`Wildcard, host) certs with
-                 | Some x -> return x
-                 | None   -> match default with
-                             | Some c -> return c
-                             | None   -> fail (`Error (`NoMatchingCertificateFound (Domain_name.to_string host)))
+    match find_matching host certs with
+    | Some x -> return x
+    | None   -> match default with
+      | Some c -> return c
+      | None   -> fail (`Error (`NoMatchingCertificateFound (Domain_name.to_string host)))
   in
   match certs, hostname with
   | `None                    , _      -> fail (`Error `NoCertificateConfigured)

lwt/examples/http_client.ml

@@ -2,20 +2,20 @@
 open Lwt
 open Ex_common
 
-let http_client ?ca ?fp host port =
+let http_client ?ca ?fp hostname port =
   let port          = int_of_string port in
   X509_lwt.authenticator
     ( match ca, fp with
-      | None, Some fp  -> `Hex_key_fingerprints (`SHA256, [(Domain_name.of_string_exn host, fp)])
+      | None, Some fp  -> `Hex_key_fingerprints (`SHA256, [ Domain_name.(host_exn (of_string_exn hostname)), fp ])
       | None, _        -> `Ca_dir ca_cert_dir
       | Some "NONE", _ -> `No_authentication_I'M_STUPID
       | Some f, _      -> `Ca_file f ) >>= fun authenticator ->
   Tls_lwt.connect_ext
     ~trace:eprint_sexp
     (Tls.Config.client ~authenticator ())
-    (host, port) >>= fun (ic, oc) ->
+    (hostname, port) >>= fun (ic, oc) ->
   let req = String.concat "\r\n" [
-    "GET / HTTP/1.1" ; "Host: " ^ host ; "Connection: close" ; "" ; ""
+    "GET / HTTP/1.1" ; "Host: " ^ hostname ; "Connection: close" ; "" ; ""
   ] in
   Lwt_io.(write oc req >>= fun () -> read ic >>= print >>= fun () -> printf "++ done.\n%!")
 

lwt/x509_lwt.ml

@@ -4,7 +4,6 @@ type priv = X509.Certificate.t list * Nocrypto.Rsa.priv
 
 type authenticator = X509.Authenticator.t
 
-
 let failure msg = fail @@ Failure msg
 
 let catch_invalid_arg th h =
@@ -13,7 +12,6 @@ let catch_invalid_arg th h =
       | Invalid_argument msg -> h msg
       | exn                  -> fail exn)
 
-
 let (</>) a b = a ^ "/" ^ b
 
 let o f g x = f (g x)
@@ -75,21 +73,43 @@ let certs_of_pem_dir path =
   >>= Lwt_list.map_p (fun file -> certs_of_pem (path </> file))
   >|= List.concat
 
-let authenticator param =
+let crl_of_pem path =
+  catch_invalid_arg
+    (read_file path >|= fun data ->
+     match X509.CRL.decode_der data with
+     | Ok cs -> cs
+     | Error (`Msg m) -> invalid_arg ("failed to parse CRL " ^ m))
+    (o failure @@ Printf.sprintf "CRL in %s: %s" path)
+
+let crls_of_pem_dir = function
+  | None -> Lwt.return None
+  | Some path ->
+    read_dir path >>= fun files ->
+    Lwt_list.map_p (fun file -> crl_of_pem (path </> file)) files >|= fun crls ->
+    Some crls
+
+let authenticator ?hash_whitelist ?crls param =
   let now = Ptime_clock.now () in
   let of_cas cas =
-    X509.Authenticator.chain_of_trust ~time:now cas
+    crls_of_pem_dir crls >|= fun crls ->
+    X509.Authenticator.chain_of_trust ?hash_whitelist ?crls ~time:now cas
   and dotted_hex_to_cs hex =
     Nocrypto.Uncommon.Cs.of_hex
       (String.map (function ':' -> ' ' | x -> x) hex)
   and fingerp hash fingerprints =
     X509.Authenticator.server_key_fingerprint ~time:now ~hash ~fingerprints
+  and cert_fingerp hash fingerprints =
+    X509.Authenticator.server_cert_fingerprint ~time:now ~hash ~fingerprints
   in
   match param with
-  | `Ca_file path -> certs_of_pem path >|= of_cas
-  | `Ca_dir path  -> certs_of_pem_dir path >|= of_cas
+  | `Ca_file path -> certs_of_pem path >>= of_cas
+  | `Ca_dir path  -> certs_of_pem_dir path >>= of_cas
   | `Key_fingerprints (hash, fps) -> return (fingerp hash fps)
   | `Hex_key_fingerprints (hash, fps) ->
     let fps = List.map (fun (n, v) -> (n, dotted_hex_to_cs v)) fps in
     return (fingerp hash fps)
+  | `Cert_fingerprints (hash, fps) -> return (cert_fingerp hash fps)
+  | `Hex_cert_fingerprints (hash, fps) ->
+    let fps = List.map (fun (n, v) -> (n, dotted_hex_to_cs v)) fps in
+    return (cert_fingerp hash fps)
   | `No_authentication_I'M_STUPID -> return X509.Authenticator.null

lwt/x509_lwt.mli

@@ -21,10 +21,12 @@ val certs_of_pem_dir : Lwt_io.file_name -> X509.Certificate.t list Lwt.t
 
 (** [authenticator methods] constructs an [authenticator] using the
     specified method and data. *)
-val authenticator :
+val authenticator : ?hash_whitelist:Nocrypto.Hash.hash list -> ?crls:Lwt_io.file_name ->
   [ `Ca_file of Lwt_io.file_name
   | `Ca_dir  of Lwt_io.file_name
-  | `Key_fingerprints of Nocrypto.Hash.hash * ('a Domain_name.t * Cstruct.t) list
-  | `Hex_key_fingerprints of Nocrypto.Hash.hash * ('a Domain_name.t * string) list
+  | `Key_fingerprints of Nocrypto.Hash.hash * ([`host] Domain_name.t * Cstruct.t) list
+  | `Hex_key_fingerprints of Nocrypto.Hash.hash * ([`host] Domain_name.t * string) list
+  | `Cert_fingerprints of Nocrypto.Hash.hash * ([`host] Domain_name.t * Cstruct.t) list
+  | `Hex_cert_fingerprints of Nocrypto.Hash.hash * ([`host] Domain_name.t * string) list
   | `No_authentication_I'M_STUPID ]
   -> authenticator Lwt.t

mirage/tls_mirage.ml

@@ -235,13 +235,22 @@ module X509 (KV : Mirage_kv.RO) (C: Mirage_clock.PCLOCK) = struct
   let read kv name =
     KV.get kv name >>= err_fail KV.pp_error >|= Cstruct.of_string
 
-  let authenticator kv = function
+  let read_crl kv = function
+    | None -> Lwt.return None
+    | Some filename ->
+      read kv (Mirage_kv.Key.v filename) >>= fun data ->
+      err_fail pp_msg (X509.CRL.decode_der data) >|= fun crl ->
+      Some [ crl ]
+
+  let authenticator ?hash_whitelist ?crl kv = function
     | `Noop -> return X509.Authenticator.null
     | `CAs  ->
         let time = Ptime.v (C.now_d_ps ()) in
         read kv ca_roots_file >>=
-        decode_or_fail X509.Certificate.decode_pem_multiple >|=
-        X509.Authenticator.chain_of_trust ?crls:None ~time
+        decode_or_fail X509.Certificate.decode_pem_multiple >>= fun cas ->
+        let ta = X509.Validation.valid_cas ~time cas in
+        read_crl kv crl >|= fun crls ->
+        X509.Authenticator.chain_of_trust ?crls ?hash_whitelist ~time ta
 
   let certificate kv =
     let read name =

mirage/tls_mirage.mli

@@ -56,10 +56,15 @@ end
 
 (** X.509 handling given a key value store and a clock *)
 module X509 (KV : Mirage_kv.RO) (C : Mirage_clock.PCLOCK) : sig
-  (** [authenticator store clock typ] creates an [authenticator], either
-      using the given certificate authorities in the [store] or
-      null. *)
-  val authenticator : KV.t -> [< `Noop | `CAs ] -> X509.Authenticator.t Lwt.t
+  (** [authenticator ~hash_whitelist ~crl store typ] creates an [authenticator],
+      either using the given certificate authorities in the [store] as
+      value for key "ca_roots.crt", or null. If [hash_whitelist] is provided,
+      only these hash algorithms are allowed for signatures of the certificate chain.
+      If [crl] is provided, the corresponding file is read and used as
+      revocation list (DER encoded). Both options only apply if [`CAs] is used.
+ *)
+  val authenticator : ?hash_whitelist:Nocrypto.Hash.hash list -> ?crl:string ->
+    KV.t -> [< `Noop | `CAs ] -> X509.Authenticator.t Lwt.t
 
   (** [certificate store typ] unmarshals a certificate chain and
       private key material from the [store]. *)

opam

@@ -19,7 +19,7 @@ build: [
 ]
 
 depends: [
-  "ocaml" {>= "4.04.2"}
+  "ocaml" {>= "4.05.0"}
   "ocamlfind" {build}
   "ocamlbuild" {build}
   "topkg" {build}
@@ -30,7 +30,7 @@ depends: [
   "cstruct-sexp"
   "sexplib"
   "nocrypto" {>= "0.5.4"}
-  "x509" {>= "0.7.0"}
+  "x509" {>= "0.9.0"}
   "domain-name" {>= "0.3.0"}
   "fmt"
   "cstruct-unix" {with-test & >= "3.0.0"}