From 0a6f65263f7d804d8fa0a0205248549a11fa658c Mon Sep 17 00:00:00 2001 From: Benjamin Canou Date: Thu, 24 May 2018 02:26:10 +0200 Subject: [PATCH] Signer: add HTTPS variant --- src/bin_client/main_signer.ml | 117 ++++++++++-- src/lib_client_base/client_keys.ml | 2 +- .../client_signer_remote.ml | 80 ++++++--- .../client_signer_remote_messages.ml | 167 +----------------- .../client_signer_remote_messages.mli | 30 +--- .../client_signer_remote_services.ml | 62 +++++++ .../client_signer_remote_services.mli | 23 +++ .../client_signer_remote_socket.ml | 157 ++++++++++++++++ .../client_signer_remote_socket.mli | 27 +++ 9 files changed, 441 insertions(+), 224 deletions(-) create mode 100644 src/lib_client_base_unix/client_signer_remote_services.ml create mode 100644 src/lib_client_base_unix/client_signer_remote_services.mli create mode 100644 src/lib_client_base_unix/client_signer_remote_socket.ml create mode 100644 src/lib_client_base_unix/client_signer_remote_socket.mli diff --git a/src/bin_client/main_signer.ml b/src/bin_client/main_signer.ml index 28275bff5..1a024024b 100644 --- a/src/bin_client/main_signer.ml +++ b/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 - (ok { Public_key.Response.public_key = public_key }) >>=? fun _ -> + send fd encoding (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 diff --git a/src/lib_client_base/client_keys.ml b/src/lib_client_base/client_keys.ml index 31e55484f..1db24608c 100644 --- a/src/lib_client_base/client_keys.ml +++ b/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 diff --git a/src/lib_client_base_unix/client_signer_remote.ml b/src/lib_client_base_unix/client_signer_remote.ml index 212e26907..ed21831f7 100644 --- a/src/lib_client_base_unix/client_signer_remote.ml +++ b/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] \n\ \ - tcp [host] [port] \n\ + \ - https [host] [port] \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 = - Client_signer_remote_messages.path * Client_signer_remote_messages.key + type key_path = path * 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 "@[Remote Schema : wrong locator %s.@,@[%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 ] - | Tcp (host, port), key -> [ "tcp" ; host ; port ; key ] + | Socket (Unix path), key -> [ "unix" ; path ; 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 -> - public_key conn key >>=? fun pk -> + request_public_key path 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 -> - public_key conn key >>=? fun pk -> + request_public_key path 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 -> - public_key conn key) >>= function + request_public_key path 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 = - Connection.connect path >>=? fun conn -> - sign conn key msg + let sign ?watermark (path, key) msg = + let msg = + match watermark with + | None -> msg + | Some watermark -> + MBytes.concat "" [ Signature.bytes_of_watermark watermark ; msg ] in + sign path key msg + end let () = diff --git a/src/lib_client_base_unix/client_signer_remote_messages.ml b/src/lib_client_base_unix/client_signer_remote_messages.ml index 2dd0f20c4..42e919eaf 100644 --- a/src/lib_client_base_unix/client_signer_remote_messages.ml +++ b/src/lib_client_base_unix/client_signer_remote_messages.ml @@ -7,11 +7,7 @@ (* *) (**************************************************************************) -type error += - | Encoding_error - | Decoding_error - | Unkwnon_alias_key of string - | Unkwnon_request_kind +type error += Unkwnon_alias_key of string 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) ; - 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) + (fun s -> Unkwnon_alias_key s) -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 }) diff --git a/src/lib_client_base_unix/client_signer_remote_messages.mli b/src/lib_client_base_unix/client_signer_remote_messages.mli index 0604074fd..7d5d5407b 100644 --- a/src/lib_client_base_unix/client_signer_remote_messages.mli +++ b/src/lib_client_base_unix/client_signer_remote_messages.mli @@ -7,29 +7,14 @@ (* *) (**************************************************************************) -type error += - | Encoding_error - | Decoding_error - | Unkwnon_alias_key of string - | Unkwnon_request_kind +type error += Unkwnon_alias_key of string -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 diff --git a/src/lib_client_base_unix/client_signer_remote_services.ml b/src/lib_client_base_unix/client_signer_remote_services.ml new file mode 100644 index 000000000..1533e9f89 --- /dev/null +++ b/src/lib_client_base_unix/client_signer_remote_services.ml @@ -0,0 +1,62 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2018. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* 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 diff --git a/src/lib_client_base_unix/client_signer_remote_services.mli b/src/lib_client_base_unix/client_signer_remote_services.mli new file mode 100644 index 000000000..1fabc76b1 --- /dev/null +++ b/src/lib_client_base_unix/client_signer_remote_services.mli @@ -0,0 +1,23 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2018. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* 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 diff --git a/src/lib_client_base_unix/client_signer_remote_socket.ml b/src/lib_client_base_unix/client_signer_remote_socket.ml new file mode 100644 index 000000000..aca03c000 --- /dev/null +++ b/src/lib_client_base_unix/client_signer_remote_socket.ml @@ -0,0 +1,157 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2018. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* 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 diff --git a/src/lib_client_base_unix/client_signer_remote_socket.mli b/src/lib_client_base_unix/client_signer_remote_socket.mli new file mode 100644 index 000000000..9a3409ed0 --- /dev/null +++ b/src/lib_client_base_unix/client_signer_remote_socket.mli @@ -0,0 +1,27 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2018. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* 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