CP-49116: Add Sha1 support to external_certificate_thumbprint_of_master.

ocaml/idl/datamodel_certificate.ml

@@ -64,8 +64,16 @@ let t =
       ; field ~qualifier:StaticRO ~lifecycle ~ty:DateTime "not_after"
           ~default_value:(Some (VDateTime Date.never))
           "Date before which the certificate is valid"
-      ; field ~qualifier:StaticRO ~lifecycle ~ty:String "fingerprint"
+      ; field ~qualifier:StaticRO
+          ~lifecycle:
+            [(Published, rel_stockholm, ""); (Deprecated, "24.19.0", "")]
+          ~ty:String "fingerprint" ~default_value:(Some (VString ""))
+          "Use fingerprint_sha256 instead"
+      ; field ~qualifier:StaticRO ~lifecycle ~ty:String "fingerprint_sha256"
           ~default_value:(Some (VString ""))
           "The certificate's SHA256 fingerprint / hash"
+      ; field ~qualifier:StaticRO ~lifecycle ~ty:String "fingerprint_sha1"
+          ~default_value:(Some (VString ""))
+          "The certificate's SHA1 fingerprint / hash"
       ]
     ~messages:[] ()

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

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 = "6566a4091ecb3200649185730e4f185d"
+let last_known_schema_hash = "e34cd0d32cdcec7805c2d3ed4e4a0c25"
 
 let current_schema_hash : string =
   let open Datamodel_types in

ocaml/xapi-cli-server/records.ml

@@ -5237,6 +5237,12 @@ let certificate_record rpc session_id certificate =
       ; make_field ~name:"fingerprint"
           ~get:(fun () -> (x ()).API.certificate_fingerprint)
           ()
+      ; make_field ~name:"fingerprint_sha256"
+          ~get:(fun () -> (x ()).API.certificate_fingerprint_sha256)
+          ()
+      ; make_field ~name:"fingerprint_sha1"
+          ~get:(fun () -> (x ()).API.certificate_fingerprint_sha1)
+          ()
       ]
   }
 

ocaml/xapi/api_server.ml

@@ -250,24 +250,28 @@ let is_host_is_slave_error (response : Rpc.response) =
       false
 
 let create_thumbprint_header req response =
-  let include_thumbprint =
+  let hash_type_opt =
     match
       List.assoc_opt
         !Xapi_globs.cert_thumbprint_header_request
         req.Http.Request.additional_headers
     with
-    | Some x when x = !Xapi_globs.cert_thumbprint_header_value ->
-        true
+    | Some x when x = !Xapi_globs.cert_thumbprint_header_value_sha256 ->
+        Some `Sha256
+    | Some x when x = !Xapi_globs.cert_thumbprint_header_value_sha1 ->
+        Some `Sha1
     | _ ->
-        false
+        None
   in
-  if include_thumbprint && is_host_is_slave_error response then
-    Helpers.external_certificate_thumbprint_of_master ()
-    |> Option.fold ~none:[] ~some:(fun x ->
-           [(!Xapi_globs.cert_thumbprint_header_response, x)]
-       )
-  else
-    []
+  Option.bind hash_type_opt (fun hash_type ->
+      if is_host_is_slave_error response then
+        Helpers.external_certificate_thumbprint_of_master ~hash_type
+      else
+        None
+  )
+  |> Option.fold ~none:[] ~some:(fun x ->
+         [(!Xapi_globs.cert_thumbprint_header_response, x)]
+     )
 
 module Unixext = Xapi_stdext_unix.Unixext
 

ocaml/xapi/certificates.ml

@@ -66,7 +66,7 @@ let update_ca_bundle () = Helpers.update_ca_bundle ()
 let to_string = function CA_Certificate -> "CA certificate" | CRL -> "CRL"
 
 (** {pp_hash hash} outputs the hexadecimal representation of the {hash}
-    adding a semicolon between every octet, in uppercase.
+    adding a colon between every octet, in uppercase.
  *)
 let pp_hash hash =
   let hex = Hex.(show @@ of_cstruct hash) in
