diff --git a/ocaml/gencert/lib.ml b/ocaml/gencert/lib.ml index 970954a537..c4f2e20bc1 100644 --- a/ocaml/gencert/lib.ml +++ b/ocaml/gencert/lib.ml @@ -17,8 +17,6 @@ module D = Debug.Make (struct let name = "gencert_lib" end) open Api_errors open Rresult -type t_certificate = Leaf | Chain - let validate_private_key pkcs8_private_key = let ensure_rsa_key_length = function | `RSA priv -> @@ -86,7 +84,7 @@ let validate_not_expired x ~error_not_yet ~error_expired ~error_invalid = _validate_not_expired ~now x ~error_not_yet ~error_expired ~error_invalid |> Rresult.R.reword_error @@ fun (`Msg (e, msgs)) -> Server_error (e, msgs) -let validate_certificate kind pem now private_key = +let validate_pem_chain ~pem_leaf ~pem_chain now private_key = let ensure_keys_match private_key certificate = let public_key = X509.Certificate.public_key certificate in match (public_key, private_key) with @@ -102,38 +100,50 @@ let validate_certificate kind pem now private_key = | _ -> Error (`Msg (server_certificate_signature_not_supported, [])) in - match kind with - | Leaf -> - _validate_not_expired ~now pem ~error_invalid:server_certificate_invalid - ~error_not_yet:server_certificate_not_valid_yet - ~error_expired:server_certificate_expired - >>= ensure_keys_match private_key - >>= ensure_sha256_signature_algorithm - | Chain -> ( - let raw_pem = Cstruct.of_string pem in - X509.Certificate.decode_pem_multiple raw_pem |> function - | Ok (cert :: _) -> - Ok cert - | Ok [] -> - D.info "Rejected certificate chain because it's empty." ; - Error (`Msg (server_certificate_chain_invalid, [])) - | Error (`Msg err_msg) -> - D.info {|Failed to validate certificate chain because "%s"|} err_msg ; - Error (`Msg (server_certificate_chain_invalid, [])) - ) + let validate_chain pem_chain = + let raw_pem = Cstruct.of_string pem_chain in + X509.Certificate.decode_pem_multiple raw_pem |> function + | Ok (_ :: _ as certs) -> + Ok certs + | Ok [] -> + D.info "Rejected certificate chain because it's empty." ; + Error (`Msg (server_certificate_chain_invalid, [])) + | Error (`Msg err_msg) -> + D.info {|Failed to validate certificate chain because "%s"|} err_msg ; + Error (`Msg (server_certificate_chain_invalid, [])) + in + _validate_not_expired ~now pem_leaf ~error_invalid:server_certificate_invalid + ~error_not_yet:server_certificate_not_valid_yet + ~error_expired:server_certificate_expired + >>= ensure_keys_match private_key + >>= ensure_sha256_signature_algorithm + >>= fun cert -> + match Option.map validate_chain pem_chain with + | None -> + Ok (cert, None) + | Some (Ok chain) -> + Ok (cert, Some chain) + | Some (Error msg) -> + Error msg let install_server_certificate ~pem_chain ~pem_leaf ~pkcs8_private_key ~server_cert_path ~cert_gid = let now = Ptime_clock.now () in validate_private_key pkcs8_private_key >>= fun priv -> - validate_certificate Leaf pem_leaf now priv >>= fun cert -> + let pkcs8_private_key = + X509.Private_key.encode_pem priv |> Cstruct.to_string + in + validate_pem_chain ~pem_leaf ~pem_chain now priv >>= fun (cert, chain) -> + let pem_leaf = X509.Certificate.encode_pem cert |> Cstruct.to_string in Option.fold ~none:(Ok [pkcs8_private_key; pem_leaf]) - ~some:(fun pem_chain -> - validate_certificate Chain pem_chain now priv >>= fun _ignored -> + ~some:(fun chain -> + let pem_chain = + X509.Certificate.encode_pem_multiple chain |> Cstruct.to_string + in Ok [pkcs8_private_key; pem_leaf; pem_chain] ) - pem_chain + chain >>= fun server_cert_components -> server_cert_components |> String.concat "\n\n" diff --git a/ocaml/gencert/lib.mli b/ocaml/gencert/lib.mli index d4b6015dff..e7011ea0b9 100644 --- a/ocaml/gencert/lib.mli +++ b/ocaml/gencert/lib.mli @@ -43,8 +43,6 @@ val validate_not_expired : (** The following functions are exposed exclusively for unit-testing, please do not use them directly, they are not stable *) -type t_certificate = Leaf | Chain - val validate_private_key : string -> ( [> `RSA of Mirage_crypto_pk.Rsa.priv] @@ -52,9 +50,12 @@ val validate_private_key : ) Result.result -val validate_certificate : - t_certificate - -> string +val validate_pem_chain : + pem_leaf:string + -> pem_chain:string option -> Ptime.t -> [> `RSA of Mirage_crypto_pk.Rsa.priv] - -> (X509.Certificate.t, [> `Msg of string * string list]) Rresult.result + -> ( X509.Certificate.t * X509.Certificate.t list option + , [> `Msg of string * string list] + ) + Result.t diff --git a/ocaml/gencert/test_lib.ml b/ocaml/gencert/test_lib.ml index f3a54517ad..379eb35f2e 100644 --- a/ocaml/gencert/test_lib.ml +++ b/ocaml/gencert/test_lib.ml @@ -162,8 +162,8 @@ let invalid_keys_tests = ) invalid_private_keys -let test_valid_cert ~kind cert time pkey = - match validate_certificate kind cert time pkey with +let test_valid_leaf_cert pem_leaf time pkey () = + match validate_pem_chain ~pem_leaf ~pem_chain:None time pkey with | Ok _ -> () | Error (`Msg (_, msg)) -> @@ -173,8 +173,8 @@ let test_valid_cert ~kind cert time pkey = msg ) -let test_invalid_cert ~kind cert time pkey error reason = - match validate_certificate kind cert time pkey with +let test_invalid_cert pem_leaf time pkey error reason = + match validate_pem_chain ~pem_leaf ~pem_chain:None time pkey with | Ok _ -> Alcotest.fail "Invalid certificate was validated without errors" | Error (`Msg msg) -> @@ -203,9 +203,6 @@ let sign_leaf_cert host_name digest pkey_leaf = >>| Cstruct.to_string let valid_leaf_cert_tests = - let test_valid_leaf_cert cert time pkey () = - test_valid_cert ~kind:Leaf cert time pkey - in List.map (fun (name, pkey_leaf_name, time, digest) -> let cert_test = @@ -222,7 +219,7 @@ let test_corrupt_leaf_cert (cert_name, pkey_name, time, error, reason) = let time = time_of_rfc3339 time in let test_cert = load_pkcs8 pkey_name >>| fun pkey -> - let test () = test_invalid_cert ~kind:Leaf cert time pkey error reason in + let test () = test_invalid_cert cert time pkey error reason in test in ("Validation of a corrupted certificate", `Quick, test_cert) @@ -230,7 +227,7 @@ let test_corrupt_leaf_cert (cert_name, pkey_name, time, error, reason) = let test_invalid_leaf_cert (name, pkey_leaf_name, pkey_expected_name, time, digest, error, reason) = let test_invalid_leaf_cert cert time pkey error reason () = - test_invalid_cert ~kind:Leaf cert time pkey error reason + test_invalid_cert cert time pkey error reason in let test_cert = load_pkcs8 pkey_leaf_name >>= fun pkey_leaf -> @@ -245,17 +242,30 @@ let invalid_leaf_cert_tests = List.map test_corrupt_leaf_cert corrupt_certificates @ List.map test_invalid_leaf_cert invalid_leaf_certificates -let test_valid_cert_chain chain time pkey () = - test_valid_cert ~kind:Chain chain time pkey +let test_valid_cert_chain ~pem_leaf ~pem_chain time pkey () = + match validate_pem_chain ~pem_leaf ~pem_chain:(Some pem_chain) time pkey with + | Ok _ -> + () + | Error (`Msg (_, msg)) -> + Alcotest.fail + (Format.asprintf "Valid certificate chain could not be validated: %a" + Fmt.(Dump.list string) + msg + ) -let test_invalid_cert_chain cert time pkey error reason () = - test_invalid_cert ~kind:Chain cert time pkey error reason +let test_invalid_cert_chain pem_leaf pem_chain time pkey error reason () = + match validate_pem_chain ~pem_leaf ~pem_chain:(Some pem_chain) time pkey with + | Ok _ -> + Alcotest.fail "Invalid certificate chain was validated without errors" + | Error (`Msg msg) -> + Alcotest.(check @@ pair string @@ list string) + "Error must match" (error, reason) msg let valid_chain_cert_tests = let time = time_of_rfc3339 "2020-02-01T00:00:00Z" in let test_cert = load_pkcs8 "pkey_rsa_4096" >>= fun pkey_root -> - let pkey, chain = + let pkey_leaf, chain = List.fold_left (fun (pkey_sign, chain_result) pkey -> let result = @@ -267,8 +277,10 @@ let valid_chain_cert_tests = ) (pkey_root, Ok []) key_chain in + sign_leaf_cert host_name `SHA256 pkey_leaf >>= fun pem_leaf -> chain >>| X509.Certificate.encode_pem_multiple >>| Cstruct.to_string - >>| fun chain -> test_valid_cert_chain chain time pkey + >>| fun pem_chain -> + test_valid_cert_chain ~pem_leaf ~pem_chain time pkey_leaf in [("Validation of a supported certificate chain", `Quick, test_cert)] @@ -277,8 +289,11 @@ let invalid_chain_cert_tests = (fun (chain_name, pkey_name, time, error, reason) -> let chain = load_test_data chain_name in let test_cert = - load_pkcs8 pkey_name >>| fun pkey -> - test_invalid_cert_chain chain (time_of_rfc3339 time) pkey error reason + (* Need to load a valid key and leaf cert *) + load_pkcs8 pkey_name >>= fun pkey -> + sign_leaf_cert host_name `SHA256 pkey >>| fun cert -> + test_invalid_cert_chain cert chain (time_of_rfc3339 time) pkey error + reason in ("Validation of an unsupported certificate chain", `Quick, test_cert) )