Validation and Authentication: accept an optional hash_whitelist, a l…

…ist of

hash algorithms used for certificate validation. Default is SHA-2
(without SHA-224) for all functions taking this argument, apart from
valid_ca{,s} which defaults to all hash algorithms (including MD5 and SHA1).

lib/authenticator.ml

@@ -7,13 +7,14 @@ type t = ?host:[`host] Domain_name.t -> Certificate.t list -> Validation.r
    * Authenticator authenticates against time it was *created* at, not at the moment of
    * authentication. This has repercussions to long-lived authenticators; reconsider.
    * *)
-let chain_of_trust ?time ?(crls = []) cas =
+let chain_of_trust ?time ?crls ?(hash_whitelist = Validation.sha2) cas =
   let revoked = match crls with
-    | [] -> None
-    | crls -> Some (Crl.is_revoked crls)
+    | None -> None
+    | Some crls -> Some (Crl.is_revoked crls ~hash_whitelist)
   in
   fun ?host certificates ->
-    Validation.verify_chain_of_trust ?host ?time ?revoked ~anchors:cas certificates
+    Validation.verify_chain_of_trust ?host ?time ?revoked ~hash_whitelist
+      ~anchors:cas certificates
 
 let server_key_fingerprint ?time ~hash ~fingerprints =
   fun ?host certificates ->

lib/crl.ml

@@ -121,30 +121,31 @@ let crl_number { asn ; _ } =
 let signature_algorithm { asn ; _ } =
   Algorithm.to_signature_algorithm asn.signature_algo
 
-let validate { raw ; asn } pub =
+let validate { raw ; asn } ?(hash_whitelist = Validation.sha2) pub =
   let tbs_raw = Validation.raw_cert_hack raw asn.signature_val in
-  Validation.validate_raw_signature tbs_raw asn.signature_algo asn.signature_val pub
+  Validation.validate_raw_signature hash_whitelist tbs_raw asn.signature_algo
+    asn.signature_val pub
 
-let verify ({ asn ; _ } as crl) ?time cert =
+let verify ({ asn ; _ } as crl) ?hash_whitelist ?time cert =
   Distinguished_name.equal asn.tbs_crl.issuer (Certificate.subject cert) &&
   (match time with
    | None -> true
    | Some x -> Ptime.is_later ~than:asn.tbs_crl.this_update x &&
                match asn.tbs_crl.next_update with
                | None -> true
                | Some y -> Ptime.is_earlier ~than:y x) &&
-  validate crl (Certificate.public_key cert)
+  validate ?hash_whitelist crl (Certificate.public_key cert)
 
 let reason (revoked : revoked_cert) =
   match Extension.(find Reason revoked.extensions) with
   | Some (_, x) -> Some x
   | None -> None
 
-let is_revoked (crls : t list) ~issuer:super ~cert =
+let is_revoked (crls : t list) ?hash_whitelist ~issuer:super ~cert =
   List.exists (fun crl ->
       if
         Distinguished_name.equal (Certificate.subject super) (issuer crl) &&
-        validate crl (Certificate.public_key super)
+        validate ?hash_whitelist crl (Certificate.public_key super)
       then
         try
           let entry = List.find

lib/signing_request.ml

@@ -138,16 +138,16 @@ let hostnames csr =
     | Some names -> names
     | None -> subj
 
-let validate_signature { asn ; raw } =
+let validate_signature hash { asn ; raw } =
   let raw_data = Validation.raw_cert_hack raw asn.signature in
-  Validation.validate_raw_signature raw_data asn.signature_algorithm asn.signature
-    asn.info.public_key
+  Validation.validate_raw_signature hash raw_data asn.signature_algorithm
+    asn.signature asn.info.public_key
 
-let decode_der cs =
+let decode_der ?(hash_whitelist = Validation.sha2) cs =
   let open Rresult.R.Infix in
   Asn_grammars.err_to_msg (Asn.signing_request_of_cs cs) >>= fun csr ->
   let csr = { raw = cs ; asn = csr } in
-  if validate_signature csr then
+  if validate_signature hash_whitelist csr then
     Ok csr
   else
     Error (`Msg "couldn't validate signature")
