Merge branch 'rpc-tls' into 'master'

Rpc tls

See merge request !128

src/client/client_config.ml

@@ -85,6 +85,10 @@ let incoming_port = in_both_groups @@
   new int_cp [ "port" ] ~short_name:"P" 8732
     "The TCP port at which the node's RPC server can be reached."
 
+let tls = in_both_groups @@
+  new bool_cp [ "tls" ] false
+    "Use TLS to connect to node."
+
 (* Version specific options *)
 
 let contextual_options : (unit -> unit) ref Protocol_hash_table.t =
@@ -191,6 +195,11 @@ let preparse_args argv cctxt : Node_rpc_services.Blocks.block Lwt.t =
         "Error: can't read the configuration file: %s\n%!" msg
     else Lwt.return ()
   end >>= fun () ->
+  begin
+    match preparse "-tls" argv with
+    | None -> ()
+    | Some _ -> tls#set true
+  end ;
   begin
     match preparse "-addr" argv with
     | None -> ()

src/client/client_node_rpcs.ml

@@ -24,10 +24,12 @@ let cpt = ref 0
 let make_request cctxt service json =
   incr cpt ;
   let cpt = !cpt in
-  let serv = "http://" ^ Client_config.incoming_addr#get
+  let scheme = if Client_config.tls#get then "https" else "http" in
-             ^ ":" ^ string_of_int Client_config.incoming_port#get in
+  let host = Client_config.incoming_addr#get in
-  let string_uri = String.concat "/" (serv :: service) in
+  let port = Client_config.incoming_port#get in
-  let uri = Uri.of_string string_uri in
+  let path = String.concat "/" service in
+  let uri = Uri.make ~scheme ~host ~port ~path () in
+  let string_uri = Uri.to_string uri in
   let reqbody = Data_encoding_ezjsonm.to_string json in
   let tzero = Unix.gettimeofday () in
   catch

src/client_main.ml

@@ -42,11 +42,14 @@ let main () =
        Lwt.catch
          (fun () ->
             Client_node_rpcs.Blocks.protocol cctxt block)
-         (fun _ ->
+         (fun exn ->
-            cctxt.message
+            cctxt.warning
-              "\n\
+              "Error trying to acquire the protocol version from the node: %s."
-               The connection to the RPC server failed, \
+              (match exn with
-               using the default protocol version.\n" >>= fun () ->
+               | Failure msg -> msg
+               | exn -> Printexc.to_string exn) >>= fun () ->
+            cctxt.warning
+              "Using the default protocol version." >>= fun () ->
             Lwt.return Client_bootstrap.Client_proto_main.protocol)
        >>= fun version ->
        let commands =
@@ -81,7 +84,7 @@ let main () =
           Format.eprintf "Command failed, %s.\n%!" message ;
           Lwt.return 1
       | Failure message ->
-          Format.eprintf "%s\n%!" message ;
+          Format.eprintf "Fatal error: %s\n%!" message ;
           Lwt.return 1
       | exn ->
           Format.printf "Fatal internal error: %s\n%!"

src/node/net/RPC_server.ml

@@ -53,8 +53,8 @@ let make_cors_headers ?(headers=Cohttp.Header.init ())
           Cohttp.Header.add_multi cors_headers
             "Access-Control-Allow-Origin" [allowed_origin]
 
-(* Promise a running RPC server. Takes the port. *)
+(* Promise a running RPC server. *)
-let launch port ?pre_hook ?post_hook root cors_allowed_origins cors_allowed_headers =
+let launch ?pre_hook ?post_hook ?(host="::") mode root cors_allowed_origins cors_allowed_headers =
   (* launch the worker *)
   let cancelation, canceler, _ = Lwt_utils.canceler () in
   let open Cohttp_lwt_unix in
@@ -180,9 +180,8 @@ let launch port ?pre_hook ?post_hook root cors_allowed_origins cors_allowed_head
   and conn_closed (_, con) =
     log_info "connection close %s" (Cohttp.Connection.to_string con) ;
     shutdown_stream con  in
-  lwt_log_info "create server listening on port %d" port >>= fun () ->
+  Conduit_lwt_unix.init ~src:host () >>= fun ctx ->
-  let ctx = Cohttp_lwt_unix_net.init () in
+  let ctx = Cohttp_lwt_unix_net.init ~ctx () in
-  let mode = `TCP (`Port port) in
   let stop = cancelation () in
   let _server =
     Server.create

src/node/net/RPC_server.mli

@@ -12,13 +12,13 @@
 (** A handle on the server worker. *)
 type server
 
