Cert Refresh

ocaml/idl/datamodel_common.ml

@@ -8,7 +8,7 @@ open Datamodel_roles
               When introducing a new release, bump the schema minor version to the next hundred
               to leave a gap for potential hotfixes needing to increment the schema version.*)
 let schema_major_vsn = 5
-let schema_minor_vsn = 703
+let schema_minor_vsn = 704
 
 (* Historical schema versions just in case this is useful later *)
 let rio_schema_major_vsn = 5

ocaml/idl/datamodel_host.ml

@@ -1029,6 +1029,14 @@ let host_query_ha = call ~flags:[`Session]
       ~allowed_roles:_R_READ_ONLY
       ()
 
+  let refresh_server_certificate = call
+      ~lifecycle:[Published, rel_next, ""]
+      ~name:"refresh_server_certificate"
+      ~doc:"Replace the internal self-signed host certficate with a new one."
+      ~params:[Ref _host, "host", "The host"]
+      ~allowed_roles:_R_POOL_ADMIN
+      ()
+
   let display =
     Enum ("host_display", [
         "enabled", "This host is outputting its console to a physical display device";
@@ -1544,6 +1552,7 @@ let host_query_ha = call ~flags:[`Session]
         crl_list;
         certificate_sync;
         get_server_certificate;
+        refresh_server_certificate;
         install_server_certificate;
         emergency_reset_server_certificate;
         reset_server_certificate;

ocaml/idl/datamodel_pool.ml

@@ -13,6 +13,7 @@ open Datamodel_types
             "sync_updates", "Indicates this pool is in the process of syncing updates";
             "get_updates", "Indicates this pool is in the process of getting updates";
             "apply_updates", "Indicates this pool is in the process of applying updates";
+            "cert_refresh", "A certificate refresh and distribution is in progress";
           ])
 
   let enable_ha = call

ocaml/idl/schematest.ml

@@ -1,7 +1,7 @@
 let hash x = Digest.string x |> Digest.to_hex
 
 (* BEWARE: if this changes, check that schema has been bumped accordingly *)
-let last_known_schema_hash = "633a99b46dda090677598aad3a830f76"
+let last_known_schema_hash = "632046e456380e732bb9faadde0ecb9e"
 
 let current_schema_hash : string =
   let open Datamodel_types in

ocaml/xapi-cli-server/cli_frontend.ml

@@ -3071,6 +3071,15 @@ let rec cmdtable_data : (string * cmd_spec) list =
       ; flags= [Host_selectors]
       }
     )
+  ; ( "host-refresh-server-certificate"
+    , {
+        reqd= ["host"]
+      ; optn= []
+      ; help= "Refresh internal server certificate of host"
+      ; implementation= No_fd Cli_operations.host_refresh_server_certificate
+      ; flags= [Host_selectors]
+      }
+    )
   ; ( "host-server-certificate-install"
     , {
         reqd= ["certificate"; "private-key"]

ocaml/xapi-cli-server/cli_operations.ml

@@ -3504,6 +3504,16 @@ let host_get_server_certificate printer rpc session_id params =
        params []
     )
 
+let host_refresh_server_certificate printer rpc session_id params =
+  ignore
+    (do_host_op rpc session_id ~multiple:false
+       (fun _ host ->
+         let host = host.getref () in
+         Client.Host.refresh_server_certificate rpc session_id host
+         )
+       params []
+    )
+
 let host_install_server_certificate fd printer rpc session_id params =
   let certificate =
     List.assoc "certificate" params |> get_file_or_fail fd "certificate"

ocaml/xapi-cli-server/record_util.ml

@@ -164,6 +164,8 @@ let pool_operation_to_string = function
       "get_updates"
   | `apply_updates ->
       "apply_updates"
+  | `cert_refresh ->
+      "cert_refresh"
 
 let host_operation_to_string = function
   | `provision ->

ocaml/xapi-consts/api_errors.ml

@@ -1221,6 +1221,8 @@ let pool_secret_rotation_pending = "POOL_SECRET_ROTATION_PENDING"
 
 let tls_verification_enable_in_progress = "TLS_VERIFICATION_ENABLE_IN_PROGRESS"
 
+let cert_refresh_in_progress = "CERT_REFRESH_IN_PROGRESS"
+
 let configure_repositories_in_progress = "CONFIGURE_REPOSITORIES_IN_PROGRESS"
 
 let invalid_base_url = "INVALID_BASE_URL"

ocaml/xapi/cert_distrib.ml

@@ -439,3 +439,17 @@ let import_joining_pool_ca_certificates ~__context ~ca_certs =
   Worker.local_write_cert_fs ~__context ApplianceCertificate Merge
     appliance_certs ;
   Worker.local_regen_bundle ~__context
+
+let distribute_new_host_cert ~__context ~host ~content =
+  let hosts = Db.Host.get_all ~__context in
+  let uuid = Db.Host.get_uuid ~__context ~self:host in
+  let file =
+    WireProtocol.{filename= Printf.sprintf "%s.new.pem" uuid; content}
+  in
+  let job rpc session_id host =
+    Worker.remote_write_certs_fs HostPoolCertificate Merge [file] host rpc
+      session_id
+  in
+  Helpers.call_api_functions ~__context @@ fun rpc session_id ->
+  List.iter (fun host -> job rpc session_id host) hosts ;
+  List.iter (fun host -> Worker.remote_regen_bundle host rpc session_id) hosts

ocaml/xapi/cert_distrib.mli

@@ -50,3 +50,7 @@ val import_joining_pool_ca_certificates :
     This parameter must be the result of
     [exchange_ca_certificates_with_joiner]. This function was designed
     as part of pool join and is unlikely to be useful elsewhere. *)
+
+val distribute_new_host_cert :
+  __context:Context.t -> host:[`host] API.Ref.t -> content:string -> unit
+(** distribute a new (additional) certificate for [host] in the pool *)

