Signer: add HTTPS variant

src/bin_client/main_signer.ml

@@ -11,7 +11,8 @@ open Client_signer_remote_messages
 
 let log = Logging.Client.Sign.lwt_log_notice
 
-let run_daemon (cctxt : #Client_context_unix.unix_full) path =
+let run_socket_daemon (cctxt : #Client_context_unix.unix_full) path =
+  let open Client_signer_remote_socket in
   Connection.bind path >>=? fun (fd, display_path) ->
   let rec loop () =
     Lwt_unix.accept fd >>= fun (fd, _) ->
@@ -20,22 +21,24 @@ let run_daemon (cctxt : #Client_context_unix.unix_full) path =
         | Sign req ->
             log "Request for signing %d bytes of data for key %s, magic byte = %02X"
               (MBytes.length req.data) req.key (MBytes.get_uint8 req.data 0) >>= fun () ->
+            let encoding = result_encoding Sign.Response.encoding in
             Client_keys.alias_keys cctxt req.key >>=? begin function
               | Some (_, _, Some skloc) ->
                   log "Signing data for key %s" req.key >>= fun () ->
                   Client_keys.sign cctxt skloc req.data >>=? fun signature ->
-                  send fd Sign.Response.encoding (ok { Sign.Response.signature = signature })
+                  send fd encoding (ok { Sign.Response.signature = signature })
               | _ ->
-                  send fd Public_key.Response.encoding (error (Unkwnon_alias_key req.key)) >>=? fun _ ->
+                  send fd encoding (error (Unkwnon_alias_key req.key)) >>=? fun _ ->
                   log "Cannot get alias for key %s" req.key >>= fun () ->
                   return ()
             end
 
         | Public_key req ->
             log "Request for public key %s" req.key >>= fun () ->
+            let encoding = result_encoding Public_key.Response.encoding in
             Client_keys.alias_keys cctxt req.key >>= begin function
               | Error err ->
-                  send fd Public_key.Response.encoding (Error err) >>=? fun _ ->
+                  send fd encoding (Error err) >>=? fun _ ->
                   log "Cannot get alias for key %s" req.key >>= fun () ->
                   return ()
               | Ok value ->
@@ -45,18 +48,17 @@ let run_daemon (cctxt : #Client_context_unix.unix_full) path =
                           Signature.Public_key_hash.pp public_key_hash req.key >>= fun () ->
                         Client_keys.get_key cctxt public_key_hash >>= begin function
                           | Error err ->
-                              send fd Public_key.Response.encoding (Error err) >>=? fun _ ->
+                              send fd encoding (Error err) >>=? fun _ ->
                               log "Cannot get key %s" req.key >>= fun () ->
                               return ()
                           | Ok (_, public_key, _) ->
                               log "Send public key %a for key %s"
                                 Signature.Public_key.pp public_key req.key >>= fun () ->
-                              send fd Public_key.Response.encoding
+                              send fd encoding (ok { Public_key.Response.public_key = public_key }) >>=? fun _ ->
-                                (ok { Public_key.Response.public_key = public_key }) >>=? fun _ ->
                               return ()
                         end
                     | None -> begin
-                        send fd Public_key.Response.encoding (error (Unkwnon_alias_key req.key)) >>=? fun _ ->
+                        send fd encoding (error (Unkwnon_alias_key req.key)) >>=? fun _ ->
                         log "Cannot find key %s" req.key >>= fun () ->
                         return ()
                       end
@@ -66,17 +68,78 @@ let run_daemon (cctxt : #Client_context_unix.unix_full) path =
     loop ()
   in
   Lwt_unix.listen fd 10 ;
-  log "Accepting requests on %s" display_path >>= fun () ->
   begin match path with
-    | Tcp _ -> ()
+    | Tcp _ ->
+        log "Accepting TCP requests on %s" display_path
     | Unix path ->
         Sys.set_signal Sys.sigint (Signal_handle (fun _ ->
             Format.printf "Removing the local socket file and quitting.@." ;
             Unix.unlink path ;
             exit 0)) ;
-  end ;
+        log "Accepting UNIX requests on %s" display_path
+  end >>= fun () ->
   loop ()
 
+let run_https_daemon (cctxt : #Client_context_unix.unix_full) host port cert key =
+  let open Client_signer_remote_services in
+  base (host, port) >>=? fun (host, port) ->
+  log "Accepting HTTPS requests on port %d" port >>= fun () ->
+  let mode : Conduit_lwt_unix.server =
+    `TLS (`Crt_file_path cert, `Key_file_path key, `No_password, `Port port) in
+  let dir = RPC_directory.empty in
+  let dir =
+    RPC_directory.register0 dir
+      sign (fun () req ->
+          log "Request for signing %d bytes of data for key %s, magic byte = %02X"
+            (MBytes.length req.data) req.key (MBytes.get_uint8 req.data 0) >>= fun () ->
+          Client_keys.alias_keys cctxt req.key >>=? function
+          | Some (_, _, Some skloc) ->
+              log "Signing data for key %s" req.key >>= fun () ->
+              Client_keys.sign cctxt skloc req.data >>=? fun signature ->
+              return { Sign.Response.signature = signature }
+          | _ ->
+              fail (Unkwnon_alias_key req.key)) in
+  let dir =
+    RPC_directory.register0 dir
+      public_key (fun () req ->
+          log "Request for public key %s" req.key >>= fun () ->
+          Client_keys.alias_keys cctxt req.key >>= begin function
+            | Error err ->
+                log "Cannot get alias for key %s" req.key >>= fun () ->
+                Lwt.return (Error err)
+            | Ok value ->
+                begin match value with
+                  | Some (public_key_hash, _, _) ->
+                      log "Found public key hash %a for key %s"
+                        Signature.Public_key_hash.pp public_key_hash req.key >>= fun () ->
+                      Client_keys.get_key cctxt public_key_hash >>= begin function
+                        | Error err ->
+                            log "Cannot get key %s" req.key >>= fun () ->
+                            Lwt.return (Error err)
+                        | Ok (_, public_key, _) ->
+                            log "Send public key %a for key %s"
+                              Signature.Public_key.pp public_key req.key >>= fun () ->
+                            return { Public_key.Response.public_key = public_key }
+                      end
+                  | None -> begin
+                      log "Cannot find key %s" req.key >>= fun () ->
+                      fail (Unkwnon_alias_key req.key)
+                    end
+                end
+          end) in
+  Lwt.catch
+    (fun () ->
+       RPC_server.launch ~host mode dir
+         ~media_types:Media_type.all_media_types
+         ~cors: { allowed_origins = [ "*" ] ;
+                  allowed_headers = [ "Content-Type" ] }
+       >>= fun _server ->
+       fst (Lwt.wait ()))
+    (function
+      | Unix.Unix_error(Unix.EADDRINUSE, "bind","") ->
+          failwith "Port already in use."
+      | exn -> Lwt.return (error_exn exn))
+
 open Clic
 
 let group =
@@ -106,7 +169,7 @@ let select_commands _ _ =
                    (parameter (fun _ s -> return s))))
              (prefixes [ "launch" ; "socket" ; "signer" ] @@ stop)
              (fun (host, port) cctxt ->
-                run_daemon cctxt (Tcp (host, port))) ;
+                run_socket_daemon cctxt (Tcp (host, port))) ;
            command ~group
              ~desc: "Launch a signer daemon over a local Unix socket."
              (args1
@@ -119,7 +182,35 @@ let select_commands _ _ =
                    (parameter (fun _ s -> return s))))
              (prefixes [ "launch" ; "local" ; "signer" ] @@ stop)
              (fun path cctxt ->
-                run_daemon cctxt (Unix path))
+                run_socket_daemon cctxt (Unix path)) ;
+           command ~group
+             ~desc: "Launch a signer daemon over HTTPS."
+             (args2
+                (default_arg
+                   ~doc: "listening address or host name"
+                   ~short: 'a'
+                   ~long: "address"
+                   ~placeholder: "host|address"
+                   ~default: "$TEZOS_SIGNER_HTTPS_HOST"
+                   (parameter (fun _ s -> return s)))
+                (default_arg
+                   ~doc: "listening HTTPS port"
+                   ~short: 'p'
+                   ~long: "port"
+                   ~placeholder: "port number"
+                   ~default: "$TEZOS_SIGNER_HTTPS_PORT"
+                   (parameter (fun _ s -> return s))))
+             (prefixes [ "launch" ; "https" ; "signer" ] @@
+              param
+                ~name:"cert"
+                ~desc: "path to th TLS certificate"
+                (parameter (fun _ s -> return s)) @@
+              param
+                ~name:"key"
+                ~desc: "path to th TLS key"
+                (parameter (fun _ s -> return s)) @@ stop)
+             (fun (host, port) cert key cctxt ->
+                run_https_daemon cctxt host port cert key) ;
          ]])
 
 let () = Client_main_run.run select_commands

src/lib_client_base/client_keys.ml

@@ -183,7 +183,7 @@ let sign ?watermark cctxt ((Sk_locator { scheme }) as skloc) buf =
   Signer.neuterize t >>= fun pk ->
   Signer.public_key pk >>=? fun pubkey ->
   fail_unless
-    (Signature.check pubkey signature buf)
+    (Signature.check ?watermark pubkey signature buf)
     (Signature_mismatch skloc) >>=? fun () ->
   return signature
 

src/lib_client_base_unix/client_signer_remote.ml

@@ -10,20 +10,42 @@
 open Client_keys
 open Client_signer_remote_messages
 
-let sign conn key data =
+type path =
+  | Socket of Client_signer_remote_socket.path
+  | Https of Client_signer_remote_services.path
+
+let socket_sign path key data =
+  let open Client_signer_remote_socket in
   let req = { Sign.Request.key = key ; data } in
+  Connection.connect path >>=? fun conn ->
   send conn Request.encoding (Request.Sign req) >>=? fun () ->
-  recv conn Sign.Response.encoding >>=? function
+  let encoding = result_encoding Sign.Response.encoding in
+  recv conn encoding >>=? function
   | Error err -> Lwt.return (Error err)
   | Ok res -> Lwt_unix.close conn >>= fun () -> return res.signature
 
-let public_key conn key =
+let socket_request_public_key path key =
+  let open Client_signer_remote_socket in
   let req = { Public_key.Request.key = key } in
+  Connection.connect path >>=? fun conn ->
   send conn Request.encoding (Request.Public_key req) >>=? fun () ->
-  recv conn Public_key.Response.encoding >>=? function
+  let encoding = result_encoding Public_key.Response.encoding in
+  recv conn encoding >>=? function
   | Error err -> Lwt.return (Error err)
   | Ok res -> Lwt_unix.close conn >>= fun () -> return res.public_key
 
+let sign path key data = match path with
+  | Socket path -> socket_sign path key data
+  | Https path ->
+      Client_signer_remote_services.(call path sign) { key ; data } >>=? fun res ->
+      return res.signature
+
+let request_public_key path key = match path with
+  | Socket path -> socket_request_public_key path key
+  | Https path ->
+      Client_signer_remote_services.(call path public_key) { key } >>=? fun res ->
+      return res.public_key
+
 module Remote_signer : SIGNER = struct
   let scheme = "remote"
 
@@ -34,21 +56,22 @@ module Remote_signer : SIGNER = struct
     "Valid locators are one of these two forms:\n\
     \  - unix [path to local signer socket] <remote key alias>\n\
     \  - tcp [host] [port] <remote key alias>\n\
+    \  - https [host] [port] <remote key alias>\n\
      All fields except the key can be of the form '$VAR', \
      in which case their value is taken from environment variable \
      VAR each time the key is accessed.\n\
      Not specifiyng fields sets them to $TEZOS_SIGNER_UNIX_PATH, \
      $TEZOS_SIGNER_TCP_HOST and $TEZOS_SIGNER_TCP_PORT, \
+     $TEZOS_SIGNER_HTTPS_HOST and $TEZOS_SIGNER_HTTPS_PORT, \
      that get evaluated to default values '$HOME/.tezos-signer-socket', \
      localhost and 6732, and can be set later on."
 
-  type path =
+  type key_path = path * key
-    Client_signer_remote_messages.path * Client_signer_remote_messages.key
 
   (* secret key is the identifier of the location key identifier *)
-  type secret_key = path
+  type secret_key = key_path
   (* public key is the identifier of the location key identifier *)
-  type public_key = path * Signature.Public_key.t
+  type public_key = key_path * Signature.Public_key.t
 
   let pks : (secret_key, Signature.Public_key.t) Hashtbl.t = Hashtbl.create 53
 
@@ -57,15 +80,21 @@ module Remote_signer : SIGNER = struct
 
   let path_of_human_input = function
     | "unix" :: key :: [] ->
-        return (Unix "$TEZOS_SIGNER_UNIX_PATH", key)
+        return (Socket (Unix "$TEZOS_SIGNER_UNIX_PATH"), key)
     | "unix" :: file :: key :: [] ->
-        return (Unix file, key)
+        return (Socket (Unix file), key)
     | "tcp" :: host :: port :: key :: [] ->
-        return (Tcp (host, port), key)
+        return (Socket (Tcp (host, port)), key)
     | "tcp" :: host :: key :: [] ->
-        return (Tcp (host, "$TEZOS_SIGNER_TCP_PORT"), key)
+        return (Socket (Tcp (host, "$TEZOS_SIGNER_TCP_PORT")), key)
     | "tcp" :: key :: [] ->
-        return (Tcp ("$TEZOS_SIGNER_TCP_HOST", "$TEZOS_SIGNER_TCP_PORT"), key)
+        return (Socket (Tcp ("$TEZOS_SIGNER_TCP_HOST", "$TEZOS_SIGNER_TCP_PORT")), key)
+    | "https" :: host :: port :: key :: [] ->
+        return (Https (host, port), key)
+    | "https" :: host :: key :: [] ->
+        return (Https (host, "$TEZOS_SIGNER_HTTPS_PORT"), key)
+    | "https" :: key :: [] ->
+        return (Https ("$TEZOS_SIGNER_HTTPS_HOST", "$TEZOS_SIGNER_HTTPS_PORT"), key)
     | location ->
         failwith
           "@[<v 2>Remote Schema : wrong locator %s.@,@[<hov 0>%a@]@]"
@@ -73,8 +102,9 @@ module Remote_signer : SIGNER = struct
           Format.pp_print_text description
 
   let locator_of_path = function
-    | Unix path, key -> [ "unix" ; path ; key ]
+    | Socket (Unix path), key -> [ "unix" ; path ; key ]
-    | Tcp (host, port), key -> [ "tcp" ; host ; port ; key ]
+    | Socket (Tcp (host, port)), key -> [ "tcp" ; host ; port ; key ]
+    | Https (host, port), key -> [ "https" ; host ; port ; key ]
 
   let pk_locator_of_human_input _cctxt path =
     path_of_human_input path >>=? fun pk ->
@@ -87,8 +117,7 @@ module Remote_signer : SIGNER = struct
 
   let sk_locator_of_human_input _cctxt input =
     path_of_human_input input >>=? fun (path, key) ->
-    Connection.connect path >>=? fun conn ->
+    request_public_key path key >>=? fun pk ->
-    public_key conn key >>=? fun pk ->
     Hashtbl.replace pks (path, key) pk ;
     sk_to_locator (path,key) >>= fun locator ->
     return locator
@@ -98,8 +127,7 @@ module Remote_signer : SIGNER = struct
 
   let pk_of_locator loc =
     path_of_human_input (Public_key_locator.location loc) >>=? fun (path, key) ->
-    Connection.connect path >>=? fun conn ->
+    request_public_key path key >>=? fun pk ->
-    public_key conn key >>=? fun pk ->
     Hashtbl.replace pks (path, key) pk ;
     return ((path, key), pk)
 
@@ -111,8 +139,7 @@ module Remote_signer : SIGNER = struct
     match Hashtbl.find_opt pks sk with
     | Some pk -> Lwt.return (sk, pk)
     | None -> begin
-        (Connection.connect path >>=? fun conn ->
+        request_public_key path key >>= function
-         public_key conn key) >>= function
         | Error _ -> Lwt.fail_with "Remote : Cannot obtain public key from remote signer"
         | Ok pk -> begin
             Hashtbl.replace pks sk pk ;
@@ -123,9 +150,14 @@ module Remote_signer : SIGNER = struct
   let public_key (_, x) = return x
   let public_key_hash (_, x) = return (Signature.Public_key.hash x)
 
-  let sign (path, key) msg =
+  let sign ?watermark (path, key) msg =
-    Connection.connect path >>=? fun conn ->
+    let msg =
-    sign conn key msg
+      match watermark with
+      | None -> msg
+      | Some watermark ->
+          MBytes.concat "" [ Signature.bytes_of_watermark watermark ; msg ] in
+    sign path key msg
+
 end
 
 let () =

src/lib_client_base_unix/client_signer_remote_messages.ml

@@ -7,11 +7,7 @@
 (*                                                                        *)
 (**************************************************************************)
 
-type error +=
+type error += Unkwnon_alias_key of string
-  | Encoding_error
-  | Decoding_error
-  | Unkwnon_alias_key of string
-  | Unkwnon_request_kind
 
 let () =
   register_error_kind `Permanent
@@ -22,165 +18,14 @@ let () =
         Format.fprintf ppf "The key %s does not is not known on the remote signer" s)
     Data_encoding.(obj1 (req "value" string))
     (function Unkwnon_alias_key s -> Some s | _ -> None)
-    (fun s -> Unkwnon_alias_key s) ;
+    (fun s -> Unkwnon_alias_key s)
-  register_error_kind `Permanent
-    ~id: "signer.unknown_request_kind"
-    ~title: "Unkwnon_request_kind"
-    ~description: "A request is not not understood by the remote signer"
-    ~pp: (fun ppf () ->
-        Format.fprintf ppf "The request is not not understood by the remote signer" )
-    Data_encoding.empty
-    (function Unkwnon_request_kind -> Some () | _ -> None)
-    (fun () -> Unkwnon_request_kind) ;
-  register_error_kind `Permanent
-    ~id: "signer.encoding_error"
-    ~title: "Encoding_error"
-    ~description: "Error while encoding a request to the remote signer"
-    ~pp: (fun ppf () ->
-        Format.fprintf ppf "Could not encode a request to the remote signer")
-    Data_encoding.empty
-    (function Encoding_error -> Some () | _ -> None)
-    (fun () -> Encoding_error) ;
-  register_error_kind `Permanent
-    ~id: "signer.decoding_error"
-    ~title: "Decoding_error"
-    ~description: "Error while decoding a request to the remote signer"
-    ~pp: (fun ppf () ->
-        Format.fprintf ppf "Could not decode a request to the remote signer")
-    Data_encoding.empty
-    (function Decoding_error -> Some () | _ -> None)
-    (fun () -> Decoding_error)
 
-type path =
-  | Unix of string
-  | Tcp of string * string
 type key = string
 
-module Connection = struct
-
-  type t = Lwt_unix.file_descr
-
-  let backlog = 10
-
-  let read_env path =
-    if path <> "" && String.get path 0 = '$' then
-      try
-        return (Sys.getenv (String.sub path 1 (String.length path - 1)))
-      with
-        Not_found ->
-          match path with
-          | "$TEZOS_SIGNER_TCP_HOST" -> return "localhost"
-          | "$TEZOS_SIGNER_TCP_PORT" -> return "6732"
-          | "$TEZOS_SIGNER_UNIX_PATH" -> return (Filename.concat (Sys.getenv "HOME") ".tezos-signer-socket")
-          | _ ->
-              failwith "Remote signer location uses environment variable %s which is not bound" path
-    else return path
-
-  let catch_unix_error msg f =
-    Lwt.catch f @@ function
-    | Unix.Unix_error (err, syscall, _) ->
-        failwith "%s\nUnix error (%s): %s" msg syscall (Unix.error_message err)
-    | Failure err -> failwith "%s\n%s" msg err
-    | exn -> Lwt.fail exn
-
-  let bind path =
-    match path with
-    | Unix path ->
-        read_env path >>=? fun path ->
-        catch_unix_error ("Cannot listen on " ^ path) @@ fun () ->
-        let addr = Lwt_unix.ADDR_UNIX path in
-        let sock = Lwt_unix.socket PF_UNIX SOCK_STREAM 0 in
-        Lwt_unix.bind sock addr >>= fun () ->
-        Lwt_unix.listen sock backlog ;
-        return (sock, path)
-    | Tcp (host, port) ->
-        read_env host >>=? fun host ->
-        read_env port >>=? fun port ->
-        let full = host ^ ":" ^ port in
-        catch_unix_error ("Cannot listen on " ^ full) @@ fun () ->
-        let port = int_of_string port in
-        let host = try
-            (Unix.gethostbyname host).h_addr_list.(0)
-          with Not_found -> Pervasives.failwith ("Host " ^ host ^ " not found") in
-        let addr = Lwt_unix.ADDR_INET (host, port) in
-        let sock = Lwt_unix.socket PF_INET SOCK_STREAM 0 in
-        Lwt_unix.setsockopt sock SO_REUSEADDR true;
-        Lwt_unix.bind sock addr >>= fun () ->
-        Lwt_unix.listen sock backlog ;
-        return (sock, full)
-
-  let connect path =
-    match path with
-    | Unix path ->
-        read_env path >>=? fun path ->
-        let addr = Lwt_unix.ADDR_UNIX path in
-        let sock = Lwt_unix.socket PF_UNIX SOCK_STREAM 0 in
-        catch_unix_error ("Cannot connect to local socket " ^ path) @@ fun () ->
-        Lwt_unix.connect sock addr >>= fun () ->
-        return sock
-    | Tcp (host, port) ->
-        read_env host >>=? fun host ->
-        read_env port >>=? fun port ->
-        catch_unix_error ("Cannot connect to " ^ host ^ ":" ^ port) @@ fun () ->
-        let port = int_of_string port in
-        let host = try
-            (Unix.gethostbyname host).h_addr_list.(0)
-          with Not_found -> Pervasives.failwith ("Host " ^ host ^ " not found") in
-        let addr = Lwt_unix.ADDR_INET (host, port) in
-        let sock = Lwt_unix.socket PF_INET SOCK_STREAM 0 in
-        Lwt_unix.connect sock addr >>= fun () ->
-        return sock
-
-  let read ~len fd buf =
-    catch_unix_error "Cannot receive message" @@ fun () ->
-    Lwt_utils_unix.read_mbytes ~len fd buf >>= return
-
-  let write fd buf =
-    catch_unix_error "Cannot send message" @@ fun () ->
-    Lwt_utils_unix.write_mbytes fd buf >>= return
-
-end
-
-let message_len_size = 2
-
-let send fd encoding message =
-  let encoded_message_len =
-    Data_encoding.Binary.length encoding message in
-  fail_unless
-    (encoded_message_len < 1 lsl (message_len_size * 8))
-    Encoding_error >>=? fun () ->
-  (* len is the length of int16 plus the length of the message we want to send *)
-  let len = message_len_size + encoded_message_len in
-  let buf = MBytes.create len in
-  match Data_encoding.Binary.write
-          encoding message buf message_len_size with
-  | None ->
-      fail Encoding_error
-  | Some last ->
-      fail_unless (last = len) Encoding_error >>=? fun () ->
-      (* we set the beginning of the buf with the length of what is next *)
-      MBytes.set_int16 buf 0 encoded_message_len ;
-      Connection.write fd buf
-
-let recv fd encoding =
-  let header_buf = MBytes.create message_len_size in
-  Connection.read ~len:message_len_size fd header_buf >>=? fun () ->
-  let len = MBytes.get_uint16 header_buf 0 in
-  let buf = MBytes.create len in
-  Connection.read ~len fd buf >>=? fun () ->
-  match Data_encoding.Binary.read encoding buf 0 len with
-  | None ->
-      fail Decoding_error
-  | Some (read_len, message) ->
-      if read_len <> len then
-        fail Decoding_error
-      else
-        return message
-
 module Sign = struct
   module Request = struct
     type t = {
-      key : string ;
+      key : key ;
       data: MBytes.t ;
     }
 
@@ -203,7 +48,6 @@ module Sign = struct
 
     let encoding =
       let open Data_encoding in
-      result_encoding @@
       conv
         (fun { signature } -> (signature))
         (fun (signature)  -> { signature })
@@ -214,7 +58,7 @@ end
 module Public_key = struct
   module Request = struct
     type t = {
-      key : string
+      key : key ;
     }
 
     let encoding =
@@ -227,12 +71,11 @@ module Public_key = struct
 
   module Response = struct
     type t = {
-      public_key : Signature.Public_key.t
+      public_key : Signature.Public_key.t ;
     }
 
     let encoding =
       let open Data_encoding in
-      result_encoding @@
       conv
         (fun { public_key } -> public_key)
         (fun public_key  -> { public_key })

src/lib_client_base_unix/client_signer_remote_messages.mli

@@ -7,29 +7,14 @@
 (*                                                                        *)
 (**************************************************************************)
 
-type error +=
+type error += Unkwnon_alias_key of string
-  | Encoding_error
-  | Decoding_error
-  | Unkwnon_alias_key of string
-  | Unkwnon_request_kind
 
-type path =
-  | Unix of string
-  | Tcp of string * string
 type key = string
 
-module Connection : sig
-  type t = Lwt_unix.file_descr
-  val bind : path -> (t * string) tzresult Lwt.t
-  val connect : path -> t tzresult Lwt.t
-  val read : len:int -> t -> MBytes.t -> unit tzresult Lwt.t
-  val write : t -> MBytes.t -> unit tzresult Lwt.t
-end
-
 module Sign : sig
   module Request : sig
     type t = {
-      key : string ;
+      key : key ;
       data: MBytes.t ;
     }
     val encoding : t Data_encoding.t
@@ -38,22 +23,22 @@ module Sign : sig
     type t = {
       signature : Signature.t ;
     }
-    val encoding : t tzresult Data_encoding.t
+    val encoding : t Data_encoding.t
   end
 end
 
 module Public_key : sig
   module Request : sig
     type t = {
-      key : string
+      key : key ;
     }
     val encoding : t Data_encoding.t
   end
   module Response : sig
     type t = {
-      public_key : Signature.Public_key.t
+      public_key : Signature.Public_key.t ;
     }
-    val encoding : t tzresult Data_encoding.t
+    val encoding : t Data_encoding.t
   end
 end
 
@@ -63,6 +48,3 @@ module Request : sig
     | Public_key of Public_key.Request.t
   val encoding : t Data_encoding.t
 end
-
-val send : Connection.t -> 'a Data_encoding.t -> 'a -> unit tzresult Lwt.t
-val recv : Connection.t -> 'a Data_encoding.t -> 'a tzresult Lwt.t

src/lib_client_base_unix/client_signer_remote_services.ml

@@ -0,0 +1,62 @@
+(**************************************************************************)
+(*                                                                        *)
+(*    Copyright (c) 2014 - 2018.                                          *)
+(*    Dynamic Ledger Solutions, Inc. <contact@tezos.com>                  *)
+(*                                                                        *)
+(*    All rights reserved. No warranty, explicit or implicit, provided.   *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Client_signer_remote_messages
+
+let sign = RPC_service.post_service
+    ~description: "Sign a piece of data with a given remote key"
+    ~query: RPC_query.empty
+    ~input: Sign.Request.encoding
+    ~output: Sign.Response.encoding
+    RPC_path.(root / "sign")
+
+let public_key = RPC_service.post_service
+    ~description: "Retrieve the public key of a given remote key"
+    ~query: RPC_query.empty
+    ~input: Public_key.Request.encoding
+    ~output: Public_key.Response.encoding
+    RPC_path.(root / "public_key")
+
+type path = string * string
+
+let read_env path =
+  if path <> "" && String.get path 0 = '$' then
+    try
+      return (Sys.getenv (String.sub path 1 (String.length path - 1)))
+    with
+      Not_found ->
+        match path with
+        | "$TEZOS_SIGNER_HTTPS_HOST" -> return "localhost"
+        | "$TEZOS_SIGNER_HTTPS_PORT" -> return "5732"
+        | _ ->
+            failwith "Remote signer location uses environment variable %s which is not bound" path
+  else return path
+
+let catch_unix_error msg f =
+  Lwt.catch f @@ function
+  | Unix.Unix_error (err, syscall, _) ->
+      failwith "%s\nUnix error (%s): %s" msg syscall (Unix.error_message err)
+  | Failure err -> failwith "%s\n%s" msg err
+  | exn -> Lwt.fail exn
+
+let base (host, port) =
+  read_env host >>=? fun host ->
+  read_env port >>=? fun port ->
+  catch_unix_error "Cannot parse port" @@ fun () ->
+  return (host, int_of_string port)
+
+let call (host, port) service arg =
+  read_env host >>=? fun host ->
+  read_env port >>=? fun port ->
+  catch_unix_error "Cannot call remote service" @@ fun () ->
+  let port = int_of_string port in
+  RPC_client.call_service
+    Media_type.all_media_types
+    ~base: (Uri.of_string (Format.asprintf "https://%s:%d" host port))
+    service () () arg

src/lib_client_base_unix/client_signer_remote_services.mli

@@ -0,0 +1,23 @@
+(**************************************************************************)
+(*                                                                        *)
+(*    Copyright (c) 2014 - 2018.                                          *)
+(*    Dynamic Ledger Solutions, Inc. <contact@tezos.com>                  *)
+(*                                                                        *)
+(*    All rights reserved. No warranty, explicit or implicit, provided.   *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Client_signer_remote_messages
+
+val sign :
+  ([ `POST ], unit, unit, unit, Sign.Request.t, Sign.Response.t) RPC_service.t
+
+val public_key :
+  ([ `POST ], unit, unit, unit, Public_key.Request.t, Public_key.Response.t) RPC_service.t
+
+type path = string * string
+
+val base : path -> (string * int) tzresult Lwt.t
+
+val call :
+  path -> ([ `POST ], unit, unit, unit, 'p, 'r) RPC_service.t -> 'p -> 'r tzresult Lwt.t

src/lib_client_base_unix/client_signer_remote_socket.ml

@@ -0,0 +1,157 @@
+(**************************************************************************)
+(*                                                                        *)
+(*    Copyright (c) 2014 - 2018.                                          *)
+(*    Dynamic Ledger Solutions, Inc. <contact@tezos.com>                  *)
+(*                                                                        *)
+(*    All rights reserved. No warranty, explicit or implicit, provided.   *)
+(*                                                                        *)
+(**************************************************************************)
+
+type error +=
+  | Encoding_error
+  | Decoding_error
+
+let () =
+  register_error_kind `Permanent
+    ~id: "signer.encoding_error"
+    ~title: "Encoding_error"
+    ~description: "Error while encoding a request to the remote signer"
+    ~pp: (fun ppf () ->
+        Format.fprintf ppf "Could not encode a request to the remote signer")
+    Data_encoding.empty
+    (function Encoding_error -> Some () | _ -> None)
+    (fun () -> Encoding_error) ;
+  register_error_kind `Permanent
+    ~id: "signer.decoding_error"
+    ~title: "Decoding_error"
+    ~description: "Error while decoding a request to the remote signer"
+    ~pp: (fun ppf () ->
+        Format.fprintf ppf "Could not decode a request to the remote signer")
+    Data_encoding.empty
+    (function Decoding_error -> Some () | _ -> None)
+    (fun () -> Decoding_error)
+
+type path =
+  | Unix of string
+  | Tcp of string * string
+
+module Connection = struct
+
+  type t = Lwt_unix.file_descr
+
+  let backlog = 10
+
+  let read_env path =
+    if path <> "" && String.get path 0 = '$' then
+      try
+        return (Sys.getenv (String.sub path 1 (String.length path - 1)))
+      with
+        Not_found ->
+          match path with
+          | "$TEZOS_SIGNER_TCP_HOST" -> return "localhost"
+          | "$TEZOS_SIGNER_TCP_PORT" -> return "6732"
+          | "$TEZOS_SIGNER_UNIX_PATH" -> return (Filename.concat (Sys.getenv "HOME") ".tezos-signer-socket")
+          | _ ->
+              failwith "Remote signer location uses environment variable %s which is not bound" path
+    else return path
+
+  let catch_unix_error msg f =
+    Lwt.catch f @@ function
+    | Unix.Unix_error (err, syscall, _) ->
+        failwith "%s\nUnix error (%s): %s" msg syscall (Unix.error_message err)
+    | Failure err -> failwith "%s\n%s" msg err
+    | exn -> Lwt.fail exn
+
+  let bind path =
+    match path with
+    | Unix path ->
+        read_env path >>=? fun path ->
+        catch_unix_error ("Cannot listen on " ^ path) @@ fun () ->
+        let addr = Lwt_unix.ADDR_UNIX path in
+        let sock = Lwt_unix.socket PF_UNIX SOCK_STREAM 0 in
+        Lwt_unix.bind sock addr >>= fun () ->
+        Lwt_unix.listen sock backlog ;
+        return (sock, path)
+    | Tcp (host, port) ->
+        read_env host >>=? fun host ->
+        read_env port >>=? fun port ->
+        let full = host ^ ":" ^ port in
+        catch_unix_error ("Cannot listen on " ^ full) @@ fun () ->
+        let port = int_of_string port in
+        let host = try
+            (Unix.gethostbyname host).h_addr_list.(0)
+          with Not_found -> Pervasives.failwith ("Host " ^ host ^ " not found") in
+        let addr = Lwt_unix.ADDR_INET (host, port) in
+        let sock = Lwt_unix.socket PF_INET SOCK_STREAM 0 in
+        Lwt_unix.setsockopt sock SO_REUSEADDR true;
+        Lwt_unix.bind sock addr >>= fun () ->
+        Lwt_unix.listen sock backlog ;
+        return (sock, full)
+
+  let connect path =
+    match path with
+    | Unix path ->
+        read_env path >>=? fun path ->
+        let addr = Lwt_unix.ADDR_UNIX path in
+        let sock = Lwt_unix.socket PF_UNIX SOCK_STREAM 0 in
+        catch_unix_error ("Cannot connect to local socket " ^ path) @@ fun () ->
+        Lwt_unix.connect sock addr >>= fun () ->
+        return sock
+    | Tcp (host, port) ->
+        read_env host >>=? fun host ->
+        read_env port >>=? fun port ->
+        catch_unix_error ("Cannot connect to " ^ host ^ ":" ^ port) @@ fun () ->
+        let port = int_of_string port in
+        let host = try
+            (Unix.gethostbyname host).h_addr_list.(0)
+          with Not_found -> Pervasives.failwith ("Host " ^ host ^ " not found") in
+        let addr = Lwt_unix.ADDR_INET (host, port) in
+        let sock = Lwt_unix.socket PF_INET SOCK_STREAM 0 in
+        Lwt_unix.connect sock addr >>= fun () ->
+        return sock
+
+  let read ~len fd buf =
+    catch_unix_error "Cannot receive message" @@ fun () ->
+    Lwt_utils_unix.read_mbytes ~len fd buf >>= return
+
+  let write fd buf =
+    catch_unix_error "Cannot send message" @@ fun () ->
+    Lwt_utils_unix.write_mbytes fd buf >>= return
+
+end
+
+let message_len_size = 2
+
+let send fd encoding message =
+  let encoded_message_len =
+    Data_encoding.Binary.length encoding message in
+  fail_unless
+    (encoded_message_len < 1 lsl (message_len_size * 8))
+    Encoding_error >>=? fun () ->
+  (* len is the length of int16 plus the length of the message we want to send *)
+  let len = message_len_size + encoded_message_len in
+  let buf = MBytes.create len in
+  match Data_encoding.Binary.write
+          encoding message buf message_len_size encoded_message_len with
+  | None ->
+      fail Encoding_error
+  | Some last ->
+      fail_unless (last = len) Encoding_error >>=? fun () ->
+      (* we set the beginning of the buf with the length of what is next *)
+      MBytes.set_int16 buf 0 encoded_message_len ;
+      Connection.write fd buf
+
+let recv fd encoding =
+  let header_buf = MBytes.create message_len_size in
+  Connection.read ~len:message_len_size fd header_buf >>=? fun () ->
+  let len = MBytes.get_uint16 header_buf 0 in
+  let buf = MBytes.create len in
+  Connection.read ~len fd buf >>=? fun () ->
+  match Data_encoding.Binary.read encoding buf 0 len with
+  | None ->
+      fail Decoding_error
+  | Some (read_len, message) ->
+      if read_len <> len then
+        fail Decoding_error
+      else
+        return message

src/lib_client_base_unix/client_signer_remote_socket.mli

@@ -0,0 +1,27 @@
+(**************************************************************************)
+(*                                                                        *)
+(*    Copyright (c) 2014 - 2018.                                          *)
+(*    Dynamic Ledger Solutions, Inc. <contact@tezos.com>                  *)
+(*                                                                        *)
+(*    All rights reserved. No warranty, explicit or implicit, provided.   *)
+(*                                                                        *)
+(**************************************************************************)
+
+type error +=
+  | Encoding_error
+  | Decoding_error
+
+type path =
+  | Unix of string
+  | Tcp of string * string
+
+module Connection : sig
+  type t = Lwt_unix.file_descr
+  val bind : path -> (t * string) tzresult Lwt.t
+  val connect : path -> t tzresult Lwt.t
+  val read : len:int -> t -> MBytes.t -> unit tzresult Lwt.t
+  val write : t -> MBytes.t -> unit tzresult Lwt.t
+end
+
+val send : Connection.t -> 'a Data_encoding.t -> 'a -> unit tzresult Lwt.t
+val recv : Connection.t -> 'a Data_encoding.t -> 'a tzresult Lwt.t