CA-398341: Populate fingerprints of CA certificates on startup (#6006)

Also CP-51527: Add --force option to pool-uninstall-ca-certificate.

Addresses the issues raised here by @stormi
#5955

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 = 782
+let schema_minor_vsn = 783
 
 (* Historical schema versions just in case this is useful later *)
 let rio_schema_major_vsn = 5

ocaml/idl/datamodel_host.ml

@@ -1479,12 +1479,40 @@ let install_ca_certificate =
 let uninstall_ca_certificate =
   call ~pool_internal:true ~hide_from_docs:true ~name:"uninstall_ca_certificate"
     ~doc:"Remove a TLS CA certificate from this host."
-    ~params:
+    ~versioned_params:
       [
-        (Ref _host, "host", "The host"); (String, "name", "The certificate name")
+        {
+          param_type= Ref _host
+        ; param_name= "host"
+        ; param_doc= "The host"
+        ; param_release= numbered_release "1.290.0"
+        ; param_default= None
+        }
+      ; {
+          param_type= String
+        ; param_name= "name"
+        ; param_doc= "The certificate name"
+        ; param_release= numbered_release "1.290.0"
+        ; param_default= None
+        }
+      ; {
+          param_type= Bool
+        ; param_name= "force"
+        ; param_doc= "Remove the DB entry even if the file is non-existent"
+        ; param_release= numbered_release "24.35.0"
+        ; param_default= Some (VBool false)
+        }
       ]
     ~allowed_roles:_R_LOCAL_ROOT_ONLY
-    ~lifecycle:[(Published, "1.290.0", "Uninstall TLS CA certificate")]
+    ~lifecycle:
+      [
+        (Published, "1.290.0", "Uninstall TLS CA certificate")
+      ; ( Changed
+        , "24.35.0"
+        , "Added --force option to allow DB entries to be removed for \
+           non-existent files"
+        )
+      ]
     ()
 
 let certificate_list =

ocaml/idl/datamodel_pool.ml

@@ -851,9 +851,41 @@ let certificate_uninstall =
 let uninstall_ca_certificate =
   call ~name:"uninstall_ca_certificate"
     ~doc:"Remove a pool-wide TLS CA certificate."
-    ~params:[(String, "name", "The certificate name")]
+    ~params:
+      [
+        (String, "name", "The certificate name")
+      ; ( Bool
+        , "force"
+        , "If true, remove the DB entry even if the file is non-existent"
+        )
+      ]
+    ~versioned_params:
+      [
+        {
+          param_type= String
+        ; param_name= "name"
+        ; param_doc= "The certificate name"
+        ; param_release= numbered_release "1.290.0"
+        ; param_default= None
+        }
+      ; {
+          param_type= Bool
+        ; param_name= "force"
+        ; param_doc= "Remove the DB entry even if the file is non-existent"
+        ; param_release= numbered_release "24.35.0"
+        ; param_default= Some (VBool false)
+        }
+      ]
     ~allowed_roles:(_R_POOL_OP ++ _R_CLIENT_CERT)
-    ~lifecycle:[(Published, "1.290.0", "Uninstall TLS CA certificate")]
+    ~lifecycle:
+      [
+        (Published, "1.290.0", "Uninstall TLS CA certificate")
+      ; ( Changed
+        , "24.35.0"
+        , "Added --force option to allow DB entries to be removed for \
+           non-existent files"
+        )
+      ]
     ()
 
 let certificate_list =

ocaml/xapi-cli-server/cli_frontend.ml

@@ -396,8 +396,11 @@ let rec cmdtable_data : (string * cmd_spec) list =
   ; ( "pool-uninstall-ca-certificate"
     , {
         reqd= ["name"]
-      ; optn= []
-      ; help= "Uninstall a pool-wide TLS CA certificate."
+      ; optn= ["force"]
+      ; help=
+          "Uninstall a pool-wide TLS CA certificate. The optional parameter \
+           '--force' will remove the DB entry even if the certificate file is \
+           non-existent"
       ; implementation= No_fd Cli_operations.pool_uninstall_ca_certificate
       ; flags= []
       }

ocaml/xapi-cli-server/cli_operations.ml

@@ -1770,7 +1770,8 @@ let pool_install_ca_certificate fd _printer rpc session_id params =
 
 let pool_uninstall_ca_certificate _printer rpc session_id params =
   let name = List.assoc "name" params in
-  Client.Pool.uninstall_ca_certificate ~rpc ~session_id ~name
+  let force = get_bool_param params "force" in
+  Client.Pool.uninstall_ca_certificate ~rpc ~session_id ~name ~force
 
 let pool_certificate_list printer rpc session_id _params =
   printer (Cli_printer.PList (Client.Pool.certificate_list ~rpc ~session_id))

ocaml/xapi/certificates.ml

@@ -304,17 +304,21 @@ let host_install kind ~name ~cert =
       (ExnHelper.string_of_exn e) ;
     raise_library_corrupt ()
 
-let host_uninstall kind ~name =
+let host_uninstall kind ~name ~force =
   validate_name kind name ;
   let filename = library_filename kind name in
-  if not (Sys.file_exists filename) then
-    raise_does_not_exist kind name ;
-  debug "Uninstalling %s %s" (to_string kind) name ;
-  try Sys.remove filename ; update_ca_bundle ()
-  with e ->
-    warn "Exception uninstalling %s %s: %s" (to_string kind) name
-      (ExnHelper.string_of_exn e) ;
-    raise_corrupt kind name
+  if Sys.file_exists filename then (
+    debug "Uninstalling %s %s" (to_string kind) name ;
+    try Sys.remove filename ; update_ca_bundle ()
+    with e ->
+      warn "Exception uninstalling %s %s: %s" (to_string kind) name
+        (ExnHelper.string_of_exn e) ;
+      raise_corrupt kind name
+  ) else if force then
+    info "Certificate file %s is non-existent but ignoring this due to force."
+      name
+  else
+    raise_does_not_exist kind name
 
 let get_cert kind name =
   validate_name kind name ;
@@ -367,6 +371,7 @@ let sync_certs kind ~__context master_certs host =
         )
         (fun rpc session_id host name ->
           Client.Host.uninstall_ca_certificate ~rpc ~session_id ~host ~name
+            ~force:false
         )
         ~__context master_certs host
   | CRL ->
@@ -403,15 +408,16 @@ let pool_install kind ~__context ~name ~cert =
   host_install kind ~name ~cert ;
   try pool_sync ~__context
   with exn ->
-    ( try host_uninstall kind ~name
+    ( try host_uninstall kind ~name ~force:false
       with e ->
         warn "Exception unwinding install of %s %s: %s" (to_string kind) name
           (ExnHelper.string_of_exn e)
     ) ;
     raise exn
 
-let pool_uninstall kind ~__context ~name =
-  host_uninstall kind ~name ; pool_sync ~__context
+let pool_uninstall kind ~__context ~name ~force =
+  host_uninstall kind ~name ~force ;
+  pool_sync ~__context
 
 (* Extracts the server certificate from the server certificate pem file.
    It strips the private key as well as the rest of the certificate chain. *)

ocaml/xapi/certificates.mli

@@ -53,12 +53,13 @@ val install_server_certificate :
 
 val host_install : t_trusted -> name:string -> cert:string -> unit
 
-val host_uninstall : t_trusted -> name:string -> unit
+val host_uninstall : t_trusted -> name:string -> force:bool -> unit
 
 val pool_install :
   t_trusted -> __context:Context.t -> name:string -> cert:string -> unit
 
-val pool_uninstall : t_trusted -> __context:Context.t -> name:string -> unit
+val pool_uninstall :
+  t_trusted -> __context:Context.t -> name:string -> force:bool -> unit
 
 (* Database manipulation *)
 

ocaml/xapi/message_forwarding.ml

@@ -3745,19 +3745,22 @@ functor
               ~cert
         )
 
-      let uninstall_ca_certificate ~__context ~host ~name =
-        info "Host.uninstall_ca_certificate: host = '%s'; name = '%s'"
+      let uninstall_ca_certificate ~__context ~host ~name ~force =
+        info
+          "Host.uninstall_ca_certificate: host = '%s'; name = '%s'; force = \
+           '%b'"
           (host_uuid ~__context host)
-          name ;
-        let local_fn = Local.Host.uninstall_ca_certificate ~host ~name in
+          name force ;
+        let local_fn = Local.Host.uninstall_ca_certificate ~host ~name ~force in
         do_op_on ~local_fn ~__context ~host (fun session_id rpc ->
             Client.Host.uninstall_ca_certificate ~rpc ~session_id ~host ~name
+              ~force
         )
 
       (* legacy names *)
       let certificate_install = install_ca_certificate
 
-      let certificate_uninstall = uninstall_ca_certificate
+      let certificate_uninstall = uninstall_ca_certificate ~force:false
 
       let certificate_list ~__context ~host =
         info "Host.certificate_list: host = '%s'" (host_uuid ~__context host) ;

ocaml/xapi/xapi_db_upgrade.ml

@@ -904,6 +904,67 @@ let upgrade_update_guidance =
       )
   }
 
