CP-49147: Reduce size of the pool record (uefi_certificates)

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)
     )

ocaml/idl/datamodel_common.ml

@@ -10,7 +10,7 @@ open Datamodel_roles
               to leave a gap for potential hotfixes needing to increment the schema version.*)
 let schema_major_vsn = 5
 
-let schema_minor_vsn = 785
+let schema_minor_vsn = 786
 
 (* Historical schema versions just in case this is useful later *)
 let rio_schema_major_vsn = 5

ocaml/idl/datamodel_pool.ml

@@ -2006,6 +2006,11 @@ let t =
                 , "22.16.0"
                 , "Became StaticRO to be editable through new method"
                 )
+              ; ( Changed
+                , "25.6.0"
+                , "Field replaced with a digest. You can still get the actual \
+                   value by calling Host.get_uefi_certificates"
+                )
               ]
             ~default_value:(Some (VString "")) "uefi_certificates"
             "The UEFI certificates allowing Secure Boot"

ocaml/idl/json_backend/gen_json.ml

@@ -613,8 +613,8 @@ module Version = struct
     try Scanf.sscanf name "%d.%d.%d%s" of_chunks
     with _ ->
       failwith
-        (Printf.sprintf "Version schema changed, please change this code %s"
-           __LOC__
+        (Printf.sprintf "Version schema changed, please change this code %s: %s"
+           name __LOC__
         )
 
   let to_name_date (lst, str) =

ocaml/idl/schematest.ml

@@ -3,7 +3,7 @@ let hash x = Digest.string x |> Digest.to_hex
 (* BEWARE: if this changes, check that schema has been bumped accordingly in
    ocaml/idl/datamodel_common.ml, usually schema_minor_vsn *)
 
-let last_known_schema_hash = "458f20f5270a5615c7ee92be8a383172"
+let last_known_schema_hash = "26f1712e0c5de2462447ace8df31dedf"
 
 let current_schema_hash : string =
   let open Datamodel_types in