ocaml/xapi/cert_refresh.ml

@@ -0,0 +1,110 @@
+(*
+ * Copyright (C) Citrix Systems Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU Lesser General Public License as published
+ * by the Free Software Foundation; version 2.1 only. with the special
+ * exception on linking described in file LICENSE.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ * GNU Lesser General Public License for more details.
+ *)
+
+module D = Debug.Make (struct let name = "cert_refresh" end)
+
+open D
+
+(* given a [filename], replace its extension with [ext]. Does not change
+the file system *)
+let replace_extension filename ~ext =
+  let base =
+    match Filename.extension filename with
+    | "" ->
+        filename
+    | _ ->
+        Filename.remove_extension filename
+  in
+  Printf.sprintf "%s.%s" base ext
+
+(* Path to host server certificate (in PEM format) *)
+let cert_path = function
+  | `host ->
+      !Xapi_globs.server_cert_path
+  | `host_internal ->
+      !Xapi_globs.server_cert_internal_path
+
+(* Paths to certificates that we are about to use *)
+let new_cert_path type' = replace_extension (cert_path type') ~ext:"new"
+
+let backup_cert_path type' = replace_extension (cert_path type') ~ext:"bak"
+
+(* Create a new host cert in the file system and return its contents
+also as a data structure *)
+let new_host_cert ~dbg ~path : X509.Certificate.t =
+  let name, ip =
+    match Networking_info.get_management_ip_addr ~dbg with
+    | None ->
+        let msg = Printf.sprintf "%s: failed to get management IP" __LOC__ in
+        D.error "%s" msg ;
+        raise Api_errors.(Server_error (internal_error, [msg]))
+    | Some ip ->
+        ip
+  in
+  let dns_names = Networking_info.dns_names () in
+  let ips = [ip] in
+  Gencertlib.Selfcert.host ~name ~dns_names ~ips path
+
+(* On this host and for this host, create a new server certificate and
+distribute it in the pool *)
+let host ~__context ~type' =
+  let host = Helpers.get_localhost ~__context in
+  let dbg = Context.string_of_task __context in
+  let pem = cert_path type' in
+  let path = new_cert_path type' in
+  let cert = new_host_cert ~dbg ~path in
+  let bak = backup_cert_path type' in
+  let content = X509.Certificate.encode_pem cert |> Cstruct.to_string in
+  (* distribute public part of new cert in pool *)
+  Cert_distrib.distribute_new_host_cert ~__context ~host ~content ;
+  (* replace certs in file system on host *)
+  info "renaming cert %s to %s" path pem ;
+  Sys.rename pem bak ;
+  Sys.rename path pem ;
+  (* remove old from database, add new *)
+  Certificates.Db_util.get_host_certs ~__context ~type' ~host
+  |> List.iter (Certificates.Db_util.remove_cert_by_ref ~__context) ;
+  let ref =
+    match type' with
+    | `host ->
+        Certificates.Db_util.add_cert ~__context ~type':(`host host) cert
+    | `host_internal ->
+        Certificates.Db_util.add_cert ~__context ~type':(`host_internal host)
+          cert
+  in
+  (* start using new cert *)
+  Helpers.Stunnel.reload () ; ref
+
+(* The stunnel clients trust the old and the new [host] server cert.  On
+the local host, rename the old cert and re-create the cert bundle
+without it *)
+let remove_stale_cert ~__context ~host ~type' =
+  let uuid = Db.Host.get_uuid ~__context ~self:host in
+  let directory =
+    match type' with
+    | `host ->
+        !Xapi_globs.trusted_certs_dir
+    | `host_internal ->
+        !Xapi_globs.trusted_pool_certs_dir
+  in
+  let next = Filename.concat directory (Printf.sprintf "%s.new.pem" uuid) in
+  let pem = Filename.concat directory (Printf.sprintf "%s.pem" uuid) in
+  let bak = Filename.concat directory (Printf.sprintf "%s.bak" uuid) in
+  if Sys.file_exists next && Sys.file_exists pem then (
+    info "cleanup - renaming %s to %s" next pem ;
+    Sys.rename pem bak ;
+    Sys.rename next pem ;
+    Certificates.update_ca_bundle ()
+  ) else
+    info "cleanup - no new cert %s found - skipping" next

