Client: allow custom headers when calling the remote signer

src/lib_rpc_http/RPC_client.ml

@@ -223,8 +223,8 @@ let request_failed meth uri error =
 type content_type = (string * string)
 type content = Cohttp_lwt.Body.t * content_type option * Media_type.t option
 
-let generic_call ?logger ?accept ?body ?media meth uri : (content, content) RPC_context.rest_result Lwt.t =
+let generic_call ?logger ?headers ?accept ?body ?media meth uri : (content, content) RPC_context.rest_result Lwt.t =
-  Client.generic_call meth ?logger ?accept ?body ?media uri >>= function
+  Client.generic_call meth ?logger ?headers ?accept ?body ?media uri >>= function
   | `Ok (Some v) -> return (`Ok v)
   | `Ok None -> request_failed meth uri Empty_answer
   | `Conflict _
@@ -277,13 +277,13 @@ let handle_error meth uri (body, media, _) f =
                                      acceptable = [Media_type.(name json)] ;
                                      body })
 
-let generic_json_call ?logger ?body meth uri : (Data_encoding.json, Data_encoding.json option) RPC_context.rest_result Lwt.t =
+let generic_json_call ?logger ?headers ?body meth uri : (Data_encoding.json, Data_encoding.json option) RPC_context.rest_result Lwt.t =
   let body =
     Option.map body ~f:begin fun b ->
       (Cohttp_lwt.Body.of_string (Data_encoding.Json.to_string b))
     end in
   let media = Media_type.json in
-  generic_call meth ?logger ~accept:Media_type.[bson ; json] ?body ~media uri >>=? function
+  generic_call meth ?logger ?headers ~accept:Media_type.[bson ; json] ?body ~media uri >>=? function
   | `Ok (body, (Some ("application", "json") | None), _) -> begin
       Cohttp_lwt.Body.to_string body >>= fun body ->
       match Data_encoding.Json.from_string body with
@@ -376,21 +376,21 @@ let handle accept (meth, uri, ans) =
 
 let call_streamed_service
     (type p q i o )
-    accept ?logger ~base (service : (_,_,p,q,i,o) RPC_service.t)
+    accept ?logger ?headers ~base (service : (_,_,p,q,i,o) RPC_service.t)
     ~on_chunk ~on_close
     (params : p) (query : q) (body : i) : (unit -> unit) tzresult Lwt.t =
   Client.call_streamed_service
-    accept ?logger ~base ~on_chunk ~on_close
+    accept ?logger ?headers ~base ~on_chunk ~on_close
     service params query body >>= fun ans ->
   handle accept ans
 
 let call_service
     (type p q i o )
-    accept ?logger ~base (service : (_,_,p,q,i,o) RPC_service.t)
+    accept ?logger ?headers ~base (service : (_,_,p,q,i,o) RPC_service.t)
     (params : p)
     (query : q) (body : i) : o tzresult Lwt.t =
   Client.call_service
-    ?logger ~base accept service params query body >>= fun ans ->
+    ?logger ?headers ~base accept service params query body >>= fun ans ->
   handle accept ans
 
 type config = {
@@ -404,7 +404,7 @@ let config_encoding =
   let open Data_encoding in
   conv
     (fun { host ; port ; tls } -> (host, port, tls))
-    (fun (host, port, tls) -> { host ; port ; tls ; logger = null_logger})
+    (fun (host, port, tls) -> { host ; port ; tls ; logger = null_logger })
     (obj3
        (req "host" string)
        (req "port" uint16)

src/lib_rpc_http/RPC_client.mli

@@ -63,6 +63,7 @@ type error +=
 val call_service :
   Media_type.t list ->
   ?logger:logger ->
+  ?headers:(string * string) list ->
   base:Uri.t ->
   ([< Resto.meth ], unit, 'p, 'q, 'i, 'o) RPC_service.t ->
   'p -> 'q -> 'i -> 'o tzresult Lwt.t
@@ -70,6 +71,7 @@ val call_service :
 val call_streamed_service :
   Media_type.t list ->
   ?logger:logger ->
+  ?headers:(string * string) list ->
   base:Uri.t ->
   ([< Resto.meth ], unit, 'p, 'q, 'i, 'o) RPC_service.t ->
   on_chunk: ('o -> unit) ->
@@ -78,6 +80,7 @@ val call_streamed_service :
 
 val generic_json_call :
   ?logger:logger ->
+  ?headers:(string * string) list ->
   ?body:Data_encoding.json ->
   [< RPC_service.meth ] -> Uri.t ->
   (Data_encoding.json, Data_encoding.json option) RPC_context.rest_result Lwt.t
@@ -87,6 +90,7 @@ type content = Cohttp_lwt.Body.t * content_type option * Media_type.t option
 
 val generic_call :
   ?logger:logger ->
+  ?headers:(string * string) list ->
   ?accept:Media_type.t list ->
   ?body:Cohttp_lwt.Body.t ->
   ?media:Media_type.t ->

src/lib_signer_backends/http_gen.ml

@@ -26,7 +26,28 @@ module Make(N : sig val scheme : string end) = struct
     let description =
       "Valid locators are of this form:\n"
       ^ " - " ^ scheme ^ "://host/tz1...\n"
-      ^ " - " ^ scheme ^ "://host:port/path/to/service/tz1..."
+      ^ " - " ^ scheme ^ "://host:port/path/to/service/tz1...\n"
+      ^ "Environment variable TEZOS_SIGNER_HTTP_HEADERS can be specified \
+         to add headers to the requests (only custom 'x-...' headers are supported)."
+
+    let headers = match Sys.getenv_opt "TEZOS_SIGNER_HTTP_HEADERS" with
+      | None -> None
+      | Some contents ->
+          let lines = String.split_on_char '\n' contents in
+          Some
+            (List.fold_left (fun acc line ->
+                 match String.index_opt line ':' with
+                 | None ->
+                     Pervasives.failwith
+                       "Http signer: invalid TEZOS_SIGNER_HTTP_HEADERS environment variable, missing colon"
+                 | Some pos ->
+                     let header = String.trim (String.sub line 0 pos) in
+                     if String.length header < 2
+                     || String.sub (String.lowercase_ascii header) 0 2 <> "x-" then
+                       Pervasives.failwith
+                         "Http signer: invalid TEZOS_SIGNER_HTTP_HEADERS environment variable, only x- headers are supported" ;
+                     let value = String.trim (String.sub line (pos + 1) (String.length line - pos - 1)) in
+                     (header, value) :: acc) [] lines)
 
     let parse uri =
       (* extract `tz1..` from the last component of the path *)
@@ -47,6 +68,7 @@ module Make(N : sig val scheme : string end) = struct
       parse (uri : pk_uri :> Uri.t) >>=? fun (base, pkh) ->
       RPC_client.call_service
         ~logger: P.logger
+        ?headers
         Media_type.all_media_types
         ~base Signer_services.public_key ((), pkh) () ()
 
@@ -66,6 +88,7 @@ module Make(N : sig val scheme : string end) = struct
             MBytes.concat "" [ Signature.bytes_of_watermark watermark ; msg ] in
       RPC_client.call_service
         ~logger: P.logger
+        ?headers
         Media_type.all_media_types
         ~base Signer_services.authorized_keys () () () >>=? fun authorized_keys ->
       begin match authorized_keys with
@@ -78,6 +101,7 @@ module Make(N : sig val scheme : string end) = struct
       end >>=? fun signature ->
       RPC_client.call_service
         ~logger: P.logger
+        ?headers
         Media_type.all_media_types
         ~base Signer_services.sign ((), pkh)
         signature