@@ -179,11 +179,12 @@ let create subject ?(digest = `SHA256) ?(extensions = Ext.empty) = function
 
 let sign signing_request
     ~valid_from ~valid_until
+    ?(hash_whitelist = Validation.sha2)
     ?(digest = `SHA256)
     ?(serial = Nocrypto.(Rng.Z.gen_r Numeric.Z.one Numeric.Z.(one lsl 64)))
     ?(extensions = Extension.empty)
     key issuer =
-  if not (validate_signature signing_request) then
+  if not (validate_signature hash_whitelist signing_request) then
     Error (`Msg "could not validate signature of signing request")
   else
     let signature_algo =

lib/validation.ml

@@ -1,5 +1,8 @@
 open Nocrypto
 
+let sha2 = [ `SHA256 ; `SHA384 ; `SHA512 ]
+let all_hashes = [ `MD5 ; `SHA1 ; `SHA224 ] @ sha2
+
 let maybe_validate_hostname cert = function
   | None   -> true
   | Some x -> Certificate.supports_hostname cert x
@@ -10,18 +13,15 @@ let issuer_matches_subject
 
 let is_self_signed cert = issuer_matches_subject cert cert
 
-let validate_raw_signature raw signature_algo signature_val pk_info =
-  match pk_info with
-  | `RSA issuing_key ->
+let validate_raw_signature hash_whitelist raw signature_algo signature_val pk_info =
+  match pk_info, Algorithm.to_signature_algorithm signature_algo with
+  | `RSA issuing_key, Some (`RSA, siga) ->
+    List.mem siga hash_whitelist &&
     ( match Rsa.PKCS1.sig_decode ~key:issuing_key signature_val with
       | None           -> false
       | Some signature ->
-        match
-          Certificate.decode_pkcs1_digest_info signature,
-          Algorithm.to_signature_algorithm signature_algo
-        with
-        | Ok (algo, hash), Some (`RSA, h) ->
-          h = algo && Cstruct.equal hash (Hash.digest algo raw)
+        match Certificate.decode_pkcs1_digest_info signature with
+        | Ok (a, hash) -> siga = a && Cstruct.equal hash (Hash.digest a raw)
         | _ -> false )
   | _ -> false
 
@@ -33,9 +33,10 @@ let raw_cert_hack raw signature =
   let lenl   = 2 + if 0x80 land snd = 0 then 0 else 0x7F land snd in
   Cstruct.(sub raw lenl (len raw - (siglen + lenl + 19 + off)))
 
-let validate_signature { Certificate.asn = trusted ; _ } cert =
+let validate_signature hash_whitelist { Certificate.asn = trusted ; _ } cert =
   let tbs_raw = raw_cert_hack cert.Certificate.raw cert.asn.signature_val in
-  validate_raw_signature tbs_raw cert.asn.signature_algo cert.asn.signature_val trusted.tbs_cert.pk_info
+  validate_raw_signature hash_whitelist tbs_raw cert.asn.signature_algo
+    cert.asn.signature_val trusted.tbs_cert.pk_info
 
 let validate_time time { Certificate.asn = cert ; _ } =
   match time with
@@ -293,11 +294,11 @@ let is_cert_valid now cert =
   | (_, false, _)      -> Error (`IntermediateInvalidVersion cert)
   | (_, _, false)      -> Error (`IntermediateInvalidExtensions cert)
 
-let is_ca_cert_valid now cert =
+let is_ca_cert_valid hash_whitelist now cert =
   match
     is_self_signed cert,
     version_matches_extensions cert,
-    validate_signature cert cert,
+    validate_signature hash_whitelist cert cert,
     validate_time now cert,
     valid_trust_anchor_extensions cert
   with
@@ -308,7 +309,8 @@ let is_ca_cert_valid now cert =
   | (_, _, _, false, _)            -> Error (`CACertificateExpired (cert, now))
   | (_, _, _, _, false)            -> Error (`CAInvalidExtensions cert)
 
-let valid_ca ?time cacert = is_ca_cert_valid time cacert
+let valid_ca ?(hash_whitelist = all_hashes) ?time cacert =
+  is_ca_cert_valid hash_whitelist time cacert
 
 let is_server_cert_valid ?host now cert =
   match
@@ -323,11 +325,11 @@ let is_server_cert_valid ?host now cert =
   | (_, _, false, _)         -> Error (`LeafInvalidVersion cert)
   | (_, _, _, false)         -> Error (`LeafInvalidExtensions cert)
 
-let signs pathlen trusted cert =
+let signs hash pathlen trusted cert =
   match
     issuer_matches_subject trusted cert,
     ext_authority_matches_subject trusted cert,
-    validate_signature trusted cert,
+    validate_signature hash trusted cert,
     validate_path_len pathlen trusted
   with
   | (true, true, true, true) -> Ok ()
@@ -339,27 +341,27 @@ let signs pathlen trusted cert =
 let issuer trusted cert =
   List.filter (fun p -> issuer_matches_subject p cert) trusted
 
-let rec validate_anchors revoked pathlen cert = function
+let rec validate_anchors revoked hash pathlen cert = function
   | []    -> Error (`NoTrustAnchor cert)
-  | x::xs -> match signs pathlen x cert with
+  | x::xs -> match signs hash pathlen x cert with
     | Ok _    -> if revoked ~issuer:x ~cert then Error (`Revoked cert) else Ok x
-    | Error _ -> validate_anchors revoked pathlen cert xs
+    | Error _ -> validate_anchors revoked hash pathlen cert xs
 
 let lift_leaf f x =
   match f x with
   | Ok () -> Ok ()
   | Error e -> Error (`Leaf e)
 
-let verify_single_chain ?time ?(revoked = fun ~issuer:_ ~cert:_ -> false) anchors chain =
+let verify_single_chain ?time ?(revoked = fun ~issuer:_ ~cert:_ -> false) hash anchors chain =
   let rec climb pathlen = function
     | cert :: issuer :: certs ->
       is_cert_valid time issuer >>= fun () ->
-      if revoked ~issuer ~cert then Error (`Revoked cert) else Ok () >>= fun () ->
-        signs pathlen issuer cert >>= fun () ->
-        climb (succ pathlen) (issuer :: certs)
+      (if revoked ~issuer ~cert then Error (`Revoked cert) else Ok ()) >>= fun () ->
+      signs hash pathlen issuer cert >>= fun () ->
+      climb (succ pathlen) (issuer :: certs)
     | [c] ->
       let anchors = issuer anchors c in
