From 8a6af5e8887f1ee511b7e17c933af11db6bdde56 Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Wed, 29 Jan 2025 16:01:57 +0000 Subject: [PATCH] CA-405593: Normalise API-installed host certificates When installing host certificates, the parser used accepts strings with extraneous characters surrounding the PEM-encoded data. The ad-hoc parser used to reject such data because it was stricter. Because the PEM-encoded objects are copied as-is after validating them, the ad-hoc parser failed to read the file correctly on xapi restarts. This change fixes the issue by encoding the key and certificates in PEM format from parsed datastructures instead of using user-provided inputs directly. Parse, don't validate Signed-off-by: Pau Ruiz Safont --- ocaml/gencert/lib.ml | 67 ++++++++++++++++++++++++--------------- ocaml/gencert/lib.mli | 13 ++++---- ocaml/gencert/test_lib.ml | 49 ++++++++++++++++++---------- 3 files changed, 80 insertions(+), 49 deletions(-) diff --git a/ocaml/gencert/lib.ml b/ocaml/gencert/lib.ml index 970954a5371..cd964276e65 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,55 @@ 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 +(** Decodes the PEM-encoded objects (private key, leaf certificate, and + certificate chain, reencodes them to make sure they are normalised, and + finally it installs them as a server certificate to be ready to use by + stunnel. It also ensures the objects maintian some cryptographic + properties. *) 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 d4b6015dff2..e7011ea0b9a 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 f3a54517ad4..379eb35f2e3 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) )