CA-405593: Do not write extraneous data into the host certificate file (#6263)

When installing host certificates, the parser used accepts string with
random characters surrounding the PEM-encoded data. The ad-hoc parser
used to read the host certificate file was unable to parse them.

Because the PEM-encoded objects are copied as-is after validating them,
the ad-hoc parser fails to read the file correctly when xapi restarts.

This change fixes the issue by making sure that the written file's data
has been sanitized, by using parsed datastructures instead of
user-provided data.

    Parse, don't validate

I've manually tested the fix on a host, before and after to validate
that indeed now all the characters in between the PEM-encoded objects
are stripped

Author: lindig

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"

ocaml/gencert/lib.mli

@@ -43,18 +43,19 @@ 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]
      , [> `Msg of string * string list]
      )
      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

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,15 +219,15 @@ 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)
 
 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)
     )