Merge pull request #5317 from snwoods/private/stevenwo/CP-46804

CP-46806: Add master's cert thumbprint to header when HOST_IS_SLAVE

ocaml/xapi/api_server.ml

@@ -237,6 +237,38 @@ let callback1 ?(json_rpc_version = Jsonrpc.V1) is_json req fd call =
 
 (* debug(fmt "response = %s" response); *)
 
+let is_host_is_slave_error (response : Rpc.response) =
+  match response.contents with
+  (* RPC response returned by the rpc endpoint *)
+  | Rpc.(Enum [String x; String _]) when x = Api_errors.host_is_slave ->
+      true
+  (* RPC response returned by the jsonrpc endpoint *)
+  | Rpc.(Dict [_; ("message", String x); _]) when x = Api_errors.host_is_slave
+    ->
+      true
+  | _ ->
+      false
+
+let create_thumbprint_header req response =
+  let include_thumbprint =
+    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
+    | _ ->
+        false
+  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
+    []
+
 module Unixext = Xapi_stdext_unix.Unixext
 
 (** HTML callback that dispatches an RPC and returns the response. *)
@@ -259,13 +291,14 @@ let callback is_json req bio _ =
       else
         Xmlrpc.string_of_response response
     in
+    let thumbprint_header = create_thumbprint_header req response in
     Http_svr.response_fct req
       ~hdrs:
-        [
-          (Http.Hdr.content_type, "text/xml")
-        ; ("Access-Control-Allow-Origin", "*")
-        ; ("Access-Control-Allow-Headers", "X-Requested-With")
-        ]
+        ((Http.Hdr.content_type, "text/xml")
+        :: ("Access-Control-Allow-Origin", "*")
+        :: ("Access-Control-Allow-Headers", "X-Requested-With")
+        :: thumbprint_header
+        )
       fd
       (Int64.of_int @@ String.length response_str)
       (fun fd -> Unixext.really_write_string fd response_str |> ignore)
@@ -293,17 +326,18 @@ let jsoncallback req bio _ =
     let json_rpc_version, id, rpc =
       Jsonrpc.version_id_and_call_of_string body
     in
+    let rpc_response = callback1 ~json_rpc_version true req fd rpc in
     let response =
-      Jsonrpc.string_of_response ~id ~version:json_rpc_version
-        (callback1 ~json_rpc_version true req fd rpc)
+      Jsonrpc.string_of_response ~id ~version:json_rpc_version rpc_response
     in
+    let thumbprint_header = create_thumbprint_header req rpc_response in
     Http_svr.response_fct req
       ~hdrs:
-        [
-          (Http.Hdr.content_type, "application/json")
-        ; ("Access-Control-Allow-Origin", "*")
-        ; ("Access-Control-Allow-Headers", "X-Requested-With")
-        ]
+        ((Http.Hdr.content_type, "application/json")
+        :: ("Access-Control-Allow-Origin", "*")
+        :: ("Access-Control-Allow-Headers", "X-Requested-With")
+        :: thumbprint_header
+        )
       fd
       (Int64.of_int @@ String.length response)
       (fun fd -> Unixext.really_write_string fd response |> ignore)

ocaml/xapi/helpers.ml

@@ -2039,6 +2039,31 @@ 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 unit_test ~__context : bool =
   Pool_role.is_unit_test ()
   ||

ocaml/xapi/xapi_globs.ml

@@ -1003,6 +1003,14 @@ let prefer_nbd_attach = ref false
 (** 1 MiB *)
 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_response =
+  ref "x-xenapi-response-host-certificate-thumbprint"
+
 let xapi_globs_spec =
   [
     ( "master_connection_reset_timeout"