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 <[email protected]>
Signed-off-by: Steven Woods <[email protected]>

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 =

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

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