ocaml/xapi/cert_refresh.mli

@@ -0,0 +1,31 @@
+(*
+ * Copyright (C) Citrix Systems Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU Lesser General Public License as published
+ * by the Free Software Foundation; version 2.1 only. with the special
+ * exception on linking described in file LICENSE.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ * GNU Lesser General Public License for more details.
+ *)
+
+(** For this host, generate a new host certificate and distribute its
+public parts. When this function returns, pool members still would
+accept the old certificate and hence need to perform some clean-up
+actions *)
+
+val host :
+  __context:Context.t -> type':[< `host | `host_internal] -> API.ref_Certificate
+
+(** On this host, remove stale certs for [host] after [host]'s
+certificates were refreshed. This needs to be executed on every 
+host of the pool *)
+
+val remove_stale_cert :
+     __context:Context.t
+  -> host:API.ref_host
+  -> type':[< `host | `host_internal]
+  -> unit

ocaml/xapi/certificates.ml

@@ -438,11 +438,10 @@ let hostnames_of_pem_cert pem =
   >>| X509.Certificate.hostnames
 
 let install_server_certificate ?(pem_chain = None) ~pem_leaf ~pkcs8_private_key
-    =
-  let server_cert_path = !Xapi_globs.server_cert_path in
+    ~path =
   let installation =
     Gencertlib.Lib.install_server_certificate ~pem_chain ~pem_leaf
-      ~pkcs8_private_key ~server_cert_path
+      ~pkcs8_private_key ~server_cert_path:path
   in
   match installation with
   | Ok cert ->

ocaml/xapi/helpers.ml

@@ -1816,6 +1816,9 @@ let try_internal_async ~__context (marshaller : Rpc.t -> 'b)
 module Stunnel : sig
   val restart : __context:Context.t -> accept:string -> unit
   (** restart stunnel, possibly changing the config file *)
+
+  val reload : unit -> unit
+  (** reload (potentially updated) configuration *)
 end = struct
   let cert = !Xapi_globs.server_cert_path
 
@@ -1902,6 +1905,8 @@ end = struct
 
   let systemctl_ cmd = systemctl cmd |> ignore
 
+  let reload () = systemctl_ "reload-or-restart"
+
   let is_enabled () =
     let is_enabled_stdout =
       try systemctl "is-enabled"

ocaml/xapi/message_forwarding.ml

@@ -3582,6 +3582,29 @@ functor
             Client.Host.get_server_certificate rpc session_id host
         )
 
+      let refresh_server_certificate ~__context ~host =
+        info "Host.refresh_server_certificate: host = '%s'"
+          (host_uuid ~__context host) ;
+        let pool = Helpers.get_pool ~__context in
+        let local_fn = Local.Host.refresh_server_certificate ~host in
+        let other =
+          Db.Host.get_all ~__context |> List.filter (fun h -> h <> host)
+        in
+        Xapi_pool_helpers.with_pool_operation ~__context
+          ~doc:"Host.refresh_server_certificate" ~self:pool ~op:`cert_refresh
+        @@ fun () ->
+        (* let host refresh its certificates first *)
+        do_op_on ~local_fn ~__context ~host (fun session_id rpc ->
+            Client.Host.refresh_server_certificate rpc session_id host
+        ) ;
+        (* update all other hosts in the pool *)
+        other
+        |> List.iter (fun h ->
+               do_op_on ~local_fn ~__context ~host:h (fun session_id rpc ->
+                   Client.Host.refresh_server_certificate rpc session_id host
+               )
+           )
+
       let _success ~__context () =
         let task = Context.get_task_id __context in
         let progress = Db.Task.get_progress ~__context ~self:task in