-(** Promise a running RPC serve ; takes the port. To call
+(** Promise a running RPC server. To call an RPC at /p/a/t/h/ in the
-    an RPC at /p/a/t/h/ in the provided service, one must call the URI
+    provided service, one must call the URI /call/p/a/t/h/. Calling
-    /call/p/a/t/h/. Calling /list/p/a/t/h/ will list the services
+    /list/p/a/t/h/ will list the services prefixed by /p/a/t/h/, if
-    prefixed by /p/a/t/h/, if any. Calling /schema/p/a/t/h/ will
+    any. Calling /schema/p/a/t/h/ will describe the input and output
-    describe the input and output of the service, if it is
+    of the service, if it is callable. Calling /pipe will read a
-    callable. Calling /pipe will read a sequence of services to call in
+    sequence of services to call in sequence from the request body,
-    sequence from the request body, see {!pipe_encoding}.
+    see {!pipe_encoding}.
 
     The arguments cors_allowed_origins and cors_allowed_headers define
     the cross-origin resource sharing using the headers
@@ -35,9 +35,11 @@ type server
     another resolution mechanism. Its result is ignored if the return
     code is [404]. The optional [post_hook] is called if both the
     [pre_hook] and the serviced answered with a [404] code. *)
-val launch : int ->
+val launch :
   ?pre_hook: (string -> string RPC.Answer.answer Lwt.t) ->
   ?post_hook: (string -> string RPC.Answer.answer Lwt.t) ->
+  ?host:string ->
+  Conduit_lwt_unix.server ->
   unit RPC.directory ->
   string list ->
   string list ->
@@ -46,8 +48,8 @@ val launch : int ->
 (** Kill an RPC server. *)
 val shutdown : server -> unit Lwt.t
 
-(** Retrieve the root service of the server *)
+(** Retrieve the root service of the server. *)
 val root_service : server -> unit RPC.directory
 
-(** Change the root service of the server *)
+(** Change the root service of the server. *)
 val set_root_service : server -> unit RPC.directory -> unit

src/node_main.ml

@@ -65,6 +65,8 @@ type cfg = {
     rpc_addr : (Ipaddr.t * int) option ;
     cors_origins : string list ;
     cors_headers : string list ;
+    rpc_crt : string option ;
+    rpc_key : string option ;
 
     (* log *)
     log_output : [`Stderr | `File of string | `Syslog | `Null] ;
@@ -97,6 +99,8 @@ let default_cfg_of_base_dir base_dir = {
   rpc_addr = None ;
   cors_origins = [] ;
   cors_headers = ["content-type"] ;
+  rpc_crt = None ;
+  rpc_key = None ;
 
   (* log *)
   log_output = `Stderr ;
@@ -280,8 +284,11 @@ module Cmdline = struct
 
   (* rpc args *)
   let rpc_addr =
-    let doc = "The TCP socket address at which this RPC server instance can be reached" in
+    let doc = "The TCP socket address at which this RPC server instance can be reached." in
     Arg.(value & opt (some sockaddr_converter) None & info ~docs:"RPC" ~doc ~docv:"ADDR:PORT" ["rpc-addr"])
+  let rpc_tls =
+    let doc = "Enable TLS for this RPC server with the provided certificate and key." in
+    Arg.(value & opt (some (pair string string)) None & info ~docs:"RPC" ~doc ~docv:"crt,key" ["rpc-tls"])
   let cors_origins =
     let doc = "CORS origin allowed by the RPC server via Access-Control-Allow-Origin; may be used multiple times" in
     Arg.(value & opt_all string [] & info ~docs:"RPC" ~doc ~docv:"ORIGIN" ["cors-origin"])
@@ -291,7 +298,8 @@ module Cmdline = struct
 
   let parse base_dir config_file sandbox sandbox_param log_level
       min_connections max_connections expected_connections
-      net_saddr local_discovery peers closed rpc_addr cors_origins cors_headers reset_cfg update_cfg =
+      net_saddr local_discovery peers closed rpc_addr tls cors_origins cors_headers reset_cfg update_cfg =
+
     let base_dir = Utils.(unopt (unopt default_cfg.base_dir base_dir) sandbox) in
     let config_file = Utils.(unopt ((unopt base_dir sandbox) // "config")) config_file in
     let no_config () =
@@ -317,6 +325,10 @@ module Cmdline = struct
       | 1 -> Some Lwt_log.Info
       | _ -> Some Lwt_log.Debug
     in
+    let rpc_crt, rpc_key = match tls with
+      | None -> None, None
+      | Some (crt, key) -> Some crt, Some key
+    in
     let cfg =
       { cfg with
         base_dir ;
@@ -334,6 +346,8 @@ module Cmdline = struct
         rpc_addr = Utils.first_some rpc_addr cfg.rpc_addr ;
         cors_origins = (match cors_origins with [] -> cfg.cors_origins | _ -> cors_origins) ;
         cors_headers = (match cors_headers with [] -> cfg.cors_headers | _ -> cors_headers) ;
+        rpc_crt ;
+        rpc_key ;
         log_output = cfg.log_output ;
       }
     in
@@ -346,7 +360,7 @@ module Cmdline = struct
                      $ sandbox $ sandbox_param $ v
                      $ min_connections $ max_connections $ expected_connections
                      $ net_addr $ local_discovery $ peers $ closed
-                     $ rpc_addr $ cors_origins $ cors_headers
+                     $ rpc_addr $ rpc_tls $ cors_origins $ cors_headers
                      $ reset_config $ update_config
       ),
     let doc = "The Tezos daemon" in
@@ -438,16 +452,28 @@ let init_node { sandbox ; sandbox_param ;
     ?patch_context
     net_params
 
-let init_rpc { rpc_addr ; cors_origins ; cors_headers } node =
+let init_rpc { rpc_addr ; rpc_crt; rpc_key ; cors_origins ; cors_headers } node =
-  match rpc_addr with
+  match rpc_addr, rpc_crt, rpc_key with
-  | None ->
+  | Some (addr, port), Some crt, Some key ->
+      lwt_log_notice "Starting the RPC server listening on port %d (TLS enabled)." port >>= fun () ->
+      let dir = Node_rpc.build_rpc_directory node in
+      let mode = `TLS (`Crt_file_path crt, `Key_file_path key, `No_password, `Port port) in
+      let host = Ipaddr.to_string addr in
+      let () =
+        let old_hook = !Lwt.async_exception_hook in
+        Lwt.async_exception_hook := function
+          | Ssl.Read_error _ -> ()
+          | exn -> old_hook exn in
+      RPC_server.launch ~host mode dir cors_origins cors_headers >>= fun server ->
+      Lwt.return (Some server)
+  | Some (_addr, port), _, _ ->
+      lwt_log_notice "Starting the RPC server listening on port %d (TLS disabled)." port >>= fun () ->
+      let dir = Node_rpc.build_rpc_directory node in
+      RPC_server.launch (`TCP (`Port port)) dir cors_origins cors_headers >>= fun server ->
+      Lwt.return (Some server)
+  | _ ->
       lwt_log_notice "Not listening to RPC calls." >>= fun () ->
       Lwt.return None
-  | Some (_addr, port) ->
-      lwt_log_notice "Starting the RPC server listening on port %d." port >>= fun () ->
-      let dir = Node_rpc.build_rpc_directory node in
-      RPC_server.launch port dir cors_origins cors_headers >>= fun server ->
-      Lwt.return (Some server)
 
 let init_signal () =
   let handler id = try Lwt_exit.exit id with _ -> () in

src/tezos-deps.opam

@@ -18,6 +18,7 @@ depends: [
   "calendar"
   "cohttp" {>= "0.21" }
   "config-file"
+  "conduit" {= "0.14.0" } # Version 0.14.1 doas not compile with `ssl` (17/01/02)
   "git"
   "git-unix"
   "irmin-watcher" (* for `irmin.unix` *)
@@ -31,6 +32,7 @@ depends: [
   "tyxml"
   "js_of_ocaml"
   "sodium" {>= "0.3.0"}
+  "ssl"
   "kaputt" # { test }
   "bisect_ppx" # { test }
 ]

src/webclient_main.ml

@@ -149,7 +149,7 @@ let find_static_file path =
            Some (OCamlRes.Res.find (index path) Webclient_static.root)
          with Not_found -> None)
 
-let http_proxy port =
+let http_proxy mode =
   let pre_hook path =
     find_static_file path >>= function
     | Some body ->
@@ -163,7 +163,7 @@ let http_proxy port =
       | None ->
           Lwt.return (RPC.Answer.Empty)) >>= fun body ->
     Lwt.return { RPC.Answer.code = 404 ; body } in
-  RPC_server.launch ~pre_hook ~post_hook port root [] []
+  RPC_server.launch ~pre_hook ~post_hook mode root [] []
 
 let web_port = Client_config.in_both_groups @@
   new Config_file.int_cp [ "web" ; "port" ] 8080
@@ -182,7 +182,8 @@ let () =
             Sys.argv Client_commands.ignore_context>>= fun _no_command ->
           Random.self_init () ;
           Sodium.Random.stir () ;
-          http_proxy web_port#get >>= fun _server ->
+          (* TODO: add TLS? *)
+          http_proxy (`TCP (`Port web_port#get)) >>= fun _server ->
           fst (Lwt.wait ()))
        (function
          | Arg.Help help ->