+let upgrade_ca_fingerprints =
+  {
+    description= "Upgrade the fingerprint fields for ca certificates"
+  ; version= (fun x -> x < (5, 783))
+  ; (* the version where we started updating missing fingerprint_sha256
+       and fingerprint_sha1 fields for ca certs *)
+    fn=
+      (fun ~__context ->
+        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 =
+                  Certificates.pp_fingerprint ~hash_type:`SHA1 certificate
+                in
+                let sha256 =
+                  Certificates.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))
+              | exn ->
+                  Error (`Msg (Printexc.to_string exn))
+            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"
+                  __FUNCTION__ record.API.certificate_name msg
+          )
+          empty
+      )
+  }
+
 let rules =
   [
     upgrade_domain_type
@@ -933,6 +994,7 @@ let rules =
   ; remove_legacy_ssl_support
   ; empty_pool_uefi_certificates
   ; upgrade_update_guidance
+  ; upgrade_ca_fingerprints
   ]
 
 (* Maybe upgrade most recent db *)

ocaml/xapi/xapi_host.ml

@@ -1548,9 +1548,9 @@ let install_ca_certificate ~__context ~host:_ ~name ~cert =
   (* don't modify db - Pool.install_ca_certificate will handle that *)
   Certificates.(host_install CA_Certificate ~name ~cert)
 
-let uninstall_ca_certificate ~__context ~host:_ ~name =
+let uninstall_ca_certificate ~__context ~host:_ ~name ~force =
   (* don't modify db - Pool.uninstall_ca_certificate will handle that *)
-  Certificates.(host_uninstall CA_Certificate ~name)
+  Certificates.(host_uninstall CA_Certificate ~name ~force)
 
 let certificate_list ~__context ~host:_ =
   Certificates.(local_list CA_Certificate)
@@ -1559,7 +1559,7 @@ let crl_install ~__context ~host:_ ~name ~crl =
   Certificates.(host_install CRL ~name ~cert:crl)
 
 let crl_uninstall ~__context ~host:_ ~name =
-  Certificates.(host_uninstall CRL ~name)
+  Certificates.(host_uninstall CRL ~name ~force:false)
 
 let crl_list ~__context ~host:_ = Certificates.(local_list CRL)
 

ocaml/xapi/xapi_host.mli

@@ -290,7 +290,7 @@ val install_ca_certificate :
   __context:Context.t -> host:API.ref_host -> name:string -> cert:string -> unit
 
 val uninstall_ca_certificate :
-  __context:Context.t -> host:API.ref_host -> name:string -> unit
+  __context:Context.t -> host:API.ref_host -> name:string -> force:bool -> unit
 
 val certificate_list : __context:'a -> host:'b -> string list
 

ocaml/xapi/xapi_pool.ml

@@ -1432,12 +1432,12 @@ let certificate_install ~__context ~name ~cert =
 
 let install_ca_certificate = certificate_install
 
-let certificate_uninstall ~__context ~name =
+let uninstall_ca_certificate ~__context ~name ~force =
   let open Certificates in
-  pool_uninstall CA_Certificate ~__context ~name ;
+  pool_uninstall CA_Certificate ~__context ~name ~force ;
   Db_util.remove_ca_cert_by_name ~__context name
 
-let uninstall_ca_certificate = certificate_uninstall
+let certificate_uninstall = uninstall_ca_certificate ~force:false
 
 let certificate_list ~__context =
   let open Certificates in
@@ -1446,7 +1446,7 @@ let certificate_list ~__context =
 
 let crl_install = Certificates.(pool_install CRL)
 
-let crl_uninstall = Certificates.(pool_uninstall CRL)
+let crl_uninstall = Certificates.(pool_uninstall CRL ~force:false)
 
 let crl_list ~__context = Certificates.(local_list CRL)
 

ocaml/xapi/xapi_pool.mli

@@ -248,7 +248,8 @@ val install_ca_certificate :
 
 val certificate_uninstall : __context:Context.t -> name:string -> unit
 
-val uninstall_ca_certificate : __context:Context.t -> name:string -> unit
+val uninstall_ca_certificate :
+  __context:Context.t -> name:string -> force:bool -> unit
 
 val certificate_list : __context:Context.t -> string list