From 92d8e39ac48b9702e182003286171f4efbf7b1ec Mon Sep 17 00:00:00 2001 From: Ming Lu Date: Tue, 27 Jan 2026 16:41:13 +0800 Subject: [PATCH 01/28] Don't use CRLs for pool internal host-host TLS communications (cherry-pick from commit c1d44032d11d7d7307a578c2fdb8b307782f29aa) As these TLS communications use 'verifyPeer=yes' actually while applying CRLs requires root CA certificates and 'verifyChain=yes'. Signed-off-by: Ming Lu --- ocaml/libs/stunnel/stunnel.ml | 31 +++++++++++++++++++++---------- ocaml/libs/stunnel/stunnel.mli | 1 + 2 files changed, 22 insertions(+), 10 deletions(-) diff --git a/ocaml/libs/stunnel/stunnel.ml b/ocaml/libs/stunnel/stunnel.ml index 5f005ba8119..762a618f0c6 100644 --- a/ocaml/libs/stunnel/stunnel.ml +++ b/ocaml/libs/stunnel/stunnel.ml @@ -122,6 +122,7 @@ type verification_config = { sni: string option ; verify: verify ; cert_bundle_path: string + ; crl_dir: string option } type t = { @@ -140,6 +141,7 @@ let appliance = sni= None ; verify= CheckHost ; cert_bundle_path= "/etc/stunnel/xapi-stunnel-ca-bundle.pem" + ; crl_dir= Some crl_path } let pool = @@ -147,12 +149,18 @@ let pool = sni= Some "pool" ; verify= VerifyPeer ; cert_bundle_path= "/etc/stunnel/xapi-pool-ca-bundle.pem" + ; crl_dir= None } let world = {appliance with cert_bundle_path= "/etc/ssl/certs/ca-bundle.crt"} let external_host ext_host_cert_file = - {sni= None; verify= VerifyPeer; cert_bundle_path= ext_host_cert_file} + { + sni= None + ; verify= VerifyPeer + ; cert_bundle_path= ext_host_cert_file + ; crl_dir= None + } let debug_conf_of_bool verbose : string = if verbose then @@ -221,7 +229,7 @@ let config_file ?(accept = None) config host port = ; ( match config with | None -> [] - | Some {sni; verify; cert_bundle_path} -> + | Some {sni; verify; cert_bundle_path; crl_dir} -> List.rev_append ( match verify with | VerifyPeer -> @@ -236,14 +244,17 @@ let config_file ?(accept = None) config host port = ; "# the cert of the server we connect to" ; (match sni with None -> "" | Some s -> sprintf "sni = %s" s) ; sprintf "CAfile=%s" cert_bundle_path - ; ( match Sys.readdir crl_path with - | [||] -> - "" - | _ -> - sprintf "CRLpath=%s" crl_path - | exception _ -> - "" - ) + ; Option.fold ~none:"" + ~some:(fun crl_dir -> + match Sys.readdir crl_dir with + | [||] -> + "" + | _ -> + sprintf "CRLpath=%s" crl_dir + | exception _ -> + "" + ) + crl_dir ] ) ; [""] diff --git a/ocaml/libs/stunnel/stunnel.mli b/ocaml/libs/stunnel/stunnel.mli index bfb7710e3b6..855f7082798 100644 --- a/ocaml/libs/stunnel/stunnel.mli +++ b/ocaml/libs/stunnel/stunnel.mli @@ -40,6 +40,7 @@ type verification_config = { sni: string option ; verify: verify ; cert_bundle_path: string + ; crl_dir: string option } (** Represents an active stunnel connection *) From 4299249c484834ecc56bd347ae59dc247bf68d96 Mon Sep 17 00:00:00 2001 From: Ming Lu Date: Tue, 6 Jan 2026 16:06:29 +0800 Subject: [PATCH 02/28] Add 'purpose' field in Certificate datamodel (cherry-pick from commit 2f42df4c8951e30b484354608ab95e66fbc095e0) Signed-off-by: Ming Lu --- ocaml/idl/datamodel_certificate.ml | 9 +++++++++ ocaml/xapi-cli-server/records.ml | 6 ++++++ ocaml/xapi/cert_distrib.ml | 2 +- ocaml/xapi/cert_refresh.ml | 5 +++-- ocaml/xapi/certificates.ml | 5 +++-- ocaml/xapi/certificates.mli | 1 + ocaml/xapi/certificates_sync.ml | 4 +++- ocaml/xapi/xapi_host.ml | 5 +++-- ocaml/xapi/xapi_pool.ml | 2 +- 9 files changed, 30 insertions(+), 9 deletions(-) diff --git a/ocaml/idl/datamodel_certificate.ml b/ocaml/idl/datamodel_certificate.ml index 53c594fb941..c5c4255081b 100644 --- a/ocaml/idl/datamodel_certificate.ml +++ b/ocaml/idl/datamodel_certificate.ml @@ -33,6 +33,12 @@ let certificate_type = ] ) +let certificate_purpose = + Enum + ( "certificate_purpose" + , [("licensing", "Trusted certificates that are for licensing purpose.")] + ) + let t = create_obj ~name:_certificate ~descr:"An X509 certificate used for TLS connections" ~doccomments:[] @@ -75,5 +81,8 @@ let t = ; field ~qualifier:StaticRO ~lifecycle:[] ~ty:String "fingerprint_sha1" ~default_value:(Some (VString "")) "The certificate's SHA1 fingerprint / hash" + ; field ~qualifier:StaticRO ~lifecycle:[] ~ty:(Set certificate_purpose) + "purpose" ~default_value:(Some (VSet [])) + "The purposes of the certificate" ] ~messages:[] () diff --git a/ocaml/xapi-cli-server/records.ml b/ocaml/xapi-cli-server/records.ml index 766500313e9..bab06c747c5 100644 --- a/ocaml/xapi-cli-server/records.ml +++ b/ocaml/xapi-cli-server/records.ml @@ -5429,6 +5429,12 @@ let certificate_record rpc session_id certificate = ; make_field ~name:"fingerprint_sha1" ~get:(fun () -> (x ()).API.certificate_fingerprint_sha1) () + ; make_field ~name:"purpose" + ~get:(fun () -> + map_and_concat Record_util.certificate_purpose_to_string + (x ()).API.certificate_purpose + ) + () ] } diff --git a/ocaml/xapi/cert_distrib.ml b/ocaml/xapi/cert_distrib.ml index d31f8a1abe7..2c71c660e58 100644 --- a/ocaml/xapi/cert_distrib.ml +++ b/ocaml/xapi/cert_distrib.ml @@ -584,7 +584,7 @@ let exchange_ca_certificates_with_joiner ~__context ~import ~export = List.iter (fun (name, cert) -> let (_ : API.ref_Certificate) = - C.Db_util.add_cert ~__context ~type':(`ca name) cert + C.Db_util.add_cert ~__context ~type':(`ca name) ~purpose:[] cert in () ) diff --git a/ocaml/xapi/cert_refresh.ml b/ocaml/xapi/cert_refresh.ml index 213d0abc224..d68977f58dc 100644 --- a/ocaml/xapi/cert_refresh.ml +++ b/ocaml/xapi/cert_refresh.ml @@ -93,10 +93,11 @@ let host ~__context ~type' = let ref = match type' with | `host -> - Certificates.Db_util.add_cert ~__context ~type':(`host host) cert + Certificates.Db_util.add_cert ~__context ~type':(`host host) ~purpose:[] + cert | `host_internal -> Certificates.Db_util.add_cert ~__context ~type':(`host_internal host) - cert + ~purpose:[] cert in (* We might have a slow client that connects using the old cert and has not picked up the new cert. To avoid that the connection fails, diff --git a/ocaml/xapi/certificates.ml b/ocaml/xapi/certificates.ml index f102bbd397a..29cd4536706 100644 --- a/ocaml/xapi/certificates.ml +++ b/ocaml/xapi/certificates.ml @@ -164,6 +164,7 @@ module Db_util : sig __context:Context.t -> type': [< `host of API.ref_host | `host_internal of API.ref_host | `ca of name] + -> purpose:API.certificate_purpose list -> X509.Certificate.t -> API.ref_Certificate @@ -207,7 +208,7 @@ end = struct debug "deleting cert ref=%s from the database" (Ref.string_of self) ; Db.Certificate.destroy ~__context ~self - let add_cert ~__context ~type' certificate = + let add_cert ~__context ~type' ~purpose certificate = let name, host, _type, post_action = match type' with | `host host -> @@ -232,7 +233,7 @@ end = struct let ref' = Ref.make () in Db.Certificate.create ~__context ~ref:ref' ~uuid ~host ~not_before ~not_after ~fingerprint:fingerprint_sha256 ~fingerprint_sha256 - ~fingerprint_sha1 ~name ~_type ; + ~fingerprint_sha1 ~name ~_type ~purpose ; debug "added cert %s under uuid=%s ref=%s" name uuid (Ref.string_of ref') ; post_action () ; ref' diff --git a/ocaml/xapi/certificates.mli b/ocaml/xapi/certificates.mli index 6776220df45..b8d0e578ac3 100644 --- a/ocaml/xapi/certificates.mli +++ b/ocaml/xapi/certificates.mli @@ -69,6 +69,7 @@ module Db_util : sig [< `ca of string | `host of API.ref_host | `host_internal of API.ref_host ] + -> purpose:API.certificate_purpose list -> X509.Certificate.t -> API.ref_Certificate diff --git a/ocaml/xapi/certificates_sync.ml b/ocaml/xapi/certificates_sync.ml index 6f90c059721..f237c7961a8 100644 --- a/ocaml/xapi/certificates_sync.ml +++ b/ocaml/xapi/certificates_sync.ml @@ -22,7 +22,9 @@ let uninstall ~__context cert = file system. This creates a new entry in the database. *) let install ~__context ~host:_ ~type' cert = try - let ref = Certificates.Db_util.add_cert ~__context ~type' cert in + let ref = + Certificates.Db_util.add_cert ~__context ~type' ~purpose:[] cert + in info "Adding host certificicate %s to database" (Ref.string_of ref) ; R.ok () with e -> diff --git a/ocaml/xapi/xapi_host.ml b/ocaml/xapi/xapi_host.ml index f6b1109d6fd..44a6c5840db 100644 --- a/ocaml/xapi/xapi_host.ml +++ b/ocaml/xapi/xapi_host.ml @@ -1615,9 +1615,10 @@ let replace_host_certificate ~__context ~type' ~host let (_ : API.ref_Certificate) = match type' with | `host -> - Db_util.add_cert ~__context ~type':(`host host) new_cert + Db_util.add_cert ~__context ~type':(`host host) ~purpose:[] new_cert | `host_internal -> - Db_util.add_cert ~__context ~type':(`host_internal host) new_cert + Db_util.add_cert ~__context ~type':(`host_internal host) ~purpose:[] + new_cert in List.iter (Db_util.remove_cert_by_ref ~__context) old_certs ; let task = Context.get_task_id __context in diff --git a/ocaml/xapi/xapi_pool.ml b/ocaml/xapi/xapi_pool.ml index 5214fb3998a..d2fa5efb179 100644 --- a/ocaml/xapi/xapi_pool.ml +++ b/ocaml/xapi/xapi_pool.ml @@ -1585,7 +1585,7 @@ let certificate_install ~__context ~name ~cert = in pool_install CA_Certificate ~__context ~name ~cert ; let (_ : API.ref_Certificate) = - Db_util.add_cert ~__context ~type':(`ca name) certificate + Db_util.add_cert ~__context ~type':(`ca name) ~purpose:[] certificate in () From 35acb7a05279287edd21b108f79bd2612d303831 Mon Sep 17 00:00:00 2001 From: Ming Lu Date: Tue, 6 Jan 2026 16:12:16 +0800 Subject: [PATCH 03/28] Add 'pinned' in type of Certificate (cherry-pick from commit 139068c8c277d1fbaec6837bfe1e18596d7ef5ae) Signed-off-by: Ming Lu --- ocaml/alerts/certificate/certificate_check.ml | 18 ++++++++++++++++-- ocaml/alerts/certificate/certificate_check.mli | 1 + ocaml/idl/datamodel_certificate.ml | 1 + ocaml/xapi-consts/api_messages.ml | 14 ++++++++++++++ ocaml/xapi/db_gc_util.ml | 5 ++++- 5 files changed, 36 insertions(+), 3 deletions(-) diff --git a/ocaml/alerts/certificate/certificate_check.ml b/ocaml/alerts/certificate/certificate_check.ml index c0dc3daa58b..9673181b635 100644 --- a/ocaml/alerts/certificate/certificate_check.ml +++ b/ocaml/alerts/certificate/certificate_check.ml @@ -5,6 +5,7 @@ type cert = | CA of API.ref_Certificate * API.datetime | Host of API.ref_host * API.datetime | Internal of API.ref_host * API.datetime + | Pinned of API.ref_Certificate * API.datetime let get_certificates rpc session_id = XenAPI.Certificate.get_all_records ~rpc ~session_id @@ -22,6 +23,8 @@ let get_certificates rpc session_id = ) | `ca -> CA (cert_ref, certificate.API.certificate_not_after) + | `pinned -> + Pinned (cert_ref, certificate.API.certificate_not_after) let certificate_description = function | Host _ -> @@ -29,7 +32,9 @@ let certificate_description = function | Internal _ -> "The internal TLS server certificate" | CA _ -> - "The CA pool certificate" + "The pool-wide trusted root CA certificate" + | Pinned _ -> + "The pool-wide trusted pinned leaf certificate" let alert_conditions = function | Host _ -> @@ -53,6 +58,13 @@ let alert_conditions = function ; (14, Api_messages.pool_ca_certificate_expiring_14) ; (30, Api_messages.pool_ca_certificate_expiring_30) ] + | Pinned _ -> + [ + (0, Api_messages.pool_pinned_certificate_expired) + ; (7, Api_messages.pool_pinned_certificate_expiring_07) + ; (14, Api_messages.pool_pinned_certificate_expiring_14) + ; (30, Api_messages.pool_pinned_certificate_expiring_30) + ] let alert_message_cls_and_obj_uuid rpc session_id cert = match cert with @@ -60,9 +72,11 @@ let alert_message_cls_and_obj_uuid rpc session_id cert = (`Host, XenAPI.Host.get_uuid ~rpc ~session_id ~self:host) | CA (cert, _) -> (`Certificate, XenAPI.Certificate.get_uuid ~rpc ~session_id ~self:cert) + | Pinned (cert, _) -> + (`Certificate, XenAPI.Certificate.get_uuid ~rpc ~session_id ~self:cert) let get_expiry = function - | Host (_, exp) | Internal (_, exp) | CA (_, exp) -> + | Host (_, exp) | Internal (_, exp) | CA (_, exp) | Pinned (_, exp) -> exp let alert rpc session_id = diff --git a/ocaml/alerts/certificate/certificate_check.mli b/ocaml/alerts/certificate/certificate_check.mli index f08e320eddf..ab9a3f96d83 100644 --- a/ocaml/alerts/certificate/certificate_check.mli +++ b/ocaml/alerts/certificate/certificate_check.mli @@ -21,6 +21,7 @@ type cert = | CA of API.ref_Certificate * API.datetime | Host of API.ref_host * API.datetime | Internal of API.ref_host * API.datetime + | Pinned of API.ref_Certificate * API.datetime val certificate_description : cert -> string diff --git a/ocaml/idl/datamodel_certificate.ml b/ocaml/idl/datamodel_certificate.ml index c5c4255081b..c90e898d274 100644 --- a/ocaml/idl/datamodel_certificate.ml +++ b/ocaml/idl/datamodel_certificate.ml @@ -30,6 +30,7 @@ let certificate_type = ; ( "host_internal" , "Certificate that identifies a single host to other pool members" ) + ; ("pinned", "Pinned leaf certificate that is trusted by the whole pool") ] ) diff --git a/ocaml/xapi-consts/api_messages.ml b/ocaml/xapi-consts/api_messages.ml index 812340d1040..42b91a67602 100644 --- a/ocaml/xapi-consts/api_messages.ml +++ b/ocaml/xapi-consts/api_messages.ml @@ -356,6 +356,20 @@ let host_internal_certificate_expiring_14 = let host_internal_certificate_expiring_07 = certificate_expiring host_internal_certificate_expiring 7 1L +let pool_pinned_certificate_expired = + addMessage "POOL_PINNED_CERTIFICATE_EXPIRED" 1L + +let pool_pinned_certificate_expiring = "POOL_PINNED_CERTIFICATE_EXPIRING" + +let pool_pinned_certificate_expiring_30 = + certificate_expiring pool_pinned_certificate_expiring 30 3L + +let pool_pinned_certificate_expiring_14 = + certificate_expiring pool_pinned_certificate_expiring 14 2L + +let pool_pinned_certificate_expiring_07 = + certificate_expiring pool_pinned_certificate_expiring 7 1L + let failed_login_attempts = addMessage "FAILED_LOGIN_ATTEMPTS" 3L let kernel_is_broken which = diff --git a/ocaml/xapi/db_gc_util.ml b/ocaml/xapi/db_gc_util.ml index 34073a79866..3b949ea9703 100644 --- a/ocaml/xapi/db_gc_util.ml +++ b/ocaml/xapi/db_gc_util.ml @@ -295,7 +295,10 @@ let gc_certificates ~__context = related to any single host *) all_certificates |> List.filter (fun (cert, record) -> - record.API.certificate_type <> `ca && not (List.mem cert host_certificates) + (record.API.certificate_type = `host + || record.API.certificate_type = `host_internal + ) + && not (List.mem cert host_certificates) ) |> List.iter (fun (cert, _) -> Db.Certificate.destroy ~__context ~self:cert) From 3d01cb9bbe33eb5b2f8ea4ff1bd3dded49bb59f6 Mon Sep 17 00:00:00 2001 From: Ming Lu Date: Tue, 6 Jan 2026 16:35:25 +0800 Subject: [PATCH 04/28] Add new APIs for trusted certificates (no impl.) (cherry-pick from commit c36ed78f69d67060984a4dfacdd53a94d2cf5db6) Signed-off-by: Ming Lu --- ocaml/idl/datamodel_pool.ml | 37 +++++++++++++++++++++++++ ocaml/xapi-cli-server/cli_frontend.ml | 18 ++++++++++++ ocaml/xapi-cli-server/cli_operations.ml | 33 ++++++++++++++++++++++ ocaml/xapi/message_forwarding.ml | 30 ++++++++++++++++++++ ocaml/xapi/xapi_pool.ml | 4 +++ ocaml/xapi/xapi_pool.mli | 14 ++++++++++ 6 files changed, 136 insertions(+) diff --git a/ocaml/idl/datamodel_pool.ml b/ocaml/idl/datamodel_pool.ml index 89b09301fb5..e1bd950ab89 100644 --- a/ocaml/idl/datamodel_pool.ml +++ b/ocaml/idl/datamodel_pool.ml @@ -1620,6 +1620,41 @@ let set_ssh_auto_mode = ] ~allowed_roles:_R_POOL_ADMIN () +let install_trusted_certificate = + call ~name:"install_trusted_certificate" + ~doc:"Install a trusted TLS certificate, pool-wide." + ~params: + [ + (Ref _pool, "self", "The pool") + ; ( Bool + , "ca" + , "The trusted certificate is a root CA certificate used to verify a \ + chain (true), or a leaf certificate used for certificate pinning \ + (false)" + ) + ; (String, "cert", "The certificate in PEM format") + ; ( Set Datamodel_certificate.certificate_purpose + , "purpose" + , "The purpose of the certificate" + ) + ] + ~allowed_roles:(_R_POOL_OP ++ _R_CLIENT_CERT) + ~lifecycle:[] () + +let uninstall_trusted_certificate = + call ~name:"uninstall_trusted_certificate" + ~doc:"Uninstall a trusted TLS certificate, pool-wide." + ~params: + [ + (Ref _pool, "self", "The pool") + ; ( Ref _certificate + , "certificate" + , "The reference of the trusted certificate to be uninstalled" + ) + ] + ~allowed_roles:(_R_POOL_OP ++ _R_CLIENT_CERT) + ~lifecycle:[] () + (** A pool class *) let t = create_obj ~in_db:true @@ -1719,6 +1754,8 @@ let t = ; set_ssh_enabled_timeout ; set_console_idle_timeout ; set_ssh_auto_mode + ; install_trusted_certificate + ; uninstall_trusted_certificate ] ~contents: ([ diff --git a/ocaml/xapi-cli-server/cli_frontend.ml b/ocaml/xapi-cli-server/cli_frontend.ml index d8185da9d47..cb74e7cc8c9 100644 --- a/ocaml/xapi-cli-server/cli_frontend.ml +++ b/ocaml/xapi-cli-server/cli_frontend.ml @@ -670,6 +670,24 @@ let rec cmdtable_data : (string * cmd_spec) list = ; flags= [] } ) + ; ( "pool-install-trusted-certificate" + , { + reqd= ["filename"; "ca"] + ; optn= ["uuid"; "purpose"] + ; help= "Install a TLS trusted certificate, pool-wide." + ; implementation= With_fd Cli_operations.pool_install_trusted_certificate + ; flags= [] + } + ) + ; ( "pool-uninstall-trusted-certificate" + , { + reqd= ["certificate-uuid"] + ; optn= ["uuid"] + ; help= "Uninstall a TLS trusted certificate, pool-wide." + ; implementation= No_fd Cli_operations.pool_uninstall_trusted_certificate + ; flags= [] + } + ) ; ( "host-shutdown" , { reqd= [] diff --git a/ocaml/xapi-cli-server/cli_operations.ml b/ocaml/xapi-cli-server/cli_operations.ml index e0921800b21..97c3d44ab44 100644 --- a/ocaml/xapi-cli-server/cli_operations.ml +++ b/ocaml/xapi-cli-server/cli_operations.ml @@ -1337,6 +1337,7 @@ let gen_cmds rpc session_id = ; "not-before" ; "not-after" ; "fingerprint" + ; "purpose" ] rpc session_id ) @@ -1953,6 +1954,38 @@ let pool_set_update_sync_enabled _printer rpc session_id params = let value = get_bool_param params "value" in Client.Pool.set_update_sync_enabled ~rpc ~session_id ~self:pool ~value +let pool_install_trusted_certificate fd _printer rpc session_id params = + let self = get_pool_with_default rpc session_id params "uuid" in + let filename = List.assoc "filename" params in + let ca = get_bool_param params ~default:true "ca" in + let purpose = + List.assoc_opt "purpose" params + |> Option.map (fun ss -> + String.split_on_char ',' ss + |> List.map Record_util.certificate_purpose_of_string + ) + |> function + | Some purposes -> + purposes + | None -> + [] + in + match get_client_file fd filename with + | Some cert -> + Client.Pool.install_trusted_certificate ~rpc ~session_id ~self ~ca ~cert + ~purpose + | None -> + marshal fd (Command (PrintStderr "Failed to read certificate\n")) ; + raise (ExitWithError 1) + +let pool_uninstall_trusted_certificate _printer rpc session_id params = + let self = get_pool_with_default rpc session_id params "uuid" in + let cert_uuid = List.assoc "certificate-uuid" params in + let certificate = + Client.Certificate.get_by_uuid ~rpc ~session_id ~uuid:cert_uuid + in + Client.Pool.uninstall_trusted_certificate ~rpc ~session_id ~self ~certificate + let vdi_type_of_string = function | "system" -> `system diff --git a/ocaml/xapi/message_forwarding.ml b/ocaml/xapi/message_forwarding.ml index 83786bd8afd..7a48a199158 100644 --- a/ocaml/xapi/message_forwarding.ml +++ b/ocaml/xapi/message_forwarding.ml @@ -357,6 +357,12 @@ functor else Printf.sprintf " (%s)" s + let raise_for_invalid cls ref = + raise + (Api_errors.Server_error + (Api_errors.handle_invalid, [cls; Ref.string_of ref]) + ) + let pool_uuid ~__context pool = try if Pool_role.is_master () then @@ -656,6 +662,14 @@ functor Ref.string_of observer with _ -> "invalid" + let certificate_uuid ~__context certificate = + try + if Pool_role.is_master () then + Db.Certificate.get_uuid ~__context ~self:certificate + else + Ref.string_of certificate + with _ -> raise_for_invalid "certificate" certificate + module Session = struct include Local.Session @@ -1219,6 +1233,22 @@ functor (pool_uuid ~__context self) value ; Local.Pool.set_ssh_auto_mode ~__context ~self ~value + + let install_trusted_certificate ~__context ~self ~ca ~cert ~purpose = + info "Pool.install_trusted_certificate: pool='%s' ca='%b' purpose=[%s]" + (pool_uuid ~__context self) + ca + (List.map Record_util.certificate_purpose_to_string purpose + |> String.concat "; " + ) ; + Local.Pool.install_trusted_certificate ~__context ~self ~ca ~cert + ~purpose + + let uninstall_trusted_certificate ~__context ~self ~certificate = + info "Pool.uninstall_trusted_certificate: pool='%s' certificate='%s'" + (pool_uuid ~__context self) + (certificate_uuid ~__context certificate) ; + Local.Pool.uninstall_trusted_certificate ~__context ~self ~certificate end module VM = struct diff --git a/ocaml/xapi/xapi_pool.ml b/ocaml/xapi/xapi_pool.ml index d2fa5efb179..963e4b5d648 100644 --- a/ocaml/xapi/xapi_pool.ml +++ b/ocaml/xapi/xapi_pool.ml @@ -4224,3 +4224,7 @@ let set_ssh_enabled_timeout = Ssh.set_enabled_timeout let set_console_idle_timeout = Ssh.set_console_timeout let set_ssh_auto_mode = Ssh.set_ssh_auto_mode + +let install_trusted_certificate ~__context ~self ~ca ~cert ~purpose = () + +let uninstall_trusted_certificate ~__context ~self ~certificate = () diff --git a/ocaml/xapi/xapi_pool.mli b/ocaml/xapi/xapi_pool.mli index dc87e90a18e..7f8943f4f39 100644 --- a/ocaml/xapi/xapi_pool.mli +++ b/ocaml/xapi/xapi_pool.mli @@ -446,3 +446,17 @@ val set_console_idle_timeout : val set_ssh_auto_mode : __context:Context.t -> self:API.ref_pool -> value:bool -> unit + +val install_trusted_certificate : + __context:Context.t + -> self:API.ref_pool + -> ca:bool + -> cert:string + -> purpose:API.certificate_purpose list + -> unit + +val uninstall_trusted_certificate : + __context:Context.t + -> self:API.ref_pool + -> certificate:API.ref_Certificate + -> unit From 7353dc1f922d9e24a3b3345be507d95253e2c916 Mon Sep 17 00:00:00 2001 From: Ming Lu Date: Tue, 6 Jan 2026 17:55:38 +0800 Subject: [PATCH 05/28] Implement APIs in xapi_pool.ml (cherry-pick from commit 6128c1c05ce49113bc0461f93b46ac39c0aae8df) Signed-off-by: Ming Lu --- ocaml/idl/datamodel_errors.ml | 15 +++++++ ocaml/xapi-consts/api_errors.ml | 11 +++++ ocaml/xapi/cert_distrib.ml | 4 +- ocaml/xapi/cert_refresh.ml | 2 +- ocaml/xapi/certificates.ml | 78 ++++++++++++++++++++++++--------- ocaml/xapi/certificates.mli | 13 ++++-- ocaml/xapi/certificates_sync.ml | 2 +- ocaml/xapi/xapi_globs.ml | 2 + ocaml/xapi/xapi_host.ml | 9 ++-- ocaml/xapi/xapi_pool.ml | 66 ++++++++++++++++++++++++---- 10 files changed, 162 insertions(+), 40 deletions(-) diff --git a/ocaml/idl/datamodel_errors.ml b/ocaml/idl/datamodel_errors.ml index 24262314274..62a4cb4d061 100644 --- a/ocaml/idl/datamodel_errors.ml +++ b/ocaml/idl/datamodel_errors.ml @@ -1709,6 +1709,21 @@ let _ = ~doc:"The provided intermediate certificates are not in a PEM-encoded X509." () ; + error Api_errors.not_trusted_certificate ["ref"] + ~doc:"The provided certificate is not a trusted certificate." () ; + + error Api_errors.certificate_lacks_purpose [] + ~doc:"No purpose is specified for the provided certificate." () ; + + error Api_errors.trusted_certificate_expired ["now"; "not_after"] + ~doc:"The provided certificate has expired." () ; + + error Api_errors.trusted_certificate_not_valid_yet ["now"; "not_before"] + ~doc:"The provided certificate is not valid yet." () ; + + error Api_errors.trusted_certificate_invalid [] + ~doc:"The provided certificate is not in a PEM-encoded X509." () ; + error Api_errors.vmpp_has_vm [] ~doc:"There is at least one VM assigned to this protection policy." () ; error Api_errors.vmpp_archive_more_frequent_than_backup [] diff --git a/ocaml/xapi-consts/api_errors.ml b/ocaml/xapi-consts/api_errors.ml index 8ca6eaafaa9..d97dcfbab5a 100644 --- a/ocaml/xapi-consts/api_errors.ml +++ b/ocaml/xapi-consts/api_errors.ml @@ -1159,6 +1159,13 @@ let server_certificate_expired = add_error "SERVER_CERTIFICATE_EXPIRED" let ca_certificate_expired = add_error "CA_CERTIFICATE_EXPIRED" +let trusted_certificate_expired = add_error "TRUSTED_CERTIFICATE_EXPIRED" + +let trusted_certificate_not_valid_yet = + add_error "TRUSTED_CERTIFICATE_NOT_VALID_YET" + +let trusted_certificate_invalid = add_error "TRUSTED_CERTIFICATE_INVALID" + let server_certificate_signature_not_supported = add_error "SERVER_CERTIFICATE_SIGNATURE_NOT_SUPPORTED" @@ -1445,3 +1452,7 @@ let invalid_ntp_config = add_error "INVALID_NTP_CONFIG" let not_allowed_when_ntp_is_enabled = add_error "NOT_ALLOWED_WHEN_NTP_IS_ENABLED" + +let not_trusted_certificate = add_error "NOT_TRUSTED_CERTIFICATE" + +let certificate_lacks_purpose = add_error "CERTIFICATE_LACKS_PURPOSE" diff --git a/ocaml/xapi/cert_distrib.ml b/ocaml/xapi/cert_distrib.ml index 2c71c660e58..fb580b84c24 100644 --- a/ocaml/xapi/cert_distrib.ml +++ b/ocaml/xapi/cert_distrib.ml @@ -572,7 +572,7 @@ let exchange_ca_certificates_with_joiner ~__context ~import ~export = let parsed = List.map (fun WireProtocol.{filename; content} -> - let () = C.(validate_name CA_Certificate filename) in + let () = C.(validate_name Root_legacy filename) in let cert = C.pem_of_string content in (filename, cert) ) @@ -583,7 +583,7 @@ let exchange_ca_certificates_with_joiner ~__context ~import ~export = Worker.local_regen_bundle ~__context ; List.iter (fun (name, cert) -> - let (_ : API.ref_Certificate) = + let (_ : API.ref_Certificate), _ = C.Db_util.add_cert ~__context ~type':(`ca name) ~purpose:[] cert in () diff --git a/ocaml/xapi/cert_refresh.ml b/ocaml/xapi/cert_refresh.ml index d68977f58dc..41f4b878177 100644 --- a/ocaml/xapi/cert_refresh.ml +++ b/ocaml/xapi/cert_refresh.ml @@ -90,7 +90,7 @@ let host ~__context ~type' = (* 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 = + let ref, _ = match type' with | `host -> Certificates.Db_util.add_cert ~__context ~type':(`host host) ~purpose:[] diff --git a/ocaml/xapi/certificates.ml b/ocaml/xapi/certificates.ml index 29cd4536706..2e62f6e28c1 100644 --- a/ocaml/xapi/certificates.ml +++ b/ocaml/xapi/certificates.ml @@ -29,7 +29,11 @@ open D * * Note that the bundles (e) and (f) are generated automatically using the contents of (c) and (d) respectively *) -type t_trusted = CA_Certificate | CRL +type t_trusted = + | Root_legacy + | CRL + | Root of API.certificate_purpose list + | Pinned of API.certificate_purpose list let pem_of_string x = match X509.Certificate.decode_pem x with @@ -41,12 +45,16 @@ let pem_of_string x = x let library_path = function - | CA_Certificate -> + | Root_legacy -> !Xapi_globs.trusted_certs_dir | CRL -> Stunnel.crl_path + | Root _ | Pinned _ -> + !Xapi_globs.trusted_certs_by_purpose_dir -let library_filename kind name = Filename.concat (library_path kind) name +let ( // ) = Filename.concat + +let library_filename kind name = library_path kind // name let mkdir_cert_path kind = Unixext.mkdir_rec (library_path kind) 0o700 @@ -62,14 +70,26 @@ let rehash' path = |> ignore let rehash () = - mkdir_cert_path CA_Certificate ; + mkdir_cert_path Root_legacy ; mkdir_cert_path CRL ; - rehash' (library_path CA_Certificate) ; + rehash' (library_path Root_legacy) ; rehash' (library_path CRL) let update_ca_bundle () = Helpers.update_ca_bundle () -let to_string = function CA_Certificate -> "CA certificate" | CRL -> "CRL" +let to_string = function + | Root_legacy -> + "legacy root CA certificate" + | CRL -> + "CRL" + | Root purposes -> + List.map API.certificate_purpose_to_string purposes + |> String.concat "; " + |> Printf.sprintf "root CA certificate [%s]" + | Pinned purposes -> + List.map API.certificate_purpose_to_string purposes + |> String.concat "; " + |> Printf.sprintf "pinned leaf certificate [%s]" (** {pp_hash hash} outputs the hexadecimal representation of the {hash} adding a colon between every octet, in uppercase. @@ -118,7 +138,7 @@ let raise_server_error parameters err = raise (Server_error (err, parameters)) let raise_name_invalid kind n = let err = match kind with - | CA_Certificate -> + | Root_legacy | Root _ | Pinned _ -> certificate_name_invalid | CRL -> crl_name_invalid @@ -131,7 +151,7 @@ let validate_name kind name = let raise_already_exists kind n = let err = match kind with - | CA_Certificate -> + | Root_legacy | Root _ | Pinned _ -> certificate_already_exists | CRL -> crl_already_exists @@ -141,7 +161,7 @@ let raise_already_exists kind n = let raise_does_not_exist kind n = let err = match kind with - | CA_Certificate -> + | Root_legacy | Root _ | Pinned _ -> certificate_does_not_exist | CRL -> crl_does_not_exist @@ -150,7 +170,11 @@ let raise_does_not_exist kind n = let raise_corrupt kind n = let err = - match kind with CA_Certificate -> certificate_corrupt | CRL -> crl_corrupt + match kind with + | Root_legacy | Root _ | Pinned _ -> + certificate_corrupt + | CRL -> + crl_corrupt in raise_server_error [n] err @@ -163,10 +187,13 @@ module Db_util : sig val add_cert : __context:Context.t -> type': - [< `host of API.ref_host | `host_internal of API.ref_host | `ca of name] + [< `host of API.ref_host + | `host_internal of API.ref_host + | `ca of name + | `pinned ] -> purpose:API.certificate_purpose list -> X509.Certificate.t - -> API.ref_Certificate + -> API.ref_Certificate * string val remove_cert_by_ref : __context:Context.t -> API.ref_Certificate -> unit @@ -215,12 +242,16 @@ end = struct ("", host, `host, Fun.id) | `host_internal host -> ("", host, `host_internal, Fun.id) - | `ca name -> + | `ca name when name <> "" -> let certs = get_ca_certs ~__context name in let remove_obsoleted_copies () = List.iter (remove_cert_by_ref ~__context) certs in (name, Ref.null, `ca, remove_obsoleted_copies) + | `ca _name -> + ("", Ref.null, `ca, Fun.id) + | `pinned -> + ("", Ref.null, `pinned, Fun.id) in let date_of_ptime time = Date.of_unix_time (Ptime.to_float_s time) in let dates_of_ptimes (a, b) = (date_of_ptime a, date_of_ptime b) in @@ -234,9 +265,10 @@ end = struct Db.Certificate.create ~__context ~ref:ref' ~uuid ~host ~not_before ~not_after ~fingerprint:fingerprint_sha256 ~fingerprint_sha256 ~fingerprint_sha1 ~name ~_type ~purpose ; - debug "added cert %s under uuid=%s ref=%s" name uuid (Ref.string_of ref') ; + debug "added cert (name='%s') under uuid=%s ref=%s" name uuid + (Ref.string_of ref') ; post_action () ; - ref' + (ref', uuid) let remove_ca_cert_by_name ~__context name = let certs = @@ -261,7 +293,9 @@ end = struct let get_ca_certs ~__context = let expr = let open Xapi_database.Db_filter_types in - Eq (Field "type", Literal "ca") + let type' = Eq (Field "type", Literal "ca") in + let name = Not (Eq (Field "name", Literal "")) in + And (type', name) in Db.Certificate.get_refs_where ~__context ~expr end @@ -360,8 +394,8 @@ let sync_certs_crls kind list_func install_func uninstall_func ~__context let sync_certs kind ~__context master_certs host = match kind with - | CA_Certificate -> - sync_certs_crls CA_Certificate + | Root_legacy -> + sync_certs_crls Root_legacy (fun rpc session_id host -> Client.Host.certificate_list ~rpc ~session_id ~host ) @@ -383,6 +417,8 @@ let sync_certs kind ~__context master_certs host = Client.Host.crl_uninstall ~rpc ~session_id ~host ~name ) ~__context master_certs host + | Root _ | Pinned _ -> + () let sync_certs_all_hosts kind ~__context master_certs hosts_but_master = let exn = ref None in @@ -398,9 +434,9 @@ let pool_sync ~__context = let master = Helpers.get_localhost ~__context in let hosts_but_master = List.filter (fun h -> h <> master) hosts in sync_all_hosts ~__context hosts ; - let master_certs = local_list CA_Certificate in + let master_certs = local_list Root_legacy in let master_crls = local_list CRL in - sync_certs_all_hosts CA_Certificate ~__context master_certs hosts_but_master ; + sync_certs_all_hosts Root_legacy ~__context master_certs hosts_but_master ; sync_certs_all_hosts CRL ~__context master_crls hosts_but_master let pool_install kind ~__context ~name ~cert = @@ -453,3 +489,5 @@ let install_server_certificate ~pem_chain ~pem_leaf ~pkcs8_private_key ~path = cert | Error (`Msg (err, msg)) -> raise_server_error msg err + +let name_of_uuid uuid = Printf.sprintf "%s.pem" uuid diff --git a/ocaml/xapi/certificates.mli b/ocaml/xapi/certificates.mli index b8d0e578ac3..cc2df2a729e 100644 --- a/ocaml/xapi/certificates.mli +++ b/ocaml/xapi/certificates.mli @@ -12,7 +12,11 @@ GNU Lesser General Public License for more details. *) -type t_trusted = CA_Certificate | CRL +type t_trusted = + | Root_legacy + | CRL + | Root of API.certificate_purpose list + | Pinned of API.certificate_purpose list (* Information extraction *) @@ -60,6 +64,8 @@ val pool_install : val pool_uninstall : t_trusted -> __context:Context.t -> name:string -> force:bool -> unit +val name_of_uuid : string -> string + (* Database manipulation *) module Db_util : sig @@ -68,10 +74,11 @@ module Db_util : sig -> type': [< `ca of string | `host of API.ref_host - | `host_internal of API.ref_host ] + | `host_internal of API.ref_host + | `pinned ] -> purpose:API.certificate_purpose list -> X509.Certificate.t - -> API.ref_Certificate + -> API.ref_Certificate * string val remove_cert_by_ref : __context:Context.t -> API.ref_Certificate -> unit diff --git a/ocaml/xapi/certificates_sync.ml b/ocaml/xapi/certificates_sync.ml index f237c7961a8..0fda822fcf0 100644 --- a/ocaml/xapi/certificates_sync.ml +++ b/ocaml/xapi/certificates_sync.ml @@ -22,7 +22,7 @@ let uninstall ~__context cert = file system. This creates a new entry in the database. *) let install ~__context ~host:_ ~type' cert = try - let ref = + let ref, _ = Certificates.Db_util.add_cert ~__context ~type' ~purpose:[] cert in info "Adding host certificicate %s to database" (Ref.string_of ref) ; diff --git a/ocaml/xapi/xapi_globs.ml b/ocaml/xapi/xapi_globs.ml index 18aeba14d76..2c244ea0bf7 100644 --- a/ocaml/xapi/xapi_globs.ml +++ b/ocaml/xapi/xapi_globs.ml @@ -799,6 +799,8 @@ let c_rehash = ref "/usr/bin/c_rehash" let trusted_certs_dir = ref "/etc/stunnel/certs" +let trusted_certs_by_purpose_dir = ref "/etc/trusted-certs" + let trusted_pool_certs_dir = ref "/etc/stunnel/certs-pool" let stunnel_bundle_path = ref "/etc/stunnel/xapi-stunnel-ca-bundle.pem" diff --git a/ocaml/xapi/xapi_host.ml b/ocaml/xapi/xapi_host.ml index 44a6c5840db..5b01fd8128b 100644 --- a/ocaml/xapi/xapi_host.ml +++ b/ocaml/xapi/xapi_host.ml @@ -1574,14 +1574,13 @@ let get_uncooperative_domains ~__context ~self:_ = [] 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) + Certificates.(host_install Root_legacy ~name ~cert) 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 ~force) + Certificates.(host_uninstall Root_legacy ~name ~force) -let certificate_list ~__context ~host:_ = - Certificates.(local_list CA_Certificate) +let certificate_list ~__context ~host:_ = Certificates.(local_list Root_legacy) let crl_install ~__context ~host:_ ~name ~crl = Certificates.(host_install CRL ~name ~cert:crl) @@ -1612,7 +1611,7 @@ let replace_host_certificate ~__context ~type' ~host with_cert_lock @@ fun () -> let old_certs = Db_util.get_host_certs ~__context ~type' ~host in let new_cert = write_cert_fs () in - let (_ : API.ref_Certificate) = + let (_ : API.ref_Certificate), _ = match type' with | `host -> Db_util.add_cert ~__context ~type':(`host host) ~purpose:[] new_cert diff --git a/ocaml/xapi/xapi_pool.ml b/ocaml/xapi/xapi_pool.ml index 963e4b5d648..d3884f1bade 100644 --- a/ocaml/xapi/xapi_pool.ml +++ b/ocaml/xapi/xapi_pool.ml @@ -859,7 +859,7 @@ let pre_join_checks ~__context ~rpc ~session_id ~force = *) let conflicting_names = ref [] in let module CertMap = Map.Make (String) in - let expr = {|field "type"="ca"|} in + let expr = {|field "type"="ca" and not (field "name"="")|} in let map_of_list list = list |> List.to_seq @@ -1583,8 +1583,8 @@ let certificate_install ~__context ~name ~cert = | Ok x -> x in - pool_install CA_Certificate ~__context ~name ~cert ; - let (_ : API.ref_Certificate) = + pool_install Root_legacy ~__context ~name ~cert ; + let (_ : API.ref_Certificate), _ = Db_util.add_cert ~__context ~type':(`ca name) ~purpose:[] certificate in () @@ -1593,7 +1593,7 @@ let install_ca_certificate = certificate_install let uninstall_ca_certificate ~__context ~name ~force = let open Certificates in - pool_uninstall CA_Certificate ~__context ~name ~force ; + pool_uninstall Root_legacy ~__context ~name ~force ; Db_util.remove_ca_cert_by_name ~__context name let certificate_uninstall = uninstall_ca_certificate ~force:false @@ -1611,6 +1611,60 @@ let crl_list ~__context = Certificates.(local_list CRL) let certificate_sync = Certificates.pool_sync +let install_trusted_certificate ~__context ~self:_ ~ca ~cert ~purpose = + let open Certificates in + let certificate = + let open Api_errors in + match + Gencertlib.Lib.validate_not_expired cert + ~error_not_yet:trusted_certificate_not_valid_yet + ~error_expired:trusted_certificate_expired + ~error_invalid:trusted_certificate_invalid + with + | Error e -> + raise e + | Ok x -> + x + in + let cert_type, kind = + match (ca, purpose = []) with + | true, _ -> + (`ca "", Root purpose) + | false, false -> + (`pinned, Pinned purpose) + | false, true -> + raise Api_errors.(Server_error (certificate_lacks_purpose, [])) + in + let (_ : API.ref_Certificate), uuid = + Db_util.add_cert ~__context ~type':cert_type ~purpose certificate + in + let name = Certificates.name_of_uuid uuid in + Certificates.host_install kind ~name ~cert ; + Cert_distrib.copy_certs_to_all ~__context ; + () + +let uninstall_trusted_certificate ~__context ~self:_ ~certificate = + let open Certificates in + let cert_rec = Db.Certificate.get_record ~__context ~self:certificate in + let purposes = cert_rec.API.certificate_purpose in + let kind = + match cert_rec.API.certificate_type with + | `ca -> + Root purposes + | `pinned -> + Pinned purposes + | _ -> + raise + Api_errors.( + Server_error (not_trusted_certificate, [Ref.string_of certificate]) + ) + in + let name = Certificates.name_of_uuid cert_rec.API.certificate_uuid in + Db_util.remove_cert_by_ref ~__context certificate ; + Certificates.host_uninstall kind ~name ~force:true ; + Cert_distrib.copy_certs_to_all ~__context ; + () + let join_common ~__context ~master_address ~master_username ~master_password ~force = assert_pooling_licensed ~__context ; @@ -4224,7 +4278,3 @@ let set_ssh_enabled_timeout = Ssh.set_enabled_timeout let set_console_idle_timeout = Ssh.set_console_timeout let set_ssh_auto_mode = Ssh.set_ssh_auto_mode - -let install_trusted_certificate ~__context ~self ~ca ~cert ~purpose = () - -let uninstall_trusted_certificate ~__context ~self ~certificate = () From 4195da29e23ccf846baeaa41a09c4da1c8e4afba Mon Sep 17 00:00:00 2001 From: Ming Lu Date: Fri, 9 Jan 2026 19:29:05 +0800 Subject: [PATCH 06/28] Check if already exists when installing a certificate (cherry-pick from commit 632c50fe6c6ccd1100b51810c9493f8651174481) Signed-off-by: Ming Lu --- ocaml/idl/datamodel_errors.ml | 2 ++ ocaml/xapi-consts/api_errors.ml | 3 +++ ocaml/xapi/certificates.ml | 27 +++++++++++++++++++++++++++ 3 files changed, 32 insertions(+) diff --git a/ocaml/idl/datamodel_errors.ml b/ocaml/idl/datamodel_errors.ml index 62a4cb4d061..5b7c9f811f4 100644 --- a/ocaml/idl/datamodel_errors.ml +++ b/ocaml/idl/datamodel_errors.ml @@ -1664,6 +1664,8 @@ let _ = ~doc:"The specified certificate does not exist." () ; error Api_errors.certificate_already_exists ["name"] ~doc:"A certificate already exists with the specified name." () ; + error Api_errors.trusted_certificate_already_exists ["fingerprint"] + ~doc:"A trusted certificate already exists with the same purpose." () ; error Api_errors.certificate_name_invalid ["name"] ~doc:"The specified certificate name is invalid." () ; error Api_errors.certificate_corrupt ["name"] diff --git a/ocaml/xapi-consts/api_errors.ml b/ocaml/xapi-consts/api_errors.ml index d97dcfbab5a..8933eb32fdf 100644 --- a/ocaml/xapi-consts/api_errors.ml +++ b/ocaml/xapi-consts/api_errors.ml @@ -1118,6 +1118,9 @@ let certificate_does_not_exist = add_error "CERTIFICATE_DOES_NOT_EXIST" let certificate_already_exists = add_error "CERTIFICATE_ALREADY_EXISTS" +let trusted_certificate_already_exists = + add_error "TRUSTED_CERTIFICATE_ALREADY_EXISTS" + let certificate_name_invalid = add_error "CERTIFICATE_NAME_INVALID" let certificate_corrupt = add_error "CERTIFICATE_CORRUPT" diff --git a/ocaml/xapi/certificates.ml b/ocaml/xapi/certificates.ml index 2e62f6e28c1..506988b1e02 100644 --- a/ocaml/xapi/certificates.ml +++ b/ocaml/xapi/certificates.ml @@ -235,6 +235,12 @@ end = struct debug "deleting cert ref=%s from the database" (Ref.string_of self) ; Db.Certificate.destroy ~__context ~self + module PurposeSet = Set.Make (struct + type t = API.certificate_purpose + + let compare = Stdlib.compare + end) + let add_cert ~__context ~type' ~purpose certificate = let name, host, _type, post_action = match type' with @@ -260,6 +266,27 @@ end = struct in let fingerprint_sha256 = pp_fingerprint ~hash_type:`SHA256 certificate in let fingerprint_sha1 = pp_fingerprint ~hash_type:`SHA1 certificate in + let expr = + let open Xapi_database.Db_filter_types in + let type' = Record_util.certificate_type_to_string _type in + let type' = Eq (Field "type", Literal type') in + let fingerprint_sha256 = + Eq (Field "fingerprint_sha256", Literal fingerprint_sha256) + in + And (type', fingerprint_sha256) + in + Db.Certificate.get_records_where ~__context ~expr + |> List.filter (fun (_, cert_rec) -> cert_rec.API.certificate_name = "") + |> List.filter (fun (_, cert_rec) -> + let open PurposeSet in + let s1 = of_list purpose in + let s2 = of_list cert_rec.API.certificate_purpose in + equal s1 s2 || not (is_empty (inter s1 s2)) + ) + |> List.iter (fun _ -> + raise_server_error [fingerprint_sha256] + trusted_certificate_already_exists + ) ; let uuid = Uuidx.(to_string (make ())) in let ref' = Ref.make () in Db.Certificate.create ~__context ~ref:ref' ~uuid ~host ~not_before From 982d9d214f3fb4fdbdecc3bf8d36e87d946375c4 Mon Sep 17 00:00:00 2001 From: Ming Lu Date: Tue, 6 Jan 2026 19:09:20 +0800 Subject: [PATCH 07/28] Update host_install (cherry-pick from commit 09a0eb1f6d399490c81bc2b6d8991b2e861b3683) Signed-off-by: Ming Lu --- ocaml/xapi/certificates.ml | 113 +++++++++++++++++++++++++++++------- ocaml/xapi/certificates.mli | 4 ++ 2 files changed, 97 insertions(+), 20 deletions(-) diff --git a/ocaml/xapi/certificates.ml b/ocaml/xapi/certificates.ml index 506988b1e02..ea4bb4de65f 100644 --- a/ocaml/xapi/certificates.ml +++ b/ocaml/xapi/certificates.ml @@ -35,6 +35,16 @@ type t_trusted = | Root of API.certificate_purpose list | Pinned of API.certificate_purpose list +let all_purposes = [] :: List.map (fun x -> [x]) API.certificate_purpose__all + +let all_trusted_kinds = + List.concat + [ + List.map (fun p -> Root p) all_purposes + ; List.map (fun p -> Pinned p) all_purposes + ; [Root_legacy; CRL] + ] + let pem_of_string x = match X509.Certificate.decode_pem x with | Error _ -> @@ -56,9 +66,68 @@ let ( // ) = Filename.concat let library_filename kind name = library_path kind // name -let mkdir_cert_path kind = Unixext.mkdir_rec (library_path kind) 0o700 +let ps = Printf.sprintf + +let of_purposes = function + | [] -> + ["general"] + | purposes -> + List.map (fun p -> Record_util.certificate_purpose_to_string p) purposes -let rehash' path = +type trusted_store = {cert_dir: string; bundle: (string * string) option} + +let trusted_store_locations kind = + let parent = library_path kind in + match kind with + | CRL -> + [{cert_dir= parent; bundle= None}] + | Root_legacy -> + [ + { + cert_dir= parent + ; bundle= + Some + ( Filename.dirname !Xapi_globs.stunnel_bundle_path + , Filename.basename !Xapi_globs.stunnel_bundle_path + ) + } + ] + | Root purposes -> + List.map + (fun p -> + { + cert_dir= parent // ps "ca-%s" p + ; bundle= Some (parent, ps "ca-bundle-%s.pem" p) + } + ) + (of_purposes purposes) + | Pinned purposes -> + List.map + (fun p -> + { + cert_dir= parent // ps "pinned-%s" p + ; bundle= Some (parent, ps "pinned-bundle-%s.pem" p) + } + ) + (of_purposes purposes) + +let with_cert_store kind f = + trusted_store_locations kind + |> List.iter (fun store -> f ~cert_dir:store.cert_dir ~bundle:store.bundle) + +let with_cert_paths kind name f = + with_cert_store kind @@ fun ~cert_dir ~bundle -> + f cert_dir (cert_dir // name) bundle + +let mkdir_cert_path kind = + trusted_store_locations kind + |> List.iter (fun store -> + Unixext.mkdir_rec store.cert_dir 0o700 ; + Option.iter (fun (dir, _) -> Unixext.mkdir_rec dir 0o700) store.bundle ; + () + ) + +let rehash path = match Sys.file_exists !Xapi_globs.c_rehash with | true -> Forkhelpers.execute_command_get_output !Xapi_globs.c_rehash [path] @@ -69,12 +138,6 @@ let rehash' path = ["rehash"; path] |> ignore -let rehash () = - mkdir_cert_path Root_legacy ; - mkdir_cert_path CRL ; - rehash' (library_path Root_legacy) ; - rehash' (library_path CRL) - let update_ca_bundle () = Helpers.update_ca_bundle () let to_string = function @@ -342,23 +405,33 @@ let local_sync () = warn "Exception rehashing certificates: %s" (ExnHelper.string_of_exn e) ; raise_library_corrupt () -let cert_perms kind = - let stat = Unix.stat (library_path kind) in - let mask = 0o666 in - let perm = stat.Unix.st_perm land mask in - debug "%d %d" perm stat.Unix.st_perm ; - perm +let update_bundle kind cert_dir bundle_path = + match kind with + | Root_legacy | CRL -> + update_ca_bundle () + | Root _ | Pinned _ -> + () (* TODO: implementation in the following commit *) let host_install kind ~name ~cert = validate_name kind name ; - let filename = library_filename kind name in - if Sys.file_exists filename then raise_already_exists kind name ; - debug "Installing %s %s" (to_string kind) name ; + with_cert_paths kind name @@ fun cert_dir cert_path bundle -> + if Sys.file_exists cert_path then raise_already_exists kind name ; + debug "%s: Installing %s (name='%s') under %s" __FUNCTION__ (to_string kind) + name cert_path ; try mkdir_cert_path kind ; - Unixext.write_string_to_file filename cert ; - Unix.chmod filename (cert_perms kind) ; - update_ca_bundle () + Unixext.write_string_to_file cert_path cert ; + Unix.chmod cert_path 0o644 ; + Option.iter + (fun (bundle_dir, bundle_name) -> + debug "%s: Updating bundle %s for %s (name='%s')" __FUNCTION__ + (bundle_dir // bundle_name) + (to_string kind) name ; + update_bundle cert_dir (bundle_dir // bundle_name) ; + Unix.chmod (bundle_dir // bundle_name) 0o644 + ) + bundle ; + rehash cert_dir with e -> warn "Exception installing %s %s: %s" (to_string kind) name (ExnHelper.string_of_exn e) ; diff --git a/ocaml/xapi/certificates.mli b/ocaml/xapi/certificates.mli index cc2df2a729e..e2c3c5f1319 100644 --- a/ocaml/xapi/certificates.mli +++ b/ocaml/xapi/certificates.mli @@ -66,6 +66,10 @@ val pool_uninstall : val name_of_uuid : string -> string +val all_purposes : API.certificate_purpose list list + +type trusted_store = {cert_dir: string; bundle: (string * string) option} + (* Database manipulation *) module Db_util : sig From adb85d10d53c2ed0bbd72447e2b22465259d490f Mon Sep 17 00:00:00 2001 From: Ming Lu Date: Wed, 7 Jan 2026 14:06:25 +0800 Subject: [PATCH 08/28] Update host_uninstall (cherry-pick from commit 6c7b9944811e1d079720b7a387720fd2a4f1171b) Signed-off-by: Ming Lu --- ocaml/xapi/certificates.ml | 12 ++++++++---- 1 file changed, 8 insertions(+), 4 deletions(-) diff --git a/ocaml/xapi/certificates.ml b/ocaml/xapi/certificates.ml index ea4bb4de65f..9615262b419 100644 --- a/ocaml/xapi/certificates.ml +++ b/ocaml/xapi/certificates.ml @@ -439,10 +439,14 @@ let host_install kind ~name ~cert = let host_uninstall kind ~name ~force = validate_name kind name ; - let filename = library_filename kind name in - if Sys.file_exists filename then ( - debug "Uninstalling %s %s" (to_string kind) name ; - try Sys.remove filename ; update_ca_bundle () + with_cert_store kind @@ fun ~cert_dir ~bundle -> + let cert_path = cert_dir // name in + debug "Uninstalling %s %s" (to_string kind) cert_path ; + if Sys.file_exists cert_path then ( + try + Sys.remove cert_path ; + rehash cert_dir ; + () (* TODO: implementation in the following commit *) with e -> warn "Exception uninstalling %s %s: %s" (to_string kind) name (ExnHelper.string_of_exn e) ; From db9cc543aad919affddbf231f542a8e5f69fe48e Mon Sep 17 00:00:00 2001 From: Ming Lu Date: Tue, 20 Jan 2026 14:15:55 +0800 Subject: [PATCH 09/28] Make CertificateProvider.store_path support multiple paths (cherry-pick from commit 6341455bb362b9dce30801cec5019233233aa816) Signed-off-by: Ming Lu --- ocaml/xapi/cert_distrib.ml | 67 ++++++++++++++++++++++++-------------- 1 file changed, 42 insertions(+), 25 deletions(-) diff --git a/ocaml/xapi/cert_distrib.ml b/ocaml/xapi/cert_distrib.ml index fb580b84c24..84526156211 100644 --- a/ocaml/xapi/cert_distrib.ml +++ b/ocaml/xapi/cert_distrib.ml @@ -103,8 +103,17 @@ let raise_internal ?e ?(details = "") msg : 'a = [msg; details; e] |> String.concat ". " |> D.error "%s" ; Helpers.internal_error "%s" msg +let ( let@ ) l f = + match l with + | x :: _ -> + f x + | [] -> + raise_internal "Impossible: must not be empty" + +let ( let* ) l f = List.iter f l + module type CertificateProvider = sig - val store_path : string + val store_paths : string list val read_certificate : string -> WireProtocol.certificate_file end @@ -112,7 +121,7 @@ end module HostPoolProvider = struct let certificate_path = !Xapi_globs.server_cert_internal_path - let store_path = !Xapi_globs.trusted_pool_certs_dir + let store_paths = [!Xapi_globs.trusted_pool_certs_dir] let cert_fname_of_host_uuid uuid = uuid ^ ".pem" @@ -133,12 +142,13 @@ end let string_of_file path = Unixext.read_lines ~path |> String.concat "\n" module ApplianceProvider = struct - let store_path = !Xapi_globs.trusted_certs_dir + let store_paths = [!Xapi_globs.trusted_certs_dir] let certificate_of_id_content filename content = WireProtocol.{filename; content} let read_certificate filename = + let@ store_path = store_paths in let content = string_of_file (Filename.concat store_path filename) in certificate_of_id_content filename content end @@ -198,7 +208,7 @@ end = struct let write_certs_fs typ strategy certs = let open Helpers.FileSys in let module P = (val provider_of_certificate typ : CertificateProvider) in - let pool_certs = P.store_path in + let* pool_certs = P.store_paths in let pool_certs_bk = Printf.sprintf "%s.bk" pool_certs in let mv_or_cp = match strategy with Erase_old -> mv | Merge -> cpr in ( try @@ -213,7 +223,7 @@ end = struct Unixext.mkdir_rec pool_certs 0o700 ; certs |> List.iter (function {filename; content} -> - let fname = Filename.concat P.store_path filename in + let fname = Filename.concat pool_certs filename in redirect content ~fname ) with e -> @@ -442,24 +452,28 @@ let exchange_certificates_in_pool ~__context = in operations |> maybe_insert_fist |> List.iter @@ fun (_, f) -> f () -let ( (get_local_ca_certs : unit -> WireProtocol.certificate_file list) - , (get_local_pool_certs : unit -> WireProtocol.certificate_file list) ) = - let g path () = - (* collects all certs in [path] ending in "pem". this is equivalent to the - * certs that would be put in a bundle, if update-ca-bundle.sh were to be - * executed on [path] *) - Sys.readdir path - |> Array.to_list - |> List.filter (fun x -> - Filename.check_suffix x "pem" && not (Filename.check_suffix x "new.pem") - ) - |> List.map (fun filename -> - let path = Filename.concat path filename in - let content = string_of_file path in - WireProtocol.{filename; content} - ) - in - (g ApplianceProvider.store_path, g HostPoolProvider.store_path) +let list_certs path = + (* collects all certs in [path] ending in "pem". this is equivalent to the + * certs that would be put in a bundle, if update-ca-bundle.sh were to be + * executed on [path] *) + Sys.readdir path + |> Array.to_list + |> List.filter (fun x -> + Filename.check_suffix x "pem" && not (Filename.check_suffix x "new.pem") + ) + |> List.map (fun filename -> + let path = Filename.concat path filename in + let content = string_of_file path in + WireProtocol.{filename; content} + ) + +let get_local_ca_certs () : WireProtocol.certificate_file list = + let@ store_path = ApplianceProvider.store_paths in + list_certs store_path + +let get_local_pool_certs () : WireProtocol.certificate_file list = + let@ store_path = HostPoolProvider.store_paths in + list_certs store_path let am_i_missing_certs ~__context : bool = (* compare what's in the database with what's on my filesystem *) @@ -476,16 +490,19 @@ let am_i_missing_certs ~__context : bool = (diff |> StringSet.elements |> String.concat "; ") ; not in_sync_with_remote in + let ( let*? ) l f = List.exists f l in let pool_certs_are_missing () = + let*? store_path = HostPoolProvider.store_paths in local_is_missing_certificates (fun ~__context -> Db.Host.get_all ~__context |> List.map (fun self -> Db.Host.get_uuid ~__context ~self) |> List.map HostPoolProvider.cert_fname_of_host_uuid ) - HostPoolProvider.store_path () + store_path () in let ca_certs_are_missing () = + let*? store_path = ApplianceProvider.store_paths in local_is_missing_certificates (fun ~__context -> Db.Certificate.get_all ~__context @@ -497,7 +514,7 @@ let am_i_missing_certs ~__context : bool = None ) ) - ApplianceProvider.store_path () + store_path () in pool_certs_are_missing () || ca_certs_are_missing () From 8af92c9b2e4545ee128c82c21966dff185a40667 Mon Sep 17 00:00:00 2001 From: Ming Lu Date: Tue, 20 Jan 2026 14:34:30 +0800 Subject: [PATCH 10/28] Add new constructors of certificate type for trusted certs (cherry-pick from commit 71b8c00418a23d0567f2996d28ed2a411fe81a2d) Signed-off-by: Ming Lu --- ocaml/xapi/cert_distrib.ml | 80 ++++++++++++++++++++++++------------- ocaml/xapi/certificates.mli | 2 + 2 files changed, 55 insertions(+), 27 deletions(-) diff --git a/ocaml/xapi/cert_distrib.ml b/ocaml/xapi/cert_distrib.ml index 84526156211..bad86d0c97d 100644 --- a/ocaml/xapi/cert_distrib.ml +++ b/ocaml/xapi/cert_distrib.ml @@ -33,7 +33,13 @@ module WireProtocol = struct resolving conflicts by taking the incoming cert *) type conflict_resolution = Erase_old | Merge [@@deriving sexp] - type certificate = HostPoolCertificate | ApplianceCertificate + type purpose = string [@@deriving sexp] + + type certificate = + | HostPoolCert + | LegacyRootCert + | RootCert of purpose list + | PinnedCert of purpose list [@@deriving sexp] type certificate_file = {filename: string; content: string} [@@deriving sexp] @@ -141,25 +147,49 @@ end let string_of_file path = Unixext.read_lines ~path |> String.concat "\n" -module ApplianceProvider = struct - let store_paths = [!Xapi_globs.trusted_certs_dir] +module type TrustedStore = sig val store_paths : string list end +module TrustedCertProvider (Store : TrustedStore) : CertificateProvider = struct let certificate_of_id_content filename content = WireProtocol.{filename; content} + let store_paths = Store.store_paths + let read_certificate filename = let@ store_path = store_paths in let content = string_of_file (Filename.concat store_path filename) in certificate_of_id_content filename content end +module LegacyRootProvider = TrustedCertProvider (struct + let store_paths = [!Xapi_globs.trusted_certs_dir] +end) + +let to_purposes = List.map Record_util.certificate_purpose_of_string + let provider_of_certificate (typ : WireProtocol.certificate) : (module CertificateProvider) = match typ with - | HostPoolCertificate -> + | HostPoolCert -> (module HostPoolProvider : CertificateProvider) - | ApplianceCertificate -> - (module ApplianceProvider : CertificateProvider) + | LegacyRootCert -> + (module LegacyRootProvider : CertificateProvider) + | RootCert purposes -> + let store_paths = + Certificates.trusted_store_locations (Root (to_purposes purposes)) + |> List.map (fun store -> store.Certificates.cert_dir) + in + (module TrustedCertProvider (struct let store_paths = store_paths end) + : CertificateProvider + ) + | PinnedCert purposes -> + let store_paths = + Certificates.trusted_store_locations (Pinned (to_purposes purposes)) + |> List.map (fun store -> store.Certificates.cert_dir) + in + (module TrustedCertProvider (struct let store_paths = store_paths end) + : CertificateProvider + ) (* eventually the remote calls should probably become API calls in the datamodel but they remain here for quick development *) @@ -365,7 +395,7 @@ let collect_pool_certs ~__context ~rpc ~session_id ~map ~from_hosts = |> List.map (fun host -> let uuid = Db.Host.get_uuid ~__context ~self:host in let cert = - Worker.remote_collect_cert HostPoolCertificate uuid host rpc session_id + Worker.remote_collect_cert HostPoolCert uuid host rpc session_id in map cert ) @@ -435,8 +465,8 @@ let exchange_certificates_in_pool ~__context = (fun host -> ( Printf.sprintf "send certs to %s" (Ref.short_string_of host) , fun () -> - Worker.remote_write_certs_fs HostPoolCertificate Erase_old certs - host rpc session_id + Worker.remote_write_certs_fs HostPoolCert Erase_old certs host + rpc session_id ) ) all_hosts @@ -468,7 +498,7 @@ let list_certs path = ) let get_local_ca_certs () : WireProtocol.certificate_file list = - let@ store_path = ApplianceProvider.store_paths in + let@ store_path = LegacyRootProvider.store_paths in list_certs store_path let get_local_pool_certs () : WireProtocol.certificate_file list = @@ -502,7 +532,7 @@ let am_i_missing_certs ~__context : bool = store_path () in let ca_certs_are_missing () = - let*? store_path = ApplianceProvider.store_paths in + let*? store_path = LegacyRootProvider.store_paths in local_is_missing_certificates (fun ~__context -> Db.Certificate.get_all ~__context @@ -527,10 +557,10 @@ let copy_certs_to_host ~__context ~host = it's missing them... this is bad, but continuing anyway" (Ref.short_string_of host) ; Helpers.call_api_functions ~__context @@ fun rpc session_id -> - Worker.remote_write_certs_fs HostPoolCertificate Erase_old - (get_local_pool_certs ()) host rpc session_id ; - Worker.remote_write_certs_fs ApplianceCertificate Erase_old - (get_local_ca_certs ()) host rpc session_id ; + Worker.remote_write_certs_fs HostPoolCert Erase_old (get_local_pool_certs ()) + host rpc session_id ; + Worker.remote_write_certs_fs LegacyRootCert Erase_old (get_local_ca_certs ()) + host rpc session_id ; Worker.remote_regen_bundle host rpc session_id (* This function is called on the pool that is incorporating a new host *) @@ -538,8 +568,7 @@ let exchange_certificates_with_joiner ~__context ~uuid ~certificate = let joiner_certificate = HostPoolProvider.certificate_of_id_content uuid certificate in - Worker.local_write_cert_fs ~__context HostPoolCertificate Merge - [joiner_certificate] ; + Worker.local_write_cert_fs ~__context HostPoolCert Merge [joiner_certificate] ; Worker.local_regen_bundle ~__context ; let () = (* now that the primary host trusts the joiner, perform best effort @@ -550,8 +579,8 @@ let exchange_certificates_with_joiner ~__context ~uuid ~certificate = secondary_hosts |> List.iter (fun host -> try - Worker.remote_write_certs_fs HostPoolCertificate Merge - [joiner_certificate] host rpc session_id + Worker.remote_write_certs_fs HostPoolCert Merge [joiner_certificate] + host rpc session_id with e -> D.warn "exchange_certificates_with_joiner: sending joiner cert to %s \ @@ -574,11 +603,11 @@ let exchange_certificates_with_joiner ~__context ~uuid ~certificate = (* This function is called on the host that is joining a pool *) let import_joining_pool_certs ~__context ~pool_certs = let pool_certs = List.map WireProtocol.certificate_file_of_pair pool_certs in - Worker.local_write_cert_fs ~__context HostPoolCertificate Merge pool_certs ; + Worker.local_write_cert_fs ~__context HostPoolCert Merge pool_certs ; Worker.local_regen_bundle ~__context let collect_ca_certs ~__context ~names = - Worker.local_collect_certs ApplianceCertificate ~__context names + Worker.local_collect_certs LegacyRootCert ~__context names |> List.map WireProtocol.pair_of_certificate_file (* This function is called on the pool that is incorporating a new host *) @@ -595,8 +624,7 @@ let exchange_ca_certificates_with_joiner ~__context ~import ~export = ) appliance_certs in - Worker.local_write_cert_fs ~__context ApplianceCertificate Merge - appliance_certs ; + Worker.local_write_cert_fs ~__context LegacyRootCert Merge appliance_certs ; Worker.local_regen_bundle ~__context ; List.iter (fun (name, cert) -> @@ -613,8 +641,7 @@ let import_joining_pool_ca_certificates ~__context ~ca_certs = let appliance_certs = List.map WireProtocol.certificate_file_of_pair ca_certs in - Worker.local_write_cert_fs ~__context ApplianceCertificate Merge - appliance_certs ; + Worker.local_write_cert_fs ~__context LegacyRootCert Merge appliance_certs ; Worker.local_regen_bundle ~__context let distribute_new_host_cert ~__context ~host ~content = @@ -624,8 +651,7 @@ let distribute_new_host_cert ~__context ~host ~content = 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 + Worker.remote_write_certs_fs HostPoolCert 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 ; diff --git a/ocaml/xapi/certificates.mli b/ocaml/xapi/certificates.mli index e2c3c5f1319..803c2ae8e89 100644 --- a/ocaml/xapi/certificates.mli +++ b/ocaml/xapi/certificates.mli @@ -70,6 +70,8 @@ val all_purposes : API.certificate_purpose list list type trusted_store = {cert_dir: string; bundle: (string * string) option} +val trusted_store_locations : t_trusted -> trusted_store list + (* Database manipulation *) module Db_util : sig From 5d005728b6b12feae7104093fe421d0c506d7110 Mon Sep 17 00:00:00 2001 From: Ming Lu Date: Wed, 7 Jan 2026 11:13:57 +0800 Subject: [PATCH 11/28] Update copy_certs_to_host to include trusted certs (cherry-pick from commit 2e8a306510bfd761d5ceb7f7ba98981d400edf26) Signed-off-by: Ming Lu --- ocaml/xapi/cert_distrib.ml | 84 ++++++++++++++++++++++++++++++++++--- ocaml/xapi/certificates.ml | 21 ++++++++++ ocaml/xapi/certificates.mli | 11 +++++ 3 files changed, 111 insertions(+), 5 deletions(-) diff --git a/ocaml/xapi/cert_distrib.ml b/ocaml/xapi/cert_distrib.ml index bad86d0c97d..acb11600d35 100644 --- a/ocaml/xapi/cert_distrib.ml +++ b/ocaml/xapi/cert_distrib.ml @@ -58,6 +58,14 @@ module WireProtocol = struct | GenBundleResult [@@deriving sexp] + let type_of_category category purposes = + let purposes = List.map API.certificate_purpose_to_string purposes in + match category with + | `Root -> + RootCert purposes + | `Pinned -> + PinnedCert purposes + let string_of_conflict_resolution x = x |> sexp_of_conflict_resolution |> Sexp.to_string @@ -482,15 +490,19 @@ let exchange_certificates_in_pool ~__context = in operations |> maybe_insert_fist |> List.iter @@ fun (_, f) -> f () -let list_certs path = - (* collects all certs in [path] ending in "pem". this is equivalent to the - * certs that would be put in a bundle, if update-ca-bundle.sh were to be - * executed on [path] *) +let list_cert_names path = + Unixext.mkdir_rec path 0o700 ; Sys.readdir path |> Array.to_list |> List.filter (fun x -> Filename.check_suffix x "pem" && not (Filename.check_suffix x "new.pem") ) + +let list_certs path = + (* collects all certs in [path] ending in "pem". this is equivalent to the + * certs that would be put in a bundle, if update-ca-bundle.sh were to be + * executed on [path] *) + list_cert_names path |> List.map (fun filename -> let path = Filename.concat path filename in let content = string_of_file path in @@ -505,6 +517,65 @@ let get_local_pool_certs () : WireProtocol.certificate_file list = let@ store_path = HostPoolProvider.store_paths in list_certs store_path +let list_all_trusted_cert_names category = + let open Certificates in + all_purposes + |> List.concat_map (fun purposes -> + let typ = WireProtocol.type_of_category category purposes in + let module P = (val provider_of_certificate typ : CertificateProvider) in + P.store_paths + |> List.map (fun cert_dir -> (cert_dir, list_cert_names cert_dir)) + ) + +let of_db_rec category db_rec = + let fname = Certificates.name_of_uuid db_rec.API.certificate_uuid in + let typ = + db_rec.API.certificate_purpose |> WireProtocol.type_of_category category + in + let module P = (val provider_of_certificate typ : CertificateProvider) in + (fname, typ, (module P : CertificateProvider)) + +let trusted_certs_are_missing ~__context = + let open Certificates in + [`Root; `Pinned] + |> List.concat_map (fun category -> + let db_type = db_type_of_category category in + let local = list_all_trusted_cert_names category in + Db_util.get_trusted_certs ~__context db_type + |> List.concat_map (fun (_, db_rec) -> + let fname = Certificates.name_of_uuid db_rec.API.certificate_uuid in + let typ = + db_rec.API.certificate_purpose + |> WireProtocol.type_of_category category + in + let module P = (val provider_of_certificate typ : CertificateProvider) + in + P.store_paths + |> List.map (fun cert_dir -> + match List.assoc_opt cert_dir local with + | None -> + true + | Some names -> + not (List.mem fname names) + ) + ) + ) + |> List.exists Fun.id + +let copy_trusted_certs_to_host ~__context host rpc session_id = + let open Certificates in + let* purposes = all_purposes in + let* category = [`Root; `Pinned] in + let typ = WireProtocol.type_of_category category purposes in + let module P = (val provider_of_certificate typ : CertificateProvider) in + P.store_paths + |> List.iter (fun cert_dir -> + let certs = + list_cert_names cert_dir |> Worker.local_collect_certs typ ~__context + in + Worker.remote_write_certs_fs typ Erase_old certs host rpc session_id + ) + let am_i_missing_certs ~__context : bool = (* compare what's in the database with what's on my filesystem *) let local_is_missing_certificates remote_list_getter trust_root_dir () = @@ -546,7 +617,9 @@ let am_i_missing_certs ~__context : bool = ) store_path () in - pool_certs_are_missing () || ca_certs_are_missing () + pool_certs_are_missing () + || ca_certs_are_missing () + || trusted_certs_are_missing ~__context let copy_certs_to_host ~__context ~host = D.debug "%s: sending my certs to host %s" __FUNCTION__ @@ -561,6 +634,7 @@ let copy_certs_to_host ~__context ~host = host rpc session_id ; Worker.remote_write_certs_fs LegacyRootCert Erase_old (get_local_ca_certs ()) host rpc session_id ; + copy_trusted_certs_to_host ~__context host rpc session_id ; Worker.remote_regen_bundle host rpc session_id (* This function is called on the pool that is incorporating a new host *) diff --git a/ocaml/xapi/certificates.ml b/ocaml/xapi/certificates.ml index 9615262b419..efdba6fc8ba 100644 --- a/ocaml/xapi/certificates.ml +++ b/ocaml/xapi/certificates.ml @@ -35,6 +35,8 @@ type t_trusted = | Root of API.certificate_purpose list | Pinned of API.certificate_purpose list +type category = [`Root_legacy | `CRL | `Root | `Pinned] + let all_purposes = [] :: List.map (fun x -> [x]) API.certificate_purpose__all let all_trusted_kinds = @@ -271,6 +273,11 @@ 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 get_trusted_certs : + __context:Context.t + -> [`ca | `pinned] + -> (API.ref_Certificate * API.certificate_t) list end = struct module Date = Clock.Date @@ -388,6 +395,17 @@ end = struct And (type', name) in Db.Certificate.get_refs_where ~__context ~expr + + let get_trusted_certs ~__context cert_type = + let cert_type = Record_util.certificate_type_to_string cert_type in + let expr = + let open Xapi_database.Db_filter_types in + let type' = Eq (Field "type", Literal cert_type) in + (* Unlike Root_legacy, the Root and Pinned certificates are of empty names always *) + let name' = Eq (Field "name", Literal "") in + And (type', name') + in + Db.Certificate.get_records_where ~__context ~expr end let local_list kind = @@ -595,3 +613,6 @@ let install_server_certificate ~pem_chain ~pem_leaf ~pkcs8_private_key ~path = raise_server_error msg err let name_of_uuid uuid = Printf.sprintf "%s.pem" uuid + +let db_type_of_category category = + match category with `Root -> `ca | `Pinned -> `pinned diff --git a/ocaml/xapi/certificates.mli b/ocaml/xapi/certificates.mli index 803c2ae8e89..ac7b06790eb 100644 --- a/ocaml/xapi/certificates.mli +++ b/ocaml/xapi/certificates.mli @@ -18,6 +18,8 @@ type t_trusted = | Root of API.certificate_purpose list | Pinned of API.certificate_purpose list +type category = [`Root_legacy | `CRL | `Root | `Pinned] + (* Information extraction *) val pem_of_string : string -> X509.Certificate.t @@ -72,6 +74,10 @@ type trusted_store = {cert_dir: string; bundle: (string * string) option} val trusted_store_locations : t_trusted -> trusted_store list +val sync_all_hosts : __context:Context.t -> API.ref_host list -> unit + +val db_type_of_category : [`Root | `Pinned] -> [`ca | `pinned] + (* Database manipulation *) module Db_util : sig @@ -97,4 +103,9 @@ module Db_util : sig -> API.ref_Certificate list val get_ca_certs : __context:Context.t -> API.ref_Certificate list + + val get_trusted_certs : + __context:Context.t + -> [`ca | `pinned] + -> (API.ref_Certificate * API.certificate_t) list end From d40c350e8e5f3cec51191c848b367d70d2fa57a2 Mon Sep 17 00:00:00 2001 From: Ming Lu Date: Wed, 21 Jan 2026 08:44:59 +0000 Subject: [PATCH 12/28] Use Cert_distrib instead of sync* in Certificates (cherry-pick from commit 74a0a450cb874b4ad603dcc48ce7cfd77962c1cf) Signed-off-by: Ming Lu --- ocaml/xapi/cert_distrib.ml | 38 +++++++++++++--- ocaml/xapi/cert_distrib.mli | 4 ++ ocaml/xapi/certificates.ml | 89 ------------------------------------- ocaml/xapi/certificates.mli | 8 ---- ocaml/xapi/xapi_pool.ml | 21 ++++++--- 5 files changed, 52 insertions(+), 108 deletions(-) diff --git a/ocaml/xapi/cert_distrib.ml b/ocaml/xapi/cert_distrib.ml index acb11600d35..af5bfed3c2e 100644 --- a/ocaml/xapi/cert_distrib.ml +++ b/ocaml/xapi/cert_distrib.ml @@ -38,6 +38,7 @@ module WireProtocol = struct type certificate = | HostPoolCert | LegacyRootCert + | CRL | RootCert of purpose list | PinnedCert of purpose list [@@deriving sexp] @@ -173,6 +174,10 @@ module LegacyRootProvider = TrustedCertProvider (struct let store_paths = [!Xapi_globs.trusted_certs_dir] end) +module CRLProvider = TrustedCertProvider (struct + let store_paths = [Stunnel.crl_path] +end) + let to_purposes = List.map Record_util.certificate_purpose_of_string let provider_of_certificate (typ : WireProtocol.certificate) : @@ -182,6 +187,8 @@ let provider_of_certificate (typ : WireProtocol.certificate) : (module HostPoolProvider : CertificateProvider) | LegacyRootCert -> (module LegacyRootProvider : CertificateProvider) + | CRL -> + (module CRLProvider : CertificateProvider) | RootCert purposes -> let store_paths = Certificates.trusted_store_locations (Root (to_purposes purposes)) @@ -517,6 +524,10 @@ let get_local_pool_certs () : WireProtocol.certificate_file list = let@ store_path = HostPoolProvider.store_paths in list_certs store_path +let get_local_crls () : WireProtocol.certificate_file list = + let@ store_path = CRLProvider.store_paths in + list_certs store_path + let list_all_trusted_cert_names category = let open Certificates in all_purposes @@ -543,12 +554,8 @@ let trusted_certs_are_missing ~__context = let local = list_all_trusted_cert_names category in Db_util.get_trusted_certs ~__context db_type |> List.concat_map (fun (_, db_rec) -> - let fname = Certificates.name_of_uuid db_rec.API.certificate_uuid in - let typ = - db_rec.API.certificate_purpose - |> WireProtocol.type_of_category category - in - let module P = (val provider_of_certificate typ : CertificateProvider) + let fname, _typ, (module P : CertificateProvider) = + of_db_rec category db_rec in P.store_paths |> List.map (fun cert_dir -> @@ -634,9 +641,28 @@ let copy_certs_to_host ~__context ~host = host rpc session_id ; Worker.remote_write_certs_fs LegacyRootCert Erase_old (get_local_ca_certs ()) host rpc session_id ; + Worker.remote_write_certs_fs CRL Erase_old (get_local_crls ()) host rpc + session_id ; copy_trusted_certs_to_host ~__context host rpc session_id ; Worker.remote_regen_bundle host rpc session_id +let copy_certs_to_all ~__context = + let hosts = Db.Host.get_all ~__context in + let master = Helpers.get_localhost ~__context in + let hosts_but_master = List.filter (fun h -> h <> master) hosts in + hosts_but_master + |> List.map (fun host -> + try + copy_certs_to_host ~__context ~host ; + Certificates.sync_all_hosts ~__context [host] ; + Ok () + with e -> + let uuid = Db.Host.get_uuid ~__context ~self:host in + D.error "Failed to copy certs to host %s: %s" uuid (Printexc.to_string e) ; + Error e + ) + |> List.iter (fun r -> match r with Error e -> raise e | Ok () -> ()) + (* This function is called on the pool that is incorporating a new host *) let exchange_certificates_with_joiner ~__context ~uuid ~certificate = let joiner_certificate = diff --git a/ocaml/xapi/cert_distrib.mli b/ocaml/xapi/cert_distrib.mli index 55f98745b10..21513c724c5 100644 --- a/ocaml/xapi/cert_distrib.mli +++ b/ocaml/xapi/cert_distrib.mli @@ -26,6 +26,10 @@ val copy_certs_to_host : __context:Context.t -> host:API.ref_host -> unit (** [copy_certs_to_host ~__context ~host] collects all local certificates and installs them on [host] *) +val copy_certs_to_all : __context:Context.t -> unit +(** [copy_certs_to_all ~__context] collects all local certificates and + installs them on hosts except the coordinator. *) + val exchange_certificates_with_joiner : __context:Context.t -> uuid:string diff --git a/ocaml/xapi/certificates.ml b/ocaml/xapi/certificates.ml index efdba6fc8ba..b0e25cd3071 100644 --- a/ocaml/xapi/certificates.ml +++ b/ocaml/xapi/certificates.ml @@ -475,15 +475,6 @@ let host_uninstall kind ~name ~force = else raise_does_not_exist kind name -let get_cert kind name = - validate_name kind name ; - let filename = library_filename kind name in - try Unixext.string_of_file filename - with e -> - warn "Exception reading %s %s: %s" (to_string kind) name - (ExnHelper.string_of_exn e) ; - raise_corrupt kind name - let sync_all_hosts ~__context hosts = let exn = ref None in Helpers.call_api_functions ~__context (fun rpc session_id -> @@ -496,86 +487,6 @@ let sync_all_hosts ~__context hosts = ) ; match !exn with Some e -> raise e | None -> () -let sync_certs_crls kind list_func install_func uninstall_func ~__context - master_certs host = - Helpers.call_api_functions ~__context (fun rpc session_id -> - let host_certs = list_func rpc session_id host in - List.iter - (fun c -> - if not (List.mem c master_certs) then - uninstall_func rpc session_id host c - ) - host_certs ; - List.iter - (fun c -> - if not (List.mem c host_certs) then - install_func rpc session_id host c (get_cert kind c) - ) - master_certs - ) - -let sync_certs kind ~__context master_certs host = - match kind with - | Root_legacy -> - sync_certs_crls Root_legacy - (fun rpc session_id host -> - Client.Host.certificate_list ~rpc ~session_id ~host - ) - (fun rpc session_id host name cert -> - Client.Host.install_ca_certificate ~rpc ~session_id ~host ~name ~cert - ) - (fun rpc session_id host name -> - Client.Host.uninstall_ca_certificate ~rpc ~session_id ~host ~name - ~force:false - ) - ~__context master_certs host - | CRL -> - sync_certs_crls CRL - (fun rpc session_id host -> Client.Host.crl_list ~rpc ~session_id ~host) - (fun rpc session_id host name crl -> - Client.Host.crl_install ~rpc ~session_id ~host ~name ~crl - ) - (fun rpc session_id host name -> - Client.Host.crl_uninstall ~rpc ~session_id ~host ~name - ) - ~__context master_certs host - | Root _ | Pinned _ -> - () - -let sync_certs_all_hosts kind ~__context master_certs hosts_but_master = - let exn = ref None in - List.iter - (fun host -> - try sync_certs kind ~__context master_certs host with e -> exn := Some e - ) - hosts_but_master ; - match !exn with Some e -> raise e | None -> () - -let pool_sync ~__context = - let hosts = Db.Host.get_all ~__context in - let master = Helpers.get_localhost ~__context in - let hosts_but_master = List.filter (fun h -> h <> master) hosts in - sync_all_hosts ~__context hosts ; - let master_certs = local_list Root_legacy in - let master_crls = local_list CRL in - sync_certs_all_hosts Root_legacy ~__context master_certs hosts_but_master ; - sync_certs_all_hosts CRL ~__context master_crls hosts_but_master - -let pool_install kind ~__context ~name ~cert = - host_install kind ~name ~cert ; - try pool_sync ~__context - with exn -> - ( 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 ~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. *) let read_public_certficate_from_pkcs12 path = diff --git a/ocaml/xapi/certificates.mli b/ocaml/xapi/certificates.mli index ac7b06790eb..56c3ff4fd9b 100644 --- a/ocaml/xapi/certificates.mli +++ b/ocaml/xapi/certificates.mli @@ -45,8 +45,6 @@ val update_ca_bundle : unit -> unit val local_sync : unit -> unit -val pool_sync : __context:Context.t -> unit - (* Certificate installation to filesystem *) val install_server_certificate : @@ -60,12 +58,6 @@ val host_install : t_trusted -> name:string -> cert: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 -> force:bool -> unit - val name_of_uuid : string -> string val all_purposes : API.certificate_purpose list list diff --git a/ocaml/xapi/xapi_pool.ml b/ocaml/xapi/xapi_pool.ml index d3884f1bade..64de556d79a 100644 --- a/ocaml/xapi/xapi_pool.ml +++ b/ocaml/xapi/xapi_pool.ml @@ -1583,7 +1583,8 @@ let certificate_install ~__context ~name ~cert = | Ok x -> x in - pool_install Root_legacy ~__context ~name ~cert ; + Certificates.host_install Root_legacy ~name ~cert ; + Cert_distrib.copy_certs_to_all ~__context ; let (_ : API.ref_Certificate), _ = Db_util.add_cert ~__context ~type':(`ca name) ~purpose:[] certificate in @@ -1593,7 +1594,8 @@ let install_ca_certificate = certificate_install let uninstall_ca_certificate ~__context ~name ~force = let open Certificates in - pool_uninstall Root_legacy ~__context ~name ~force ; + host_uninstall Root_legacy ~name ~force ; + Cert_distrib.copy_certs_to_all ~__context ; Db_util.remove_ca_cert_by_name ~__context name let certificate_uninstall = uninstall_ca_certificate ~force:false @@ -1603,13 +1605,22 @@ let certificate_list ~__context = Db_util.get_ca_certs ~__context |> List.map @@ fun self -> Db.Certificate.get_name ~__context ~self -let crl_install = Certificates.(pool_install CRL) +let crl_install ~__context ~name ~cert = + Certificates.host_install CRL ~name ~cert ; + Cert_distrib.copy_certs_to_all ~__context ; + () -let crl_uninstall = Certificates.(pool_uninstall CRL ~force:false) +let crl_uninstall ~__context ~name = + Certificates.host_uninstall CRL ~name ~force:false ; + Cert_distrib.copy_certs_to_all ~__context ; + () let crl_list ~__context = Certificates.(local_list CRL) -let certificate_sync = Certificates.pool_sync +let certificate_sync ~__context = + Cert_distrib.copy_certs_to_all ~__context ; + Certificates.sync_all_hosts ~__context (Db.Host.get_all ~__context) ; + () let install_trusted_certificate ~__context ~self:_ ~ca ~cert ~purpose = let open Certificates in From 9b12db8b39433377a731ce9981759579a3bfe66a Mon Sep 17 00:00:00 2001 From: Ming Lu Date: Wed, 21 Jan 2026 10:32:14 +0000 Subject: [PATCH 13/28] Update how to update bundles (cherry-pick from commit 9509a1fdcaf45c34d915899ba81ff591cdd94c62) Signed-off-by: Ming Lu --- ocaml/xapi/cert_distrib.ml | 2 +- ocaml/xapi/cert_refresh.ml | 2 +- ocaml/xapi/certificates.ml | 71 ++++++++++++++++++++++++++++----- ocaml/xapi/certificates.mli | 2 +- ocaml/xapi/certificates_sync.ml | 2 +- ocaml/xapi/helpers.ml | 15 ------- scripts/update-ca-bundle.sh | 3 +- 7 files changed, 66 insertions(+), 31 deletions(-) diff --git a/ocaml/xapi/cert_distrib.ml b/ocaml/xapi/cert_distrib.ml index af5bfed3c2e..c895ca31615 100644 --- a/ocaml/xapi/cert_distrib.ml +++ b/ocaml/xapi/cert_distrib.ml @@ -288,7 +288,7 @@ end = struct pool_certs_bk (Printexc.to_string e) let regen_bundle ~__context = - Helpers.update_ca_bundle () ; + Certificates.update_all_bundles () ; let host = Helpers.get_localhost ~__context in match Xapi_clustering.find_cluster_host ~__context ~host with | None -> diff --git a/ocaml/xapi/cert_refresh.ml b/ocaml/xapi/cert_refresh.ml index 41f4b878177..8b41a4ed941 100644 --- a/ocaml/xapi/cert_refresh.ml +++ b/ocaml/xapi/cert_refresh.ml @@ -126,6 +126,6 @@ let remove_stale_cert ~__context ~host ~type' = info "cleanup - renaming %s to %s" next pem ; Sys.rename pem bak ; Sys.rename next pem ; - Certificates.update_ca_bundle () + Certificates.update_all_bundles () ) else info "cleanup - no new cert %s found - skipping" next diff --git a/ocaml/xapi/certificates.ml b/ocaml/xapi/certificates.ml index b0e25cd3071..dcb352896c4 100644 --- a/ocaml/xapi/certificates.ml +++ b/ocaml/xapi/certificates.ml @@ -37,6 +37,8 @@ type t_trusted = type category = [`Root_legacy | `CRL | `Root | `Pinned] +let all_categories = [`Root_legacy; `CRL; `Root; `Pinned] + let all_purposes = [] :: List.map (fun x -> [x]) API.certificate_purpose__all let all_trusted_kinds = @@ -140,7 +142,24 @@ let rehash path = ["rehash"; path] |> ignore -let update_ca_bundle () = Helpers.update_ca_bundle () +let remove_empty_bundle bundle_path = + if Sys.file_exists bundle_path then + let s = Unix.stat bundle_path in + if s.Unix.st_size = 0 then Sys.remove bundle_path + +let local_sync' () = + List.iter + (fun kind -> + mkdir_cert_path kind ; + with_cert_store kind @@ fun ~cert_dir ~bundle -> + rehash cert_dir ; + Option.iter + (fun (bundle_dir, bundle_name) -> + remove_empty_bundle (bundle_dir // bundle_name) + ) + bundle + ) + all_trusted_kinds let to_string = function | Root_legacy -> @@ -418,17 +437,45 @@ let local_list kind = (Array.to_list (Sys.readdir (library_path kind))) let local_sync () = - try rehash () + try local_sync' () with e -> warn "Exception rehashing certificates: %s" (ExnHelper.string_of_exn e) ; raise_library_corrupt () -let update_bundle kind cert_dir bundle_path = - match kind with - | Root_legacy | CRL -> - update_ca_bundle () - | Root _ | Pinned _ -> - () (* TODO: implementation in the following commit *) +let update_bundle = + let m = Mutex.create () in + fun cert_dir bundle_path -> + Xapi_stdext_threads.Threadext.Mutex.execute m (fun () -> + ignore + (Forkhelpers.execute_command_get_output + "/opt/xensource/bin/update-ca-bundle.sh" [cert_dir; bundle_path] + ) ; + remove_empty_bundle bundle_path + ) + +let update_all_bundles () = + (* Update bundle for pool *) + update_bundle !Xapi_globs.trusted_pool_certs_dir !Xapi_globs.pool_bundle_path ; + let ( let* ) l f = List.iter f l in + let* category = all_categories in + let* purposes = all_purposes in + let kind = + match category with + | `Root_legacy -> + Root_legacy + | `CRL -> + CRL + | `Root -> + Root purposes + | `Pinned -> + Pinned purposes + in + let* store = trusted_store_locations kind in + Option.iter + (fun (bundle_dir, bundle_name) -> + update_bundle store.cert_dir (bundle_dir // bundle_name) + ) + store.bundle let host_install kind ~name ~cert = validate_name kind name ; @@ -463,8 +510,12 @@ let host_uninstall kind ~name ~force = if Sys.file_exists cert_path then ( try Sys.remove cert_path ; - rehash cert_dir ; - () (* TODO: implementation in the following commit *) + Option.iter + (fun (bundle_dir, bundle_name) -> + update_bundle cert_dir (bundle_dir // bundle_name) + ) + bundle ; + rehash cert_dir with e -> warn "Exception uninstalling %s %s: %s" (to_string kind) name (ExnHelper.string_of_exn e) ; diff --git a/ocaml/xapi/certificates.mli b/ocaml/xapi/certificates.mli index 56c3ff4fd9b..b9928ac8e37 100644 --- a/ocaml/xapi/certificates.mli +++ b/ocaml/xapi/certificates.mli @@ -41,7 +41,7 @@ val get_internal_server_certificate : unit -> string (* Keeping CA roots updated in the filesystem *) -val update_ca_bundle : unit -> unit +val update_all_bundles : unit -> unit val local_sync : unit -> unit diff --git a/ocaml/xapi/certificates_sync.ml b/ocaml/xapi/certificates_sync.ml index 0fda822fcf0..2e92fcf377f 100644 --- a/ocaml/xapi/certificates_sync.ml +++ b/ocaml/xapi/certificates_sync.ml @@ -150,7 +150,7 @@ let eject_certs_from_fs_for ~__context host = match Sys.file_exists file with | true -> Sys.remove file ; - Certificates.update_ca_bundle () ; + Certificates.update_all_bundles () ; info "removed host certificate %s" file | false -> info "host %s has no certificate %s to remove" host_uuid file diff --git a/ocaml/xapi/helpers.ml b/ocaml/xapi/helpers.ml index e791dc72c3a..f75dc38a29f 100644 --- a/ocaml/xapi/helpers.ml +++ b/ocaml/xapi/helpers.ml @@ -2177,21 +2177,6 @@ end = struct raise e end -let update_ca_bundle = - (* it is not safe for multiple instances of this bash script to be - * running at the same time, so we must lock it. - * - * NB: we choose not to implement the lock inside the bash script - * itself *) - let m = Mutex.create () in - fun () -> - with_lock m (fun () -> - ignore - (Forkhelpers.execute_command_get_output - "/opt/xensource/bin/update-ca-bundle.sh" [] - ) - ) - let external_certificate_thumbprint_of_master ~hash_type = if List.mem hash_type [`Sha256; `Sha1] then Server_helpers.exec_with_new_task diff --git a/scripts/update-ca-bundle.sh b/scripts/update-ca-bundle.sh index 61420be4910..8d5eefc5beb 100755 --- a/scripts/update-ca-bundle.sh +++ b/scripts/update-ca-bundle.sh @@ -28,5 +28,4 @@ regen_bundle () { mv "$BUNDLE.tmp" "$BUNDLE" } -regen_bundle "/etc/stunnel/certs" "/etc/stunnel/xapi-stunnel-ca-bundle.pem" -regen_bundle "/etc/stunnel/certs-pool" "/etc/stunnel/xapi-pool-ca-bundle.pem" +regen_bundle "$1" "$2" From c73183a36654f5d5a8a83221e3794d0e445defb1 Mon Sep 17 00:00:00 2001 From: Ming Lu Date: Thu, 22 Jan 2026 06:53:59 +0000 Subject: [PATCH 14/28] Add collect_trusted_certs (cherry-pick from commit 608926c661c90cd978ba07755a774b32edc9f003) Signed-off-by: Ming Lu --- ocaml/xapi/cert_distrib.ml | 36 ++++++++++++++++++++++++++++++++++++ ocaml/xapi/cert_distrib.mli | 10 ++++++++++ 2 files changed, 46 insertions(+) diff --git a/ocaml/xapi/cert_distrib.ml b/ocaml/xapi/cert_distrib.ml index c895ca31615..aa74a78a23a 100644 --- a/ocaml/xapi/cert_distrib.ml +++ b/ocaml/xapi/cert_distrib.ml @@ -710,6 +710,42 @@ let collect_ca_certs ~__context ~names = Worker.local_collect_certs LegacyRootCert ~__context names |> List.map WireProtocol.pair_of_certificate_file +module CertMap = Map.Make (String) + +let collect_trusted_certs ~__context ~ca ~certificates = + let certs_in_db = + let category = + if ca then + `Root + else + `Pinned + in + let db_type = Certificates.db_type_of_category category in + Certificates.Db_util.get_trusted_certs ~__context db_type + |> List.map (fun (ref, r) -> (Ref.string_of ref, (category, r))) + |> List.fold_left (fun acc (ref, x) -> CertMap.add ref x acc) CertMap.empty + in + certificates + |> List.concat_map (fun ref -> + let ref = Ref.string_of ref in + match CertMap.find_opt ref certs_in_db with + | Some (category, r) -> + let fname, typ, (module P : CertificateProvider) = + of_db_rec category r + in + Worker.local_collect_certs typ ~__context [fname] + |> List.map (fun WireProtocol.{content; _} -> + ( content + , List.map Record_util.certificate_purpose_to_string + r.API.certificate_purpose + ) + ) + | None -> + D.error "%s: the certificate is not a trusted one with ca=%b." + __FUNCTION__ ca ; + raise Api_errors.(Server_error (not_trusted_certificate, [ref])) + ) + (* This function is called on the pool that is incorporating a new host *) let exchange_ca_certificates_with_joiner ~__context ~import ~export = let module C = Certificates in diff --git a/ocaml/xapi/cert_distrib.mli b/ocaml/xapi/cert_distrib.mli index 21513c724c5..f3ca9370231 100644 --- a/ocaml/xapi/cert_distrib.mli +++ b/ocaml/xapi/cert_distrib.mli @@ -55,6 +55,16 @@ val collect_ca_certs : (** [collect_ca_certs ~__context ~names] returns the ca certificates present in the filesystem with the filenames [names], ready to export. *) +val collect_trusted_certs : + __context:Context.t + -> ca:bool + -> certificates:API.ref_Certificate list + -> (string * string list) list +(** [collect_trusted_certs ~__context ~ca ~certificates] returns the + (content, purpose list) pairs of the trusted certificates referenced by the + [certificates]. When [ca] is true, the certificates are root CA, otherwise, + they are pinned leaf certificates. *) + val exchange_ca_certificates_with_joiner : __context:Context.t -> import:(string * string) list From b7bc8617e2737325af8d41384198b1bb25cd6cae Mon Sep 17 00:00:00 2001 From: Ming Lu Date: Thu, 22 Jan 2026 10:39:44 +0000 Subject: [PATCH 15/28] Add pool.exchange_trusted_certificates_on_join (cherry-pick from commit df5b2558b47bb024981ff8d0a42605b2ab560183) Signed-off-by: Ming Lu --- ocaml/idl/datamodel_errors.ml | 7 ++ ocaml/idl/datamodel_pool.ml | 25 ++++ ocaml/xapi-consts/api_errors.ml | 3 + ocaml/xapi/certificates.ml | 2 + ocaml/xapi/certificates.mli | 2 + ocaml/xapi/message_forwarding.ml | 24 ++++ ocaml/xapi/xapi_pool.ml | 196 ++++++++++++++++++++++++------- ocaml/xapi/xapi_pool.mli | 8 ++ 8 files changed, 225 insertions(+), 42 deletions(-) diff --git a/ocaml/idl/datamodel_errors.ml b/ocaml/idl/datamodel_errors.ml index 5b7c9f811f4..fb0ab8d59d7 100644 --- a/ocaml/idl/datamodel_errors.ml +++ b/ocaml/idl/datamodel_errors.ml @@ -878,6 +878,13 @@ let _ = "The host joining the pool has different CA certificates from the pool \ coordinator while using the same name, uninstall them and try again." () ; + error Api_errors.pool_joining_host_trusted_certificates_conflict + ["ref_in_pool"; "ref_on_host"] + ~doc: + "The joining host has a trusted certificate identical to one on the pool \ + coordinator but with different purpose. Uninstall it then install it on \ + the host again with the pool-compatible purpose, and try again." + () ; error Api_errors.pool_joining_sm_features_incompatible ["pool_sm_ref"; "candidate_sm_ref"] ~doc: diff --git a/ocaml/idl/datamodel_pool.ml b/ocaml/idl/datamodel_pool.ml index e1bd950ab89..84cf450f54a 100644 --- a/ocaml/idl/datamodel_pool.ml +++ b/ocaml/idl/datamodel_pool.ml @@ -1655,6 +1655,30 @@ let uninstall_trusted_certificate = ~allowed_roles:(_R_POOL_OP ++ _R_CLIENT_CERT) ~lifecycle:[] () +let trusted_certs = Map (String, Set String) + +let exchange_trusted_certificates_on_join = + call ~name:"exchange_trusted_certificates_on_join" + ~doc: + "Exchange the trusted TLS certificates which are referred by \ + [certificates]." + ~params: + [ + (Ref _pool, "self", "The pool") + ; (Bool, "ca", "true for 'ca' or false for 'pinned'") + ; ( trusted_certs + , "import" + , "The trusted TLS certificates to be installed." + ) + ; ( Set (Ref _certificate) + , "export" + , "The references of the trusted TLS certificates to be returned." + ) + ] + ~result:(trusted_certs, "The contents of these trusted TLS certificates.") + ~allowed_roles:(_R_POOL_OP ++ _R_CLIENT_CERT) + ~hide_from_docs:true ~lifecycle:[] () + (** A pool class *) let t = create_obj ~in_db:true @@ -1756,6 +1780,7 @@ let t = ; set_ssh_auto_mode ; install_trusted_certificate ; uninstall_trusted_certificate + ; exchange_trusted_certificates_on_join ] ~contents: ([ diff --git a/ocaml/xapi-consts/api_errors.ml b/ocaml/xapi-consts/api_errors.ml index 8933eb32fdf..026faadbbd6 100644 --- a/ocaml/xapi-consts/api_errors.ml +++ b/ocaml/xapi-consts/api_errors.ml @@ -751,6 +751,9 @@ let pool_joining_host_tls_verification_mismatch = let pool_joining_host_ca_certificates_conflict = add_error "POOL_JOINING_HOST_CA_CERTIFICATES_CONFLICT" +let pool_joining_host_trusted_certificates_conflict = + add_error "POOL_JOINING_HOST_TRUSTED_CERTIFICATES_CONFLICT" + let pool_joining_sm_features_incompatible = add_error "POOL_JOINING_SM_FEATURES_INCOMPATIBLE" diff --git a/ocaml/xapi/certificates.ml b/ocaml/xapi/certificates.ml index dcb352896c4..8b6044c9c8c 100644 --- a/ocaml/xapi/certificates.ml +++ b/ocaml/xapi/certificates.ml @@ -268,6 +268,8 @@ let raise_library_corrupt () = module Db_util : sig type name = string + module PurposeSet : Set.S with type elt = API.certificate_purpose + val add_cert : __context:Context.t -> type': diff --git a/ocaml/xapi/certificates.mli b/ocaml/xapi/certificates.mli index b9928ac8e37..bf63bb3fb85 100644 --- a/ocaml/xapi/certificates.mli +++ b/ocaml/xapi/certificates.mli @@ -73,6 +73,8 @@ val db_type_of_category : [`Root | `Pinned] -> [`ca | `pinned] (* Database manipulation *) module Db_util : sig + module PurposeSet : Set.S with type elt = API.certificate_purpose + val add_cert : __context:Context.t -> type': diff --git a/ocaml/xapi/message_forwarding.ml b/ocaml/xapi/message_forwarding.ml index 7a48a199158..a56cec95a6b 100644 --- a/ocaml/xapi/message_forwarding.ml +++ b/ocaml/xapi/message_forwarding.ml @@ -1235,6 +1235,10 @@ functor Local.Pool.set_ssh_auto_mode ~__context ~self ~value let install_trusted_certificate ~__context ~self ~ca ~cert ~purpose = + Xapi_pool_helpers.with_pool_operation ~__context + ~op:`copy_primary_host_certs ~doc:"Pool.install_trusted_certificate" + ~self:(Helpers.get_pool ~__context) + @@ fun () -> info "Pool.install_trusted_certificate: pool='%s' ca='%b' purpose=[%s]" (pool_uuid ~__context self) ca @@ -1245,10 +1249,30 @@ functor ~purpose let uninstall_trusted_certificate ~__context ~self ~certificate = + Xapi_pool_helpers.with_pool_operation ~__context + ~op:`copy_primary_host_certs ~doc:"Pool.uninstall_trusted_certificate" + ~self:(Helpers.get_pool ~__context) + @@ fun () -> info "Pool.uninstall_trusted_certificate: pool='%s' certificate='%s'" (pool_uuid ~__context self) (certificate_uuid ~__context certificate) ; Local.Pool.uninstall_trusted_certificate ~__context ~self ~certificate + + let exchange_trusted_certificates_on_join ~__context ~self ~ca ~import + ~export = + Xapi_pool_helpers.with_pool_operation ~__context + ~op:`copy_primary_host_certs + ~doc:"Pool.exchange_trusted_certificates_on_join" + ~self:(Helpers.get_pool ~__context) + @@ fun () -> + info + "Pool.exchange_trusted_certificates_on_join: pool='%s' ca=%b \ + export=[%s]" + (pool_uuid ~__context self) + ca + (List.map (certificate_uuid ~__context) export |> String.concat ";") ; + Local.Pool.exchange_trusted_certificates_on_join ~__context ~self ~ca + ~import ~export end module VM = struct diff --git a/ocaml/xapi/xapi_pool.ml b/ocaml/xapi/xapi_pool.ml index 64de556d79a..bd33d3f43c7 100644 --- a/ocaml/xapi/xapi_pool.ml +++ b/ocaml/xapi/xapi_pool.ml @@ -849,7 +849,7 @@ let pre_join_checks ~__context ~rpc ~session_id ~force = then raise Api_errors.(Server_error (not_supported_during_upgrade, [])) in - let assert_ca_certificates_compatible () = + let assert_legacy_ca_certificates_compatible () = (* When both pools trust a different certificate using the same name joining is blocked. The conflict could be resolved by renaming one of the two certificates but this might break the assumptions of the @@ -895,6 +895,72 @@ let pre_join_checks ~__context ~rpc ~session_id ~force = (pool_joining_host_ca_certificates_conflict, !conflicting_names) ) in + let assert_trusted_certificates_compatible () = + (* The usual cases are that: + - the joining host has no trusted certificates (fresh installed host); + - the joining host has exactly same trusted certificates with the pool. + In either of these cases, the exchanging in next step will work well. + It can work as well when the joining host and the pool have, i.e., a same + certificate with two completely different purpose sets that their + intersection is empty. + However, it will not work well in case that the joining host and the pool + have, i.e., a same certificate with different purpose sets and the + intersection of the two sets is not empty. + This assertion is to block the join when this is the case. + *) + let expr = Printf.sprintf {|field "type"="ca" or field "type"="pinned"|} in + let module CertMap = Map.Make (String) in + let to_map = + List.fold_left + (fun acc (ref, r) -> + if r.API.certificate_name = "" then + CertMap.add r.API.certificate_fingerprint_sha256 (ref, r) acc + else + acc + ) + CertMap.empty + in + let remote = + Client.Certificate.get_all_records_where ~rpc ~session_id ~expr |> to_map + in + let local = + Db.Certificate.get_all_records_where ~__context ~expr |> to_map + in + CertMap.merge + (fun _key remote local -> + match (remote, local) with + | Some (ref1, r1), Some (ref2, r2) -> + let module S = Certificates.Db_util.PurposeSet in + let s1 = S.of_list r1.API.certificate_purpose in + let s2 = S.of_list r2.API.certificate_purpose in + if S.equal s1 s2 || S.is_empty (S.inter s1 s2) then + None + else + let f l = + List.map API.certificate_purpose_to_string l + |> String.concat ";" + in + error + "%s: trusted certificates conflict: uuid=%s (purpose=[%s]) in \ + pool and uuid=%s (purpose=[%s]) on joining host." + __FUNCTION__ r1.API.certificate_uuid + (f r1.API.certificate_purpose) + r2.API.certificate_uuid + (f r2.API.certificate_purpose) ; + Some (ref1, ref2) + | _ -> + None + ) + remote local + |> CertMap.iter (fun _ (ref1, ref2) -> + let f = Ref.string_of in + raise + Api_errors.( + Server_error + (pool_joining_host_trusted_certificates_conflict, [f ref1; f ref2]) + ) + ) + in let assert_no_host_pending_mandatory_guidance () = (* Assert that there is no host pending mandatory guidance on the joiner or the remote pool coordinator. @@ -1009,7 +1075,8 @@ let pre_join_checks ~__context ~rpc ~session_id ~force = assert_homogeneous_primary_address_type () ; assert_compatible_network_purpose () ; assert_tls_verification_matches () ; - assert_ca_certificates_compatible () ; + assert_legacy_ca_certificates_compatible () ; + assert_trusted_certificates_compatible () ; assert_not_in_updating_on_me () ; assert_no_hosts_in_updating () ; assert_sm_features_compatible () @@ -1676,6 +1743,81 @@ let uninstall_trusted_certificate ~__context ~self:_ ~certificate = Cert_distrib.copy_certs_to_all ~__context ; () +let install_trusted_certificate_ignore_dup ~__context ~self ~ca ~cert ~purpose = + try install_trusted_certificate ~__context ~self ~ca ~cert ~purpose + with + | Api_errors.(Server_error (code, [fp])) + when code = Api_errors.trusted_certificate_already_exists + -> + warn "%s: a trusted certificate (fingerprint=%s) exists already." + __FUNCTION__ fp ; + () + +let purpose_of_string_list = List.map Record_util.certificate_purpose_of_string + +let exchange_trusted_certificates_on_join ~__context ~self ~ca ~import ~export = + List.iter + (fun (cert, purpose') -> + let purpose = purpose_of_string_list purpose' in + install_trusted_certificate_ignore_dup ~__context ~self ~ca ~cert ~purpose + ) + import ; + Cert_distrib.collect_trusted_certs ~__context ~ca ~certificates:export + +let exchange_trusted_certificates ~__context ~rpc ~session_id ~remote ~local = + List.iter + (fun db_type -> + let ca = db_type = `ca in + let refs_of rs = + List.filter (fun (_, r) -> r.API.certificate_type = db_type) rs + |> List.map fst + in + let export = refs_of remote in + let import = + Cert_distrib.collect_trusted_certs ~__context ~ca + ~certificates:(refs_of local) + in + Client.Pool.exchange_trusted_certificates_on_join ~rpc ~session_id + ~self:(get_pool ~rpc ~session_id) + ~ca ~import ~export + |> List.iter (fun (cert, purpose') -> + let purpose = purpose_of_string_list purpose' in + install_trusted_certificate_ignore_dup ~__context + ~self:(Helpers.get_pool ~__context) + ~ca ~cert ~purpose + ) + ) + [`ca; `pinned] + +let exchange_legacy_ca_certificates ~__context ~rpc ~session_id ~remote ~local = + let module CertSet = Set.Make (String) in + let get_name = function _, {API.certificate_name; _} -> certificate_name in + let remote_names = List.map get_name remote |> CertSet.of_list in + let local_names = local |> List.map get_name |> CertSet.of_list in + let from_pool = CertSet.(diff remote_names local_names) in + let to_pool = CertSet.(diff local_names remote_names) in + let remote_cert_refs = + List.filter_map + (function + | ref, API.{certificate_name; _} + when CertSet.mem certificate_name from_pool -> + Some ref + | _ -> + None + ) + remote + in + let local_appliance_certs = + Cert_distrib.collect_ca_certs ~__context + ~names:(CertSet.to_seq to_pool |> List.of_seq) + in + let downloaded_certs = + Client.Pool.exchange_ca_certificates_on_join ~rpc ~session_id + ~import:local_appliance_certs ~export:remote_cert_refs + in + Cert_distrib.import_joining_pool_ca_certificates ~__context + ~ca_certs:downloaded_certs + let join_common ~__context ~master_address ~master_username ~master_password ~force = assert_pooling_licensed ~__context ; @@ -1754,51 +1896,21 @@ let join_common ~__context ~master_address ~master_username ~master_password in finally (fun () -> - (* Merge certificates used for trusting appliances, also known as ca - certificates. At this point the names of certificates have been tested - for uniqueness across pools, the name of the certificate is used to - identify each certificate. *) - let expr = {|field "type"="ca"|} in - let module CertSet = Set.Make (String) in - let get_name = function - | _, {API.certificate_name; _} -> - certificate_name + (* Merge trusted certificates, includinng the legacy CA certficates. *) + let expr = + Printf.sprintf {|field "type"="ca" or field "type"="pinned"|} in - let remote_certs = + let remote, remote_legacy = Client.Certificate.get_all_records_where ~rpc ~session_id ~expr + |> List.partition (fun (_, r) -> r.API.certificate_name = "") in - let remote_names = List.map get_name remote_certs |> CertSet.of_list in - let local_names = + let local, local_legacy = Db.Certificate.get_all_records_where ~__context ~expr - |> List.map get_name - |> CertSet.of_list - in - - let from_pool = CertSet.(diff remote_names local_names) in - let to_pool = CertSet.(diff local_names remote_names) in - - let remote_cert_refs = - List.filter_map - (function - | ref, API.{certificate_name; _} - when CertSet.mem certificate_name from_pool -> - Some ref - | _ -> - None - ) - remote_certs - in - - let local_appliance_certs = - Cert_distrib.collect_ca_certs ~__context - ~names:(CertSet.to_seq to_pool |> List.of_seq) - in - let downloaded_certs = - Client.Pool.exchange_ca_certificates_on_join ~rpc ~session_id - ~import:local_appliance_certs ~export:remote_cert_refs + |> List.partition (fun (_, r) -> r.API.certificate_name = "") in - Cert_distrib.import_joining_pool_ca_certificates ~__context - ~ca_certs:downloaded_certs ; + exchange_legacy_ca_certificates ~__context ~rpc ~session_id + ~remote:remote_legacy ~local:local_legacy ; + exchange_trusted_certificates ~__context ~rpc ~session_id ~remote ~local ; (* get pool db from new master so I have a backup ready if we failover to me *) ( try diff --git a/ocaml/xapi/xapi_pool.mli b/ocaml/xapi/xapi_pool.mli index 7f8943f4f39..05efaff3a27 100644 --- a/ocaml/xapi/xapi_pool.mli +++ b/ocaml/xapi/xapi_pool.mli @@ -460,3 +460,11 @@ val uninstall_trusted_certificate : -> self:API.ref_pool -> certificate:API.ref_Certificate -> unit + +val exchange_trusted_certificates_on_join : + __context:Context.t + -> self:API.ref_pool + -> ca:bool + -> import:(string * string list) list + -> export:API.ref_Certificate list + -> (string * string list) list From 40003ac3ab7c7078dbdc6e115c078aa23e99c2be Mon Sep 17 00:00:00 2001 From: Ming Lu Date: Thu, 22 Jan 2026 07:08:15 +0000 Subject: [PATCH 16/28] Add collect_crls (cherry-pick from commit 2a3a7598eb1b83b564347d93caae5fe23fbab517) Signed-off-by: Ming Lu --- ocaml/xapi/cert_distrib.ml | 4 ++++ ocaml/xapi/cert_distrib.mli | 6 ++++++ 2 files changed, 10 insertions(+) diff --git a/ocaml/xapi/cert_distrib.ml b/ocaml/xapi/cert_distrib.ml index aa74a78a23a..b5f9f923b29 100644 --- a/ocaml/xapi/cert_distrib.ml +++ b/ocaml/xapi/cert_distrib.ml @@ -746,6 +746,10 @@ let collect_trusted_certs ~__context ~ca ~certificates = raise Api_errors.(Server_error (not_trusted_certificate, [ref])) ) +let collect_crls ~__context ~names = + Worker.local_collect_certs CRL ~__context names + |> List.map WireProtocol.pair_of_certificate_file + (* This function is called on the pool that is incorporating a new host *) let exchange_ca_certificates_with_joiner ~__context ~import ~export = let module C = Certificates in diff --git a/ocaml/xapi/cert_distrib.mli b/ocaml/xapi/cert_distrib.mli index f3ca9370231..e9c9e53579f 100644 --- a/ocaml/xapi/cert_distrib.mli +++ b/ocaml/xapi/cert_distrib.mli @@ -65,6 +65,12 @@ val collect_trusted_certs : [certificates]. When [ca] is true, the certificates are root CA, otherwise, they are pinned leaf certificates. *) +val collect_crls : + __context:Context.t -> names:string list -> (string * string) list +(** [collect_crls ~__context ~names] returns the (name, content) pairs of the + Certificate Revocation Lists (CRLs) installed in the pool referenced by + [names] which are filenames in dom0's filesystem on the coordinator. *) + val exchange_ca_certificates_with_joiner : __context:Context.t -> import:(string * string) list From cccecfcc737909938b7cdf1514e516cd3d1279cd Mon Sep 17 00:00:00 2001 From: Ming Lu Date: Fri, 23 Jan 2026 05:52:45 +0000 Subject: [PATCH 17/28] Add pool.exchange_crls_on_join (cherry-pick from commit 2fdfaf4fe90f6fbce0d1851cae6bea69ac769023) Signed-off-by: Ming Lu --- ocaml/idl/datamodel_pool.ml | 30 ++++++++++++++++++++++++++++++ ocaml/xapi/message_forwarding.ml | 11 +++++++++++ ocaml/xapi/xapi_pool.ml | 18 ++++++++++++++++++ ocaml/xapi/xapi_pool.mli | 7 +++++++ ocaml/xapi/xapi_pool_helpers.ml | 4 +++- 5 files changed, 69 insertions(+), 1 deletion(-) diff --git a/ocaml/idl/datamodel_pool.ml b/ocaml/idl/datamodel_pool.ml index 84cf450f54a..6912f1d8814 100644 --- a/ocaml/idl/datamodel_pool.ml +++ b/ocaml/idl/datamodel_pool.ml @@ -47,6 +47,9 @@ let operations = host" ) ; ("eject", "Ejection of a host from the pool is under way") + ; ( "exchange_crls_on_join" + , "Indicates this pool is exchanging CRLs with a new joiner" + ) ] ) @@ -1679,6 +1682,32 @@ let exchange_trusted_certificates_on_join = ~allowed_roles:(_R_POOL_OP ++ _R_CLIENT_CERT) ~hide_from_docs:true ~lifecycle:[] () +let exchange_crls_on_join = + call ~name:"exchange_crls_on_join" + ~doc: + "Install the TLS CA-issued Certificate Revocation Lists (CRLs) provided \ + in [import] and return the CRLs referenced by [export]." + ~params: + [ + (Ref _pool, "self", "The pool") + ; ( certs + , "import" + , "The TLS CA-issued Certificate Revocation Lists (CRLs) to be \ + installed." + ) + ; ( Set String + , "export" + , "The names of the installed TLS CA-issued Certificate Revocation \ + Lists (CRLs) to be returned." + ) + ] + ~result: + ( certs + , "The contents of the TLS CA-issued Certificate Revocation Lists (CRLs)." + ) + ~allowed_roles:(_R_POOL_OP ++ _R_CLIENT_CERT) + ~hide_from_docs:true ~lifecycle:[] () + (** A pool class *) let t = create_obj ~in_db:true @@ -1781,6 +1810,7 @@ let t = ; install_trusted_certificate ; uninstall_trusted_certificate ; exchange_trusted_certificates_on_join + ; exchange_crls_on_join ] ~contents: ([ diff --git a/ocaml/xapi/message_forwarding.ml b/ocaml/xapi/message_forwarding.ml index a56cec95a6b..b19c4de75b4 100644 --- a/ocaml/xapi/message_forwarding.ml +++ b/ocaml/xapi/message_forwarding.ml @@ -1273,6 +1273,17 @@ functor (List.map (certificate_uuid ~__context) export |> String.concat ";") ; Local.Pool.exchange_trusted_certificates_on_join ~__context ~self ~ca ~import ~export + + let exchange_crls_on_join ~__context ~self ~import ~export = + Xapi_pool_helpers.with_pool_operation ~__context + ~op:`exchange_crls_on_join ~doc:"Pool.exchange_crls_on_join" + ~self:(Helpers.get_pool ~__context) + @@ fun () -> + info "Pool.exchange_crls_on_join: pool='%s' import=[%s] export=[%s]" + (pool_uuid ~__context self) + (String.concat ";" (List.map fst import)) + (String.concat ";" export) ; + Local.Pool.exchange_crls_on_join ~__context ~self ~import ~export end module VM = struct diff --git a/ocaml/xapi/xapi_pool.ml b/ocaml/xapi/xapi_pool.ml index bd33d3f43c7..0ff8d8b7e17 100644 --- a/ocaml/xapi/xapi_pool.ml +++ b/ocaml/xapi/xapi_pool.ml @@ -1789,6 +1789,10 @@ let exchange_trusted_certificates ~__context ~rpc ~session_id ~remote ~local = ) [`ca; `pinned] +let exchange_crls_on_join ~__context ~self:_ ~import ~export = + List.iter (fun (name, crl) -> crl_install ~__context ~name ~cert:crl) import ; + Cert_distrib.collect_crls ~__context ~names:export + let exchange_legacy_ca_certificates ~__context ~rpc ~session_id ~remote ~local = let module CertSet = Set.Make (String) in let get_name = function _, {API.certificate_name; _} -> certificate_name in @@ -1818,6 +1822,19 @@ let exchange_legacy_ca_certificates ~__context ~rpc ~session_id ~remote ~local = Cert_distrib.import_joining_pool_ca_certificates ~__context ~ca_certs:downloaded_certs +let exchange_crls ~__context ~rpc ~session_id = + let local_names = crl_list ~__context in + let local_crls = Cert_distrib.collect_crls ~__context ~names:local_names in + let remote_names = Client.Pool.crl_list ~rpc ~session_id in + let remote_crls = + Client.Pool.exchange_crls_on_join ~rpc ~session_id + ~self:(get_pool ~rpc ~session_id) + ~import:local_crls ~export:remote_names + in + List.iter + (fun (name, crl) -> crl_install ~__context ~name ~cert:crl) + remote_crls + let join_common ~__context ~master_address ~master_username ~master_password ~force = assert_pooling_licensed ~__context ; @@ -1911,6 +1928,7 @@ let join_common ~__context ~master_address ~master_username ~master_password exchange_legacy_ca_certificates ~__context ~rpc ~session_id ~remote:remote_legacy ~local:local_legacy ; exchange_trusted_certificates ~__context ~rpc ~session_id ~remote ~local ; + exchange_crls ~__context ~rpc ~session_id ; (* get pool db from new master so I have a backup ready if we failover to me *) ( try diff --git a/ocaml/xapi/xapi_pool.mli b/ocaml/xapi/xapi_pool.mli index 05efaff3a27..e483d835a71 100644 --- a/ocaml/xapi/xapi_pool.mli +++ b/ocaml/xapi/xapi_pool.mli @@ -468,3 +468,10 @@ val exchange_trusted_certificates_on_join : -> import:(string * string list) list -> export:API.ref_Certificate list -> (string * string list) list + +val exchange_crls_on_join : + __context:Context.t + -> self:API.ref_pool + -> import:API.string_to_string_map + -> export:string list + -> API.string_to_string_map diff --git a/ocaml/xapi/xapi_pool_helpers.ml b/ocaml/xapi/xapi_pool_helpers.ml index bdd4e0454b1..21d442d07a0 100644 --- a/ocaml/xapi/xapi_pool_helpers.ml +++ b/ocaml/xapi/xapi_pool_helpers.ml @@ -37,7 +37,8 @@ type waiting_operations = | `eject | `exchange_ca_certificates_on_join | `exchange_certificates_on_join - | `get_updates ] + | `get_updates + | `exchange_crls_on_join ] type all_operations = [blocking_operations | waiting_operations] @@ -77,6 +78,7 @@ let waiting_ops : waiting_operations list = ; `copy_primary_host_certs ; `eject ; `get_updates + ; `exchange_crls_on_join ] (* Shadow with widening coercions to allow us to query using From 277ab8ae64002e24f0b741324af481ef94f30d68 Mon Sep 17 00:00:00 2001 From: Ming Lu Date: Sat, 24 Jan 2026 08:05:25 +0000 Subject: [PATCH 18/28] Fix certificate error messages (cherry-pick from commit bc6e11bebb9848d8c5d82deb8c598203283ac635) Signed-off-by: Ming Lu --- ocaml/idl/datamodel_errors.ml | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/ocaml/idl/datamodel_errors.ml b/ocaml/idl/datamodel_errors.ml index fb0ab8d59d7..69ec2e51cf3 100644 --- a/ocaml/idl/datamodel_errors.ml +++ b/ocaml/idl/datamodel_errors.ml @@ -1699,7 +1699,7 @@ let _ = () ; error Api_errors.server_certificate_invalid [] - ~doc:"The provided certificate is not in a PEM-encoded X509." () ; + ~doc:"The provided certificate is not in a PEM-encoded X509 format." () ; error Api_errors.server_certificate_key_mismatch [] ~doc: "The provided key does not match the provided certificate's public key." @@ -1715,7 +1715,9 @@ let _ = () ; error Api_errors.server_certificate_chain_invalid [] - ~doc:"The provided intermediate certificates are not in a PEM-encoded X509." + ~doc: + "The provided intermediate certificates are not in a PEM-encoded X509 \ + format." () ; error Api_errors.not_trusted_certificate ["ref"] @@ -1731,7 +1733,7 @@ let _ = ~doc:"The provided certificate is not valid yet." () ; error Api_errors.trusted_certificate_invalid [] - ~doc:"The provided certificate is not in a PEM-encoded X509." () ; + ~doc:"The provided certificate is not in a PEM-encoded X509 format." () ; error Api_errors.vmpp_has_vm [] ~doc:"There is at least one VM assigned to this protection policy." () ; From 6ae6dcddcd45e7b10c7301a06ab6fed234c50c24 Mon Sep 17 00:00:00 2001 From: Ming Lu Date: Sat, 24 Jan 2026 09:19:07 +0000 Subject: [PATCH 19/28] Cleanup trusted on ejected host (cherry-pick from commit 23fbffc24d85102585e7c6464416d3660d0a7256) Signed-off-by: Ming Lu --- ocaml/xapi/certificates.ml | 12 ++++++++++++ ocaml/xapi/certificates.mli | 2 ++ ocaml/xapi/xapi_pool.ml | 1 + 3 files changed, 15 insertions(+) diff --git a/ocaml/xapi/certificates.ml b/ocaml/xapi/certificates.ml index 8b6044c9c8c..5e22c9d2c04 100644 --- a/ocaml/xapi/certificates.ml +++ b/ocaml/xapi/certificates.ml @@ -580,3 +580,15 @@ let name_of_uuid uuid = Printf.sprintf "%s.pem" uuid let db_type_of_category category = match category with `Root -> `ca | `Pinned -> `pinned + +let cleanup_all_trusted () = + let ( let* ) l f = List.iter f l in + let* kind = all_trusted_kinds in + let* store = trusted_store_locations kind in + Unixext.rm_rec ~rm_top:false store.cert_dir ; + Option.iter + (fun (bundle_dir, bundle_name) -> + Unixext.unlink_safe (bundle_dir // bundle_name) + ) + store.bundle ; + () diff --git a/ocaml/xapi/certificates.mli b/ocaml/xapi/certificates.mli index bf63bb3fb85..ea284f48a4a 100644 --- a/ocaml/xapi/certificates.mli +++ b/ocaml/xapi/certificates.mli @@ -70,6 +70,8 @@ val sync_all_hosts : __context:Context.t -> API.ref_host list -> unit val db_type_of_category : [`Root | `Pinned] -> [`ca | `pinned] +val cleanup_all_trusted : unit -> unit + (* Database manipulation *) module Db_util : sig diff --git a/ocaml/xapi/xapi_pool.ml b/ocaml/xapi/xapi_pool.ml index 0ff8d8b7e17..55b34679fa1 100644 --- a/ocaml/xapi/xapi_pool.ml +++ b/ocaml/xapi/xapi_pool.ml @@ -2385,6 +2385,7 @@ let eject_self ~__context ~host = Unixext.unlink_safe Xapi_globs.db_temporary_restore_path ; Unixext.unlink_safe Db_globs.ha_metadata_db ; Unixext.unlink_safe Db_globs.gen_metadata_db ; + Certificates.cleanup_all_trusted () ; (* If we've got local storage, remove it *) if Helpers.local_storage_exists () then ( ignore From 3eef0a9b8c9b289d6033e7c857607082678b30bc Mon Sep 17 00:00:00 2001 From: Ming Lu Date: Wed, 4 Feb 2026 14:59:32 +0800 Subject: [PATCH 20/28] [doc] Update how to handle trusted certificates when pool.join (cherry-pick from commit 36890b6983837a1cf9c6f6e811ae522b263c54d7) Signed-off-by: Ming Lu --- doc/content/design/pool-certificates.md | 10 ++ doc/content/design/trusted-certificates.md | 127 ++++++++++++++++++--- 2 files changed, 121 insertions(+), 16 deletions(-) diff --git a/doc/content/design/pool-certificates.md b/doc/content/design/pool-certificates.md index 043638e3296..db960f2a8d1 100644 --- a/doc/content/design/pool-certificates.md +++ b/doc/content/design/pool-certificates.md @@ -6,6 +6,8 @@ revision: 2 status: released (22.6.0) --- +This design is modified by [trusted-certificates.md](trusted-certificates.md). + ## Overview Xenserver has used TLS-encrypted communications between xapi daemons in a pool since its first release. @@ -353,18 +355,25 @@ This feature needs clients to behave differently when initiating pool joins, to Several alerts are introduced: * POOL_CA_CERTIFICATE_EXPIRING_30, POOL_CA_CERTIFICATE_EXPIRING_14, POOL_CA_CERTIFICATE_EXPIRING_07, POOL_CA_CERTIFICATE_EXPIRED: Similar to host certificates, now the user-installable pool's CA certificates are monitored for expiry dates and alerts are generated about them. The body for this type of message is: +``` The trusted TLS server certificate {is expiring soon|has expired}.20210302T02:00:01Z +``` * HOST_INTERNAL_CERTIFICATE_EXPIRING_30, HOST_INTERNAL_CERTIFICATE_EXPIRING_14, HOST_INTERNAL_CERTIFICATE_EXPIRING_07, HOST_INTERNAL_CERTIFICATE_EXPIRED: Similar to host certificates, the newly-introduced hosts' internal server certificates are monitored for expiry dates and alerts are generated about them. The body for this type of message is: +``` The TLS server certificate for internal communications {is expiring soon|has expired}.20210302T02:00:01Z +``` * TLS_VERIFICATION_EMERGENCY_DISABLED: The host is in emergency mode and is not enforcing tls verification anymore, the situation that forced the disabling must be fixed and the verification enabled ASAP. +``` HOST-UUID +``` * FAILED_LOGIN_ATTEMPTS: An hourly alert that contains the number of failed attempts and the 3 most common origins for these failed alerts. The body for this type of message is: +``` 35 usr5origin55.4.3.21020200922T15:03:13Z @@ -372,3 +381,4 @@ Several alerts are introduced: UA4.3.2.1420200922T14:57:11Z 10 +``` diff --git a/doc/content/design/trusted-certificates.md b/doc/content/design/trusted-certificates.md index d48868d7034..eb51b0d1682 100644 --- a/doc/content/design/trusted-certificates.md +++ b/doc/content/design/trusted-certificates.md @@ -2,7 +2,7 @@ title: Trusted certificates for identity validation in TLS connections layout: default design_doc: true -revision: 1 +revision: 2 status: draft --- @@ -10,8 +10,8 @@ status: draft In various use cases, TLS connections are established on the host on which XAPI runs. When establishing a TLS connection, the peer identity needs to be validated. -This is done using either a root CA certificate to perform certificate chain validation, or a known peer certificate for validation with certificate pinning. -The root CA certificates and peer certificates involved in this process are referred to as trusted certificates. +This is done using either a root CA certificate to perform certificate chain validation, or a pinned certificate for validation with certificate pinning. +The root CA certificates and pinned certificates involved in this process are referred to as trusted certificates. When a trusted certificate is installed, the local endpoint can validate the peer identity during TLS connection establishment. Certificate chain validation is a general-purpose, standards-based approach but requires additional steps, such as getting the peer's certificate signed by a CA. In contrast, certificate pinning offers a quicker way to set up trust in some cases without the overhead of CA signing. @@ -21,13 +21,13 @@ This allows the use case to start in quicker and easier way without prior CA sig As the unified API for the whole system, XAPI also exposes interfaces for users to install and manage trusted certificates that are used by system components for different purposes. -The base design described in [pool-certificates.md](https://github.com/minglumlu/xen-api/blob/5d1ea1520825d502c57a90a02db476cd7d6a9132/doc/content/design/pool-certificates.md) defines the database, API, and trust store in the filesystem for managing trusted certificates. +The base design described in [pool-certificates.md](pool-certificates.md) defines the database, API, and trust store in the filesystem for managing trusted certificates. This document introduces the following enhancements to that design: -* Explicit separation of root CA certificates and peer certificates: +* Explicit separation of root CA certificates and pinned certificates: In the base design, both certificate types share the same database schema, APIs, and are stored together in a single bundle file. This makes it difficult to determine the appropriate validation approach based on the certificate type. -The improvement introduces a type value to separate root CA certificates and peer certificates explicitly. +The improvement introduces a type value to separate root CA certificates and pinned certificates explicitly. * Add a "purpose" attribute for trusted certificates: According to the base design, only certificates used for internal TLS connections among XAPI processes within a pool are stored separately. @@ -49,13 +49,13 @@ This case benefits from the improvements introduced in this design as well. ## Database schema The *Certificate* class in database is defined to represent general certificates, including trusted certificates. One existing class field "type" supports the following enumeration values: -* "ca": trusted certificates including both root CA and peer. +* "ca": trusted certificates including both root CA and pinned. * "host": identity certificate of a host for communication with entities outside the pool. * "host_internal": identity certificate of a host for communication with other pool members. Two improvements in this design: -* A new value "peer" is introduced in this design so that the existing "ca" now represents trusted root CA only. -The new "peer" will represent trusted peer certificates. +* A new value "pinned" is introduced in this design so that the existing "ca" now represents trusted root CA only. +The new "pinned" will represent trusted pinned certificates. * A new enumeration type "purpose" is introduced to indicate the intended usage of a trusted certificate. A new *Certificate* class field "purpose" (a set of values of enumeration type "purpose") will be added to represent all applicable purposes of a trusted certificate. @@ -79,13 +79,13 @@ For the same reason, "pool.uninstall_ca_certificate" will also be deprecated. This is a new API introduced in this design with its arguments being defined as: * session (ref session_id): reference to a valid session; * self (ref Pool): reference to the pool; -* ca (boolean): the trusted certificate is a root CA certificate used to verify a chain (true), or a peer certificate used for certificate pinning (false); +* ca (boolean): the trusted certificate is a root CA certificate used to verify a chain (true), or a pinned certificate used for certificate pinning (false); * cert (string): the trusted certificate in PEM format; * purpose (string list): the purposes of the trusted certificate. This new API is used to install trusted certificate. When *purpose* is an empty set, it stands for a root CA certificate for general purpose. -The *purpose* can not be an empty set when the *ca* is false, because each peer certificate is specific to a single server and therefore unsuitable for a shared trusted certificate for general purpose. +The *purpose* can not be an empty set when the *ca* is false, because each pinned certificate is specific to a single server and therefore unsuitable for a shared trusted certificate for general purpose. It returns *void* when succeed. Otherwise, return corresponding API error. @@ -93,13 +93,108 @@ It returns *void* when succeed. Otherwise, return corresponding API error. This is a new API introduced in this design to uninstall a trusted certificate with its arguments being defined as: * session (ref session_id): reference to a valid session; * certificate (ref Certificate): reference to the trusted certificate; -* force (bool): remove the database entry even if the file doesn't exist. It returns *void* when succeed. Otherwise, return corresponding API error. ### pool.join -Prior to this design, trusted certificates are exchanged between the pool and the joining host during the pre‑join phase. -This design preserves that behavior to ensure the joiner works correctly both before and after joining the pool. +According to the base design, trusted certificates are exchanged between the pool and the joining host during the pre‑join phase. +This design basically preserves that behavior to ensure the joiner works correctly both before and after joining the pool. +However, a number of modifications have been introduced compared with the base design. + +~~~mermaid + +sequenceDiagram +participant clnt as Client +participant join as Joiner +participant coor as Coordinator +participant memb as Member +clnt->>join: Pool.join coordinator_ip coordinator_username coordinator_password +join->>coor:login_with_password rpc_no_verify coordinator_ip coordinator_username coordinator_password +coor-->>join: + +Note over join: pre_join_checks +rect rgba(0,0,0,0.05) +join->>join: assert_tls_verification_matches +alt fails +Note over join: interrupt join, raise error +end +end + +Note over join: exchnage trusted intra-pool host identity certificates +rect rgba(0,0,0,0.05) +join->>coor: Pool.exchange_certificates_on_join +coor->>coor: Cert_distrib.exchange_certificates_with_joiner start +coor->>memb: Host.cert_distrib_atom Write +memb-->>coor: +coor->>coor: Cert_distrib.get_local_pool_certs +coor-->>coor: Cert_distrib.exchange_certificates_with_joiner done +coor-->>join: +join->>join: Cert_distrib.import_joining_pool_certs +end + +join->>coor:login_with_password rpc_verify coordinator_ip coordinator_username coordinator_password +coor-->>join: + +Note over join: exchange legacy ca certificates +rect rgba(0,0,0,0.05) +join->>coor: Pool.exchange_ca_certificates_on_join +coor->>coor: Cert_distrib.exchange_ca_certificates_with_joiner +coor-->>join: +join->>join: Cert_distrib.import_joining_pool_ca_certificates +end + +Note over join: exchange trusted certificates +rect rgba(0,0,0,0.05) +join->>coor: Pool.exchange_trusted_certificates_on_join +loop for every in Joiner +coor->>coor: Pool.install_trusted_certificate start +coor->>memb: Host.cert_distrib_atom Write +memb-->>coor: +coor->>memb: Host.certificate_sync +memb-->>coor: +coor-->>coor: Pool.install_trusted_certificate done +end +coor->>coor: Cert_distrib.collect_trusted_certs +coor-->>join: +loop for every in pool +join->>join: Pool.install_trusted_certificate +end +end + +Note over join: exchange CRLs +rect rgba(0,0,0,0.05) +join->>coor: Pool.exchange_crls_on_join +loop for every in Joiner +coor->>coor: Pool.crl_install start +coor->>memb: Host.cert_distrib_atom Write +memb-->>coor: +coor->>memb: Host.certificate_sync +memb-->>coor: +coor-->>coor: Pool.crl_install done +end +coor->>coor: Cert_distrib.collect_crls +coor-->>join: +loop for every in pool +join->>join: Pool.crl_install +end +end + +join->>coor: Host.add joiner +coor-->>join: + +join->>join: restart_as_slave + +Note over join: Copy all certificates from coordinator +rect rgba(0,0,0,0.05) +join->>coor: Host.copy_primary_host_certs +coor->>join: Host.cert_distrib_atom Write +join-->>coor: +coor->>join: Host.cert_distrib_atom GenBundle +join-->>coor: +coor-->>join: return from Host.copy_primary_host_certs +end + +~~~ ### pool.eject The trusted certificates will be removed from any host which is being eject from the pool. @@ -130,10 +225,10 @@ The stores for the certificates installed via "pool.install_trusted_certificate" | Name | Filesystem location | Used for | | ---- | ------------------- | -------- | | Trusted General CA | /etc/trusted-certs/ca-general/ | Trusted root CA certificates that users can install to validate a peer’s identity when establishing a TLS connection for general purpose. -| Trusted Peer | /etc/trusted-certs/peer-\/ | Trusted peer certificates that users can install to validate a peer’s identity when establishing a TLS connection for \. +| Trusted Peer | /etc/trusted-certs/pinned-\/ | Trusted pinned certificates that users can install to validate a peer’s identity when establishing a TLS connection for \. | Trusted CA | /etc/trusted-certs/ca-\/ | Trusted root CA certificates that users can install to validate a peer’s identity when establishing a TLS connection for \. | General Bundle | /etc/trusted-certs/ca-bundle-general.pem | Bundle of trusted root CA certificates under /etc/trusted-certs/ca-general/ to verify a peer's identity when establishing a TLS connection for general purpose. -| Peer Bundle | /etc/trusted-certs/peer-bundle-\.pem | Bundle of trusted peer certificates under /etc/trusted-certs/peer-\/ to verify a peer's identity when establishing a TLS connection for \. +| Peer Bundle | /etc/trusted-certs/pinned-bundle-\.pem | Bundle of trusted pinned certificates under /etc/trusted-certs/pinned-\/ to verify a peer's identity when establishing a TLS connection for \. | CA Bundle | /etc/trusted-certs/ca-bundle-\.pem | Bundle of trusted root CA certificates under /etc/trusted-certs/ca-\/ to verify a peer's identity when establishing a TLS connection for \. The filesystem location is derived from the \. Each \ string corresponds to a predefined value of the "purpose" type in the database, implemented as predefined constants. From b0f0c0eea17139cfb3e87d7c996cf53310fdea5e Mon Sep 17 00:00:00 2001 From: Ming Lu Date: Wed, 4 Mar 2026 15:12:03 +0800 Subject: [PATCH 21/28] Bump up last_known_schema_hash Signed-off-by: Ming Lu --- ocaml/idl/schematest.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ocaml/idl/schematest.ml b/ocaml/idl/schematest.ml index a90bf8687d9..0edc6b32542 100644 --- a/ocaml/idl/schematest.ml +++ b/ocaml/idl/schematest.ml @@ -3,7 +3,7 @@ let hash x = Digest.string x |> Digest.to_hex (* BEWARE: if this changes, check that schema has been bumped accordingly in ocaml/idl/datamodel_common.ml, usually schema_minor_vsn *) -let last_known_schema_hash = "a01358e3ff5f42d5aee162e995d2ec05" +let last_known_schema_hash = "c5a74beaa04de3f6c9cfed7ec5e72d4c" let current_schema_hash : string = let open Datamodel_types in From 0bc05a24c2a80d453e943f4cd3cdf84df6b01cd9 Mon Sep 17 00:00:00 2001 From: Changlei Li Date: Thu, 5 Feb 2026 16:56:08 +0800 Subject: [PATCH 22/28] CA-423556: print full checkout error msg in xe apply-edition (cherry-pick from commit 8f2abd15b6fbf89a47e4e24eb38cc46337e6c0f8) A new LICENSE_SERVER_CERT_CHECK_FAILED is added in LICENSE_CHECKOUT_ERROR with second string of . Now the xe command only prints the second string in this case, it is hard to understand and distinguish with the existing CERTIFICATE_INVALID. So concact the two strings and print. Signed-off-by: Changlei Li --- ocaml/xapi-cli-server/cli_operations.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/ocaml/xapi-cli-server/cli_operations.ml b/ocaml/xapi-cli-server/cli_operations.ml index 97c3d44ab44..2eb0543a2b8 100644 --- a/ocaml/xapi-cli-server/cli_operations.ml +++ b/ocaml/xapi-cli-server/cli_operations.ml @@ -5449,7 +5449,7 @@ let with_license_server_changes printer rpc session_id params hosts f = hosts ) ; try f rpc session_id with - | Api_errors.Server_error (name, [_; msg]) + | Api_errors.Server_error (name, [msg1; msg2]) when name = Api_errors.license_checkout_error -> (* Put back original license_server_details *) List.iter @@ -5458,7 +5458,7 @@ let with_license_server_changes printer rpc session_id params hosts f = ~value:license_server ) current_license_servers ; - printer (Cli_printer.PStderr (msg ^ "\n")) ; + printer (Cli_printer.PStderr (Printf.sprintf "%s: %s\n" msg1 msg2)) ; raise (ExitWithError 1) | Api_errors.Server_error (name, _) as e when name = Api_errors.invalid_edition -> From 2229630c1d3d1e11961924c9ffeefe7bbe4fc964 Mon Sep 17 00:00:00 2001 From: Changlei Li Date: Wed, 4 Feb 2026 14:11:32 +0800 Subject: [PATCH 23/28] CP-310090 Stunnel lib: Expose unix socket path for TLS proxy (cherry-pick from commit fd98c31977b058dc9d7cbfc365d532577f8319cb) Add a module UnixSocketProxy in stunnel lib to provide a unix socket path that can proxy TLS. This can offer a unified mechanism for differnt users. Stunnel listens on the unix socket path, accepts the connection from local request then forwards to remote host and port with TLS. The certificate checking in TLS connection can be done by stunnel with the new trusted-certs implementation. Two set of APIs are provided: 1. long-running stunnel proxy for that the user want to use it multi-times and handle the proxy lifecycle itself. ```OCaml let stunnel_proxy = Stunnel.UnixSocketProxy.start ~verify_cert ~remote_host ~remote_port () in match stunnel_proxy with | Error e -> (* handle error *) | Ok proxy_handle -> let socket_path = Stunnel.UnixSocketProxy.socket_path proxy_handle in (* use socket_path with HTTP clients *) ... Stunnel.UnixSocketProxy.diagnose proxy_handle |> function | Ok () -> (* all good *) | Error err -> (* handle connection errors *) ... Stunnel.UnixSocketProxy.stop proxy_handle (* clean up when done *) ``` 2. short-lived stunnel proxy for that the user just want to use one-shot with auto cleanup. ```OCaml Stunnel.UnixSocketProxy.with_proxy ~verify_cert ~remote_host ~remote_port (fun proxy_handle -> let socket_path = Stunnel.UnixSocketProxy.socket_path proxy_handle in (* use socket_path with HTTP clients *) ... Stunnel.UnixSocketProxy.diagnose proxy_handle) ... ) ``` Signed-off-by: Changlei Li --- ocaml/libs/stunnel/stunnel.ml | 190 ++++++++++++++++++++++++-- ocaml/libs/stunnel/stunnel.mli | 77 +++++++++++ ocaml/libs/stunnel/stunnel_client.ml | 44 ++++++ ocaml/libs/stunnel/stunnel_client.mli | 3 + ocaml/libs/stunnel/stunnel_error.ml | 23 ++++ ocaml/libs/stunnel/stunnel_error.mli | 23 ++++ ocaml/xapi-consts/constants.ml | 6 + ocaml/xapi/certificates.ml | 9 +- ocaml/xapi/xapi_globs.ml | 2 - 9 files changed, 359 insertions(+), 18 deletions(-) create mode 100644 ocaml/libs/stunnel/stunnel_error.ml create mode 100644 ocaml/libs/stunnel/stunnel_error.mli diff --git a/ocaml/libs/stunnel/stunnel.ml b/ocaml/libs/stunnel/stunnel.ml index 762a618f0c6..3d59681dd76 100644 --- a/ocaml/libs/stunnel/stunnel.ml +++ b/ocaml/libs/stunnel/stunnel.ml @@ -212,11 +212,13 @@ let config_file ?(accept = None) config host port = ) ; [debug_conf_of_env ()] ; ( match accept with - | Some (h, p) -> + | Some (`Local_host_port (h, p)) -> [ "[client-proxy]" ; Printf.sprintf "accept=%s:%s" h (string_of_int p) ] + | Some (`Unix_socket_path path) -> + ["[client-proxy]"; Printf.sprintf "accept=%s" path] | None -> [] ) @@ -400,12 +402,24 @@ let attempt_one_connect ?(use_fork_exec_helper = true) match data_channel with | `Local_host_port (h, p) -> (* The stunnel will listen on a local host and port *) - let config = config_file ~accept:(Some (h, p)) verify_cert host port in + let config = + config_file + ~accept:(Some (`Local_host_port (h, p))) + verify_cert host port + in start None config | `Unix_socket s -> (* The stunnel will listen on a UNIX socket *) let config = config_file verify_cert host port in start (Some s) config + | `Unix_socket_path path -> + (* The stunnel will listen on a UNIX socket path *) + let config = + config_file + ~accept:(Some (`Unix_socket_path path)) + verify_cert host port + in + start None config in (* Tidy up any remaining unclosed fds *) match result with @@ -475,7 +489,7 @@ let with_client_proxy_systemd_service ~verify_cert ~remote_host ~remote_port let cmd_path = stunnel_path () in let config = config_file - ~accept:(Some (local_host, local_port)) + ~accept:(Some (`Local_host_port (local_host, local_port))) verify_cert remote_host remote_port in let stop () = ignore (Fe_systemctl.stop ~service) in @@ -525,19 +539,169 @@ let check_verify_error line = else () -let check_error s line = - if Astring.String.is_infix ~affix:s line then raise (Stunnel_error s) +let check_error line = + [ + "Configuration failed" + ; "Connection refused" + ; "No host resolved" + ; "No route to host" + ; "Invalid argument" + ; "Address already in use" + ] + |> List.iter (fun s -> + if Astring.String.is_infix ~affix:s line then raise (Stunnel_error s) + ) -let diagnose_failure st_proc = +let check_stunnel_logfile logfile = let check_line line = - !stunnel_logger line ; - check_verify_error line ; - check_error "Connection refused" line ; - check_error "No host resolved" line ; - check_error "No route to host" line ; - check_error "Invalid argument" line + !stunnel_logger line ; check_verify_error line ; check_error line + in + Unixext.readfile_line check_line logfile + +let diagnose_failure st_proc = check_stunnel_logfile st_proc.logfile + +let check_stunnel_status logfile = + try Ok (check_stunnel_logfile logfile) with + | Stunnel_verify_error reason -> + Error (Stunnel_error.Certificate_verify reason) + | Stunnel_error reason -> + Error (Stunnel_error.Stunnel reason) + | e -> + Error (Stunnel_error.Stunnel (Printexc.to_string e)) + +let wait_for_init_done unix_socket_path logfile = + let has_done logfile = + let s = "Configuration successful" in + try + let content = Unixext.string_of_file logfile in + Astring.String.is_infix ~affix:s content + with e -> + D.debug "Exception when checking stunnel log file: %s" + (Printexc.to_string e) ; + false + in + let rec check ~max_retries cnt = + Thread.delay 1.0 ; + check_stunnel_logfile logfile ; + match (Sys.file_exists unix_socket_path && has_done logfile, cnt) with + | true, _ -> + () + | false, cnt when cnt > max_retries -> + raise (Stunnel_error "Timed out when initialising stunnel") + | false, cnt -> + check ~max_retries (cnt + 1) in - Unixext.readfile_line check_line st_proc.logfile + check ~max_retries:3 0 + +module UnixSocketProxy = struct + (** Handle for a long-running stunnel proxy *) + type t = {proxy_pid: pid; proxy_socket_path: string; proxy_logfile: string} + + let socket_path handle = handle.proxy_socket_path + + (** Generate a unique UNIX socket path for the stunnel proxy *) + let generate_socket_path ~remote_host ~remote_port = + let uuid = Uuidx.(to_string (make ())) in + Printf.sprintf "/tmp/stunnel-proxy-%s-%d-%s.sock" remote_host remote_port + uuid + + let diagnose handle = check_stunnel_status handle.proxy_logfile + + let start ~verify_cert ~remote_host ~remote_port ?unix_socket_path + ?socket_mode () = + try + let unix_socket_path = + match unix_socket_path with + | Some path -> + path + | None -> + generate_socket_path ~remote_host ~remote_port + in + Unixext.unlink_safe unix_socket_path ; + let write_to_log = D.debug "%s: %s" __FUNCTION__ in + let pid, logfile = + attempt_one_connect ~write_to_log ~extended_diagnosis:true + (`Unix_socket_path unix_socket_path) verify_cert remote_host + remote_port + in + wait_for_init_done unix_socket_path logfile ; + Option.iter + (fun mode -> + D.debug "chmod %s to %o" unix_socket_path mode ; + Unix.chmod unix_socket_path mode + ) + socket_mode ; + D.debug "%s: started stunnel proxy (pid:%d):%s -> %s:%d log: %s" + __FUNCTION__ (getpid pid) unix_socket_path remote_host remote_port + logfile ; + let handle = + { + proxy_pid= pid + ; proxy_socket_path= unix_socket_path + ; proxy_logfile= logfile + } + in + Ok handle + with + | Stunnel_error reason -> + Error (Stunnel_error.Stunnel reason) + | Stunnel_verify_error reason -> + Error (Stunnel_error.Certificate_verify reason) + | exn -> + Error (Stunnel_error.Stunnel (Printexc.to_string exn)) + + let stop handle = + disconnect_with_pid ~wait:false ~force:true handle.proxy_pid ; + Unixext.unlink_safe handle.proxy_socket_path ; + Unixext.unlink_safe handle.proxy_logfile ; + D.debug "%s: stopped stunnel proxy (pid:%d):%s" __FUNCTION__ + (getpid handle.proxy_pid) handle.proxy_socket_path + + let with_proxy ~verify_cert ~remote_host ~remote_port ?unix_socket_path + ?socket_mode f = + match + start ~verify_cert ~remote_host ~remote_port ?unix_socket_path + ?socket_mode () + with + | Error _ as e -> + e + | Ok handle -> + let finally = Xapi_stdext_pervasives.Pervasiveext.finally in + finally (fun () -> f handle) (fun () -> stop handle) +end + +(** Fetch the server certificate from a remote host. + Uses openssl s_client to connect and retrieve the certificate in PEM format. + This is useful for TOFU (Trust-On-First-Use) scenarios. *) +let fetch_server_cert ~remote_host ~remote_port = + try + let openssl = !Constants.openssl_path in + (* First get the certificate with s_client *) + let s_client_args = + [ + "s_client" + ; "-connect" + ; Printf.sprintf "%s:%d" remote_host remote_port + ; "-showcerts" + ] + in + let cert_output, _ = + Forkhelpers.execute_command_get_output_send_stdin openssl s_client_args "" + in + (* Then parse it with x509 to get PEM format *) + let x509_args = ["x509"; "-outform"; "PEM"] in + let pem_output, _ = + Forkhelpers.execute_command_get_output_send_stdin openssl x509_args + cert_output + in + if + String.length pem_output > 0 + && Astring.String.is_infix ~affix:"BEGIN CERTIFICATE" pem_output + then + Some (String.trim pem_output) + else + None + with _ -> None (* If we reach here the whole stunnel log should have been gone through (possibly printed/logged somewhere. No necessity to raise an exception, diff --git a/ocaml/libs/stunnel/stunnel.mli b/ocaml/libs/stunnel/stunnel.mli index 855f7082798..5d7d2562e1e 100644 --- a/ocaml/libs/stunnel/stunnel.mli +++ b/ocaml/libs/stunnel/stunnel.mli @@ -102,3 +102,80 @@ val with_client_proxy_systemd_service : -> service:string -> (unit -> 'a) -> 'a + +module UnixSocketProxy : sig + (** Handle for a long-running stunnel proxy that exposes TLS connection + via a UNIX socket file. + This module allows to create stunnel clients. But in XAPI, if you are + finding a stunnel client to use, you probably should use stunnel_cache.ml. + Stunnel instances there are managed and reused. + *) + type t + + val socket_path : t -> string + (** Get the UNIX socket file path for connecting to the proxy. + Use this path with HTTP clients (curl, urllib, etc.) to send traffic + through the TLS tunnel. *) + + val start : + verify_cert:verification_config option + -> remote_host:string + -> remote_port:int + -> ?unix_socket_path:string + -> ?socket_mode:int + -> unit + -> (t, Stunnel_error.t) result + (** Start a long-running stunnel proxy listening on a UNIX socket. + Returns [Ok handle] if stunnel starts successfully. The handle MUST be + stopped with [stop] when no longer needed. + Returns [Error] if stunnel fails to start, initialize. + If [unix_socket_path] is not provided, a unique path will be generated + automatically in /tmp with the format: + stunnel-proxy-{host}-{port}-{uuid}.sock + If [socket_mode] is provided (e.g., [~socket_mode:0o666]), the socket + file permissions will be set accordingly after creation using chmod. + + Use example: + let stunnel_proxy = + Stunnel.UnixSocketProxy.start ~verify_cert ~remote_host ~remote_port () + in + match stunnel_proxy with + | Error e -> (* handle error *) + | Ok proxy_handle -> + let socket_path = Stunnel.UnixSocketProxy.socket_path proxy_handle in + (* use socket_path with HTTP clients *) + ... + Stunnel.UnixSocketProxy.diagnose proxy_handle |> function + | Ok () -> (* all good *) + | Error err -> (* handle connection errors *) + ... + Stunnel.UnixSocketProxy.stop proxy_handle (* clean up when done *) + *) + + val stop : t -> unit + (** Stop a running stunnel proxy and clean up resources. + This kills the stunnel process and removes the socket and log files. *) + + val diagnose : t -> (unit, Stunnel_error.t) result + (** Diagnose the status of a running stunnel proxy by checking its logfile. + Returns [Ok ()] if no new errors found, [Error] with details otherwise. *) + + val with_proxy : + verify_cert:verification_config option + -> remote_host:string + -> remote_port:int + -> ?unix_socket_path:string + -> ?socket_mode:int + -> (t -> ('a, Stunnel_error.t) result) + -> ('a, Stunnel_error.t) result + (** Start a proxy, execute a function with it, and automatically stop it. + The proxy is guaranteed to be stopped even if the function raises an exception. + If [unix_socket_path] is not provided, a unique path will be generated. + If [socket_mode] is provided, stunnel will set the socket file permissions. + This is the preferred way for short-lived proxies. *) +end + +val fetch_server_cert : remote_host:string -> remote_port:int -> string option +(** Fetch the server certificate from a remote host. + Uses openssl s_client to connect and retrieve the certificate in PEM format. + This is useful for TOFU (Trust-On-First-Use) scenarios. *) diff --git a/ocaml/libs/stunnel/stunnel_client.ml b/ocaml/libs/stunnel/stunnel_client.ml index aa9391d613e..db3b0289a7f 100644 --- a/ocaml/libs/stunnel/stunnel_client.ml +++ b/ocaml/libs/stunnel/stunnel_client.ml @@ -37,3 +37,47 @@ let world () = get_verification_config Stunnel.world let external_host cert_file = Stunnel.external_host cert_file |> get_verification_config + +let construct_cert_verification ~purpose = + let open Stunnel in + let base_dir = Constants.trusted_certs_by_purpose_dir in + let pinned_prefix = Constants.trusted_certs_pinned_prefix in + let root_prefix = Constants.trusted_certs_root_prefix in + let pinned_pem = + Printf.sprintf "%s/%s-%s.pem" base_dir pinned_prefix purpose + in + let chain_pem = Printf.sprintf "%s/%s-%s.pem" base_dir root_prefix purpose in + let general_pem = Printf.sprintf "%s/%s-general.pem" base_dir root_prefix in + match + ( Sys.file_exists pinned_pem + , Sys.file_exists chain_pem + , Sys.file_exists general_pem + ) + with + | true, _, _ -> + Some + { + sni= None + ; verify= VerifyPeer + ; cert_bundle_path= pinned_pem + ; crl_dir= None + } + | false, true, _ -> + Some + { + sni= None + ; verify= CheckHost + ; cert_bundle_path= chain_pem + ; crl_dir= None + } + | false, false, true -> + Some + { + sni= None + ; verify= CheckHost + ; cert_bundle_path= general_pem + ; crl_dir= None + } + | false, false, false -> + D.debug "%s: No cert bundle found for purpose %s" __FUNCTION__ purpose ; + None diff --git a/ocaml/libs/stunnel/stunnel_client.mli b/ocaml/libs/stunnel/stunnel_client.mli index ab9cb297e65..3510d1bea30 100644 --- a/ocaml/libs/stunnel/stunnel_client.mli +++ b/ocaml/libs/stunnel/stunnel_client.mli @@ -33,3 +33,6 @@ val external_host : string -> Stunnel.verification_config option (** [external_host path] returns the configuration that's meant to be used to connect to a xapi hosts outside the pool. This is useful, for example, to provide an update repository to download updates from. *) + +val construct_cert_verification : + purpose:string -> Stunnel.verification_config option diff --git a/ocaml/libs/stunnel/stunnel_error.ml b/ocaml/libs/stunnel/stunnel_error.ml new file mode 100644 index 00000000000..4e373fc4add --- /dev/null +++ b/ocaml/libs/stunnel/stunnel_error.ml @@ -0,0 +1,23 @@ +(* + * Copyright (c) Cloud Software Group, 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. + *) + +(** Stunnel error types shared between modules *) + +type t = Certificate_verify of string | Stunnel of string + +let to_string = function + | Certificate_verify s -> + "Certificate verification errors: " ^ s + | Stunnel s -> + "Stunnel error: " ^ s diff --git a/ocaml/libs/stunnel/stunnel_error.mli b/ocaml/libs/stunnel/stunnel_error.mli new file mode 100644 index 00000000000..3b132eeb6e1 --- /dev/null +++ b/ocaml/libs/stunnel/stunnel_error.mli @@ -0,0 +1,23 @@ +(* + * Copyright (c) Cloud Software Group, 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. + *) + +(** Shared error types for stunnel operations *) + +type t = + | Certificate_verify of string + (** Certificate verification failed with the reason *) + | Stunnel of string (** Stunnel process error with description *) + +val to_string : t -> string +(** Convert error to human-readable string *) diff --git a/ocaml/xapi-consts/constants.ml b/ocaml/xapi-consts/constants.ml index a094f959803..1976c71b764 100644 --- a/ocaml/xapi-consts/constants.ml +++ b/ocaml/xapi-consts/constants.ml @@ -470,3 +470,9 @@ let default_ssh_enabled_timeout = 0L let default_console_idle_timeout = 0L let default_ssh_auto_mode = false + +let trusted_certs_by_purpose_dir = "/etc/trusted-certs" + +let trusted_certs_root_prefix = "ca-bundle" + +let trusted_certs_pinned_prefix = "pinned-bundle" diff --git a/ocaml/xapi/certificates.ml b/ocaml/xapi/certificates.ml index 5e22c9d2c04..2adf2774f6e 100644 --- a/ocaml/xapi/certificates.ml +++ b/ocaml/xapi/certificates.ml @@ -64,7 +64,7 @@ let library_path = function | CRL -> Stunnel.crl_path | Root _ | Pinned _ -> - !Xapi_globs.trusted_certs_by_purpose_dir + Constants.trusted_certs_by_purpose_dir let ( // ) = Filename.concat @@ -101,7 +101,8 @@ let trusted_store_locations kind = (fun p -> { cert_dir= parent // ps "ca-%s" p - ; bundle= Some (parent, ps "ca-bundle-%s.pem" p) + ; bundle= + Some (parent, ps "%s-%s.pem" Constants.trusted_certs_root_prefix p) } ) (of_purposes purposes) @@ -110,7 +111,9 @@ let trusted_store_locations kind = (fun p -> { cert_dir= parent // ps "pinned-%s" p - ; bundle= Some (parent, ps "pinned-bundle-%s.pem" p) + ; bundle= + Some + (parent, ps "%s-%s.pem" Constants.trusted_certs_pinned_prefix p) } ) (of_purposes purposes) diff --git a/ocaml/xapi/xapi_globs.ml b/ocaml/xapi/xapi_globs.ml index 2c244ea0bf7..18aeba14d76 100644 --- a/ocaml/xapi/xapi_globs.ml +++ b/ocaml/xapi/xapi_globs.ml @@ -799,8 +799,6 @@ let c_rehash = ref "/usr/bin/c_rehash" let trusted_certs_dir = ref "/etc/stunnel/certs" -let trusted_certs_by_purpose_dir = ref "/etc/trusted-certs" - let trusted_pool_certs_dir = ref "/etc/stunnel/certs-pool" let stunnel_bundle_path = ref "/etc/stunnel/xapi-stunnel-ca-bundle.pem" From 18dde795f691856b6c5cdee038d1abd0e9632e3e Mon Sep 17 00:00:00 2001 From: Changlei Li Date: Wed, 4 Feb 2026 15:09:13 +0800 Subject: [PATCH 24/28] Improve certificate_verity errors (cherry-pick from commit 04304753a4483f1757e62810aac45af6c5dcf1c8) Currently, the verify_error relies on "certificate verify failed" and "No certificate or private key specified" in the stunnel log file. In fact, "No certificate or private key specified" is a normal log for stunnel_proxy. It happens on stunnel configuration fail with verbose log enabled. We can remove it and it is covered by "Configuration failed". For "certificate verify failed", it is a indicator for certificate verify fail, but the detail reasons is in previous lines like "CERT: Pre-verification error: unable to get local issuer certificate" "CERT: Subject checks failed". So the "CERT: " line is collected, if "certificate verify failed" is found, the details can be raised out as reason. Signed-off-by: Changlei Li --- ocaml/libs/stunnel/stunnel.ml | 37 ++++++++++++++--------------------- 1 file changed, 15 insertions(+), 22 deletions(-) diff --git a/ocaml/libs/stunnel/stunnel.ml b/ocaml/libs/stunnel/stunnel.ml index 3d59681dd76..f724eefddae 100644 --- a/ocaml/libs/stunnel/stunnel.ml +++ b/ocaml/libs/stunnel/stunnel.ml @@ -509,33 +509,19 @@ let with_client_proxy_systemd_service ~verify_cert ~remote_host ~remote_port ) (fun () -> Unixext.unlink_safe conf_path) -let check_verify_error line = - let sub_after i s = - let len = String.length s in - String.sub s i (len - i) - in - let split_1 c s = - match Astring.String.cut ~sep:c s with Some (x, _) -> x | None -> s - in +let check_verify_error cert_errors line = (* When verified with a mismatched certificate, one line of log from stunnel * would look like: SSL_connect: ssl/statem/statem_clnt.c:1889: error:0A000086:SSL routines::certificate verify failed + * The detailed reason would be in previous lines of log, which we have collected + * in cert_errors parameter. For example: + CERT: Pre-verification error: unable to get local issuer certificate + CERT: Subject checks failed * in this case, Stunnel_verify_error can be raised with detailed error as * reason if it can found in the log *) if Astring.String.is_infix ~affix:"certificate verify failed" line then - match Astring.String.find_sub ~sub:"error:" line with - | Some e -> - raise - (Stunnel_verify_error - (split_1 "," (sub_after (e + String.length "error:") line)) - ) - | None -> - raise (Stunnel_verify_error "") - else if - Astring.String.is_infix ~affix:"No certificate or private key specified" - line - then - raise (Stunnel_verify_error "The specified certificate is corrupt") + let err_msg = String.concat "; " cert_errors in + raise (Stunnel_verify_error err_msg) else () @@ -553,8 +539,15 @@ let check_error line = ) let check_stunnel_logfile logfile = + let cert_errors = ref [] in let check_line line = - !stunnel_logger line ; check_verify_error line ; check_error line + !stunnel_logger line ; + Astring.String.cut ~rev:true ~sep:"CERT: " line + |> Option.iter (fun (_, cert_error) -> + cert_errors := cert_error :: !cert_errors + ) ; + check_verify_error !cert_errors line ; + check_error line in Unixext.readfile_line check_line logfile From bc7299039fa70b9beddcee8c52615ba7d3dbce03 Mon Sep 17 00:00:00 2001 From: Changlei Li Date: Wed, 4 Feb 2026 16:02:18 +0800 Subject: [PATCH 25/28] Support check stunnel log with input channel (cherry-pick from commit 9e8f41a6801a198fefb6a6d57a10279b57372e69) In long time running proxy, every time to call diagnose need to read entire the stunnel log. It is inficient. Store the input channel of log file in the proxy t, then the diagnose can read the log from position after the last it is called. Signed-off-by: Changlei Li --- ocaml/libs/stunnel/stunnel.ml | 201 +++++++++------------ ocaml/libs/stunnel/stunnel.mli | 3 + ocaml/libs/stunnel/stunnel_log_scanner.ml | 112 ++++++++++++ ocaml/libs/stunnel/stunnel_log_scanner.mli | 73 ++++++++ 4 files changed, 274 insertions(+), 115 deletions(-) create mode 100644 ocaml/libs/stunnel/stunnel_log_scanner.ml create mode 100644 ocaml/libs/stunnel/stunnel_log_scanner.mli diff --git a/ocaml/libs/stunnel/stunnel.ml b/ocaml/libs/stunnel/stunnel.ml index f724eefddae..70e0b40f37a 100644 --- a/ocaml/libs/stunnel/stunnel.ml +++ b/ocaml/libs/stunnel/stunnel.ml @@ -509,86 +509,24 @@ let with_client_proxy_systemd_service ~verify_cert ~remote_host ~remote_port ) (fun () -> Unixext.unlink_safe conf_path) -let check_verify_error cert_errors line = - (* When verified with a mismatched certificate, one line of log from stunnel - * would look like: - SSL_connect: ssl/statem/statem_clnt.c:1889: error:0A000086:SSL routines::certificate verify failed - * The detailed reason would be in previous lines of log, which we have collected - * in cert_errors parameter. For example: - CERT: Pre-verification error: unable to get local issuer certificate - CERT: Subject checks failed - * in this case, Stunnel_verify_error can be raised with detailed error as - * reason if it can found in the log *) - if Astring.String.is_infix ~affix:"certificate verify failed" line then - let err_msg = String.concat "; " cert_errors in - raise (Stunnel_verify_error err_msg) - else - () - -let check_error line = - [ - "Configuration failed" - ; "Connection refused" - ; "No host resolved" - ; "No route to host" - ; "Invalid argument" - ; "Address already in use" - ] - |> List.iter (fun s -> - if Astring.String.is_infix ~affix:s line then raise (Stunnel_error s) - ) - -let check_stunnel_logfile logfile = - let cert_errors = ref [] in - let check_line line = - !stunnel_logger line ; - Astring.String.cut ~rev:true ~sep:"CERT: " line - |> Option.iter (fun (_, cert_error) -> - cert_errors := cert_error :: !cert_errors - ) ; - check_verify_error !cert_errors line ; - check_error line - in - Unixext.readfile_line check_line logfile - -let diagnose_failure st_proc = check_stunnel_logfile st_proc.logfile - -let check_stunnel_status logfile = - try Ok (check_stunnel_logfile logfile) with - | Stunnel_verify_error reason -> - Error (Stunnel_error.Certificate_verify reason) - | Stunnel_error reason -> - Error (Stunnel_error.Stunnel reason) - | e -> - Error (Stunnel_error.Stunnel (Printexc.to_string e)) - -let wait_for_init_done unix_socket_path logfile = - let has_done logfile = - let s = "Configuration successful" in - try - let content = Unixext.string_of_file logfile in - Astring.String.is_infix ~affix:s content - with e -> - D.debug "Exception when checking stunnel log file: %s" - (Printexc.to_string e) ; - false - in - let rec check ~max_retries cnt = - Thread.delay 1.0 ; - check_stunnel_logfile logfile ; - match (Sys.file_exists unix_socket_path && has_done logfile, cnt) with - | true, _ -> - () - | false, cnt when cnt > max_retries -> - raise (Stunnel_error "Timed out when initialising stunnel") - | false, cnt -> - check ~max_retries (cnt + 1) - in - check ~max_retries:3 0 +let diagnose_failure st_proc = + Unixext.with_input_channel st_proc.logfile @@ fun ic -> + match Stunnel_log_scanner.check_stunnel_logfile ~ic !stunnel_logger with + | Error (Stunnel_error.Certificate_verify reason) -> + raise (Stunnel_verify_error reason) + | Error (Stunnel_error.Stunnel reason) -> + raise (Stunnel_error reason) + | _ -> + () module UnixSocketProxy = struct (** Handle for a long-running stunnel proxy *) - type t = {proxy_pid: pid; proxy_socket_path: string; proxy_logfile: string} + type t = { + proxy_pid: pid + ; proxy_socket_path: string + ; proxy_logfile: string + ; proxy_log_ic: in_channel + } let socket_path handle = handle.proxy_socket_path @@ -598,54 +536,87 @@ module UnixSocketProxy = struct Printf.sprintf "/tmp/stunnel-proxy-%s-%d-%s.sock" remote_host remote_port uuid - let diagnose handle = check_stunnel_status handle.proxy_logfile + let diagnose handle = + let ic = handle.proxy_log_ic in + Stunnel_log_scanner.check_stunnel_logfile ~ic (fun s -> !stunnel_logger s) let start ~verify_cert ~remote_host ~remote_port ?unix_socket_path ?socket_mode () = - try - let unix_socket_path = - match unix_socket_path with - | Some path -> - path - | None -> - generate_socket_path ~remote_host ~remote_port - in - Unixext.unlink_safe unix_socket_path ; - let write_to_log = D.debug "%s: %s" __FUNCTION__ in - let pid, logfile = + let ( let* ) = Result.bind in + let open Stunnel_error in + let unix_socket_path = + match unix_socket_path with + | Some path -> + path + | None -> + generate_socket_path ~remote_host ~remote_port + in + Unixext.unlink_safe unix_socket_path ; + let write_to_log = D.debug "%s: %s" __FUNCTION__ in + let* pid, logfile = + try attempt_one_connect ~write_to_log ~extended_diagnosis:true (`Unix_socket_path unix_socket_path) verify_cert remote_host remote_port - in - wait_for_init_done unix_socket_path logfile ; - Option.iter - (fun mode -> - D.debug "chmod %s to %o" unix_socket_path mode ; - Unix.chmod unix_socket_path mode - ) - socket_mode ; - D.debug "%s: started stunnel proxy (pid:%d):%s -> %s:%d log: %s" - __FUNCTION__ (getpid pid) unix_socket_path remote_host remote_port - logfile ; - let handle = - { - proxy_pid= pid - ; proxy_socket_path= unix_socket_path - ; proxy_logfile= logfile - } - in - Ok handle - with - | Stunnel_error reason -> - Error (Stunnel_error.Stunnel reason) - | Stunnel_verify_error reason -> - Error (Stunnel_error.Certificate_verify reason) - | exn -> - Error (Stunnel_error.Stunnel (Printexc.to_string exn)) + |> Result.ok + with + | Stunnel_initialisation_failed -> + Error (Stunnel "stunnel initialisation failed") + | Stunnel_error reason -> + Error (Stunnel reason) + | Stunnel_verify_error reason -> + Error (Certificate_verify reason) + | exn -> + Error (Certificate_verify (Printexc.to_string exn)) + in + let ic = open_in logfile in + let clean_up () = + close_in ic ; + disconnect_with_pid ~wait:false ~force:true pid ; + Unixext.unlink_safe unix_socket_path ; + Unixext.unlink_safe logfile + in + let* _ = + Stunnel_log_scanner.wait_for_configuration_success ~ic + |> Result.map_error (fun e -> + D.error "%s: stunnel init failed" __FUNCTION__ ; + clean_up () ; + e + ) + in + let* () = + if Sys.file_exists unix_socket_path then ( + D.debug "%s: unix socket %s created" __FUNCTION__ unix_socket_path ; + Ok () + ) else ( + D.error "%s: unix socket %s not created" __FUNCTION__ unix_socket_path ; + clean_up () ; + Error (Stunnel "stunnel failed to create unix socket") + ) + in + Option.iter + (fun mode -> + D.debug "chmod %s to %o" unix_socket_path mode ; + Unix.chmod unix_socket_path mode + ) + socket_mode ; + D.debug "%s: started stunnel proxy (pid:%d):%s -> %s:%d log: %s" + __FUNCTION__ (getpid pid) unix_socket_path remote_host remote_port logfile ; + + let handle = + { + proxy_pid= pid + ; proxy_socket_path= unix_socket_path + ; proxy_logfile= logfile + ; proxy_log_ic= ic + } + in + Ok handle let stop handle = disconnect_with_pid ~wait:false ~force:true handle.proxy_pid ; Unixext.unlink_safe handle.proxy_socket_path ; + close_in handle.proxy_log_ic ; Unixext.unlink_safe handle.proxy_logfile ; D.debug "%s: stopped stunnel proxy (pid:%d):%s" __FUNCTION__ (getpid handle.proxy_pid) handle.proxy_socket_path diff --git a/ocaml/libs/stunnel/stunnel.mli b/ocaml/libs/stunnel/stunnel.mli index 5d7d2562e1e..cf0b3919ab6 100644 --- a/ocaml/libs/stunnel/stunnel.mli +++ b/ocaml/libs/stunnel/stunnel.mli @@ -158,6 +158,9 @@ module UnixSocketProxy : sig val diagnose : t -> (unit, Stunnel_error.t) result (** Diagnose the status of a running stunnel proxy by checking its logfile. + Only checks NEW log entries since the last call to [diagnose] (or since + [start] if never called). This allows efficient monitoring of connection + failures that occur after the initial certificate verification. Returns [Ok ()] if no new errors found, [Error] with details otherwise. *) val with_proxy : diff --git a/ocaml/libs/stunnel/stunnel_log_scanner.ml b/ocaml/libs/stunnel/stunnel_log_scanner.ml new file mode 100644 index 00000000000..77cda308ad4 --- /dev/null +++ b/ocaml/libs/stunnel/stunnel_log_scanner.ml @@ -0,0 +1,112 @@ +(* + * Copyright (c) Cloud Software Group, 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. + *) + +(** Stunnel log file scanning and analysis *) + +(** Monadic bind for log_line_status composition *) +let ( >>= ) check1 check2 line = + match check1 line with None -> check2 line | r -> r + +let find ~indicators ~box line = + List.find_map + (fun ind -> + if Astring.String.is_infix ~affix:ind line then + Some (box ind) + else + None + ) + indicators + +let stunnel_error_indicators = + [ + "Configuration failed" + ; "Connection refused" + ; "No host resolved" + ; "No route to host" + ; "Invalid argument" + ; "Address already in use" + ] + +let stunnel_error_checker = + find ~indicators:stunnel_error_indicators ~box:(fun ind -> + Error (Stunnel_error.Stunnel ind) + ) + +let certificate_verify_error_indicators = ["certificate verify failed"] + +let make_check_verify_error () = + let cert_errors = ref [] in + fun line -> + (* Extract and accumulate CERT errors from the line + * examples: + * CERT: Pre-verification error: certificate has expired + * CERT: Subject checks failed *) + Astring.String.cut ~rev:true ~sep:"CERT: " line + |> Option.iter (fun (_, cert_error) -> + cert_errors := cert_error :: !cert_errors + ) ; + (* When verified with a mismatched certificate, one line of log from stunnel + * would look like: + SSL_connect: ssl/statem/statem_clnt.c:1889: error:0A000086:SSL routines::certificate verify failed + * in this case, Stunnel_verify_error can be raised with detailed error as + * reason if it can find in the log *) + find ~indicators:certificate_verify_error_indicators + ~box:(fun _ -> + Error (Stunnel_error.Certificate_verify (String.concat ";" !cert_errors)) + ) + line + +let configuration_success_indicators = ["Configuration successful"] + +let configuration_success_checker = + find ~indicators:configuration_success_indicators ~box:(fun ind -> Ok ind) + +let scan ~ic ~line_checker = + let rec loop () = + match input_line ic with + | exception End_of_file -> + None + | line -> ( + match line_checker line with None -> loop () | r -> r + ) + in + loop () + +let check_stunnel_logfile ~ic logger = + let verify_error_checker = make_check_verify_error () in + let line_checker line = + logger line ; + (verify_error_checker >>= stunnel_error_checker) line + in + match scan ~ic ~line_checker with Some (Error e) -> Error e | _ -> Ok () + +let check_stunnel_log_until_found_or_error ~ic ~line_checker interval + max_retries = + let rec check cnt = + match scan ~ic ~line_checker with + | None when cnt < max_retries -> + Thread.delay interval ; + check (cnt + 1) + | None -> + Error (Stunnel_error.Stunnel "Timed out waiting for stunnel condition") + | Some (Error e) -> + Error e + | Some (Ok ind) -> + Ok ind + in + check 1 + +let wait_for_configuration_success ~ic = + let line_checker = configuration_success_checker >>= stunnel_error_checker in + check_stunnel_log_until_found_or_error ~ic ~line_checker 1.0 3 diff --git a/ocaml/libs/stunnel/stunnel_log_scanner.mli b/ocaml/libs/stunnel/stunnel_log_scanner.mli new file mode 100644 index 00000000000..d009457be47 --- /dev/null +++ b/ocaml/libs/stunnel/stunnel_log_scanner.mli @@ -0,0 +1,73 @@ +(* + * Copyright (c) Cloud Software Group, 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. + *) + +(** Stunnel log file scanning and analysis *) + +val stunnel_error_indicators : string list +(** List of known stunnel error indicator strings *) + +val stunnel_error_checker : string -> (string, Stunnel_error.t) result option +(** Check if a log line contains common stunnel error patterns *) + +val certificate_verify_error_indicators : string list +(** List of certificate verification error indicator strings *) + +val make_check_verify_error : + unit -> string -> (string, Stunnel_error.t) result option +(** Create a stateful checker for certificate verification errors. + The returned function accumulates CERT error messages from log lines + and detects certificate verification failures. + @return A stateful checker function that maintains its own error accumulation *) + +val configuration_success_indicators : string list +(** List of configuration success indicator strings *) + +val configuration_success_checker : + string -> (string, Stunnel_error.t) result option +(** Check if a log line indicates successful configuration *) + +val scan : + ic:in_channel + -> line_checker:(string -> (string, Stunnel_error.t) result option) + -> (string, Stunnel_error.t) result option +(** Scan through an input channel line by line, applying the line checker. + Returns the first non-None result from the checker, or None if EOF is reached. *) + +val check_stunnel_logfile : + ic:in_channel -> (string -> unit) -> (unit, Stunnel_error.t) result +(** Check stunnel log file with custom line checker and logger. + This logs lines and accumulates CERT errors. + @param ic Input channel to read from + @param logger Function to log each line (e.g., for debugging) + @return Ok () if no errors found, Error with Stunnel_error.t if error detected *) + +val check_stunnel_log_until_found_or_error : + ic:in_channel + -> line_checker:(string -> (string, Stunnel_error.t) result option) + -> float + -> int + -> (string, Stunnel_error.t) result +(** Poll a stunnel log file until a condition is met or timeout. + @param ic Input channel to read from + @param line_checker Function to check each line + @param interval Delay between polling attempts (seconds) + @param max_retries Maximum number of retry attempts + @return Ok with signature string if target found, Error if error detected or timeout *) + +val wait_for_configuration_success : + ic:in_channel -> (string, Stunnel_error.t) result +(** Wait for configuration success message in stunnel log. + Polls the log file until "Configuration successful" is found or timeout. + @param ic Input channel to read from + @return Ok with success message if found, Error if timeout or error detected *) From fcce6f949bd572828ae75a0d56c80856cefe5f69 Mon Sep 17 00:00:00 2001 From: Changlei Li Date: Wed, 4 Feb 2026 17:36:43 +0800 Subject: [PATCH 26/28] Add unit test for stunnel_log_scanner (cherry-pick from commit f9abe00a738a0ce86b769b0b16a49a23a63f8678) Signed-off-by: Changlei Li --- .../stunnel/test/data/certificate_expired.log | 14 + .../test/data/certificate_self_signed.log | 14 + .../test/data/configuration_failed.log | 25 ++ .../stunnel/test/data/connection_refused.log | 11 + ocaml/libs/stunnel/test/data/empty.log | 0 .../stunnel/test/data/no_host_resolved.log | 11 + .../test/data/subject_checks_failed.log | 14 + .../test/data/successful_connection.log | 12 + ocaml/libs/stunnel/test/dune | 12 + .../stunnel/test/test_stunnel_log_scanner.ml | 266 ++++++++++++++++++ .../stunnel/test/test_stunnel_log_scanner.mli | 0 11 files changed, 379 insertions(+) create mode 100644 ocaml/libs/stunnel/test/data/certificate_expired.log create mode 100644 ocaml/libs/stunnel/test/data/certificate_self_signed.log create mode 100644 ocaml/libs/stunnel/test/data/configuration_failed.log create mode 100644 ocaml/libs/stunnel/test/data/connection_refused.log create mode 100644 ocaml/libs/stunnel/test/data/empty.log create mode 100644 ocaml/libs/stunnel/test/data/no_host_resolved.log create mode 100644 ocaml/libs/stunnel/test/data/subject_checks_failed.log create mode 100644 ocaml/libs/stunnel/test/data/successful_connection.log create mode 100644 ocaml/libs/stunnel/test/dune create mode 100644 ocaml/libs/stunnel/test/test_stunnel_log_scanner.ml create mode 100644 ocaml/libs/stunnel/test/test_stunnel_log_scanner.mli diff --git a/ocaml/libs/stunnel/test/data/certificate_expired.log b/ocaml/libs/stunnel/test/data/certificate_expired.log new file mode 100644 index 00000000000..c8baca07660 --- /dev/null +++ b/ocaml/libs/stunnel/test/data/certificate_expired.log @@ -0,0 +1,14 @@ +2026.01.09 06:01:27 LOG5[ui]: stunnel 5.60 on x86_64-koji-linux-gnu platform +2026.01.09 06:01:27 LOG5[ui]: Compiled/running with OpenSSL 3.0.9 30 May 2023 +2026.01.09 06:01:27 LOG5[ui]: Threading:PTHREAD Sockets:POLL,IPv6 TLS:ENGINE,OCSP,SNI Auth:LIBWRAP +2026.01.09 06:01:27 LOG5[ui]: Reading configuration from descriptor 8 +2026.01.09 06:01:27 LOG5[ui]: UTF-8 byte order mark not detected +2026.01.09 06:01:27 LOG5[ui]: FIPS mode disabled +2026.01.09 06:01:27 LOG5[ui]: Configuration successful +2026.01.09 06:01:28 LOG5[0]: Service [client-proxy] accepted connection from unnamed socket +2026.01.09 06:01:28 LOG5[0]: s_connect: connected 10.79.16.92:4433 +2026.01.09 06:01:28 LOG5[0]: Service [client-proxy] connected remote server from 10.79.16.89:56850 +2026.01.09 06:01:28 LOG4[0]: CERT: Pre-verification error: certificate has expired +2026.01.09 06:01:28 LOG4[0]: Rejected by CERT at depth=0: C=US, ST=California, L=San Francisco, O=MyCompany, CN=testserver +2026.01.09 06:01:28 LOG3[0]: SSL_connect: ssl/statem/statem_clnt.c:1889: error:0A000086:SSL routines::certificate verify failed +2026.01.09 06:01:28 LOG5[0]: Connection reset: 0 byte(s) sent to TLS, 0 byte(s) sent to socket diff --git a/ocaml/libs/stunnel/test/data/certificate_self_signed.log b/ocaml/libs/stunnel/test/data/certificate_self_signed.log new file mode 100644 index 00000000000..99b9a7008e4 --- /dev/null +++ b/ocaml/libs/stunnel/test/data/certificate_self_signed.log @@ -0,0 +1,14 @@ +2026.01.09 06:36:43 LOG5[ui]: stunnel 5.60 on x86_64-koji-linux-gnu platform +2026.01.09 06:36:43 LOG5[ui]: Compiled/running with OpenSSL 3.0.9 30 May 2023 +2026.01.09 06:36:43 LOG5[ui]: Threading:PTHREAD Sockets:POLL,IPv6 TLS:ENGINE,OCSP,SNI Auth:LIBWRAP +2026.01.09 06:36:43 LOG5[ui]: Reading configuration from descriptor 8 +2026.01.09 06:36:43 LOG5[ui]: UTF-8 byte order mark not detected +2026.01.09 06:36:43 LOG5[ui]: FIPS mode disabled +2026.01.09 06:36:43 LOG5[ui]: Configuration successful +2026.01.09 06:36:44 LOG5[0]: Service [client-proxy] accepted connection from unnamed socket +2026.01.09 06:36:44 LOG5[0]: s_connect: connected 10.79.16.92:4433 +2026.01.09 06:36:44 LOG5[0]: Service [client-proxy] connected remote server from 10.79.16.89:56884 +2026.01.09 06:36:44 LOG4[0]: CERT: Pre-verification error: self-signed certificate +2026.01.09 06:36:44 LOG4[0]: Rejected by CERT at depth=0: CN=testserver +2026.01.09 06:36:44 LOG3[0]: SSL_connect: ssl/statem/statem_clnt.c:1889: error:0A000086:SSL routines::certificate verify failed +2026.01.09 06:36:44 LOG5[0]: Connection reset: 0 byte(s) sent to TLS, 0 byte(s) sent to socket diff --git a/ocaml/libs/stunnel/test/data/configuration_failed.log b/ocaml/libs/stunnel/test/data/configuration_failed.log new file mode 100644 index 00000000000..b1c9ad90a89 --- /dev/null +++ b/ocaml/libs/stunnel/test/data/configuration_failed.log @@ -0,0 +1,25 @@ +[ ] Initializing inetd mode configuration +[ ] Clients allowed=500 +[.] stunnel 5.60 on x86_64-koji-linux-gnu platform +[.] Compiled/running with OpenSSL 3.0.9 30 May 2023 +[.] Threading:PTHREAD Sockets:POLL,IPv6 TLS:ENGINE,OCSP,SNI Auth:LIBWRAP +[ ] errno: (*__errno_location ()) +[ ] Initializing inetd mode configuration +[.] Reading configuration from descriptor 8 +[.] UTF-8 byte order mark not detected +[.] FIPS mode disabled +[ ] No PRNG seeding was required +[ ] Initializing service [client-proxy] +[ ] stunnel default security level set: 2 +[ ] Ciphers: ECDHE-RSA-AES256-GCM-SHA384:ECDHE-RSA-AES128-GCM-SHA256 +[ ] TLSv1.3 ciphersuites: TLS_AES_256_GCM_SHA384:TLS_AES_128_GCM_SHA256:TLS_CHACHA20_POLY1305_SHA256 +[ ] TLS options: 0x02100000 (+0x00000000, -0x00000000) +[ ] Session resumption enabled +[ ] No certificate or private key specified +[!] error queue: crypto/x509/by_file.c:234: error:05880009:x509 certificate routines::PEM lib +[!] error queue: crypto/pem/pem_info.c:169: error:0488000D:PEM routines::ASN1 lib +[!] error queue: crypto/asn1/tasn_dec.c:349: error:0688010A:asn1 encoding routines::nested asn1 error +[!] SSL_CTX_load_verify_locations: crypto/asn1/tasn_dec.c:1188: error:068000A8:asn1 encoding routines::wrong tag +[!] Service [client-proxy]: Failed to initialize TLS context +[!] Configuration failed +[ ] Deallocating temporary section defaults diff --git a/ocaml/libs/stunnel/test/data/connection_refused.log b/ocaml/libs/stunnel/test/data/connection_refused.log new file mode 100644 index 00000000000..a5b7f9911d4 --- /dev/null +++ b/ocaml/libs/stunnel/test/data/connection_refused.log @@ -0,0 +1,11 @@ +2026.01.09 05:45:23 LOG5[ui]: stunnel 5.60 on x86_64-koji-linux-gnu platform +2026.01.09 05:45:23 LOG5[ui]: Compiled/running with OpenSSL 3.0.9 30 May 2023 +2026.01.09 05:45:23 LOG5[ui]: Threading:PTHREAD Sockets:POLL,IPv6 TLS:ENGINE,OCSP,SNI Auth:LIBWRAP +2026.01.09 05:45:23 LOG5[ui]: Reading configuration from descriptor 8 +2026.01.09 05:45:23 LOG5[ui]: UTF-8 byte order mark not detected +2026.01.09 05:45:23 LOG5[ui]: FIPS mode disabled +2026.01.09 05:45:23 LOG5[ui]: Configuration successful +2026.01.09 05:45:24 LOG5[0]: Service [client-proxy] accepted connection from unnamed socket +2026.01.09 05:45:24 LOG5[0]: s_connect: connecting 192.168.1.100:443 +2026.01.09 05:45:24 LOG3[0]: s_connect: connect 192.168.1.100:443: Connection refused +2026.01.09 05:45:24 LOG5[0]: Connection reset: 0 byte(s) sent to TLS, 0 byte(s) sent to socket diff --git a/ocaml/libs/stunnel/test/data/empty.log b/ocaml/libs/stunnel/test/data/empty.log new file mode 100644 index 00000000000..e69de29bb2d diff --git a/ocaml/libs/stunnel/test/data/no_host_resolved.log b/ocaml/libs/stunnel/test/data/no_host_resolved.log new file mode 100644 index 00000000000..a524d4b7ca9 --- /dev/null +++ b/ocaml/libs/stunnel/test/data/no_host_resolved.log @@ -0,0 +1,11 @@ +2026.01.09 05:52:10 LOG5[ui]: stunnel 5.60 on x86_64-koji-linux-gnu platform +2026.01.09 05:52:10 LOG5[ui]: Compiled/running with OpenSSL 3.0.9 30 May 2023 +2026.01.09 05:52:10 LOG5[ui]: Threading:PTHREAD Sockets:POLL,IPv6 TLS:ENGINE,OCSP,SNI Auth:LIBWRAP +2026.01.09 05:52:10 LOG5[ui]: Reading configuration from descriptor 8 +2026.01.09 05:52:10 LOG5[ui]: UTF-8 byte order mark not detected +2026.01.09 05:52:10 LOG5[ui]: FIPS mode disabled +2026.01.09 05:52:10 LOG5[ui]: Configuration successful +2026.01.09 05:52:11 LOG5[0]: Service [client-proxy] accepted connection from unnamed socket +2026.01.09 05:52:11 LOG5[0]: s_connect: connecting invalid.example.com:443 +2026.01.09 05:52:11 LOG3[0]: s_connect: No host resolved +2026.01.09 05:52:11 LOG5[0]: Connection reset: 0 byte(s) sent to TLS, 0 byte(s) sent to socket diff --git a/ocaml/libs/stunnel/test/data/subject_checks_failed.log b/ocaml/libs/stunnel/test/data/subject_checks_failed.log new file mode 100644 index 00000000000..6b6f8bcc2d2 --- /dev/null +++ b/ocaml/libs/stunnel/test/data/subject_checks_failed.log @@ -0,0 +1,14 @@ +2026.01.09 05:47:45 LOG5[ui]: stunnel 5.60 on x86_64-koji-linux-gnu platform +2026.01.09 05:47:45 LOG5[ui]: Compiled/running with OpenSSL 3.0.9 30 May 2023 +2026.01.09 05:47:45 LOG5[ui]: Threading:PTHREAD Sockets:POLL,IPv6 TLS:ENGINE,OCSP,SNI Auth:LIBWRAP +2026.01.09 05:47:45 LOG5[ui]: Reading configuration from descriptor 8 +2026.01.09 05:47:45 LOG5[ui]: UTF-8 byte order mark not detected +2026.01.09 05:47:45 LOG5[ui]: FIPS mode disabled +2026.01.09 05:47:45 LOG5[ui]: Configuration successful +2026.01.09 05:47:46 LOG5[0]: Service [client-proxy] accepted connection from unnamed socket +2026.01.09 05:47:46 LOG5[0]: s_connect: connected 10.79.16.92:4433 +2026.01.09 05:47:46 LOG5[0]: Service [client-proxy] connected remote server from 10.79.16.89:56830 +2026.01.09 05:47:46 LOG4[0]: CERT: Subject checks failed +2026.01.09 05:47:46 LOG4[0]: Rejected by CERT at depth=0: C=US, ST=California, L=San Francisco, O=MyCompany, CN=testserver +2026.01.09 05:47:46 LOG3[0]: SSL_connect: ssl/statem/statem_clnt.c:1889: error:0A000086:SSL routines::certificate verify failed +2026.01.09 05:47:46 LOG5[0]: Connection reset: 0 byte(s) sent to TLS, 0 byte(s) sent to socket diff --git a/ocaml/libs/stunnel/test/data/successful_connection.log b/ocaml/libs/stunnel/test/data/successful_connection.log new file mode 100644 index 00000000000..be678f189a5 --- /dev/null +++ b/ocaml/libs/stunnel/test/data/successful_connection.log @@ -0,0 +1,12 @@ +2026.01.09 06:17:43 LOG5[ui]: stunnel 5.60 on x86_64-koji-linux-gnu platform +2026.01.09 06:17:43 LOG5[ui]: Compiled/running with OpenSSL 3.0.9 30 May 2023 +2026.01.09 06:17:43 LOG5[ui]: Threading:PTHREAD Sockets:POLL,IPv6 TLS:ENGINE,OCSP,SNI Auth:LIBWRAP +2026.01.09 06:17:43 LOG5[ui]: Reading configuration from descriptor 8 +2026.01.09 06:17:43 LOG5[ui]: UTF-8 byte order mark not detected +2026.01.09 06:17:43 LOG5[ui]: FIPS mode disabled +2026.01.09 06:17:43 LOG5[ui]: Configuration successful +2026.01.09 06:17:44 LOG5[0]: Service [client-proxy] accepted connection from unnamed socket +2026.01.09 06:17:44 LOG5[0]: s_connect: connected 10.71.212.108:8083 +2026.01.09 06:17:44 LOG5[0]: Service [client-proxy] connected remote server from 10.79.16.89:34844 +2026.01.09 06:17:45 LOG5[0]: Certificate accepted at depth=0: C=US, ST=Florida, L=Fort Lauderdale, O="Citrix Systems, Inc.", CN=*.xenrt.citrite.net +2026.01.09 06:17:45 LOG5[0]: Connection closed: 6 byte(s) sent to TLS, 519 byte(s) sent to socket diff --git a/ocaml/libs/stunnel/test/dune b/ocaml/libs/stunnel/test/dune new file mode 100644 index 00000000000..df413f4db64 --- /dev/null +++ b/ocaml/libs/stunnel/test/dune @@ -0,0 +1,12 @@ +(test + (name test_stunnel_log_scanner) + (libraries + alcotest + astring + stunnel + unix + xapi-stdext-pervasives + xapi-stdext-std + xapi-stdext-unix) + (deps + (source_tree data))) diff --git a/ocaml/libs/stunnel/test/test_stunnel_log_scanner.ml b/ocaml/libs/stunnel/test/test_stunnel_log_scanner.ml new file mode 100644 index 00000000000..970fd90d8c9 --- /dev/null +++ b/ocaml/libs/stunnel/test/test_stunnel_log_scanner.ml @@ -0,0 +1,266 @@ +(* + * Copyright (c) Cloud Software Group, 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. + *) + +open Stunnel_log_scanner + +(** Path to test data directory - relative to where dune runs the test *) +let data_dir = "data" + +(** Helper to build path to test log file *) +let log_path filename = Filename.concat data_dir filename + +(** Collect logged lines for verification *) +let make_logger () = + let lines = ref [] in + let log line = + Printf.printf "%s\n" line ; + lines := line :: !lines + in + (log, fun () -> List.rev !lines) + +let calculate_next_line logfile substring = + let lines = Xapi_stdext_unix.Unixext.read_lines ~path:logfile in + match + Xapi_stdext_std.Listext.List.find_index + (fun line -> Astring.String.is_infix ~affix:substring line) + lines + with + | Some index -> + List.nth_opt lines (index + 1) + | None -> + None + +(** Read the next line from an input channel *) +let read_next_line ic = try Some (input_line ic) with End_of_file -> None + +(** Test successful connection log *) +let test_successful_connection () = + let logfile = log_path "successful_connection.log" in + let logger, _get_lines = make_logger () in + Xapi_stdext_unix.Unixext.with_input_channel logfile @@ fun ic -> + match check_stunnel_logfile ~ic logger with + | Ok () -> + Alcotest.(check bool) + "Should reach the end of the log" true + (read_next_line ic = None) + | Error e -> + Alcotest.fail + ("Should not error on successful connection log: " + ^ Stunnel_error.to_string e + ) + +let test_certificate_verify logfile expected_substring () = + let logfile = log_path logfile in + let logger, _get_lines = make_logger () in + Xapi_stdext_unix.Unixext.with_input_channel logfile @@ fun ic -> + match check_stunnel_logfile ~ic logger with + | Error (Stunnel_error.Certificate_verify msg) -> + Alcotest.(check bool) + "Error message should contain expected substring" true + (Astring.String.is_infix ~affix:expected_substring msg) ; + let next_line = calculate_next_line logfile "certificate verify failed" in + let next_line_str = Option.value next_line ~default:"" in + Alcotest.(check bool) + ("next line should be matched: " ^ next_line_str) + true + (read_next_line ic = next_line) + | Ok () -> + Alcotest.fail "Should detect certificate verification failure" + | Error e -> + Alcotest.fail + ("Wrong error type: " + ^ Stunnel_error.to_string e + ^ ", expected certificate verify error" + ) + +let test_stunnel_error logfile expected_substring () = + let logfile = log_path logfile in + let logger, _get_lines = make_logger () in + Xapi_stdext_unix.Unixext.with_input_channel logfile @@ fun ic -> + match check_stunnel_logfile ~ic logger with + | Error (Stunnel_error.Stunnel msg) -> + Alcotest.(check string) + "Error message should be expected substring" expected_substring msg ; + let next_line = calculate_next_line logfile expected_substring in + let next_line_str = Option.value next_line ~default:"" in + Alcotest.(check bool) + ("next line should be matched: " ^ next_line_str) + true + (read_next_line ic = next_line) + | Ok () -> + Alcotest.fail "Should detect stunnel error" + | Error e -> + Alcotest.fail + ("Wrong error type: " + ^ Stunnel_error.to_string e + ^ ", expected stunnel error" + ) + +let test_wait_for_configuration_success () = + let logfile = log_path "successful_connection.log" in + Xapi_stdext_unix.Unixext.with_input_channel logfile @@ fun ic -> + match wait_for_configuration_success ~ic with + | Ok ind -> + Alcotest.(check string) + "Indicator should be expected substring" "Configuration successful" ind + | Error e -> + Alcotest.fail + ("Should detect configuration success, but got error: " + ^ Stunnel_error.to_string e + ) + +let test_wait_for_configuration_fail () = + let logfile = log_path "configuration_failed.log" in + Xapi_stdext_unix.Unixext.with_input_channel logfile @@ fun ic -> + match wait_for_configuration_success ~ic with + | Ok _ -> + Alcotest.fail "Should detect configuration failure" + | Error (Stunnel_error.Stunnel msg) -> + Alcotest.(check string) + "Should detect configuration failure" "Configuration failed" msg + | Error e -> + Alcotest.fail + ("Wrong error type: " + ^ Stunnel_error.to_string e + ^ ", expected stunnel error for configuration failure" + ) + +let test_wait_timeout_for_configuration_success () = + let logfile = log_path "empty.log" in + Xapi_stdext_unix.Unixext.with_input_channel logfile @@ fun ic -> + match + check_stunnel_log_until_found_or_error ~ic + ~line_checker:configuration_success_checker 1.0 3 + with + | Ok _ -> + Alcotest.fail "Should detect timeout waiting for configuration success" + | Error (Stunnel_error.Stunnel msg) -> + Printf.printf "Received error message: %s\n" msg ; + Alcotest.(check string) + "Should detect timeout" "Timed out waiting for stunnel condition" msg + | Error e -> + Alcotest.fail + ("Wrong error type: " + ^ Stunnel_error.to_string e + ^ ", expected stunnel error for timeout" + ) + +let file_append filename contents = + let oc = open_out_gen [Open_wronly; Open_append; Open_creat] 0o644 filename in + output_string oc contents ; close_out oc + +let with_created_logfile logfile f = + Xapi_stdext_unix.Unixext.touch_file logfile ; + Xapi_stdext_pervasives.Pervasiveext.finally + (fun () -> f logfile) + (fun () -> Xapi_stdext_unix.Unixext.unlink_safe logfile) + +let test_writing_log () = + (* Create a test log file *) + let logfile = log_path "test.log" in + let logger, get_lines = make_logger () in + let config_part = + {|2026.01.09 05:45:23 LOG5[ui]: stunnel 5.60 on x86_64-koji-linux-gnu platform +2026.01.09 05:45:23 LOG5[ui]: Compiled/running with OpenSSL 3.0.9 30 May 2023 +2026.01.09 05:45:23 LOG5[ui]: Threading:PTHREAD Sockets:POLL,IPv6 TLS:ENGINE,OCSP,SNI Auth:LIBWRAP +2026.01.09 05:45:23 LOG5[ui]: Reading configuration from descriptor 8 +2026.01.09 05:45:23 LOG5[ui]: UTF-8 byte order mark not detected +2026.01.09 05:45:23 LOG5[ui]: FIPS mode disabled +2026.01.09 05:45:23 LOG5[ui]: Configuration successful +|} + in + let connection_part = + {|2026.01.09 05:45:24 LOG5[0]: Service [client-proxy] accepted connection from unnamed socket +2026.01.09 05:45:24 LOG5[0]: s_connect: connecting 192.168.1.100:443 +2026.01.09 05:45:24 LOG3[0]: s_connect: connect 192.168.1.100:443: Connection refused +2026.01.09 05:45:24 LOG5[0]: Connection reset: 0 byte(s) sent to TLS, 0 byte(s) sent to socket +|} + in + with_created_logfile logfile @@ fun logfile -> + file_append logfile config_part ; + Xapi_stdext_unix.Unixext.with_input_channel logfile @@ fun ic -> + ( match wait_for_configuration_success ~ic with + | Ok ind -> + Alcotest.(check string) + "Indicator should be expected substring" "Configuration successful" ind + | Error e -> + Alcotest.fail + ("Should detect configuration success, but got error: " + ^ Stunnel_error.to_string e + ) + ) ; + file_append logfile connection_part ; + let next_line = calculate_next_line logfile "Configuration successful" in + let next_line_str = Option.value next_line ~default:"" in + (* test stunnel error *) + match check_stunnel_logfile ~ic logger with + | Error (Stunnel_error.Stunnel msg) -> + Alcotest.(check string) + "Error message should be expected substring" "Connection refused" msg ; + let first_line = + match get_lines () with + | first :: _ -> + first + | [] -> + "" + in + Alcotest.(check string) + ("first logged line should be matched: " ^ first_line) + next_line_str first_line + | Ok () -> + let str = String.concat "\n" (get_lines ()) in + Alcotest.fail ("Should detect stunnel error, but got: " ^ str) + | Error e -> + Alcotest.fail + ("Wrong error type: " + ^ Stunnel_error.to_string e + ^ ", expected stunnel error" + ) + +let tests = + [ + ( "test_stunnel_log_scanner" + , [ + Alcotest.test_case "successful_connection" `Quick + test_successful_connection + ; Alcotest.test_case "certificate_self_signed" `Quick + (test_certificate_verify "certificate_self_signed.log" + "self-signed certificate" + ) + ; Alcotest.test_case "certificate_expired" `Quick + (test_certificate_verify "certificate_expired.log" + "certificate has expired" + ) + ; Alcotest.test_case "subject_checks_failed" `Quick + (test_certificate_verify "subject_checks_failed.log" + "Subject checks failed" + ) + ; Alcotest.test_case "connection_refused" `Quick + (test_stunnel_error "connection_refused.log" "Connection refused") + ; Alcotest.test_case "no_host_resolved" `Quick + (test_stunnel_error "no_host_resolved.log" "No host resolved") + ; Alcotest.test_case "configuration_failed" `Quick + (test_stunnel_error "configuration_failed.log" "Configuration failed") + ; Alcotest.test_case "wait_for_configuration_success" `Quick + test_wait_for_configuration_success + ; Alcotest.test_case "wait_for_configuration_fail" `Quick + test_wait_for_configuration_fail + ; Alcotest.test_case "test_wait_timeout_for_configuration_success" `Quick + test_wait_timeout_for_configuration_success + ; Alcotest.test_case "writing_log" `Quick test_writing_log + ] + ) + ] + +let () = Alcotest.run "StunnelLogScanner" tests diff --git a/ocaml/libs/stunnel/test/test_stunnel_log_scanner.mli b/ocaml/libs/stunnel/test/test_stunnel_log_scanner.mli new file mode 100644 index 00000000000..e69de29bb2d From daef7c75fa4e08fc5b83bc5de08794b07dc7d323 Mon Sep 17 00:00:00 2001 From: Ming Lu Date: Tue, 14 Apr 2026 16:28:45 +0800 Subject: [PATCH 27/28] Bump up schema_minor_vsn to 794 Signed-off-by: Ming Lu --- ocaml/idl/datamodel_common.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ocaml/idl/datamodel_common.ml b/ocaml/idl/datamodel_common.ml index bb8413396ee..93a3fbc6fe3 100644 --- a/ocaml/idl/datamodel_common.ml +++ b/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 = 793 +let schema_minor_vsn = 794 (* Historical schema versions just in case this is useful later *) let rio_schema_major_vsn = 5 From 4c48602ba471fcd9d3778c3f048fb525fbab57c7 Mon Sep 17 00:00:00 2001 From: Ming Lu Date: Wed, 22 Apr 2026 07:12:16 +0000 Subject: [PATCH 28/28] Update datamodel_lifecycle for feature/trusted-certs Signed-off-by: Ming Lu --- ocaml/idl/datamodel_lifecycle.ml | 10 ++++++++++ 1 file changed, 10 insertions(+) diff --git a/ocaml/idl/datamodel_lifecycle.ml b/ocaml/idl/datamodel_lifecycle.ml index f60c057a15b..20aa69fc973 100644 --- a/ocaml/idl/datamodel_lifecycle.ml +++ b/ocaml/idl/datamodel_lifecycle.ml @@ -69,6 +69,8 @@ let prototyped_of_field = function Some "24.23.0" | "Repository", "gpgkey_path" -> Some "22.12.0" + | "Certificate", "purpose" -> + Some "26.1.9-next" | "Certificate", "fingerprint_sha1" -> Some "24.20.0" | "Certificate", "fingerprint_sha256" -> @@ -289,6 +291,14 @@ let prototyped_of_message = function Some "25.22.0" | "VM", "set_groups" -> Some "24.19.1" + | "pool", "exchange_crls_on_join" -> + Some "26.1.9-next" + | "pool", "exchange_trusted_certificates_on_join" -> + Some "26.1.9-next" + | "pool", "uninstall_trusted_certificate" -> + Some "26.1.9-next" + | "pool", "install_trusted_certificate" -> + Some "26.1.9-next" | "pool", "set_ssh_auto_mode" -> Some "25.27.0" | "pool", "set_console_idle_timeout" ->