-      validate_anchors revoked pathlen c anchors
+      validate_anchors revoked hash pathlen c anchors
     | [] -> Error `EmptyCertificateChain
   in
   climb 0 chain
@@ -369,20 +371,20 @@ let lift_chain f x =
   | Ok x -> Ok x
   | Error e -> Error (`Chain e)
 
-let verify_chain ?host ?time ?revoked ~anchors = function
+let verify_chain ?host ?time ?revoked ?(hash_whitelist = sha2) ~anchors = function
   | [] -> Error (`Chain `EmptyCertificateChain)
   | server :: certs ->
     let anchors = List.filter (validate_time time) anchors in
     lift_leaf (is_server_cert_valid ?host time) server >>= fun () ->
-    lift_chain (verify_single_chain ?time ?revoked anchors) (server :: certs)
+    lift_chain (verify_single_chain ?time ?revoked hash_whitelist anchors) (server :: certs)
 
 let rec any_m e f = function
   | [] -> Error e
   | c::cs -> match f c with
     | Ok ta -> Ok (Some (c, ta))
     | Error _ -> any_m e f cs
 
-let verify_chain_of_trust ?host ?time ?revoked ~anchors = function
+let verify_chain_of_trust ?host ?time ?revoked ?(hash_whitelist = sha2) ~anchors = function
   | [] -> Error `EmptyCertificateChain
   | server :: certs ->
     (* verify server! *)
@@ -392,10 +394,12 @@ let verify_chain_of_trust ?host ?time ?revoked ~anchors = function
     and anchors = List.filter (validate_time time) anchors
     in
     (* exists there one which is good? *)
-    any_m `InvalidChain (verify_single_chain ?time ?revoked anchors) paths
+    any_m `InvalidChain (verify_single_chain ?time ?revoked hash_whitelist anchors) paths
 
-let valid_cas ?time cas =
-  List.filter (fun cert -> Rresult.R.is_ok (is_ca_cert_valid time cert)) cas
+let valid_cas ?(hash_whitelist = all_hashes) ?time cas =
+  List.filter (fun cert ->
+      Rresult.R.is_ok (is_ca_cert_valid hash_whitelist time cert))
+    cas
 
 let fingerprint_verification ?host ?time fingerprints fp = function
   | [] -> Error `EmptyCertificateChain