From 8f863bd761831e7b089d9a0928277b9c0a50998f Mon Sep 17 00:00:00 2001
From: Pau Ruiz Safont <pau.ruizsafont@cloud.com>
Date: Thu, 29 Aug 2024 13:28:27 +0100
Subject: [PATCH] CA-398341: Populate fingerprints of CA certificates on
 startup

SHA256 and SHA1 certificates' fingerprints do not get populated when the
database is upgraded, so empty values need to be detected and amended on
startup.

Signed-off-by: Pau Ruiz Safont <pau.ruizsafont@cloud.com>
Signed-off-by: Steven Woods <steven.woods@citrix.com>
---
 ocaml/xapi/certificates.ml  | 46 +++++++++++++++++++++++++++++++++++++
 ocaml/xapi/certificates.mli |  2 ++
 ocaml/xapi/xapi.ml          |  4 ++++
 3 files changed, 52 insertions(+)

diff --git a/ocaml/xapi/certificates.ml b/ocaml/xapi/certificates.ml
index 6e1c01b7be6..fdc9b9b3704 100644
--- a/ocaml/xapi/certificates.ml
+++ b/ocaml/xapi/certificates.ml
@@ -173,6 +173,8 @@ module Db_util : sig
     * of type [type'] belonging to [host] (the term 'host' is overloaded here) *)
 
   val get_ca_certs : __context:Context.t -> API.ref_Certificate list
+
+  val upgrade_ca_fingerprints : __context:Context.t -> unit
 end = struct
   module Date = Xapi_stdext_date.Date
 
@@ -256,6 +258,50 @@ end = struct
       Eq (Field "type", Literal "ca")
     in
     Db.Certificate.get_refs_where ~__context ~expr
+
+  let upgrade_ca_fingerprints ~__context =
+    let __FUN = __FUNCTION__ in
+    let expr =
+      let open Xapi_database.Db_filter_types in
+      And
+        ( Or
+            ( Eq (Field "fingerprint_sha256", Literal "")
+            , Eq (Field "fingerprint_sha1", Literal "")
+            )
+        , Eq (Field "type", Literal "ca")
+        )
+    in
+    let empty = Db.Certificate.get_records_where ~__context ~expr in
+    List.iter
+      (fun (self, record) ->
+        let read_fingerprints filename =
+          let ( let* ) = Result.bind in
+          try
+            let* certificate =
+              Xapi_stdext_unix.Unixext.string_of_file filename
+              |> Cstruct.of_string
+              |> X509.Certificate.decode_pem
+            in
+            let sha1 = pp_fingerprint ~hash_type:`SHA1 certificate in
+            let sha256 = pp_fingerprint ~hash_type:`SHA256 certificate in
+            Ok (sha1, sha256)
+          with Unix.Unix_error (Unix.ENOENT, _, _) ->
+            Error (`Msg (Printf.sprintf "filename %s does not exist" filename))
+        in
+        let filename =
+          Filename.concat
+            !Xapi_globs.trusted_certs_dir
+            record.API.certificate_name
+        in
+        match read_fingerprints filename with
+        | Ok (sha1, sha256) ->
+            Db.Certificate.set_fingerprint_sha1 ~__context ~self ~value:sha1 ;
+            Db.Certificate.set_fingerprint_sha256 ~__context ~self ~value:sha256
+        | Error (`Msg msg) ->
+            D.info "%s: ignoring error when reading CA certificate %s: %s" __FUN
+              record.API.certificate_name msg
+      )
+      empty
 end
 
 let local_list kind =
diff --git a/ocaml/xapi/certificates.mli b/ocaml/xapi/certificates.mli
index 486ada825e2..1a514ce4a91 100644
--- a/ocaml/xapi/certificates.mli
+++ b/ocaml/xapi/certificates.mli
@@ -83,4 +83,6 @@ module Db_util : sig
     -> API.ref_Certificate list
 
   val get_ca_certs : __context:Context.t -> API.ref_Certificate list
+
+  val upgrade_ca_fingerprints : __context:Context.t -> unit
 end
diff --git a/ocaml/xapi/xapi.ml b/ocaml/xapi/xapi.ml
index b702001ef2e..5c002e1534a 100644
--- a/ocaml/xapi/xapi.ml
+++ b/ocaml/xapi/xapi.ml
@@ -1147,6 +1147,10 @@ let server_init () =
             , []
             , fun () -> report_tls_verification ~__context
             )
+          ; ( "Update shared certificate's metadata"
+            , [Startup.OnlyMaster]
+            , fun () -> Certificates.Db_util.upgrade_ca_fingerprints ~__context
+            )
           ; ( "Remote requests"
             , [Startup.OnThread]
             , Remote_requests.handle_requests