@@ -218,13 +218,17 @@ end = struct
     let not_before, not_after =
       dates_of_ptimes (X509.Certificate.validity certificate)
     in
-    let fingerprint =
+    let fingerprint_sha256 =
       X509.Certificate.fingerprint `SHA256 certificate |> pp_hash
     in
+    let fingerprint_sha1 =
+      X509.Certificate.fingerprint `SHA1 certificate |> pp_hash
+    in
     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 ~name ~_type ;
+      ~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') ;
     post_action () ;
     ref'

ocaml/xapi/certificates_sync.ml

@@ -32,7 +32,9 @@ let install ~__context ~host:_ ~type' cert =
 (** determine if the database is up to date by comparing the fingerprint
   of xapi-ssl.pem with the entry in the database *)
 let is_unchanged ~__context cert_ref cert =
-  let ref_hash = Db.Certificate.get_fingerprint ~__context ~self:cert_ref in
+  let ref_hash =
+    Db.Certificate.get_fingerprint_sha256 ~__context ~self:cert_ref
+  in
   let cert_hash =
     X509.Certificate.fingerprint `SHA256 cert |> Certificates.pp_hash
   in

ocaml/xapi/helpers.ml

@@ -2041,30 +2041,35 @@ let update_ca_bundle =
           )
     )
 
-let external_certificate_thumbprint_of_master ?(hash_type = `Sha256) () =
-  match hash_type with
-  | `Sha256 ->
-      Server_helpers.exec_with_new_task
-        "Get master's external certificate thumbprint" (fun __context ->
-          let master_ref = get_master ~__context in
-          let certs =
-            Db.Certificate.get_records_where ~__context
-              ~expr:
-                (And
-                   ( Eq (Field "host", Literal (Ref.string_of master_ref))
-                   , Eq (Field "type", Literal "host")
-                   )
-                )
-          in
-          match certs with
-          | [] ->
-              debug "Failed to fetch master's external certificate" ;
-              None
-          | (_, cert_record) :: _ ->
-              Some cert_record.certificate_fingerprint
-      )
-  | _ ->
-      None
+let external_certificate_thumbprint_of_master ~hash_type =
+  if List.mem hash_type [`Sha256; `Sha1] then
+    Server_helpers.exec_with_new_task
+      "Get master's external certificate thumbprint" (fun __context ->
+        let master_ref = get_master ~__context in
+        let certs =
+          Db.Certificate.get_records_where ~__context
+            ~expr:
+              (And
+                 ( Eq (Field "host", Literal (Ref.string_of master_ref))
+                 , Eq (Field "type", Literal "host")
+                 )
+              )
+        in
+        match certs with
+        | [] ->
+            debug "%s: Failed to fetch master's external certificate"
+              __FUNCTION__ ;
+            None
+        | (_, cert_record) :: _ -> (
+          match hash_type with
+          | `Sha256 ->
+              Some cert_record.certificate_fingerprint_sha256
+          | `Sha1 ->
+              Some cert_record.certificate_fingerprint_sha1
+        )
+    )
+  else
+    None
 
 let unit_test ~__context : bool =
   Pool_role.is_unit_test ()

ocaml/xapi/xapi_globs.ml

@@ -1020,7 +1020,9 @@ let max_observer_file_size = ref (1 lsl 20)
 let cert_thumbprint_header_request =
   ref "x-xenapi-request-host-certificate-thumbprint"
 
-let cert_thumbprint_header_value = ref "sha-256:master"
+let cert_thumbprint_header_value_sha256 = ref "sha-256:master"
+
+let cert_thumbprint_header_value_sha1 = ref "sha-1:master"
 
 let cert_thumbprint_header_response =
   ref "x-xenapi-response-host-certificate-thumbprint"

ocaml/xapi/xapi_pool.ml

@@ -775,7 +775,9 @@ let pre_join_checks ~__context ~rpc ~session_id ~force =
       list
       |> List.to_seq
       |> Seq.map (fun (_, record) ->
-             (record.API.certificate_name, record.API.certificate_fingerprint)
+             ( record.API.certificate_name
+             , record.API.certificate_fingerprint_sha256
+             )
          )
       |> CertMap.of_seq
     in