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

This allows the CA certificate to be removed from the DB even if the
certificate file does not exist.

Signed-off-by: Steven Woods <[email protected]>

ocaml/idl/datamodel_host.ml

@@ -1079,10 +1079,23 @@ let uninstall_ca_certificate =
     ~doc:"Remove a TLS CA certificate from this host."
     ~params:
       [
-        (Ref _host, "host", "The host"); (String, "name", "The certificate name")
+        (Ref _host, "host", "The host")
+      ; (String, "name", "The certificate name")
+      ; ( Bool
+        , "force"
+        , "If true, remove the DB entry even if the file is non-existent"
+        )
       ]
     ~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.29.0"
+        , "Added --force option to allow DB entries to be removed for \
+           non-existent files"
+        )
+      ]
     ()
 
 let certificate_list =

ocaml/idl/datamodel_pool.ml

@@ -639,9 +639,24 @@ 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"
+        )
+      ]
     ~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.29.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

@@ -1778,7 +1778,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

@@ -285,8 +285,11 @@ end = struct
             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))
+          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
@@ -342,17 +345,21 @@ let host_install kind ~name ~cert =
       (ExnHelper.string_of_exn e) ;
     raise_library_corrupt ()
 
-let host_uninstall kind ~name =
+let host_uninstall ?(force = false) kind ~name =
   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 ;
@@ -405,6 +412,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 ->
@@ -448,8 +456,9 @@ let pool_install kind ~__context ~name ~cert =
     ) ;
     raise exn
 
-let pool_uninstall kind ~__context ~name =
-  host_uninstall kind ~name ; pool_sync ~__context
+let pool_uninstall ?(force = false) kind ~__context ~name =
+  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 : ?force:bool -> t_trusted -> name:string -> 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 :
+  ?force:bool -> t_trusted -> __context:Context.t -> name:string -> unit
 
 (* Database manipulation *)
 

ocaml/xapi/message_forwarding.ml

@@ -3726,19 +3726,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_host.ml

@@ -1545,9 +1545,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)

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

@@ -1397,12 +1397,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

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