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. 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 53c594fb941..c90e898d274 100644 --- a/ocaml/idl/datamodel_certificate.ml +++ b/ocaml/idl/datamodel_certificate.ml @@ -30,9 +30,16 @@ 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") ] ) +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 +82,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/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 diff --git a/ocaml/idl/datamodel_errors.ml b/ocaml/idl/datamodel_errors.ml index c1b1f09e2b3..1d301c52a6f 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: @@ -1659,6 +1666,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"] @@ -1685,7 +1694,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." @@ -1701,9 +1710,26 @@ 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"] + ~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 format." () ; + 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/idl/datamodel_pool.ml b/ocaml/idl/datamodel_pool.ml index 843ed3b19c5..2c2936fe966 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" + ) ] ) @@ -1620,6 +1623,91 @@ 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:[] () + +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:[] () + +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 @@ -1719,6 +1807,10 @@ let t = ; set_ssh_enabled_timeout ; set_console_idle_timeout ; set_ssh_auto_mode + ; install_trusted_certificate + ; uninstall_trusted_certificate + ; exchange_trusted_certificates_on_join + ; exchange_crls_on_join ] ~contents: ([ diff --git a/ocaml/idl/schematest.ml b/ocaml/idl/schematest.ml index 6bd5ee9ae36..e92f9e944eb 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 = "08510322cf77e8ba10082f2e611ebb40" +let last_known_schema_hash = "ce90c659723cbcd5265e4dd856802b74" let current_schema_hash : string = let open Datamodel_types in 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 b20ed934107..9f1ba94f0d1 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-cli-server/records.ml b/ocaml/xapi-cli-server/records.ml index d7f3cdf421d..139032d9bce 100644 --- a/ocaml/xapi-cli-server/records.ml +++ b/ocaml/xapi-cli-server/records.ml @@ -5463,6 +5463,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-consts/api_errors.ml b/ocaml/xapi-consts/api_errors.ml index e796369f583..598a6fe4a9f 100644 --- a/ocaml/xapi-consts/api_errors.ml +++ b/ocaml/xapi-consts/api_errors.ml @@ -749,6 +749,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" @@ -1116,6 +1119,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" @@ -1157,6 +1163,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" @@ -1443,3 +1456,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-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/cert_distrib.ml b/ocaml/xapi/cert_distrib.ml index d31f8a1abe7..b5f9f923b29 100644 --- a/ocaml/xapi/cert_distrib.ml +++ b/ocaml/xapi/cert_distrib.ml @@ -33,7 +33,14 @@ 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 + | CRL + | RootCert of purpose list + | PinnedCert of purpose list [@@deriving sexp] type certificate_file = {filename: string; content: string} [@@deriving sexp] @@ -52,6 +59,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 @@ -103,8 +118,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 +136,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" @@ -132,24 +156,55 @@ end let string_of_file path = Unixext.read_lines ~path |> String.concat "\n" -module ApplianceProvider = struct - let store_path = !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) + +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) : (module CertificateProvider) = match typ with - | HostPoolCertificate -> + | HostPoolCert -> (module HostPoolProvider : CertificateProvider) - | ApplianceCertificate -> - (module ApplianceProvider : CertificateProvider) + | LegacyRootCert -> + (module LegacyRootProvider : CertificateProvider) + | CRL -> + (module CRLProvider : 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 *) @@ -198,7 +253,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 +268,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 -> @@ -233,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 -> @@ -355,7 +410,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 ) @@ -425,8 +480,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 @@ -442,24 +497,91 @@ 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} - ) +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 + WireProtocol.{filename; content} + ) + +let get_local_ca_certs () : WireProtocol.certificate_file list = + let@ store_path = LegacyRootProvider.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 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 + |> 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 - (g ApplianceProvider.store_path, g HostPoolProvider.store_path) + 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, _typ, (module P : CertificateProvider) = + of_db_rec category db_rec + 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 *) @@ -476,16 +598,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 = LegacyRootProvider.store_paths in local_is_missing_certificates (fun ~__context -> Db.Certificate.get_all ~__context @@ -497,9 +622,11 @@ let am_i_missing_certs ~__context : bool = None ) ) - ApplianceProvider.store_path () + 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__ @@ -510,19 +637,38 @@ 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_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 = 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 @@ -533,8 +679,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 \ @@ -557,11 +703,51 @@ 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 + +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])) + ) + +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 *) @@ -572,19 +758,18 @@ 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) ) 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) -> - let (_ : API.ref_Certificate) = - C.Db_util.add_cert ~__context ~type':(`ca name) cert + let (_ : API.ref_Certificate), _ = + C.Db_util.add_cert ~__context ~type':(`ca name) ~purpose:[] cert in () ) @@ -596,8 +781,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 = @@ -607,8 +791,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/cert_distrib.mli b/ocaml/xapi/cert_distrib.mli index 55f98745b10..e9c9e53579f 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 @@ -51,6 +55,22 @@ 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 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 diff --git a/ocaml/xapi/cert_refresh.ml b/ocaml/xapi/cert_refresh.ml index 213d0abc224..8b41a4ed941 100644 --- a/ocaml/xapi/cert_refresh.ml +++ b/ocaml/xapi/cert_refresh.ml @@ -90,13 +90,14 @@ 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) 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, @@ -125,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 f102bbd397a..5e22c9d2c04 100644 --- a/ocaml/xapi/certificates.ml +++ b/ocaml/xapi/certificates.ml @@ -29,7 +29,25 @@ 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 + +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 = + 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 @@ -41,16 +59,79 @@ 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 ( // ) = Filename.concat -let library_filename kind name = Filename.concat (library_path kind) name +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 + +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 = +let rehash path = match Sys.file_exists !Xapi_globs.c_rehash with | true -> Forkhelpers.execute_command_get_output !Xapi_globs.c_rehash [path] @@ -61,15 +142,38 @@ let rehash' path = ["rehash"; path] |> ignore -let rehash () = - mkdir_cert_path CA_Certificate ; - mkdir_cert_path CRL ; - rehash' (library_path CA_Certificate) ; - rehash' (library_path CRL) +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 update_ca_bundle () = Helpers.update_ca_bundle () +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 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 +222,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 +235,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 +245,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 +254,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 @@ -160,12 +268,18 @@ 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': - [< `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 @@ -180,6 +294,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 @@ -207,19 +326,29 @@ 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 = + 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 | `host host -> ("", 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 @@ -228,14 +357,36 @@ 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 ~not_after ~fingerprint:fingerprint_sha256 ~fingerprint_sha256 - ~fingerprint_sha1 ~name ~_type ; - debug "added cert %s under uuid=%s ref=%s" name uuid (Ref.string_of ref') ; + ~fingerprint_sha1 ~name ~_type ~purpose ; + 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 = @@ -260,9 +411,22 @@ 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 + + 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 = @@ -275,28 +439,66 @@ 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 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 = + 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 ; - 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) ; @@ -304,10 +506,18 @@ 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 ; + 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) ; @@ -318,15 +528,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 -> @@ -339,84 +540,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 - | CA_Certificate -> - sync_certs_crls CA_Certificate - (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 - -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 CA_Certificate in - let master_crls = local_list CRL in - sync_certs_all_hosts CA_Certificate ~__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 = @@ -452,3 +575,20 @@ 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 + +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 6776220df45..ea284f48a4a 100644 --- a/ocaml/xapi/certificates.mli +++ b/ocaml/xapi/certificates.mli @@ -12,7 +12,13 @@ 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 + +type category = [`Root_legacy | `CRL | `Root | `Pinned] (* Information extraction *) @@ -35,12 +41,10 @@ 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 -val pool_sync : __context:Context.t -> unit - (* Certificate installation to filesystem *) val install_server_certificate : @@ -54,23 +58,35 @@ 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 name_of_uuid : string -> string + +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 -val pool_uninstall : - t_trusted -> __context:Context.t -> name:string -> force:bool -> unit +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 + module PurposeSet : Set.S with type elt = API.certificate_purpose + val add_cert : __context:Context.t -> 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 @@ -83,4 +99,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 diff --git a/ocaml/xapi/certificates_sync.ml b/ocaml/xapi/certificates_sync.ml index 6f90c059721..2e92fcf377f 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 -> @@ -148,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/db_gc_util.ml b/ocaml/xapi/db_gc_util.ml index 80114c5400a..0789cc0c3bc 100644 --- a/ocaml/xapi/db_gc_util.ml +++ b/ocaml/xapi/db_gc_util.ml @@ -275,7 +275,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) diff --git a/ocaml/xapi/helpers.ml b/ocaml/xapi/helpers.ml index 519fc0f2948..75111ab95f8 100644 --- a/ocaml/xapi/helpers.ml +++ b/ocaml/xapi/helpers.ml @@ -2171,21 +2171,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/ocaml/xapi/message_forwarding.ml b/ocaml/xapi/message_forwarding.ml index 1d8d228cc80..e8e8befa115 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,57 @@ functor (pool_uuid ~__context self) value ; 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 + (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 = + 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 + + 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_globs.ml b/ocaml/xapi/xapi_globs.ml index fb02570e872..6c41d45bc1e 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 08ded94e240..88228301817 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,12 +1611,13 @@ 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) 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 ef4abe5cd07..56dc120087d 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 @@ -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 @@ -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 () @@ -1583,9 +1650,10 @@ let certificate_install ~__context ~name ~cert = | Ok x -> x in - pool_install CA_Certificate ~__context ~name ~cert ; - let (_ : API.ref_Certificate) = - Db_util.add_cert ~__context ~type':(`ca name) certificate + 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 +1661,8 @@ let install_ca_certificate = certificate_install let uninstall_ca_certificate ~__context ~name ~force = let open Certificates in - pool_uninstall CA_Certificate ~__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 +1672,168 @@ 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 + 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 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_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 + 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 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 = @@ -1689,51 +1913,22 @@ 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 ; + exchange_crls ~__context ~rpc ~session_id ; (* get pool db from new master so I have a backup ready if we failover to me *) ( try @@ -2190,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 diff --git a/ocaml/xapi/xapi_pool.mli b/ocaml/xapi/xapi_pool.mli index dc87e90a18e..e483d835a71 100644 --- a/ocaml/xapi/xapi_pool.mli +++ b/ocaml/xapi/xapi_pool.mli @@ -446,3 +446,32 @@ 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 + +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 + +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 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"