Signer: split main_signer.ml in multiple files

src/bin_signer/handler.ml

@@ -0,0 +1,35 @@
+(**************************************************************************)
+(*                                                                        *)
+(*    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 log = Logging.Client.Sign.lwt_log_notice
+
+let sign (cctxt : #Client_context.wallet) key data =
+  log "Request for signing %d bytes of data for key %s, magic byte = %02X"
+    (MBytes.length data)
+    key
+    (MBytes.get_uint8 data 0) >>= fun () ->
+  Client_keys.alias_keys cctxt key >>=? function
+  | None -> failwith "Unknown alias key (%s)" key
+  | Some (_, _, None) -> failwith "Unknown secret key (%s)" key
+  | Some (_, _, Some skloc) ->
+      log "Signing data for key %s" key >>= fun () ->
+      Client_keys.sign cctxt skloc data >>=? fun signature ->
+      return { Sign.Response.signature = signature }
+
+let public_key (cctxt : #Client_context.wallet) key =
+  Client_keys.alias_keys cctxt key >>=? function
+  | None -> failwith "Unkown alias key (%s)" key
+  | Some (public_key_hash, _, _) ->
+      log "Found public key hash %a for key %s"
+        Signature.Public_key_hash.pp public_key_hash key >>= fun () ->
+      Client_keys.get_key cctxt public_key_hash >>=? fun (_, public_key, _) ->
+      log "Found public key for key %s" key >>= fun () ->
+      return { Public_key.Response.public_key }

src/bin_signer/https_daemon.ml

@@ -0,0 +1,36 @@
+(**************************************************************************)
+(*                                                                        *)
+(*    Copyright (c) 2014 - 2018.                                          *)
+(*    Dynamic Ledger Solutions, Inc. <contact@tezos.com>                  *)
+(*                                                                        *)
+(*    All rights reserved. No warranty, explicit or implicit, provided.   *)
+(*                                                                        *)
+(**************************************************************************)
+
+let log = Logging.Client.Sign.lwt_log_notice
+
+let run (cctxt : #Client_context.io_wallet) ~host ~port ~cert ~key =
+  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 Client_signer_remote_services.sign begin fun () req ->
+      Handler.sign cctxt req.key req.data
+    end in
+  let dir =
+    RPC_directory.register0 dir Client_signer_remote_services.public_key begin fun () req ->
+      Handler.public_key cctxt req.key
+    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))

src/bin_signer/https_daemon.mli

@@ -0,0 +1,12 @@
+(**************************************************************************)
+(*                                                                        *)
+(*    Copyright (c) 2014 - 2018.                                          *)
+(*    Dynamic Ledger Solutions, Inc. <contact@tezos.com>                  *)
+(*                                                                        *)
+(*    All rights reserved. No warranty, explicit or implicit, provided.   *)
+(*                                                                        *)
+(**************************************************************************)
+
+val run:
+  #Client_context.io_wallet ->
+  host:string -> port:int -> cert:string -> key:string -> 'a tzresult Lwt.t

src/bin_signer/main_signer.ml

@@ -7,8 +7,6 @@
 (*                                                                        *)
 (**************************************************************************)
 
-open Client_signer_remote_messages
-
 let default_tcp_host =
   match Sys.getenv_opt "TEZOS_SIGNER_TCP_HOST" with
   | None -> "localhost"
@@ -34,212 +32,89 @@ let default_https_port =
   | None -> "443"
   | Some port -> port
 
-let log = Logging.Client.Sign.lwt_log_notice
-
-let run_socket_daemon (cctxt : #Client_context.io_wallet) path =
-  Lwt_utils_unix.Socket.bind path >>=? fun fd ->
-  let rec loop () =
-    Lwt_unix.accept fd >>= fun (fd, _) ->
-    Lwt.async (fun () ->
-        Lwt_utils_unix.Socket.recv fd Request.encoding >>=? function
-        | 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 ->
-                  Lwt_utils_unix.Socket.send fd encoding (ok { Sign.Response.signature = signature })
-              | _ ->
-                  Lwt_utils_unix.Socket.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 ->
-                  Lwt_utils_unix.Socket.send fd encoding (Error err) >>=? fun _ ->
-                  log "Cannot get alias for key %s" req.key >>= fun () ->
-                  return ()
-              | 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 ->
-                              Lwt_utils_unix.Socket.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 () ->
-                              Lwt_utils_unix.Socket.send fd encoding (ok { Public_key.Response.public_key = public_key }) >>=? fun _ ->
-                              return ()
-                        end
-                    | None -> begin
-                        Lwt_utils_unix.Socket.send fd encoding (error (Unkwnon_alias_key req.key)) >>=? fun _ ->
-                        log "Cannot find key %s" req.key >>= fun () ->
-                        return ()
-                      end
-                  end
-            end
-      );
-    loop ()
-  in
-  Lwt_unix.listen fd 10 ;
-  begin match path with
-    | Tcp (host, port) ->
-        log "Accepting TCP requests on %s:%d" host port
-    | Unix path ->
-        Sys.set_signal Sys.sigint (Signal_handle (fun _ ->
-            Format.printf "Removing the local socket file and quitting.@." ;
-            Unix.unlink path ;
-            exit 0)) ;
-        log "Accepting UNIX requests on %s" path
-  end >>= fun () ->
-  loop ()
-
-let run_https_daemon (cctxt : #Client_context.io_wallet) host port cert key =
-  let open Client_signer_remote_services in
-  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 =
   { Clic.name = "signer" ;
     title = "Commands specific to the signing daemon" }
 
-let select_commands _ _ =
+let commands =
-  return
+  Client_keys_commands.commands () @
-    (List.map
+  [ command ~group
-       (Clic.map_command
+      ~desc: "Launch a signer daemon over a TCP socket."
-          (fun (o : Client_context.full) -> (o :> Client_context.io_wallet))) @@
+      (args2
-     List.flatten
+         (default_arg
-       [ Client_keys_commands.commands () ;
+            ~doc: "listening address or host name"
-         [ command ~group
+            ~short: 'a'
-             ~desc: "Launch a signer daemon over a TCP socket."
+            ~long: "address"
-             (args2
+            ~placeholder: "host|address"
-                (default_arg
+            ~default: default_tcp_host
-                   ~doc: "listening address or host name"
+            (parameter (fun _ s -> return s)))
-                   ~short: 'a'
+         (default_arg
-                   ~long: "address"
+            ~doc: "listening TCP port"
-                   ~placeholder: "host|address"
+            ~short: 'p'
-                   ~default: default_tcp_host
+            ~long: "port"
-                   (parameter (fun _ s -> return s)))
+            ~placeholder: "port number"
-                (default_arg
+            ~default: default_tcp_port
-                   ~doc: "listening TCP port"
+            (parameter
-                   ~short: 'p'
+               (fun _ x ->
-                   ~long: "port"
+                  try return (int_of_string x)
-                   ~placeholder: "port number"
+                  with Failure _ -> failwith "Invalid port %s" x))))
-                   ~default: default_tcp_port
+      (prefixes [ "launch" ; "socket" ; "signer" ] @@ stop)
-                   (parameter (fun _ s -> return s))))
+      (fun (host, port) cctxt ->
-             (prefixes [ "launch" ; "socket" ; "signer" ] @@ stop)
+         Socket_daemon.run cctxt (Tcp (host, port))) ;
-             (fun (host, port) cctxt ->
+    command ~group
-                let port = int_of_string port in
+      ~desc: "Launch a signer daemon over a local Unix socket."
-                run_socket_daemon cctxt (Tcp (host, port))) ;
+      (args1
-           command ~group
+         (default_arg
-             ~desc: "Launch a signer daemon over a local Unix socket."
+            ~doc: "path to the local socket file"
-             (args1
+            ~short: 's'
-                (default_arg
+            ~long: "socket"
-                   ~doc: "path to the local socket file"
+            ~placeholder: "path"
-                   ~short: 's'
+            ~default: default_unix_path
-                   ~long: "socket"
+            (parameter (fun _ s -> return s))))
-                   ~placeholder: "path"
+      (prefixes [ "launch" ; "local" ; "signer" ] @@ stop)
-                   ~default: default_unix_path
+      (fun path cctxt ->
-                   (parameter (fun _ s -> return s))))
+         Socket_daemon.run cctxt (Unix path)) ;
-             (prefixes [ "launch" ; "local" ; "signer" ] @@ stop)
+    command ~group
-             (fun path cctxt ->
+      ~desc: "Launch a signer daemon over HTTPS."
-                run_socket_daemon cctxt (Unix path)) ;
+      (args2
-           command ~group
+         (default_arg
-             ~desc: "Launch a signer daemon over HTTPS."
+            ~doc: "listening address or host name"
-             (args2
+            ~short: 'a'
-                (default_arg
+            ~long: "address"
-                   ~doc: "listening address or host name"
+            ~placeholder: "host|address"
-                   ~short: 'a'
+            ~default: default_https_host
-                   ~long: "address"
+            (parameter (fun _ s -> return s)))
-                   ~placeholder: "host|address"
+         (default_arg
-                   ~default: default_https_host
+            ~doc: "listening HTTPS port"
-                   (parameter (fun _ s -> return s)))
+            ~short: 'p'
-                (default_arg
+            ~long: "port"
-                   ~doc: "listening HTTPS port"
+            ~placeholder: "port number"
-                   ~short: 'p'
+            ~default: default_https_port
-                   ~long: "port"
+            (parameter
-                   ~placeholder: "port number"
+               (fun _ x ->
-                   ~default: default_https_port
+                  try return (int_of_string x)
-                   (parameter (fun _ s -> return s))))
+                  with Failure _ -> failwith "Invalid port %s" x))))
-             (prefixes [ "launch" ; "https" ; "signer" ] @@
+      (prefixes [ "launch" ; "https" ; "signer" ] @@
-              param
+       param
-                ~name:"cert"
+         ~name:"cert"
-                ~desc: "path to th TLS certificate"
+         ~desc: "path to th TLS certificate"
-                (parameter (fun _ s -> return s)) @@
+         (parameter (fun _ s -> return s)) @@
-              param
+       param
-                ~name:"key"
+         ~name:"key"
-                ~desc: "path to th TLS key"
+         ~desc: "path to th TLS key"
-                (parameter (fun _ s -> return s)) @@ stop)
+         (parameter (fun _ s -> return s)) @@ stop)
-             (fun (host, port) cert key cctxt ->
+      (fun (host, port) cert key cctxt ->
-                let port = int_of_string port in
+         Https_daemon.run cctxt ~host ~port ~cert ~key) ;
-                run_https_daemon cctxt host port cert key) ;
+  ]
-         ]])
+
 
 let () =
-  Client_main_run.run select_commands
+  Client_main_run.run
+    (fun _ _ ->
+       return @@
+       List.map
+         (Clic.map_command
+            (fun (o : Client_context.full) -> (o :> Client_context.io_wallet)))
+         commands)

src/bin_signer/socket_daemon.ml

@@ -0,0 +1,48 @@
+(**************************************************************************)
+(*                                                                        *)
+(*    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 log = Logging.Client.Sign.lwt_log_notice
+
+let run (cctxt : #Client_context.wallet) path =
+  Lwt_utils_unix.Socket.bind path >>=? fun fd ->
+  let rec loop () =
+    Lwt_unix.accept fd >>= fun (fd, _) ->
+    Lwt.async begin fun () ->
+      Lwt_utils_unix.Socket.recv fd Request.encoding >>=? function
+      | Sign req ->
+          let encoding = result_encoding Sign.Response.encoding in
+          Handler.sign cctxt req.key req.data >>= fun res ->
+          Lwt_utils_unix.Socket.send fd encoding res >>= fun _ ->
+          Lwt_unix.close fd >>= fun () ->
+          return ()
+      | Public_key req ->
+          let encoding = result_encoding Public_key.Response.encoding in
+          Handler.public_key cctxt req.key >>= fun res ->
+          Lwt_utils_unix.Socket.send fd encoding res >>= fun _ ->
+          Lwt_unix.close fd >>= fun () ->
+          return ()
+    end ;
+    loop ()
+  in
+  Lwt_unix.listen fd 10 ;
+  begin
+    match path with
+    | Tcp (host, port) ->
+        log "Accepting TCP requests on port %s:%d" host port
+    | Unix path ->
+        Sys.set_signal Sys.sigint (Signal_handle begin fun _ ->
+            Format.printf "Removing the local socket file and quitting.@." ;
+            Unix.unlink path ;
+            exit 0
+          end) ;
+        log "Accepting UNIX requests on %s" path
+  end >>= fun () ->
+  loop ()

src/bin_signer/socket_daemon.mli

@@ -0,0 +1,12 @@
+(**************************************************************************)
+(*                                                                        *)
+(*    Copyright (c) 2014 - 2018.                                          *)
+(*    Dynamic Ledger Solutions, Inc. <contact@tezos.com>                  *)
+(*                                                                        *)
+(*    All rights reserved. No warranty, explicit or implicit, provided.   *)
+(*                                                                        *)
+(**************************************************************************)
+
+val run:
+  #Client_context.io_wallet ->
+  Lwt_utils_unix.Socket.addr -> 'a tzresult Lwt.t

src/lib_client_base_unix/client_signer_remote.ml

@@ -10,9 +10,15 @@
 open Client_keys
 open Client_signer_remote_messages
 
+let call host port service arg =
+  RPC_client.call_service
+    Media_type.all_media_types
+    ~base: (Uri.of_string (Format.asprintf "https://%s:%d" host port))
+    service () () arg
+
 type path =
   | Socket of Lwt_utils_unix.Socket.addr
-  | Https of Client_signer_remote_services.path
+  | Https of string * int
 
 let socket_sign path key data =
   let req = { Sign.Request.key = key ; data } in
@@ -34,14 +40,16 @@ let socket_request_public_key path key =
 
 let sign path key data = match path with
   | Socket path -> socket_sign path key data
-  | Https path ->
+  | Https (host, port) ->
-      Client_signer_remote_services.(call path sign) { key ; data } >>=? fun res ->
+      call host port
+        Client_signer_remote_services.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 ->
+  | Https (host, port) ->
-      Client_signer_remote_services.(call path public_key) { key } >>=? fun res ->
+      call host port
+        Client_signer_remote_services.public_key { key } >>=? fun res ->
       return res.public_key
 
 module Remote_signer : SIGNER = struct
@@ -89,11 +97,12 @@ module Remote_signer : SIGNER = struct
     (* | "tcp" :: key :: [] -> *)
     (* return (Socket (Tcp ("$TEZOS_SIGNER_TCP_HOST", "$TEZOS_SIGNER_TCP_PORT")), key) *)
     | "https" :: host :: port :: key :: [] ->
-        return (Https (host, port), key)
+        return (Https (host, int_of_string port), key)
-    | "https" :: host :: key :: [] ->
+    (* Temporary FIXME *)
-        return (Https (host, "$TEZOS_SIGNER_HTTPS_PORT"), key)
+    (* | "https" :: host :: key :: [] -> *)
-    | "https" :: key :: [] ->
+    (* return (Https (host, "$TEZOS_SIGNER_HTTPS_PORT"), key) *)
-        return (Https ("$TEZOS_SIGNER_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@]@]"
@@ -103,7 +112,7 @@ module Remote_signer : SIGNER = struct
   let locator_of_path = function
     | Socket (Unix path), key -> [ "unix" ; path ; key ]
     | Socket (Tcp (host, port)), key -> [ "tcp" ; host ; string_of_int port ; key ]
-    | Https (host, port), key -> [ "https" ; host ; port ; key ]
+    | Https (host, port), key -> [ "https" ; host ; string_of_int port ; key ]
 
   let pk_locator_of_human_input _cctxt path =
     path_of_human_input path >>=? fun pk ->

src/lib_client_base_unix/client_signer_remote_services.ml

@@ -22,41 +22,3 @@ let public_key = RPC_service.post_service
     ~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

@@ -14,10 +14,3 @@ val sign :
 
 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