diff --git a/src/Makefile b/src/Makefile index 61b2dbc1f..6c41afadf 100644 --- a/src/Makefile +++ b/src/Makefile @@ -486,8 +486,9 @@ clean:: ############################################################################ CLIENT_LIB_INTFS := \ - client/client_commands.mli \ + client/client_rpcs.mli \ client/client_node_rpcs.mli \ + client/client_commands.mli \ client/client_generic_rpcs.mli \ client/client_helpers.mli \ client/client_aliases.mli \ @@ -498,9 +499,10 @@ CLIENT_LIB_INTFS := \ client/client_network.mli \ CLIENT_LIB_IMPLS := \ + client/client_rpcs.ml \ + client/client_node_rpcs.ml \ client/client_commands.ml \ client/client_config.ml \ - client/client_node_rpcs.ml \ client/client_generic_rpcs.ml \ client/client_helpers.ml \ client/client_aliases.ml \ diff --git a/src/client/client_aliases.ml b/src/client/client_aliases.ml index efd87354c..7287ff180 100644 --- a/src/client/client_aliases.ml +++ b/src/client/client_aliases.ml @@ -9,7 +9,7 @@ (* Tezos Command line interface - Local Storage for Configuration *) -open Lwt +open Lwt.Infix open Cli_entries module type Entity = sig @@ -97,7 +97,7 @@ module Alias = functor (Entity : Entity) -> struct let load cctxt = let filename = filename cctxt in - if not (Sys.file_exists filename) then return [] else + if not (Sys.file_exists filename) then Lwt.return [] else Data_encoding_ezjsonm.read_file filename >>= function | Error _ -> cctxt.Client_commands.error @@ -108,43 +108,43 @@ module Alias = functor (Entity : Entity) -> struct cctxt.Client_commands.error "didn't understand the %s alias file" Entity.name | list -> - return list + Lwt.return list let find_opt cctxt name = load cctxt >>= fun list -> - try return (Some (List.assoc name list)) - with Not_found -> return None + try Lwt.return (Some (List.assoc name list)) + with Not_found -> Lwt.return_none let find cctxt name = load cctxt >>= fun list -> - try return (List.assoc name list) + try Lwt.return (List.assoc name list) with Not_found -> cctxt.Client_commands.error "no %s alias named %s" Entity.name name let rev_find cctxt v = load cctxt >>= fun list -> - try return (Some (List.find (fun (_, v') -> v = v') list |> fst)) - with Not_found -> return None + try Lwt.return (Some (List.find (fun (_, v') -> v = v') list |> fst)) + with Not_found -> Lwt.return_none let mem cctxt name = load cctxt >>= fun list -> try ignore (List.assoc name list) ; - Lwt.return true + Lwt.return_true with - | Not_found -> Lwt.return false + | Not_found -> Lwt.return_false let save cctxt list = - catch + Lwt.catch (fun () -> let dirname = dirname cctxt in (if not (Sys.file_exists dirname) then Lwt_utils.create_dir dirname - else return ()) >>= fun () -> + else Lwt.return ()) >>= fun () -> let filename = filename cctxt in let json = Data_encoding.Json.construct encoding list in Data_encoding_ezjsonm.write_file filename json >>= function - | Error _ -> fail (Failure "Json.write_file") - | Ok () -> return ()) + | Error _ -> Lwt.fail (Failure "Json.write_file") + | Ok () -> Lwt.return ()) (fun exn -> cctxt.Client_commands.error "could not write the %s alias file: %s." @@ -157,20 +157,20 @@ module Alias = functor (Entity : Entity) -> struct Lwt_list.iter_s (fun (n, v) -> if n = name && v = value then (keep := true ; - cctxt.Client_commands.message + cctxt.message "The %s alias %s already exists with the same value." Entity.name n) else if n = name && v <> value then - cctxt.Client_commands.error + cctxt.error "another %s is already aliased as %s, use -force true to update" Entity.name n else if n <> name && v = value then - cctxt.Client_commands.error + cctxt.error "this %s is already aliased as %s, use -force true to insert duplicate" Entity.name n - else return ()) - list else return ()) >>= fun () -> + else Lwt.return ()) + list else Lwt.return ()) >>= fun () -> let list = List.filter (fun (n, _) -> n <> name) list in let list = (name, value) :: list in if !keep then - return () + Lwt.return () else save cctxt list >>= fun () -> cctxt.Client_commands.message @@ -198,7 +198,7 @@ module Alias = functor (Entity : Entity) -> struct let alias_param ?(name = "name") ?(desc = "existing " ^ Entity.name ^ " alias") next = param ~name ~desc - (fun cctxt s -> find cctxt s >>= fun v -> return (s, v)) + (fun cctxt s -> find cctxt s >>= fun v -> Lwt.return (s, v)) next let fresh_alias_param ?(name = "new") ?(desc = "new " ^ Entity.name ^ " alias") next = @@ -210,10 +210,10 @@ module Alias = functor (Entity : Entity) -> struct if n = s then cctxt.Client_commands.error "the %s alias %s already exists, use -force true to update" Entity.name n - else return ()) + else Lwt.return ()) list >>= fun () -> - return s - else return s) + Lwt.return s + else Lwt.return s) next let source_param ?(name = "src") ?(desc = "source " ^ Entity.name) next = @@ -224,7 +224,7 @@ module Alias = functor (Entity : Entity) -> struct param ~name ~desc (fun cctxt s -> let read path = - catch + Lwt.catch (fun () -> Lwt_io.(with_file ~mode:Input path read)) (fun exn -> Lwt.fail_with @@ Format.asprintf "cannot read file (%s)" (Printexc.to_string exn)) >>= of_source cctxt in @@ -236,10 +236,10 @@ module Alias = functor (Entity : Entity) -> struct | [ "file" ; path ] -> read path | _ -> - catch + Lwt.catch (fun () -> find cctxt s) (fun _ -> - catch + Lwt.catch (fun () -> read s) (fun _ -> of_source cctxt s))) next diff --git a/src/client/client_blocks.ml b/src/client/client_blocks.ml index 9f3ef8003..b116b28b5 100644 --- a/src/client/client_blocks.ml +++ b/src/client/client_blocks.ml @@ -11,18 +11,17 @@ let genesis = Block_hash.of_b58check "BLockGenesisGenesisGenesisGenesisGenesisGeneskvg68z" -let get_block_hash cctxt = function - | `Hash hash -> Lwt.return hash +let get_block_hash config = function + | `Hash hash -> return hash | `Genesis | `Head _ | `Test_head _ as block -> - Client_node_rpcs.Blocks.hash cctxt block - | `Prevalidation -> Client_node_rpcs.Blocks.hash cctxt (`Head 0) - | `Test_prevalidation -> Client_node_rpcs.Blocks.hash cctxt (`Test_head 0) + Client_node_rpcs.Blocks.hash config block + | `Prevalidation -> Client_node_rpcs.Blocks.hash config (`Head 0) + | `Test_prevalidation -> Client_node_rpcs.Blocks.hash config (`Test_head 0) - -let get_block_info cctxt block = +let get_block_info config block = let block = match block with | `Prevalidation -> `Head 0 | `Test_prevalidation -> `Test_head 0 | b -> b in - Client_node_rpcs.Blocks.info cctxt block + Client_node_rpcs.Blocks.info config block diff --git a/src/client/client_blocks.mli b/src/client/client_blocks.mli index dcf0cfb3d..66da485c9 100644 --- a/src/client/client_blocks.mli +++ b/src/client/client_blocks.mli @@ -10,11 +10,11 @@ val genesis: Block_hash.t val get_block_hash: - Client_commands.context -> + Client_rpcs.config -> Client_node_rpcs.Blocks.block -> - Block_hash.Table.key Lwt.t + Block_hash.Table.key tzresult Lwt.t val get_block_info: - Client_commands.context -> + Client_rpcs.config -> Client_node_rpcs.Blocks.block -> - Client_node_rpcs.Blocks.block_info Lwt.t + Client_node_rpcs.Blocks.block_info tzresult Lwt.t diff --git a/src/client/client_commands.ml b/src/client/client_commands.ml index 6eb580370..13285c0e6 100644 --- a/src/client/client_commands.ml +++ b/src/client/client_commands.ml @@ -12,31 +12,27 @@ type ('a, 'b) lwt_format = type cfg = { - (* network options. *) - node_addr : string ; - node_port : int ; - tls : bool ; - (* webclient options *) web_port : int ; (* misc options *) base_dir : string ; - print_timings : bool ; force : bool ; block : Node_rpc_services.Blocks.block ; } -type context = - { config : cfg ; - error : 'a 'b. ('a, 'b) lwt_format -> 'a ; - warning : 'a. ('a, unit) lwt_format -> 'a ; - message : 'a. ('a, unit) lwt_format -> 'a ; - answer : 'a. ('a, unit) lwt_format -> 'a ; - log : 'a. string -> ('a, unit) lwt_format -> 'a } +type context = { + rpc_config : Client_rpcs.config ; + config : cfg ; + error : 'a 'b. ('a, 'b) lwt_format -> 'a ; + warning : 'a. ('a, unit) lwt_format -> 'a ; + message : 'a. ('a, unit) lwt_format -> 'a ; + answer : 'a. ('a, unit) lwt_format -> 'a ; + log : 'a. string -> ('a, unit) lwt_format -> 'a ; +} -type command = (context, unit) Cli_entries.command +type command = (context, unit tzresult) Cli_entries.command (* Default config *) @@ -44,14 +40,9 @@ let (//) = Filename.concat let default_cfg_of_base_dir base_dir = { base_dir ; - print_timings = false ; force = false ; block = `Prevalidation ; - node_addr = "127.0.0.1" ; - node_port = 8732 ; - tls = false ; - web_port = 8080 ; } @@ -63,7 +54,10 @@ let default_base_dir = home // ".tezos-client" let default_cfg = default_cfg_of_base_dir default_base_dir -let make_context ?(config = default_cfg) log = +let make_context + ?(config = default_cfg) + ?(rpc_config = Client_rpcs.default_config) + log = let error fmt = Format.kasprintf (fun msg -> @@ -83,7 +77,7 @@ let make_context ?(config = default_cfg) log = Format.kasprintf (fun msg -> log name msg) fmt in - { config ; error ; warning ; message ; answer ; log } + { config ; rpc_config ; error ; warning ; message ; answer ; log } let ignore_context = make_context (fun _ _ -> Lwt.return ()) diff --git a/src/client/client_commands.mli b/src/client/client_commands.mli index d69450af1..158094a20 100644 --- a/src/client/client_commands.mli +++ b/src/client/client_commands.mli @@ -12,29 +12,25 @@ type ('a, 'b) lwt_format = type cfg = { - (* network options. *) - node_addr : string ; - node_port : int ; - tls : bool ; - (* webclient options *) web_port : int ; (* misc options *) base_dir : string ; - print_timings : bool ; force : bool ; block : Node_rpc_services.Blocks.block ; } -type context = - { config : cfg ; - error : 'a 'b. ('a, 'b) lwt_format -> 'a ; - warning : 'a. ('a, unit) lwt_format -> 'a ; - message : 'a. ('a, unit) lwt_format -> 'a ; - answer : 'a. ('a, unit) lwt_format -> 'a ; - log : 'a. string -> ('a, unit) lwt_format -> 'a } +type context = { + rpc_config : Client_rpcs.config ; + config : cfg ; + error : 'a 'b. ('a, 'b) lwt_format -> 'a ; + warning : 'a. ('a, unit) lwt_format -> 'a ; + message : 'a. ('a, unit) lwt_format -> 'a ; + answer : 'a. ('a, unit) lwt_format -> 'a ; + log : 'a. string -> ('a, unit) lwt_format -> 'a ; +} (** This [context] allows the client {!command} handlers to work in various modes (command line, batch mode, web client, etc.) by abstracting some basic operations such as logging and reading @@ -48,6 +44,7 @@ val default_cfg : cfg val make_context : ?config:cfg -> + ?rpc_config:Client_rpcs.config -> (string -> string -> unit Lwt.t) -> context (** [make_context ?config log_fun] builds a context whose logging callbacks call [log_fun section msg], and whose [error] function @@ -58,7 +55,7 @@ val ignore_context : context (** [ignore_context] is a context whose logging callbacks do nothing, and whose [error] function calls [Lwt.fail_with]. *) -type command = (context, unit) Cli_entries.command +type command = (context, unit tzresult) Cli_entries.command exception Version_not_found diff --git a/src/client/client_generic_rpcs.ml b/src/client/client_generic_rpcs.ml index b7acd0225..f275ee565 100644 --- a/src/client/client_generic_rpcs.ml +++ b/src/client/client_generic_rpcs.ml @@ -9,7 +9,8 @@ (* Tezos Command line interface - Generic JSON RPC interface *) -open Lwt +open Lwt.Infix +open Client_commands open Cli_entries open Json_schema @@ -44,92 +45,92 @@ let fill_in input schema = | Some (m, `Inclusive) -> int_of_float m | Some (m, `Exclusive) -> int_of_float m - 1 in input.int minimum maximum title path >>= fun i -> - return (`Float (float i)) + Lwt.return (`Float (float i)) | Number _ -> input.float title path >>= fun f -> - return (`Float f) + Lwt.return (`Float f) | Boolean -> input.bool title path >>= fun f -> - return (`Bool f) + Lwt.return (`Bool f) | String _ -> input.string title path >>= fun f -> - return (`String f) + Lwt.return (`String f) | Combine ((One_of | Any_of), elts) -> let nb = List.length elts in input.int 0 (nb - 1) (Some "Select the schema to follow") path >>= fun n -> element path (List.nth elts n) - | Combine ((All_of | Not), _) -> fail Unsupported_construct + | Combine ((All_of | Not), _) -> Lwt.fail Unsupported_construct | Def_ref name -> - return (`String (Json_query.json_pointer_of_path name)) + Lwt.return (`String (Json_query.json_pointer_of_path name)) | Id_ref _ | Ext_ref _ -> - fail Unsupported_construct + Lwt.fail Unsupported_construct | Array (elts, _) -> let rec fill_loop acc n ls = match ls with - | [] -> return acc + | [] -> Lwt.return acc | elt :: elts -> element (string_of_int n :: path) elt >>= fun json -> fill_loop (json :: acc) (succ n) elts in fill_loop [] 0 elts >>= fun acc -> - return (`A (List.rev acc)) + Lwt.return (`A (List.rev acc)) | Object { properties } -> let rec fill_loop acc ls = match ls with - | [] -> return acc + | [] -> Lwt.return acc | (n, elt, _, _) :: elts -> element (n :: path) elt >>= fun json -> fill_loop ((n, json) :: acc) elts in fill_loop [] properties >>= fun acc -> - return (`O (List.rev acc)) + Lwt.return (`O (List.rev acc)) | Monomorphic_array (elt, specs) -> let rec fill_loop acc min n max = if n > max then - return acc + Lwt.return acc else element (string_of_int n :: path) elt >>= fun json -> - (if n < min then return true else input.continue title path) >>= function + (if n < min then Lwt.return true else input.continue title path) >>= function | true -> fill_loop (json :: acc) min (succ n) max - | false -> return (json :: acc) + | false -> Lwt.return (json :: acc) in let max = match specs.max_items with None -> max_int | Some m -> m in fill_loop [] specs.min_items 0 max >>= fun acc -> - return (`A (List.rev acc)) - | Any -> fail Unsupported_construct - | Dummy -> fail Unsupported_construct - | Null -> return `Null + Lwt.return (`A (List.rev acc)) + | Any -> Lwt.fail Unsupported_construct + | Dummy -> Lwt.fail Unsupported_construct + | Null -> Lwt.return `Null in element [] (Json_schema.root schema) let random_fill_in schema = - let display _ = return () in + let display _ = Lwt.return () in let int min max _ _ = let max = Int64.of_int max and min = Int64.of_int min in let range = Int64.sub max min in let random_int64 = Int64.add (Random.int64 range) min in - return (Int64.to_int random_int64) in - let string _title _ = return "" in - let float _ _ = return (Random.float infinity) in - let bool _ _ = return (Random.int 2 = 0) in - let continue _ _ = return (Random.int 4 = 0) in - catch + Lwt.return (Int64.to_int random_int64) in + let string _title _ = Lwt.return "" in + let float _ _ = Lwt.return (Random.float infinity) in + let bool _ _ = Lwt.return (Random.int 2 = 0) in + let continue _ _ = Lwt.return (Random.int 4 = 0) in + Lwt.catch (fun () -> fill_in { int ; float ; string ; bool ; display ; continue } schema >>= fun json -> - return (Ok json)) + Lwt.return (Ok json)) (fun e -> let msg = Printf.sprintf "Fill-in failed %s\n%!" (Printexc.to_string e) in - return (Error msg)) + Lwt.return (Error msg)) let editor_fill_in schema = let tmp = Filename.temp_file "tezos_rpc_call_" ".json" in let rec init () = (* write a temp file with instructions *) random_fill_in schema >>= function - | Error msg -> return (Error msg) + | Error msg -> Lwt.return (Error msg) | Ok json -> Lwt_io.(with_file Output tmp (fun fp -> write_line fp (Data_encoding_ezjsonm.to_string json))) >>= fun () -> @@ -139,30 +140,30 @@ let editor_fill_in schema = let editor_cmd = try let ed = Sys.getenv "EDITOR" in Lwt_process.shell (ed ^ " " ^ tmp) with Not_found -> - try let ed = Sys.getenv "VISUAL" in Lwt_process.shell (ed ^ " " ^ tmp) - with Not_found -> - if Sys.win32 then - (* TODO: I have no idea what I'm doing here *) - ("", [| "notepad.exe" ; tmp |]) - else - (* TODO: vi on MacOSX ? *) - ("", [| "nano" ; tmp |]) + try let ed = Sys.getenv "VISUAL" in Lwt_process.shell (ed ^ " " ^ tmp) + with Not_found -> + if Sys.win32 then + (* TODO: I have no idea what I'm doing here *) + ("", [| "notepad.exe" ; tmp |]) + else + (* TODO: vi on MacOSX ? *) + ("", [| "nano" ; tmp |]) in (Lwt_process.open_process_none editor_cmd) # status >>= function | Unix.WEXITED 0 -> reread () >>= fun json -> delete () >>= fun () -> - return json + Lwt.return json | Unix.WSIGNALED x | Unix.WSTOPPED x | Unix.WEXITED x -> let msg = Printf.sprintf "FAILED %d \n%!" x in delete () >>= fun () -> - return (Error msg) + Lwt.return (Error msg) and reread () = (* finally reread the file *) Lwt_io.(with_file Input tmp (fun fp -> read fp)) >>= fun text -> match Data_encoding_ezjsonm.from_string text with - | Ok r -> return (Ok r) - | Error msg -> return (Error (Printf.sprintf "bad input: %s" msg)) + | Ok r -> Lwt.return (Ok r) + | Error msg -> Lwt.return (Error (Printf.sprintf "bad input: %s" msg)) and delete () = (* and delete the temp file *) Lwt_unix.unlink tmp @@ -194,7 +195,8 @@ let rec count = let list url cctxt = let args = Utils.split '/' url in - Client_node_rpcs.describe cctxt ~recurse:true args >>= fun tree -> + Client_node_rpcs.describe cctxt.rpc_config + ~recurse:true args >>=? fun tree -> let open RPC.Description in let collected_args = ref [] in let collect arg = @@ -274,23 +276,26 @@ let list url cctxt = in cctxt.message "@ @[Available services:@ @ %a@]@." display (args, args, tree) >>= fun () -> - if !collected_args <> [] then + if !collected_args <> [] then begin cctxt.message "@,@[Dynamic parameter description:@ @ %a@]@." - (Format.pp_print_list display_arg) !collected_args - else Lwt.return () + (Format.pp_print_list display_arg) !collected_args >>= fun () -> + return () + end else return () let schema url cctxt = let args = Utils.split '/' url in let open RPC.Description in - Client_node_rpcs.describe cctxt ~recurse:false args >>= function + Client_node_rpcs.describe cctxt.rpc_config ~recurse:false args >>=? function | Static { service = Some { input ; output } } -> cctxt.message "Input schema:\n%s\nOutput schema:\n%s\n%!" (Data_encoding_ezjsonm.to_string (Json_schema.to_json input)) - (Data_encoding_ezjsonm.to_string (Json_schema.to_json output)) + (Data_encoding_ezjsonm.to_string (Json_schema.to_json output)) >>= fun () -> + return () | _ -> cctxt.message - "No service found at this URL (but this is a valid prefix)\n%!" + "No service found at this URL (but this is a valid prefix)\n%!" >>= fun () -> + return () let fill_in schema = let open Json_schema in @@ -302,32 +307,36 @@ let fill_in schema = let call url cctxt = let args = Utils.split '/' url in let open RPC.Description in - Client_node_rpcs.describe cctxt ~recurse:false args >>= function + Client_node_rpcs.describe cctxt.rpc_config ~recurse:false args >>=? function | Static { service = Some { input } } -> begin fill_in input >>= function | Error msg -> - cctxt.error "%s" msg + cctxt.error "%s" msg >>= fun () -> + return () | Ok json -> - Client_node_rpcs.get_json cctxt `POST args json >>= fun json -> + Client_rpcs.get_json cctxt.rpc_config `POST args json >>=? fun json -> cctxt.message - "Output:\n%s\n%!" (Data_encoding_ezjsonm.to_string json) + "Output:\n%s\n%!" (Data_encoding_ezjsonm.to_string json) >>= fun () -> + return () end | _ -> cctxt.message - "No service found at this URL (but this is a valid prefix)\n%!" + "No service found at this URL (but this is a valid prefix)\n%!" >>= fun () -> + return () let call_with_json url json (cctxt: Client_commands.context) = let args = Utils.split '/' url in match Data_encoding_ezjsonm.from_string json with | Error err -> cctxt.error - "Failed to parse the proviede json: %s\n%!" + "Failed to parse the provided json: %s\n%!" err | Ok json -> let open RPC.Description in - Client_node_rpcs.get_json cctxt `POST args json >>= fun json -> + Client_rpcs.get_json cctxt.rpc_config `POST args json >>=? fun json -> cctxt.message - "Output:\n%s\n%!" (Data_encoding_ezjsonm.to_string json) + "Output:\n%s\n%!" (Data_encoding_ezjsonm.to_string json) >>= fun () -> + return () let group = { Cli_entries.name = "rpc" ; @@ -339,7 +348,8 @@ let commands = [ (fun cctxt -> Lwt_list.iter_s (fun (ver, _) -> cctxt.Client_commands.message "%a" Protocol_hash.pp_short ver) - (Client_commands.get_versions ())) ; + (Client_commands.get_versions ()) >>= fun () -> + return ()) ; command ~group ~desc: "list available RPCs (low level command for advanced users)" (prefixes [ "rpc" ; "list" ] @@ stop) (list "/"); diff --git a/src/client/client_helpers.ml b/src/client/client_helpers.ml index 923b56d54..0da3e6fa6 100644 --- a/src/client/client_helpers.ml +++ b/src/client/client_helpers.ml @@ -7,6 +7,7 @@ (* *) (**************************************************************************) +open Client_commands open Client_config let unique = ref false @@ -28,25 +29,31 @@ let commands () = Cli_entries.[ ~desc: "the prefix of the Base58Check-encoded hash to be completed" @@ stop) (fun prefix cctxt -> - Client_node_rpcs.complete cctxt ~block:cctxt.config.block prefix >>= fun completions -> + Client_node_rpcs.complete + cctxt.rpc_config ~block:cctxt.config.block prefix >>=? fun completions -> match completions with | [] -> Pervasives.exit 3 | _ :: _ :: _ when !unique -> Pervasives.exit 3 | completions -> List.iter print_endline completions ; - Lwt.return_unit) ; + return ()) ; command ~desc: "Wait for the node to be bootstrapped." ~args: [] (prefixes [ "bootstrapped" ] @@ stop) (fun cctxt -> - Client_node_rpcs.bootstrapped cctxt >>= fun stream -> - Lwt_stream.iter_s (fun (hash, time) -> - cctxt.message "Current head: %a (%a)" - Block_hash.pp_short hash - Time.pp_hum time + Client_node_rpcs.bootstrapped cctxt.rpc_config >>=? fun stream -> + Lwt_stream.iter_s (function + | Ok (hash, time) -> + cctxt.message "Current head: %a (%a)" + Block_hash.pp_short hash + Time.pp_hum time + | Error err -> + cctxt.error "Error: %a" + pp_print_error err ) stream >>= fun () -> - cctxt.answer "Bootstrapped." + cctxt.answer "Bootstrapped." >>= fun () -> + return () ) ] diff --git a/src/client/client_keys.ml b/src/client/client_keys.ml index 9b34a514c..2d219070c 100644 --- a/src/client/client_keys.ml +++ b/src/client/client_keys.ml @@ -63,7 +63,8 @@ let gen_keys ?seed cctxt name = Secret_key.add cctxt name secret_key >>= fun () -> Public_key.add cctxt name public_key >>= fun () -> Public_key_hash.add cctxt name (Ed25519.Public_key.hash public_key) >>= fun () -> - cctxt.message "I generated a brand new pair of keys under the name '%s'." name + cctxt.message "I generated a brand new pair of keys under the name '%s'." name >>= fun () -> + return () let check_keys_consistency pk sk = let message = MBytes.of_string "Voulez-vous coucher avec moi, ce soir ?" in @@ -116,19 +117,22 @@ let commands () = @@ Secret_key.source_param @@ stop) (fun name sk cctxt -> - Lwt.catch (fun () -> - Public_key.find cctxt name >>= fun pk -> - if check_keys_consistency pk sk || cctxt.config.force then - Secret_key.add cctxt name sk - else - cctxt.error - "public and secret keys '%s' don't correspond, \ - please don't use -force true" name) - (function - | Not_found -> + begin + Lwt.catch (fun () -> + Public_key.find cctxt name >>= fun pk -> + if check_keys_consistency pk sk || cctxt.config.force then + Secret_key.add cctxt name sk + else cctxt.error - "no public key named '%s', add it before adding the secret key" name - | exn -> Lwt.fail exn)) ; + "public and secret keys '%s' don't correspond, \ + please don't use -force true" name) + (function + | Not_found -> + cctxt.error + "no public key named '%s', add it before adding the secret key" name + | exn -> Lwt.fail exn) + end >>= fun () -> + return ()) ; command ~group ~desc: "add a public key to the wallet" (prefixes [ "add" ; "public" ; "key" ] @@ Public_key.fresh_alias_param @@ -136,14 +140,16 @@ let commands () = @@ stop) (fun name key cctxt -> Public_key_hash.add cctxt name (Ed25519.Public_key.hash key) >>= fun () -> - Public_key.add cctxt name key) ; + Public_key.add cctxt name key >>= fun () -> + return ()) ; command ~group ~desc: "add an ID a public key hash to the wallet" (prefixes [ "add" ; "identity" ] @@ Public_key_hash.fresh_alias_param @@ Public_key_hash.source_param @@ stop) (fun name hash cctxt -> - Public_key_hash.add cctxt name hash) ; + Public_key_hash.add cctxt name hash >>= fun () -> + return ()) ; command ~group ~desc: "list all public key hashes and associated keys" (fixed [ "list" ; "known" ; "identities" ]) (fun cctxt -> @@ -153,14 +159,18 @@ let commands () = cctxt.message "%s: %s%s%s" name v (if pkm then " (public key known)" else "") (if pks then " (secret key known)" else "")) - l) ; + l >>= fun () -> + return ()) ; command ~group ~desc: "forget all keys" (fixed [ "forget" ; "all" ; "keys" ]) (fun cctxt -> - if not cctxt.config.force then - cctxt.Client_commands.error "this can only used with option -force true" - else - Public_key.save cctxt [] >>= fun () -> - Secret_key.save cctxt [] >>= fun () -> - Public_key_hash.save cctxt []) ; + begin + if not cctxt.config.force then + cctxt.Client_commands.error "this can only used with option -force true" + else + Public_key.save cctxt [] >>= fun () -> + Secret_key.save cctxt [] >>= fun () -> + Public_key_hash.save cctxt [] + end >>= fun () -> + return ()) ; ] diff --git a/src/client/client_keys.mli b/src/client/client_keys.mli index 2f4423878..edc4289c6 100644 --- a/src/client/client_keys.mli +++ b/src/client/client_keys.mli @@ -38,6 +38,6 @@ val gen_keys: ?seed: Sodium.Sign.seed -> Client_commands.context -> string -> - unit Lwt.t + unit tzresult Lwt.t val commands: unit -> Client_commands.command list diff --git a/src/client/client_network.ml b/src/client/client_network.ml index b25dc41ea..deb12a365 100644 --- a/src/client/client_network.ml +++ b/src/client/client_network.ml @@ -7,6 +7,8 @@ (* *) (**************************************************************************) +open Client_commands + let group = { Cli_entries.name = "network" ; title = "Commands for monitoring and controlling network state" } @@ -15,10 +17,10 @@ let commands () = [ let open Cli_entries in command ~group ~desc: "show global network status" (prefixes ["network" ; "stat"] stop) begin fun cctxt -> - Client_node_rpcs.Network.stat cctxt >>= fun stat -> - Client_node_rpcs.Network.connections cctxt >>= fun conns -> - Client_node_rpcs.Network.peers cctxt >>= fun peers -> - Client_node_rpcs.Network.points cctxt >>= fun points -> + Client_node_rpcs.Network.stat cctxt.rpc_config >>=? fun stat -> + Client_node_rpcs.Network.connections cctxt.rpc_config >>=? fun conns -> + Client_node_rpcs.Network.peers cctxt.rpc_config >>=? fun peers -> + Client_node_rpcs.Network.points cctxt.rpc_config >>=? fun points -> cctxt.message "GLOBAL STATS" >>= fun () -> cctxt.message " %a" P2p_types.Stat.pp stat >>= fun () -> cctxt.message "CONNECTIONS" >>= fun () -> @@ -64,6 +66,6 @@ let commands () = [ Point.pp p (if pi.trusted then "★" else " ") end points >>= fun () -> - Lwt.return_unit + return () end ] diff --git a/src/client/client_node_rpcs.ml b/src/client/client_node_rpcs.ml index 74f04ea49..ecc13baa5 100644 --- a/src/client/client_node_rpcs.ml +++ b/src/client/client_node_rpcs.ml @@ -9,153 +9,46 @@ (* Tezos Command line interface - RPC Calls *) -open Lwt -open Cli_entries -open Client_commands -open Logging.RPC - -let log_request { log } cpt url req = - log "requests" ">>>>%d: %s\n%s\n" cpt url req - -let log_response { log } cpt code ans = - log "requests" "<<<<%d: %s\n%s\n" cpt (Cohttp.Code.string_of_status code) ans - -let cpt = ref 0 -let make_request cctxt meth service json = - incr cpt ; - let cpt = !cpt in - let scheme = if cctxt.config.tls then "https" else "http" in - let host = cctxt.config.node_addr in - let port = cctxt.config.node_port 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 - (fun () -> - let body = Cohttp_lwt_body.of_string reqbody in - Cohttp_lwt_unix.Client.call meth ~body uri >>= fun (code, ansbody) -> - log_request cctxt cpt string_uri reqbody >>= fun () -> - return (cpt, Unix.gettimeofday () -. tzero, - code.Cohttp.Response.status, ansbody)) - (fun e -> - let msg = match e with - | Unix.Unix_error (e, _, _) -> Unix.error_message e - | e -> Printexc.to_string e in - cctxt.error "cannot connect to the RPC server (%s)" msg) - -let get_streamed_json cctxt meth service json = - make_request cctxt meth service json >>= fun (_cpt, time, code, ansbody) -> - let ansbody = Cohttp_lwt_body.to_stream ansbody in - match code, ansbody with - | #Cohttp.Code.success_status, ansbody -> - (if cctxt.config.print_timings then - cctxt.message "Request to /%s succeeded in %gs" - (String.concat "/" service) time - else Lwt.return ()) >>= fun () -> - Lwt.return ( - Lwt_stream.filter_map_s - (function - | Ok v -> Lwt.return (Some v) - | Error msg -> - lwt_log_error - "Failed to parse json: %s" msg >>= fun () -> - Lwt.return None) - (Data_encoding_ezjsonm.from_stream ansbody)) - | err, _ansbody -> - (if cctxt.config.print_timings then - cctxt.message "Request to /%s failed in %gs" - (String.concat "/" service) time - else Lwt.return ()) >>= fun () -> - cctxt.message "Request to /%s failed, server returned %s" - (String.concat "/" service) (Cohttp.Code.string_of_status err) >>= fun () -> - cctxt.error "the RPC server returned a non-success status (%s)" - (Cohttp.Code.string_of_status err) - -let get_json cctxt meth service json = - make_request cctxt meth service json >>= fun (cpt, time, code, ansbody) -> - Cohttp_lwt_body.to_string ansbody >>= fun ansbody -> - match code, ansbody with - | #Cohttp.Code.success_status, ansbody -> begin - (if cctxt.config.print_timings then - cctxt.message "Request to /%s succeeded in %gs" - (String.concat "/" service) time - else Lwt.return ()) >>= fun () -> - log_response cctxt cpt code ansbody >>= fun () -> - if ansbody = "" then Lwt.return `Null - else match Data_encoding_ezjsonm.from_string ansbody with - | Error _ -> cctxt.error "the RPC server returned malformed JSON" - | Ok res -> Lwt.return res - end - | err, _ansbody -> - (if cctxt.config.print_timings then - cctxt.message "Request to /%s failed in %gs" - (String.concat "/" service) time - else Lwt.return ()) >>= fun () -> - cctxt.message "Request to /%s failed, server returned %s" - (String.concat "/" service) (Cohttp.Code.string_of_status err) >>= fun () -> - cctxt.error "the RPC server returned a non-success status (%s)" - (Cohttp.Code.string_of_status err) - -exception Unknown_error of Data_encoding.json - -let parse_answer cctxt service path json = - match RPC.read_answer service json with - | Error msg -> (* TODO print_error *) - cctxt.error "request to /%s returned wrong JSON (%s)\n%s" - (String.concat "/" path) msg (Data_encoding_ezjsonm.to_string json) - | Ok v -> return v - -let call_service0 cctxt service arg = - let meth, path, arg = RPC.forge_request service () arg in - get_json cctxt meth path arg >>= fun json -> - parse_answer cctxt service path json - -let call_service1 cctxt service a1 arg = - let meth, path, arg = RPC.forge_request service ((), a1) arg in - get_json cctxt meth path arg >>= fun json -> - parse_answer cctxt service path json - -let call_service2 cctxt service a1 a2 arg = - let meth, path, arg = RPC.forge_request service (((), a1), a2) arg in - get_json cctxt meth path arg >>= fun json -> - parse_answer cctxt service path json - -let call_streamed_service0 cctxt service arg = - let meth, path, arg = RPC.forge_request service () arg in - get_streamed_json cctxt meth path arg >|= fun st -> - Lwt_stream.map_s (parse_answer cctxt service path) st - +open Client_rpcs module Services = Node_rpc_services + let errors cctxt = call_service0 cctxt Services.Error.service () + let forge_block cctxt ?net ?predecessor ?timestamp fitness ops header = call_service0 cctxt Services.forge_block (net, predecessor, timestamp, fitness, ops, header) + let validate_block cctxt net block = - call_service0 cctxt Services.validate_block (net, block) + call_err_service0 cctxt Services.validate_block (net, block) + let inject_block cctxt ?(async = false) ?(force = false) raw operations = - call_service0 cctxt Services.inject_block + call_err_service0 cctxt Services.inject_block { raw ; blocking = not async ; force ; operations } + let inject_operation cctxt ?(async = false) ?force operation = - call_service0 cctxt Services.inject_operation (operation, not async, force) + call_err_service0 cctxt Services.inject_operation + (operation, not async, force) + let inject_protocol cctxt ?(async = false) ?force protocol = - call_service0 cctxt Services.inject_protocol (protocol, not async, force) + call_err_service0 cctxt Services.inject_protocol + (protocol, not async, force) + let bootstrapped cctxt = call_streamed_service0 cctxt Services.bootstrapped () + let complete cctxt ?block prefix = match block with | None -> call_service1 cctxt Services.complete prefix () | Some block -> call_service2 cctxt Services.Blocks.complete block prefix () -let describe cctxt ?recurse path = - let meth, prefix, arg = RPC.forge_request Services.describe () recurse in - get_json cctxt meth (prefix @ path) arg >>= - parse_answer cctxt Services.describe prefix + +let describe config ?recurse path = + call_describe0 config Services.describe path recurse module Blocks = struct + type block = Services.Blocks.block type block_info = Services.Blocks.block_info = { @@ -181,18 +74,30 @@ module Blocks = struct fitness: MBytes.t list ; timestamp: Time.t ; } - let net cctxt h = call_service1 cctxt Services.Blocks.net h () - let predecessor cctxt h = call_service1 cctxt Services.Blocks.predecessor h () - let predecessors cctxt h l = call_service1 cctxt Services.Blocks.predecessors h l - let hash cctxt h = call_service1 cctxt Services.Blocks.hash h () - let timestamp cctxt h = call_service1 cctxt Services.Blocks.timestamp h () - let fitness cctxt h = call_service1 cctxt Services.Blocks.fitness h () - let operations cctxt h = call_service1 cctxt Services.Blocks.operations h () - let protocol cctxt h = call_service1 cctxt Services.Blocks.protocol h () - let test_protocol cctxt h = call_service1 cctxt Services.Blocks.test_protocol h () - let test_network cctxt h = call_service1 cctxt Services.Blocks.test_network h () + let net cctxt h = + call_service1 cctxt Services.Blocks.net h () + let predecessor cctxt h = + call_service1 cctxt Services.Blocks.predecessor h () + let predecessors cctxt h l = + call_service1 cctxt Services.Blocks.predecessors h l + let hash cctxt h = + call_service1 cctxt Services.Blocks.hash h () + let timestamp cctxt h = + call_service1 cctxt Services.Blocks.timestamp h () + let fitness cctxt h = + call_service1 cctxt Services.Blocks.fitness h () + let operations cctxt h = + call_service1 cctxt Services.Blocks.operations h () + let protocol cctxt h = + call_service1 cctxt Services.Blocks.protocol h () + let test_protocol cctxt h = + call_service1 cctxt Services.Blocks.test_protocol h () + let test_network cctxt h = + call_service1 cctxt Services.Blocks.test_network h () let preapply cctxt h ?timestamp ?(sort = false) operations = - call_service1 cctxt Services.Blocks.preapply h { operations ; sort ; timestamp } + call_err_service1 + cctxt Services.Blocks.preapply h + { operations ; sort ; timestamp } let pending_operations cctxt block = call_service1 cctxt Services.Blocks.pending_operations block () let info cctxt ?(operations = true) ?(data = true) h = @@ -209,30 +114,44 @@ module Blocks = struct call_streamed_service0 cctxt Services.Blocks.list { operations ; data ; length ; heads ; monitor = Some true ; delay ; min_date ; min_heads } + end module Operations = struct + let contents cctxt hashes = call_service1 cctxt Services.Operations.contents hashes () + let monitor cctxt ?contents () = call_streamed_service0 cctxt Services.Operations.list { monitor = Some true ; contents } + end module Protocols = struct + let contents cctxt hash = call_service1 cctxt Services.Protocols.contents hash () + let list cctxt ?contents () = - call_service0 cctxt Services.Protocols.list { contents; monitor = Some false } + call_service0 + cctxt Services.Protocols.list + { contents; monitor = Some false } + end module Network = struct + let stat cctxt = call_service0 cctxt Services.Network.stat () + let connections cctxt = call_service0 cctxt Services.Network.Connection.list () + let peers cctxt = call_service0 cctxt Services.Network.Peer_id.list [] + let points cctxt = call_service0 cctxt Services.Network.Point.list [] + end diff --git a/src/client/client_node_rpcs.mli b/src/client/client_node_rpcs.mli index 6340148e2..050562e73 100644 --- a/src/client/client_node_rpcs.mli +++ b/src/client/client_node_rpcs.mli @@ -7,19 +7,20 @@ (* *) (**************************************************************************) +open Client_rpcs + val errors: - Client_commands.context -> - Json_schema.schema Lwt.t + config -> Json_schema.schema tzresult Lwt.t val forge_block: - Client_commands.context -> + config -> ?net:Net_id.t -> ?predecessor:Block_hash.t -> ?timestamp:Time.t -> Fitness.fitness -> Operation_list_list_hash.t -> MBytes.t -> - MBytes.t Lwt.t + MBytes.t tzresult Lwt.t (** [forge_block cctxt ?net ?predecessor ?timestamp fitness ops proto_hdr] returns the serialization of a block header with [proto_hdr] as protocol-specific part. The arguments [?net] and @@ -27,12 +28,12 @@ val forge_block: and [?timestamp] defaults to [Time.now ()]. *) val validate_block: - Client_commands.context -> + config -> Net_id.t -> Block_hash.t -> unit tzresult Lwt.t val inject_block: - Client_commands.context -> + config -> ?async:bool -> ?force:bool -> MBytes.t -> Operation_hash.t list list -> Block_hash.t tzresult Lwt.t @@ -43,13 +44,13 @@ val inject_block: fitness. *) val inject_operation: - Client_commands.context -> + config -> ?async:bool -> ?force:bool -> MBytes.t -> Operation_hash.t tzresult Lwt.t val inject_protocol: - Client_commands.context -> + config -> ?async:bool -> ?force:bool -> Tezos_compiler.Protocol.t -> Protocol_hash.t tzresult Lwt.t @@ -64,39 +65,40 @@ module Blocks : sig ] val net: - Client_commands.context -> - block -> Net_id.t Lwt.t + config -> + block -> Net_id.t tzresult Lwt.t val predecessor: - Client_commands.context -> - block -> Block_hash.t Lwt.t + config -> + block -> Block_hash.t tzresult Lwt.t val predecessors: - Client_commands.context -> - block -> int -> Block_hash.t list Lwt.t + config -> + block -> int -> Block_hash.t list tzresult Lwt.t val hash: - Client_commands.context -> - block -> Block_hash.t Lwt.t + config -> + block -> Block_hash.t tzresult Lwt.t val timestamp: - Client_commands.context -> - block -> Time.t Lwt.t + config -> + block -> Time.t tzresult Lwt.t val fitness: - Client_commands.context -> - block -> MBytes.t list Lwt.t + config -> + block -> MBytes.t list tzresult Lwt.t val operations: - Client_commands.context -> - block -> Operation_hash.t list list Lwt.t + config -> + block -> Operation_hash.t list list tzresult Lwt.t val protocol: - Client_commands.context -> - block -> Protocol_hash.t Lwt.t + config -> + block -> Protocol_hash.t tzresult Lwt.t val test_protocol: - Client_commands.context -> - block -> Protocol_hash.t option Lwt.t + config -> + block -> Protocol_hash.t option tzresult Lwt.t val test_network: - Client_commands.context -> - block -> (Net_id.t * Time.t) option Lwt.t + config -> + block -> (Net_id.t * Time.t) option tzresult Lwt.t val pending_operations: - Client_commands.context -> - block -> (error Updater.preapply_result * Operation_hash.Set.t) Lwt.t + config -> + block -> + (error Updater.preapply_result * Operation_hash.Set.t) tzresult Lwt.t type block_info = { hash: Block_hash.t ; @@ -113,20 +115,20 @@ module Blocks : sig } val info: - Client_commands.context -> - ?operations:bool -> ?data:bool -> block -> block_info Lwt.t + config -> + ?operations:bool -> ?data:bool -> block -> block_info tzresult Lwt.t val list: - Client_commands.context -> + config -> ?operations:bool -> ?data:bool -> ?length:int -> ?heads:Block_hash.t list -> ?delay:int -> ?min_date:Time.t -> ?min_heads:int -> - unit -> block_info list list Lwt.t + unit -> block_info list list tzresult Lwt.t val monitor: - Client_commands.context -> + config -> ?operations:bool -> ?data:bool -> ?length:int -> ?heads:Block_hash.t list -> ?delay:int -> ?min_date:Time.t -> ?min_heads:int -> - unit -> block_info list list Lwt_stream.t Lwt.t + unit -> block_info list list tzresult Lwt_stream.t tzresult Lwt.t type preapply_result = { operations: error Updater.preapply_result ; @@ -135,7 +137,7 @@ module Blocks : sig } val preapply: - Client_commands.context -> + config -> block -> ?timestamp:Time.t -> ?sort:bool -> @@ -146,63 +148,54 @@ end module Operations : sig val contents: - Client_commands.context -> - Operation_hash.t list -> Store.Operation.t list Lwt.t + config -> + Operation_hash.t list -> Store.Operation.t list tzresult Lwt.t val monitor: - Client_commands.context -> + config -> ?contents:bool -> unit -> - (Operation_hash.t * Store.Operation.t option) list list Lwt_stream.t Lwt.t + (Operation_hash.t * Store.Operation.t option) list list tzresult + Lwt_stream.t tzresult Lwt.t end module Protocols : sig val contents: - Client_commands.context -> - Protocol_hash.t -> Store.Protocol.t Lwt.t + config -> + Protocol_hash.t -> Store.Protocol.t tzresult Lwt.t val list: - Client_commands.context -> + config -> ?contents:bool -> unit -> - (Protocol_hash.t * Store.Protocol.t option) list Lwt.t + (Protocol_hash.t * Store.Protocol.t option) list tzresult Lwt.t end val bootstrapped: - Client_commands.context -> (Block_hash.t * Time.t) Lwt_stream.t Lwt.t + config -> (Block_hash.t * Time.t) tzresult Lwt_stream.t tzresult Lwt.t module Network : sig + val stat: - Client_commands.context -> P2p_types.Stat.t Lwt.t + config -> P2p_types.Stat.t tzresult Lwt.t + val connections: - Client_commands.context -> P2p_types.Connection_info.t list Lwt.t + config -> P2p_types.Connection_info.t list tzresult Lwt.t + val peers: - Client_commands.context -> (P2p.Peer_id.t * P2p.RPC.Peer_id.info) list Lwt.t + config -> (P2p.Peer_id.t * P2p.RPC.Peer_id.info) list tzresult Lwt.t + val points: - Client_commands.context -> (P2p.Point.t * P2p.RPC.Point.info) list Lwt.t + config -> (P2p.Point.t * P2p.RPC.Point.info) list tzresult Lwt.t + end val complete: - Client_commands.context -> - ?block:Blocks.block -> string -> string list Lwt.t + config -> + ?block:Blocks.block -> string -> string list tzresult Lwt.t val describe: - Client_commands.context -> - ?recurse:bool -> string list -> RPC.Description.directory_descr Lwt.t - -(** Low-level *) - -val get_json: - Client_commands.context -> - RPC.meth -> string list -> Data_encoding.json -> Data_encoding.json Lwt.t - -val call_service0: - Client_commands.context -> - (unit, unit, 'i, 'o) RPC.service -> 'i -> 'o Lwt.t -val call_service1: - Client_commands.context -> - (unit, unit * 'a, 'i, 'o) RPC.service -> 'a -> 'i -> 'o Lwt.t -val call_service2: - Client_commands.context -> - (unit, (unit * 'a) * 'b, 'i, 'o) RPC.service -> 'a -> 'b -> 'i -> 'o Lwt.t + config -> + ?recurse:bool -> string list -> + RPC.Description.directory_descr tzresult Lwt.t diff --git a/src/client/client_protocols.ml b/src/client/client_protocols.ml index 47fc152ad..4e01ce7db 100644 --- a/src/client/client_protocols.ml +++ b/src/client/client_protocols.ml @@ -7,6 +7,8 @@ (* *) (**************************************************************************) +open Client_commands + let group = { Cli_entries.name = "protocols" ; title = "Commands for managing protocols" } @@ -24,8 +26,9 @@ let commands () = command ~group ~desc: "list known protocols" (prefixes [ "list" ; "protocols" ] stop) (fun cctxt -> - Client_node_rpcs.Protocols.list cctxt ~contents:false () >>= fun protos -> - Lwt_list.iter_s (fun (ph, _p) -> cctxt.message "%a" Protocol_hash.pp ph) protos + Client_node_rpcs.Protocols.list cctxt.rpc_config ~contents:false () >>=? fun protos -> + Lwt_list.iter_s (fun (ph, _p) -> cctxt.message "%a" Protocol_hash.pp ph) protos >>= fun () -> + return () ); command ~group ~desc: "inject a new protocol to the shell database" (prefixes [ "inject" ; "protocol" ] @@ -35,24 +38,30 @@ let commands () = Lwt.catch (fun () -> let proto = Tezos_compiler.Protocol.of_dir dirname in - Client_node_rpcs.inject_protocol cctxt proto >>= function + Client_node_rpcs.inject_protocol cctxt.rpc_config proto >>= function | Ok hash -> - cctxt.message "Injected protocol %a successfully" Protocol_hash.pp_short hash + cctxt.message "Injected protocol %a successfully" Protocol_hash.pp_short hash >>= fun () -> + return () + | Error err -> cctxt.error "Error while injecting protocol from %s: %a" - dirname Error_monad.pp_print_error err) + dirname Error_monad.pp_print_error err >>= fun () -> + return ()) (fun exn -> cctxt.error "Error while injecting protocol from %s: %a" - dirname Error_monad.pp_print_error [Error_monad.Exn exn]) + dirname Error_monad.pp_print_error [Error_monad.Exn exn] >>= fun () -> + return ()) ); command ~group ~desc: "dump a protocol from the shell database" (prefixes [ "dump" ; "protocol" ] @@ param ~name:"protocol hash" ~desc:"" check_hash @@ stop) (fun ph cctxt -> - Client_node_rpcs.Protocols.contents cctxt ph >>= fun proto -> + Client_node_rpcs.Protocols.contents cctxt.rpc_config ph >>=? fun proto -> Updater.extract "" ph proto >>= fun () -> - cctxt.message "Extracted protocol %a" Protocol_hash.pp_short ph) ; + cctxt.message "Extracted protocol %a" Protocol_hash.pp_short ph >>= fun () -> + return () + ) ; (* | Error err -> *) (* cctxt.error "Error while dumping protocol %a: %a" *) (* Protocol_hash.pp_short ph Error_monad.pp_print_error err); *) diff --git a/src/client/client_rpcs.ml b/src/client/client_rpcs.ml new file mode 100644 index 000000000..15f2a756c --- /dev/null +++ b/src/client/client_rpcs.ml @@ -0,0 +1,231 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +open Error_monad +open Lwt.Infix + +type logger = Logger : { + log_request: Uri.t -> Data_encoding.json -> 'a Lwt.t ; + log_success: + 'a -> Cohttp.Code.status_code -> Data_encoding.json -> unit Lwt.t ; + log_error: + 'a -> Cohttp.Code.status_code -> string -> unit Lwt.t ; + } -> logger + +type config = { + host : string ; + port : int ; + tls : bool ; + logger : logger ; +} + +let null_logger = + Logger { + log_request = (fun _ _ -> Lwt.return_unit) ; + log_success = (fun _ _ _ -> Lwt.return_unit) ; + log_error = (fun _ _ _ -> Lwt.return_unit) ; + } + +let timings_logger ppf = + Logger { + log_request = begin fun url _body -> + let tzero = Unix.gettimeofday () in + let url = Uri.to_string url in + Lwt.return (url, tzero) + end ; + log_success = begin fun (url, tzero) _code _body -> + let time = Unix.gettimeofday () -. tzero in + Format.fprintf ppf "Request to %s succeeded in %gs" url time ; + Lwt.return_unit + end ; + log_error = begin fun (url, tzero) _code _body -> + let time = Unix.gettimeofday () -. tzero in + Format.fprintf ppf "Request to %s failed in %gs" url time ; + Lwt.return_unit + end ; + } + +let full_logger ppf = + let cpt = ref 0 in + Logger { + log_request = begin fun url body -> + let id = !cpt in + let url = Uri.to_string url in + let body = Data_encoding_ezjsonm.to_string body in + incr cpt ; + Format.fprintf ppf ">>>>%d: %s\n%s@." id url body ; + Lwt.return (id, url) + end ; + log_success = begin fun (id, _url) code body -> + let code = Cohttp.Code.string_of_status code in + let body = Data_encoding_ezjsonm.to_string body in + Format.fprintf ppf "<<<<%d: %s\n%s@." id code body ; + Lwt.return_unit + end ; + log_error = begin fun (id, _url) code body -> + let code = Cohttp.Code.string_of_status code in + Format.fprintf ppf "<<<<%d: %s\n%s@." id code body ; + Lwt.return_unit + end ; +} + +let default_config = { + host = "localhost" ; + port = 8732 ; + tls = false ; + logger = null_logger ; +} + +type rpc_error = + | Cannot_connect_to_RPC_server of string + | Request_failed of string list * Cohttp.Code.status_code + | Malformed_json of string list * string * string + | Unexpected_json of string list * Data_encoding.json * string + +type error += RPC_error of config * rpc_error + +let fail config err = fail (RPC_error (config, err)) + +let make_request config log_request meth service json = + let scheme = if config.tls then "https" else "http" in + let path = String.concat "/" service in + let uri = + Uri.make ~scheme ~host:config.host ~port:config.port ~path () in + let reqbody = Data_encoding_ezjsonm.to_string json in + Lwt.catch begin fun () -> + let body = Cohttp_lwt_body.of_string reqbody in + Cohttp_lwt_unix.Client.call meth ~body uri >>= fun (code, ansbody) -> + log_request uri json >>= fun reqid -> + return (reqid, code.Cohttp.Response.status, ansbody) + end begin fun e -> + let msg = match e with + | Unix.Unix_error (e, _, _) -> Unix.error_message e + | e -> Printexc.to_string e in + fail config (Cannot_connect_to_RPC_server msg) + end + +let get_streamed_json config meth service json = + let Logger logger = config.logger in + make_request config logger.log_request + meth service json >>=? fun (reqid, code, ansbody) -> + match code with + | #Cohttp.Code.success_status -> + let ansbody = Cohttp_lwt_body.to_stream ansbody in + let json_st = Data_encoding_ezjsonm.from_stream ansbody in + let parsed_st, push = Lwt_stream.create () in + let rec loop () = + Lwt_stream.get json_st >>= function + | Some (Ok json) as v -> + push v ; + logger.log_success reqid code json >>= fun () -> + loop () + | None -> + push None ; + Lwt.return_unit + | Some (Error msg) -> + let error = + RPC_error (config, Malformed_json (service, "", msg)) in + push (Some (Error [error])) ; + push None ; + Lwt.return_unit + in + Lwt.async loop ; + return parsed_st + | err -> + Cohttp_lwt_body.to_string ansbody >>= fun ansbody -> + logger.log_error reqid code ansbody >>= fun () -> + fail config (Request_failed (service, err)) + +let get_json config meth service json = + let Logger logger = config.logger in + make_request config logger.log_request + meth service json >>=? fun (reqid, code, ansbody) -> + Cohttp_lwt_body.to_string ansbody >>= fun ansbody -> + match code with + | #Cohttp.Code.success_status -> begin + if ansbody = "" then + return `Null + else + match Data_encoding_ezjsonm.from_string ansbody with + | Error msg -> + logger.log_error reqid code ansbody >>= fun () -> + fail config (Malformed_json (service, ansbody, msg)) + | Ok json -> + logger.log_success reqid code json >>= fun () -> + return json + end + | err -> + logger.log_error reqid code ansbody >>= fun () -> + fail config (Request_failed (service, err)) + +let parse_answer config service path json = + match RPC.read_answer service json with + | Error msg -> (* TODO print_error *) + fail config (Unexpected_json (path, json, msg)) + | Ok v -> return v + +let call_service0 cctxt service arg = + let meth, path, arg = RPC.forge_request service () arg in + get_json cctxt meth path arg >>=? fun json -> + parse_answer cctxt service path json + +let call_service1 cctxt service a1 arg = + let meth, path, arg = RPC.forge_request service ((), a1) arg in + get_json cctxt meth path arg >>=? fun json -> + parse_answer cctxt service path json + +let call_service2 cctxt service a1 a2 arg = + let meth, path, arg = RPC.forge_request service (((), a1), a2) arg in + get_json cctxt meth path arg >>=? fun json -> + parse_answer cctxt service path json + +let call_streamed_service0 cctxt service arg = + let meth, path, arg = RPC.forge_request service () arg in + get_streamed_json cctxt meth path arg >>=? fun json_st -> + let parsed_st, push = Lwt_stream.create () in + let rec loop () = + Lwt_stream.get json_st >>= function + | Some (Ok json) -> begin + parse_answer cctxt service path json >>= function + | Ok v -> push (Some (Ok v)) ; loop () + | Error _ as err -> + push (Some err) ; push None ; Lwt.return_unit + end + | Some (Error _) as v -> + push v ; push None ; Lwt.return_unit + | None -> push None ; Lwt.return_unit + in + Lwt.async loop ; + return parsed_st + +let parse_err_answer config service path json = + match RPC.read_answer service json with + | Error msg -> (* TODO print_error *) + fail config (Unexpected_json (path, json, msg)) + | Ok v -> Lwt.return v + +let call_err_service0 cctxt service arg = + let meth, path, arg = RPC.forge_request service () arg in + get_json cctxt meth path arg >>=? fun json -> + parse_err_answer cctxt service path json + +let call_err_service1 cctxt service a1 arg = + let meth, path, arg = RPC.forge_request service ((), a1) arg in + get_json cctxt meth path arg >>=? fun json -> + parse_err_answer cctxt service path json + +let call_err_service2 cctxt service a1 a2 arg = + let meth, path, arg = RPC.forge_request service (((), a1), a2) arg in + get_json cctxt meth path arg >>=? fun json -> + parse_err_answer cctxt service path json + +let call_describe0 cctxt service path arg = + let meth, prefix, arg = RPC.forge_request service () arg in + get_json cctxt meth (prefix @ path) arg >>=? fun json -> + parse_answer cctxt service prefix json diff --git a/src/client/client_rpcs.mli b/src/client/client_rpcs.mli new file mode 100644 index 000000000..f56b9a43c --- /dev/null +++ b/src/client/client_rpcs.mli @@ -0,0 +1,74 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +type config = { + host : string ; + port : int ; + tls : bool ; + logger : logger ; +} + +and logger = + Logger : { + log_request : Uri.t -> Data_encoding.json -> 'a Lwt.t ; + log_success : + 'a -> Cohttp.Code.status_code -> Data_encoding.json -> unit Lwt.t ; + log_error : + 'a -> Cohttp.Code.status_code -> string -> unit Lwt.t ; + } -> logger + +val default_config: config +val null_logger: logger +val timings_logger: Format.formatter -> logger +val full_logger: Format.formatter -> logger + +val get_json: + config -> + RPC.meth -> string list -> Data_encoding.json -> + Data_encoding.json tzresult Lwt.t + +val call_service0: + config -> + (unit, unit, 'i, 'o) RPC.service -> + 'i -> 'o tzresult Lwt.t + +val call_service1: + config -> + (unit, unit * 'a, 'i, 'o) RPC.service -> + 'a -> 'i -> 'o tzresult Lwt.t + +val call_service2: + config -> + (unit, (unit * 'a) * 'b, 'i, 'o) RPC.service -> + 'a -> 'b -> 'i -> 'o tzresult Lwt.t + +val call_streamed_service0: + config -> + (unit, unit, 'a, 'b) RPC.service -> + 'a -> ('b, error list) result Lwt_stream.t tzresult Lwt.t + +val call_err_service0: + config -> + (unit, unit, 'i, 'o tzresult) RPC.service -> + 'i -> 'o tzresult Lwt.t + +val call_err_service1: + config -> + (unit, unit * 'a, 'i, 'o tzresult) RPC.service -> + 'a -> 'i -> 'o tzresult Lwt.t + +val call_err_service2: + config -> + (unit, (unit * 'a) * 'b, 'i, 'o tzresult) RPC.service -> + 'a -> 'b -> 'i -> 'o tzresult Lwt.t + +val call_describe0: + config -> + (unit, unit, 'a, 'b) RPC.service -> + string list -> 'a -> 'b tzresult Lwt.t diff --git a/src/client/client_tags.mli b/src/client/client_tags.mli index 9b85b8556..a80000661 100644 --- a/src/client/client_tags.mli +++ b/src/client/client_tags.mli @@ -28,8 +28,8 @@ module Tags (Entity : Entity) : sig val tag_param: ?name:string -> ?desc:string -> - ('a, Client_commands.context, unit) Cli_entries.params -> - (Tag.t -> 'a, Client_commands.context, unit) Cli_entries.params + ('a, Client_commands.context, 'ret) Cli_entries.params -> + (Tag.t -> 'a, Client_commands.context, 'ret) Cli_entries.params val rev_find_by_tag: Client_commands.context -> diff --git a/src/client/embedded/alpha/baker/client_mining_blocks.ml b/src/client/embedded/alpha/baker/client_mining_blocks.ml index c084dc8da..48c84f48d 100644 --- a/src/client/embedded/alpha/baker/client_mining_blocks.ml +++ b/src/client/embedded/alpha/baker/client_mining_blocks.ml @@ -33,7 +33,7 @@ let convert_block_info_err cctxt return { hash ; predecessor ; fitness ; timestamp ; protocol ; level } let info cctxt ?operations block = - Client_node_rpcs.Blocks.info cctxt ?operations block >>= fun block -> + Client_node_rpcs.Blocks.info cctxt ?operations block >>=? fun block -> convert_block_info_err cctxt block let compare (bi1 : block_info) (bi2 : block_info) = @@ -58,9 +58,11 @@ let monitor cctxt ?min_date ?min_heads ?compare () = Client_node_rpcs.Blocks.monitor cctxt ?operations ?length ?heads ?delay ?min_date ?min_heads - () >>= fun block_stream -> - let convert blocks = sort_blocks cctxt ?compare (List.flatten blocks) in - Lwt.return (Lwt_stream.map_s convert block_stream) + () >>=? fun block_stream -> + let convert blocks = + Lwt.return blocks >>=? fun blocks -> + sort_blocks cctxt ?compare (List.flatten blocks) >>= return in + return (Lwt_stream.map_s convert block_stream) let blocks_from_cycle cctxt block cycle = let block = @@ -71,7 +73,7 @@ let blocks_from_cycle cctxt block cycle = Client_proto_rpcs.Context.level cctxt block >>=? fun level -> Client_proto_rpcs.Helpers.levels cctxt block cycle >>=? fun (first, last) -> let length = Int32.to_int (Raw_level.diff level.level first) in - Client_node_rpcs.Blocks.predecessors cctxt block length >>= fun blocks -> + Client_node_rpcs.Blocks.predecessors cctxt block length >>=? fun blocks -> let blocks = Utils.remove_elem_from_list (length - (1 + Int32.to_int (Raw_level.diff last first))) blocks in diff --git a/src/client/embedded/alpha/baker/client_mining_blocks.mli b/src/client/embedded/alpha/baker/client_mining_blocks.mli index 654fda8c0..1cda9483f 100644 --- a/src/client/embedded/alpha/baker/client_mining_blocks.mli +++ b/src/client/embedded/alpha/baker/client_mining_blocks.mli @@ -17,21 +17,21 @@ type block_info = { } val info: - Client_commands.context -> + Client_rpcs.config -> ?operations:bool -> Client_node_rpcs.Blocks.block -> block_info tzresult Lwt.t val compare: block_info -> block_info -> int val monitor: - Client_commands.context -> + Client_rpcs.config -> ?operations:bool -> ?length:int -> ?heads:Block_hash.t list -> ?delay:int -> ?min_date:Time.t -> ?min_heads:int -> ?compare:(block_info -> block_info -> int) -> - unit -> block_info list Lwt_stream.t Lwt.t + unit -> block_info list tzresult Lwt_stream.t tzresult Lwt.t val blocks_from_cycle: - Client_commands.context -> + Client_rpcs.config -> Client_node_rpcs.Blocks.block -> Cycle.t -> Block_hash.t list tzresult Lwt.t diff --git a/src/client/embedded/alpha/baker/client_mining_daemon.ml b/src/client/embedded/alpha/baker/client_mining_daemon.ml index fe886dac2..84646d527 100644 --- a/src/client/embedded/alpha/baker/client_mining_daemon.ml +++ b/src/client/embedded/alpha/baker/client_mining_daemon.ml @@ -7,6 +7,7 @@ (* *) (**************************************************************************) +open Client_commands open Logging.Client.Mining let run cctxt ?max_priority ~delay ?min_date delegates = @@ -14,33 +15,36 @@ let run cctxt ?max_priority ~delay ?min_date delegates = let endorsement = if Client_proto_args.Daemon.(!all || !endorsement) then Client_mining_blocks.monitor - cctxt ?min_date ~min_heads:1 () >>= fun block_stream -> - Client_mining_endorsement.create cctxt ~delay delegates block_stream + cctxt.rpc_config ?min_date ~min_heads:1 () >>=? fun block_stream -> + Client_mining_endorsement.create cctxt ~delay delegates block_stream >>= fun () -> + return () else - Lwt.return_unit + return () in let denunciation = if Client_proto_args.Daemon.(!all || !denunciation) then Client_mining_operations.monitor_endorsement - cctxt >>= fun endorsement_stream -> - Client_mining_denunciation.create cctxt endorsement_stream + cctxt.rpc_config >>=? fun endorsement_stream -> + Client_mining_denunciation.create cctxt endorsement_stream >>= fun () -> + return () else - Lwt.return_unit + return () in let forge = if Client_proto_args.Daemon.(!all || !mining) then begin Client_mining_blocks.monitor - cctxt ?min_date ~min_heads:1 () >>= fun block_stream -> + cctxt.rpc_config ?min_date ~min_heads:1 () >>=? fun block_stream -> (* Temporary desactivate the monitoring of endorsement: too slow for now. *) (* Client_mining_operations.monitor_endorsement *) (* cctxt >>= fun endorsement_stream -> *) let endorsement_stream, _push = Lwt_stream.create () in Client_mining_forge.create cctxt - ?max_priority delegates block_stream endorsement_stream + ?max_priority delegates block_stream endorsement_stream >>=? fun () -> + return () end else - Lwt.return_unit + return () in - denunciation >>= fun () -> - endorsement >>= fun () -> + denunciation >>=? fun () -> + endorsement >>=? fun () -> forge diff --git a/src/client/embedded/alpha/baker/client_mining_daemon.mli b/src/client/embedded/alpha/baker/client_mining_daemon.mli index 360bfd41b..bbb3fa317 100644 --- a/src/client/embedded/alpha/baker/client_mining_daemon.mli +++ b/src/client/embedded/alpha/baker/client_mining_daemon.mli @@ -12,4 +12,4 @@ val run: ?max_priority: int -> delay: int -> ?min_date: Time.t -> - public_key_hash list -> unit Lwt.t + public_key_hash list -> unit tzresult Lwt.t diff --git a/src/client/embedded/alpha/baker/client_mining_denunciation.ml b/src/client/embedded/alpha/baker/client_mining_denunciation.ml index 2d1aa6a2b..7c640c251 100644 --- a/src/client/embedded/alpha/baker/client_mining_denunciation.ml +++ b/src/client/embedded/alpha/baker/client_mining_denunciation.ml @@ -24,9 +24,9 @@ let create cctxt endorsement_stream = (* (timeout >|= fun () -> `Timeout) ; *) (get_endorsement () >|= fun e -> `Endorsement e) ; ] >>= function - | `Endorsement None -> + | `Endorsement (None | Some (Error _)) -> Lwt.return_unit - | `Endorsement (Some e) -> + | `Endorsement (Some (Ok e)) -> last_get_endorsement := None ; Client_keys.Public_key_hash.name cctxt e.Client_mining_operations.source >>= fun source -> diff --git a/src/client/embedded/alpha/baker/client_mining_denunciation.mli b/src/client/embedded/alpha/baker/client_mining_denunciation.mli index 20cd8eec1..aab1b08ad 100644 --- a/src/client/embedded/alpha/baker/client_mining_denunciation.mli +++ b/src/client/embedded/alpha/baker/client_mining_denunciation.mli @@ -9,5 +9,5 @@ val create: Client_commands.context -> - Client_mining_operations.valid_endorsement Lwt_stream.t -> + Client_mining_operations.valid_endorsement tzresult Lwt_stream.t -> unit Lwt.t diff --git a/src/client/embedded/alpha/baker/client_mining_endorsement.ml b/src/client/embedded/alpha/baker/client_mining_endorsement.ml index a057c6264..098974b75 100644 --- a/src/client/embedded/alpha/baker/client_mining_endorsement.ml +++ b/src/client/embedded/alpha/baker/client_mining_endorsement.ml @@ -8,6 +8,7 @@ (**************************************************************************) open Logging.Client.Endorsement +open Client_commands open Cli_entries module Ed25519 = Environment.Ed25519 @@ -118,9 +119,9 @@ let get_signing_slots cctxt ?max_priority block delegate level = let inject_endorsement cctxt block level ?async ?force src_sk source slot = - Client_blocks.get_block_hash cctxt block >>= fun block_hash -> - Client_node_rpcs.Blocks.net cctxt block >>= fun net -> - Client_proto_rpcs.Helpers.Forge.Delegate.endorsement cctxt + Client_blocks.get_block_hash cctxt.rpc_config block >>=? fun block_hash -> + Client_node_rpcs.Blocks.net cctxt.rpc_config block >>=? fun net -> + Client_proto_rpcs.Helpers.Forge.Delegate.endorsement cctxt.rpc_config block ~net ~source @@ -129,7 +130,7 @@ let inject_endorsement cctxt () >>=? fun bytes -> let signed_bytes = Ed25519.Signature.append src_sk bytes in Client_node_rpcs.inject_operation - cctxt ?force ?async signed_bytes >>=? fun oph -> + cctxt.rpc_config ?force ?async signed_bytes >>=? fun oph -> State.record_endorsement cctxt level block_hash slot oph >>=? fun () -> return oph @@ -157,14 +158,14 @@ let forge_endorsement cctxt | `Test_prevalidation -> `Test_head 0 | _ -> block in let src_pkh = Ed25519.Public_key.hash src_pk in - Client_proto_rpcs.Context.level cctxt block >>=? fun level -> + Client_proto_rpcs.Context.level cctxt.rpc_config block >>=? fun level -> let level = Raw_level.succ level.level in begin match slot with | Some slot -> return slot | None -> get_signing_slots - cctxt ?max_priority block src_pkh level >>=? function + cctxt.rpc_config ?max_priority block src_pkh level >>=? function | slot::_ -> return slot | [] -> cctxt.error "No slot found at level %a" Raw_level.pp level end >>=? fun slot -> @@ -223,7 +224,7 @@ let schedule_endorsements cctxt state bis = Block_hash.pp_short block.hash name >>= fun () -> let b = `Hash block.hash in let level = Raw_level.succ block.level.level in - get_signing_slots cctxt b delegate level >>=? fun slots -> + get_signing_slots cctxt.rpc_config b delegate level >>=? fun slots -> lwt_debug "Found slots for %a/%s (%d)" Block_hash.pp_short block.hash name (List.length slots) >>= fun () -> iter_p @@ -341,9 +342,9 @@ let compute_timeout state = let create cctxt ~delay contracts block_stream = lwt_log_info "Starting endorsement daemon" >>= fun () -> Lwt_stream.get block_stream >>= function - | None | Some [] -> + | None | Some (Ok []) | Some (Error _) -> cctxt.Client_commands.error "Can't fetch the current block head." - | Some (bi :: _ as initial_heads) -> + | Some (Ok (bi :: _ as initial_heads)) -> let last_get_block = ref None in let get_block () = match !last_get_block with @@ -357,9 +358,9 @@ let create cctxt ~delay contracts block_stream = let timeout = compute_timeout state in Lwt.choose [ (timeout >|= fun () -> `Timeout) ; (get_block () >|= fun b -> `Hash b) ] >>= function - | `Hash None -> + | `Hash (None | Some (Error _)) -> Lwt.return_unit - | `Hash (Some bis) -> + | `Hash (Some (Ok bis)) -> Lwt.cancel timeout ; last_get_block := None ; schedule_endorsements cctxt state bis >>= fun () -> diff --git a/src/client/embedded/alpha/baker/client_mining_endorsement.mli b/src/client/embedded/alpha/baker/client_mining_endorsement.mli index 2ddc1fcc3..b86492394 100644 --- a/src/client/embedded/alpha/baker/client_mining_endorsement.mli +++ b/src/client/embedded/alpha/baker/client_mining_endorsement.mli @@ -21,5 +21,5 @@ val create: Client_commands.context -> delay: int -> public_key_hash list -> - Client_mining_blocks.block_info list Lwt_stream.t -> + Client_mining_blocks.block_info list tzresult Lwt_stream.t -> unit Lwt.t diff --git a/src/client/embedded/alpha/baker/client_mining_forge.ml b/src/client/embedded/alpha/baker/client_mining_forge.ml index 782409ae3..51f96bd6e 100644 --- a/src/client/embedded/alpha/baker/client_mining_forge.ml +++ b/src/client/embedded/alpha/baker/client_mining_forge.ml @@ -7,6 +7,8 @@ (* *) (**************************************************************************) + +open Client_commands open Logging.Client.Mining module Ed25519 = Environment.Ed25519 @@ -42,7 +44,7 @@ let inject_block cctxt block ~priority ~timestamp ~fitness ~seed_nonce ~src_sk operation_list = let block = match block with `Prevalidation -> `Head 0 | block -> block in - Client_node_rpcs.Blocks.info cctxt block >>= fun bi -> + Client_node_rpcs.Blocks.info cctxt block >>=? fun bi -> let seed_nonce_hash = Nonce.hash seed_nonce in Client_proto_rpcs.Context.next_level cctxt block >>=? fun level -> let operations = @@ -89,11 +91,11 @@ let forge_block cctxt block match operations with | None -> Client_node_rpcs.Blocks.pending_operations - cctxt block >|= fun (ops, pendings) -> - Operation_hash.Set.elements @@ - Operation_hash.Set.union (Updater.operations ops) pendings - | Some operations -> Lwt.return operations - end >>= fun operations -> + cctxt block >>=? fun (ops, pendings) -> + return (Operation_hash.Set.elements @@ + Operation_hash.Set.union (Updater.operations ops) pendings) + | Some operations -> return operations + end >>=? fun operations -> begin match priority with | `Set prio -> begin @@ -304,24 +306,24 @@ let compute_timeout { future_slots } = Lwt_unix.sleep (Int64.to_float delay) let get_unrevealed_nonces cctxt ?(force = false) block = - Client_proto_rpcs.Context.next_level cctxt block >>=? fun level -> + Client_proto_rpcs.Context.next_level cctxt.rpc_config block >>=? fun level -> let cur_cycle = level.cycle in match Cycle.pred cur_cycle with | None -> return [] | Some cycle -> Client_mining_blocks.blocks_from_cycle - cctxt block cycle >>=? fun blocks -> + cctxt.rpc_config block cycle >>=? fun blocks -> map_filter_s (fun hash -> Client_proto_nonces.find cctxt hash >>= function | None -> return None | Some nonce -> Client_proto_rpcs.Context.level - cctxt (`Hash hash) >>=? fun level -> + cctxt.rpc_config (`Hash hash) >>=? fun level -> if force then return (Some (hash, (level.level, nonce))) else Client_proto_rpcs.Context.Nonce.get - cctxt block level.level >>=? function + cctxt.rpc_config block level.level >>=? function | Missing nonce_hash when Nonce.check_hash nonce nonce_hash -> cctxt.warning "Found nonce for %a (level: %a)@." @@ -362,7 +364,7 @@ let insert_block ~before:(Time.add state.best.timestamp (-1800L)) state ; end ; get_delegates cctxt state >>= fun delegates -> - get_mining_slot cctxt ?max_priority bi delegates >>= function + get_mining_slot cctxt.rpc_config ?max_priority bi delegates >>= function | None -> lwt_debug "Can't compute slot for %a" Block_hash.pp_short bi.hash >>= fun () -> @@ -392,7 +394,7 @@ let insert_blocks cctxt ?max_priority state bis = let mine cctxt state = let slots = pop_mining_slots state in - Lwt_list.map_p + map_p (fun (timestamp, (bi, prio, delegate)) -> let block = `Hash bi.Client_mining_blocks.hash in let timestamp = @@ -404,19 +406,19 @@ let mine cctxt state = lwt_debug "Try mining after %a (slot %d) for %s (%a)" Block_hash.pp_short bi.hash prio name Time.pp_hum timestamp >>= fun () -> - Client_node_rpcs.Blocks.pending_operations cctxt - block >>= fun (res, ops) -> + Client_node_rpcs.Blocks.pending_operations cctxt.rpc_config + block >>=? fun (res, ops) -> let operations = let open Operation_hash.Set in elements (union ops (Updater.operations res)) in let request = List.length operations in - Client_node_rpcs.Blocks.preapply cctxt block + Client_node_rpcs.Blocks.preapply cctxt.rpc_config block ~timestamp ~sort:true operations >>= function | Error errs -> lwt_log_error "Error while prevalidating operations:\n%a" pp_print_error errs >>= fun () -> - Lwt.return_none + return None | Ok { operations ; fitness ; timestamp } -> lwt_debug "Computed condidate block after %a (slot %d): %d/%d fitness: %a" @@ -424,9 +426,9 @@ let mine cctxt state = (List.length operations.applied) request Fitness.pp fitness >>= fun () -> - Lwt.return + return (Some (bi, prio, fitness, timestamp, operations, delegate))) - slots >>= fun candidates -> + slots >>=? fun candidates -> let candidates = List.sort (fun (_,_,f1,_,_,_) (_,_,f2,_,_,_) -> ~- (Fitness.compare f1 f2)) @@ -441,7 +443,7 @@ let mine cctxt state = Fitness.pp fitness >>= fun () -> let seed_nonce = generate_seed_nonce () in Client_keys.get_key cctxt delegate >>=? fun (_,_,src_sk) -> - inject_block cctxt + inject_block cctxt.rpc_config ~force:true ~src_sk ~priority ~timestamp ~fitness ~seed_nonce (`Hash bi.hash) [operations.applied] |> trace_exn (Failure "Error while injecting block") >>=? fun block_hash -> @@ -466,14 +468,14 @@ let mine cctxt state = let create cctxt ?max_priority delegates (block_stream: - Client_mining_blocks.block_info list Lwt_stream.t) + Client_mining_blocks.block_info list tzresult Lwt_stream.t) (endorsement_stream: - Client_mining_operations.valid_endorsement Lwt_stream.t) = + Client_mining_operations.valid_endorsement tzresult Lwt_stream.t) = Lwt_stream.get block_stream >>= function - | None | Some [] -> + | None | Some (Ok [] | Error _) -> cctxt.Client_commands.error "Can't fetch the current block head." - | Some (bi :: _ as initial_heads) -> - Client_node_rpcs.Blocks.hash cctxt `Genesis >>= fun genesis_hash -> + | Some (Ok (bi :: _ as initial_heads)) -> + Client_node_rpcs.Blocks.hash cctxt.rpc_config `Genesis >>=? fun genesis_hash -> let last_get_block = ref None in let get_block () = match !last_get_block with @@ -498,10 +500,10 @@ let create (get_block () >|= fun b -> `Hash b) ; (get_endorsement () >|= fun e -> `Endorsement e) ; ] >>= function - | `Hash None - | `Endorsement None -> + | `Hash (None | Some (Error _)) + | `Endorsement (None | Some (Error _)) -> Lwt.return_unit - | `Hash (Some bis) -> begin + | `Hash (Some (Ok bis)) -> begin Lwt.cancel timeout ; last_get_block := None ; lwt_debug @@ -514,7 +516,7 @@ let create insert_blocks cctxt ?max_priority state bis >>= fun () -> worker_loop () end - | `Endorsement (Some e) -> + | `Endorsement (Some (Ok e)) -> Lwt.cancel timeout ; last_get_endorsement := None ; Client_keys.Public_key_hash.name cctxt @@ -534,7 +536,8 @@ let create end >>= fun () -> worker_loop () in lwt_log_info "Starting mining daemon" >>= fun () -> - worker_loop () + worker_loop () >>= fun () -> + return () (* FIXME bug in ocamldep ?? *) open Level diff --git a/src/client/embedded/alpha/baker/client_mining_forge.mli b/src/client/embedded/alpha/baker/client_mining_forge.mli index 3d9e907ab..a82ca9363 100644 --- a/src/client/embedded/alpha/baker/client_mining_forge.mli +++ b/src/client/embedded/alpha/baker/client_mining_forge.mli @@ -14,7 +14,7 @@ val generate_seed_nonce: unit -> Nonce.t reveal the aforementionned nonce during the next cycle. *) val inject_block: - Client_commands.context -> + Client_rpcs.config -> Client_proto_rpcs.block -> ?force:bool -> priority:int -> @@ -31,7 +31,7 @@ val inject_block: precomputed). [src_sk] is used to sign the block header. *) val forge_block: - Client_commands.context -> + Client_rpcs.config -> Client_proto_rpcs.block -> ?force:bool -> ?operations:Operation_hash.t list -> @@ -74,9 +74,9 @@ val create: Client_commands.context -> ?max_priority: int -> public_key_hash list -> - Client_mining_blocks.block_info list Lwt_stream.t -> - Client_mining_operations.valid_endorsement Lwt_stream.t -> - unit Lwt.t + Client_mining_blocks.block_info list tzresult Lwt_stream.t -> + Client_mining_operations.valid_endorsement tzresult Lwt_stream.t -> + unit tzresult Lwt.t val get_unrevealed_nonces: Client_commands.context -> diff --git a/src/client/embedded/alpha/baker/client_mining_main.ml b/src/client/embedded/alpha/baker/client_mining_main.ml index aebb9159a..06e6c84ff 100644 --- a/src/client/embedded/alpha/baker/client_mining_main.ml +++ b/src/client/embedded/alpha/baker/client_mining_main.ml @@ -8,6 +8,7 @@ (**************************************************************************) open Cli_entries +open Client_commands open Client_proto_contracts let mine_block cctxt block ?force ?max_priority ?src_sk delegate = @@ -18,10 +19,10 @@ let mine_block cctxt block ?force ?max_priority ?src_sk delegate = return src_sk | Some sk -> return sk end >>=? fun src_sk -> - Client_proto_rpcs.Context.level cctxt block >>=? fun level -> + Client_proto_rpcs.Context.level cctxt.rpc_config block >>=? fun level -> let level = Raw_level.succ level.level in let seed_nonce = Client_mining_forge.generate_seed_nonce () in - Client_mining_forge.forge_block cctxt + Client_mining_forge.forge_block cctxt.rpc_config ~timestamp:(Time.now ()) ?force ~seed_nonce ~src_sk block @@ -62,7 +63,7 @@ let reveal_block_nonces cctxt ?force block_hashes = (fun hash -> Lwt.catch (fun () -> - Client_mining_blocks.info cctxt (`Hash hash) >>= function + Client_mining_blocks.info cctxt.rpc_config (`Hash hash) >>= function | Ok bi -> Lwt.return (Some bi) | Error _ -> Lwt.fail Not_found) @@ -119,8 +120,7 @@ let commands () = @@ stop) (fun (_, delegate) cctxt -> endorse_block cctxt - ~force:!force ?max_priority:!max_priority delegate >>= - Client_proto_rpcs.handle_error cctxt) ; + ~force:!force ?max_priority:!max_priority delegate) ; command ~group ~desc: "Forge and inject block using the delegate rights" ~args: [ max_priority_arg ; force_arg ] (prefixes [ "mine"; "for" ] @@ -129,23 +129,20 @@ let commands () = @@ stop) (fun (_, delegate) cctxt -> mine_block cctxt cctxt.config.block - ~force:!force ?max_priority:!max_priority delegate >>= - Client_proto_rpcs.handle_error cctxt) ; + ~force:!force ?max_priority:!max_priority delegate) ; command ~group ~desc: "Forge and inject a seed-nonce revelation operation" ~args: [ force_arg ] (prefixes [ "reveal"; "nonce"; "for" ] @@ Cli_entries.seq_of_param Block_hash.param) (fun block_hashes cctxt -> reveal_block_nonces cctxt - ~force:!force block_hashes >>= - Client_proto_rpcs.handle_error cctxt) ; + ~force:!force block_hashes) ; command ~group ~desc: "Forge and inject redemption operations" ~args: [ force_arg ] (prefixes [ "reveal"; "nonces" ] @@ stop) (fun cctxt -> - reveal_nonces cctxt ~force:!force () >>= - Client_proto_rpcs.handle_error cctxt) ; + reveal_nonces cctxt ~force:!force ()) ; ] let () = diff --git a/src/client/embedded/alpha/baker/client_mining_operations.ml b/src/client/embedded/alpha/baker/client_mining_operations.ml index d1715bbfe..ffe66c04a 100644 --- a/src/client/embedded/alpha/baker/client_mining_operations.ml +++ b/src/client/embedded/alpha/baker/client_mining_operations.ml @@ -19,29 +19,22 @@ type operation = { } let monitor cctxt ?contents ?check () = - Client_node_rpcs.Operations.monitor cctxt ?contents () >>= fun ops_stream -> + Client_node_rpcs.Operations.monitor cctxt ?contents () >>=? fun ops_stream -> let convert ops = - Lwt_list.filter_map_p + Lwt.return ops >>=? fun ops -> + map_s (fun (hash, op) -> match op with - | None -> Lwt.return (Some { hash; content = None }) - | Some op -> + | None -> return { hash; content = None } + | Some (op : Updater.raw_operation) -> Client_proto_rpcs.Helpers.Parse.operations cctxt - `Prevalidation ?check [op] >>= function - | Ok [proto] -> - Lwt.return (Some { hash ; content = Some (op.shell, proto) }) - | Ok _ -> - lwt_log_error - "@[Error while parsing operations@[" >>= fun () -> - Lwt.return None - | Error err -> - lwt_log_error - "@[Error while parsing operations@,%a@[" - pp_print_error err >>= fun () -> - Lwt.return None) - (List.concat ops) + `Prevalidation ?check [op] >>=? function + | [proto] -> + return { hash ; content = Some (op.shell, proto) } + | _ -> failwith "Error while parsing the operation") + (List.concat ops) in - Lwt.return (Lwt_stream.map_s convert ops_stream) + return (Lwt_stream.map_s convert ops_stream) type valid_endorsement = { @@ -97,17 +90,25 @@ let filter_valid_endorsement cctxt { hash; content } = with Not_found -> Lwt.return_none let monitor_endorsement cctxt = - monitor cctxt ~contents:true ~check:true () >>= fun ops_stream -> + monitor cctxt ~contents:true ~check:true () >>=? fun ops_stream -> let endorsement_stream, push = Lwt_stream.create () in Lwt.async begin fun () -> Lwt_stream.closed ops_stream >|= fun () -> push None end ; Lwt.async begin fun () -> Lwt_stream.iter_p - (Lwt_list.iter_p (fun e -> - filter_valid_endorsement cctxt e >>= function - | None -> Lwt.return_unit - | Some e -> push (Some e) ; Lwt.return_unit)) + (fun ops -> + match ops with + | Error _ as err -> + push (Some err) ; + Lwt.return_unit + | Ok ops -> + Lwt_list.iter_p + (fun e -> + filter_valid_endorsement cctxt e >>= function + | None -> Lwt.return_unit + | Some e -> push (Some (Ok e)) ; Lwt.return_unit) + ops) ops_stream end ; - Lwt.return endorsement_stream + return endorsement_stream diff --git a/src/client/embedded/alpha/baker/client_mining_operations.mli b/src/client/embedded/alpha/baker/client_mining_operations.mli index a75943339..43c860be3 100644 --- a/src/client/embedded/alpha/baker/client_mining_operations.mli +++ b/src/client/embedded/alpha/baker/client_mining_operations.mli @@ -13,9 +13,9 @@ type operation = { } val monitor: - Client_commands.context -> + Client_rpcs.config -> ?contents:bool -> ?check:bool -> unit -> - operation list Lwt_stream.t Lwt.t + operation list tzresult Lwt_stream.t tzresult Lwt.t type valid_endorsement = { hash: Operation_hash.t ; @@ -25,9 +25,9 @@ type valid_endorsement = { } val filter_valid_endorsement: - Client_commands.context -> + Client_rpcs.config -> operation -> valid_endorsement option Lwt.t val monitor_endorsement: - Client_commands.context -> - valid_endorsement Lwt_stream.t Lwt.t + Client_rpcs.config -> + valid_endorsement tzresult Lwt_stream.t tzresult Lwt.t diff --git a/src/client/embedded/alpha/baker/client_mining_revelation.ml b/src/client/embedded/alpha/baker/client_mining_revelation.ml index 03cec8468..b626f010d 100644 --- a/src/client/embedded/alpha/baker/client_mining_revelation.ml +++ b/src/client/embedded/alpha/baker/client_mining_revelation.ml @@ -16,7 +16,7 @@ let inject_seed_nonce_revelation cctxt block ?force ?async nonces = List.map (fun (level, nonce) -> Seed_nonce_revelation { level ; nonce }) nonces in - Client_node_rpcs.Blocks.net cctxt block >>= fun net -> + Client_node_rpcs.Blocks.net cctxt block >>=? fun net -> Client_proto_rpcs.Helpers.Forge.Anonymous.operations cctxt block ~net operations >>=? fun bytes -> Client_node_rpcs.inject_operation cctxt ?force ?async bytes >>=? fun oph -> @@ -27,14 +27,14 @@ type Error_monad.error += Bad_revelation let forge_seed_nonce_revelation (cctxt: Client_commands.context) block ?(force = false) nonces = - Client_node_rpcs.Blocks.hash cctxt block >>= fun hash -> + Client_node_rpcs.Blocks.hash cctxt.rpc_config block >>=? fun hash -> match nonces with | [] -> cctxt.message "No nonce to reveal for block %a" Block_hash.pp_short hash >>= fun () -> return () | _ -> - inject_seed_nonce_revelation cctxt block ~force nonces >>=? fun oph -> + inject_seed_nonce_revelation cctxt.rpc_config block ~force nonces >>=? fun oph -> cctxt.answer "Operation successfully injected %d revelation(s) for %a." (List.length nonces) diff --git a/src/client/embedded/alpha/baker/client_mining_revelation.mli b/src/client/embedded/alpha/baker/client_mining_revelation.mli index 8f6642bb6..b1bd97c6d 100644 --- a/src/client/embedded/alpha/baker/client_mining_revelation.mli +++ b/src/client/embedded/alpha/baker/client_mining_revelation.mli @@ -8,7 +8,7 @@ (**************************************************************************) val inject_seed_nonce_revelation: - Client_commands.context -> + Client_rpcs.config -> Client_proto_rpcs.block -> ?force:bool -> ?async:bool -> diff --git a/src/client/embedded/alpha/client_proto_args.mli b/src/client/embedded/alpha/client_proto_args.mli index 0a42109e7..8e996f295 100644 --- a/src/client/embedded/alpha/client_proto_args.mli +++ b/src/client/embedded/alpha/client_proto_args.mli @@ -23,8 +23,8 @@ val endorsement_delay_arg: string * Arg.spec * string val tez_param : name:string -> desc:string -> - ('a, Client_commands.context, unit) Cli_entries.params -> - (Tez.t -> 'a, Client_commands.context, unit) Cli_entries.params + ('a, Client_commands.context, 'ret) Cli_entries.params -> + (Tez.t -> 'a, Client_commands.context, 'ret) Cli_entries.params val delegate: string option ref val source: string option ref diff --git a/src/client/embedded/alpha/client_proto_context.ml b/src/client/embedded/alpha/client_proto_context.ml index 0966d53c5..f76310720 100644 --- a/src/client/embedded/alpha/client_proto_context.ml +++ b/src/client/embedded/alpha/client_proto_context.ml @@ -11,6 +11,7 @@ open Client_proto_args open Client_proto_contracts open Client_proto_programs open Client_keys +open Client_commands module Ed25519 = Environment.Ed25519 let check_contract cctxt neu = @@ -30,11 +31,12 @@ let get_delegate_pkh cctxt = function (fun _ -> Lwt.return None) let get_timestamp cctxt block = - Client_node_rpcs.Blocks.timestamp cctxt block >>= fun v -> - cctxt.message "%s" (Time.to_notation v) + Client_node_rpcs.Blocks.timestamp cctxt.rpc_config block >>=? fun v -> + cctxt.message "%s" (Time.to_notation v) >>= fun () -> + return () let list_contracts cctxt block = - Client_proto_rpcs.Context.Contract.list cctxt block >>=? fun contracts -> + Client_proto_rpcs.Context.Contract.list cctxt.rpc_config block >>=? fun contracts -> map_s (fun h -> begin match Contract.is_default h with | Some m -> begin @@ -52,7 +54,7 @@ let list_contracts cctxt block = contracts let list_contract_labels cctxt block = - Client_proto_rpcs.Context.Contract.list cctxt block >>=? fun contracts -> + Client_proto_rpcs.Context.Contract.list cctxt.rpc_config block >>=? fun contracts -> map_s (fun h -> begin match Contract.is_default h with | Some m -> begin @@ -83,28 +85,28 @@ let transfer cctxt block ?force ~source ~src_pk ~src_sk ~destination ?arg ~amount ~fee () = let open Cli_entries in - Client_node_rpcs.Blocks.net cctxt block >>= fun net -> + Client_node_rpcs.Blocks.net cctxt.rpc_config block >>=? fun net -> begin match arg with | Some arg -> Client_proto_programs.parse_data cctxt arg >>= fun arg -> Lwt.return (Some arg) | None -> Lwt.return None end >>= fun parameters -> - Client_proto_rpcs.Context.Contract.counter cctxt block source >>=? fun pcounter -> + Client_proto_rpcs.Context.Contract.counter cctxt.rpc_config block source >>=? fun pcounter -> let counter = Int32.succ pcounter in cctxt.message "Acquired the source's sequence counter (%ld -> %ld)." pcounter counter >>= fun () -> - Client_proto_rpcs.Helpers.Forge.Manager.transaction cctxt block + Client_proto_rpcs.Helpers.Forge.Manager.transaction cctxt.rpc_config block ~net ~source ~sourcePubKey:src_pk ~counter ~amount ~destination ?parameters ~fee () >>=? fun bytes -> cctxt.Client_commands.message "Forged the raw origination frame." >>= fun () -> - Client_node_rpcs.Blocks.predecessor cctxt block >>= fun predecessor -> + Client_node_rpcs.Blocks.predecessor cctxt.rpc_config block >>=? fun predecessor -> let signature = Ed25519.sign src_sk bytes in let signed_bytes = MBytes.concat bytes signature in let oph = Operation_hash.hash_bytes [ signed_bytes ] in - Client_proto_rpcs.Helpers.apply_operation cctxt block + Client_proto_rpcs.Helpers.apply_operation cctxt.rpc_config block predecessor oph bytes (Some signature) >>=? fun contracts -> - Client_node_rpcs.inject_operation cctxt ?force signed_bytes >>=? fun injected_oph -> + Client_node_rpcs.inject_operation cctxt.rpc_config ?force signed_bytes >>=? fun injected_oph -> assert (Operation_hash.equal oph injected_oph) ; cctxt.message "Operation successfully injected in the node." >>= fun () -> cctxt.message "Operation hash is '%a'." Operation_hash.pp oph >>= fun () -> @@ -116,12 +118,12 @@ let originate cctxt ?force ~block ?signature bytes = match signature with | None -> bytes | Some signature -> MBytes.concat bytes signature in - Client_node_rpcs.Blocks.predecessor cctxt block >>= fun predecessor -> + Client_node_rpcs.Blocks.predecessor cctxt.rpc_config block >>=? fun predecessor -> let oph = Operation_hash.hash_bytes [ signed_bytes ] in - Client_proto_rpcs.Helpers.apply_operation cctxt block + Client_proto_rpcs.Helpers.apply_operation cctxt.rpc_config block predecessor oph bytes signature >>=? function | [ contract ] -> - Client_node_rpcs.inject_operation cctxt ?force signed_bytes >>=? fun injected_oph -> + Client_node_rpcs.inject_operation cctxt.rpc_config ?force signed_bytes >>=? fun injected_oph -> assert (Operation_hash.equal oph injected_oph) ; cctxt.message "Operation successfully injected in the node." >>= fun () -> cctxt.message "Operation hash is '%a'." Operation_hash.pp oph >>= fun () -> @@ -132,12 +134,12 @@ let originate cctxt ?force ~block ?signature bytes = let originate_account cctxt block ?force ~source ~src_pk ~src_sk ~manager_pkh ?delegatable ?spendable ?delegate ~balance ~fee () = - Client_node_rpcs.Blocks.net cctxt block >>= fun net -> - Client_proto_rpcs.Context.Contract.counter cctxt block source >>=? fun pcounter -> + Client_node_rpcs.Blocks.net cctxt.rpc_config block >>=? fun net -> + Client_proto_rpcs.Context.Contract.counter cctxt.rpc_config block source >>=? fun pcounter -> let counter = Int32.succ pcounter in cctxt.message "Acquired the source's sequence counter (%ld -> %ld)." pcounter counter >>= fun () -> - Client_proto_rpcs.Helpers.Forge.Manager.origination cctxt block + Client_proto_rpcs.Helpers.Forge.Manager.origination cctxt.rpc_config block ~net ~source ~sourcePubKey:src_pk ~managerPubKey:manager_pkh ~counter ~balance ?spendable ?delegatable ?delegatePubKey:delegate ~fee () >>=? fun bytes -> @@ -150,12 +152,12 @@ let originate_contract cctxt ~(code:Script.code) ~init ~fee () = Client_proto_programs.parse_data cctxt init >>= fun storage -> let storage = Script.{ storage ; storage_type = code.storage_type } in - Client_proto_rpcs.Context.Contract.counter cctxt block source >>=? fun pcounter -> + Client_proto_rpcs.Context.Contract.counter cctxt.rpc_config block source >>=? fun pcounter -> let counter = Int32.succ pcounter in cctxt.message "Acquired the source's sequence counter (%ld -> %ld)." pcounter counter >>= fun () -> - Client_node_rpcs.Blocks.net cctxt block >>= fun net -> - Client_proto_rpcs.Helpers.Forge.Manager.origination cctxt block + Client_node_rpcs.Blocks.net cctxt.rpc_config block >>=? fun net -> + Client_proto_rpcs.Helpers.Forge.Manager.origination cctxt.rpc_config block ~net ~source ~sourcePubKey:src_pk ~managerPubKey:manager_pkh ~counter ~balance ~spendable:!spendable ?delegatable ?delegatePubKey @@ -164,8 +166,8 @@ let originate_contract cctxt originate cctxt ?force ~block ~signature bytes let faucet cctxt block ?force ~manager_pkh () = - Client_node_rpcs.Blocks.net cctxt block >>= fun net -> - Client_proto_rpcs.Helpers.Forge.Anonymous.faucet cctxt block + Client_node_rpcs.Blocks.net cctxt.rpc_config block >>=? fun net -> + Client_proto_rpcs.Helpers.Forge.Anonymous.faucet cctxt.rpc_config block ~net ~id:manager_pkh () >>=? fun bytes -> originate cctxt ?force ~block bytes @@ -173,24 +175,24 @@ let delegate_contract cctxt block ?force ~source ?src_pk ~manager_sk ~fee delegate_opt = - Client_node_rpcs.Blocks.net cctxt block >>= fun net -> - Client_proto_rpcs.Context.Contract.counter cctxt block source + Client_node_rpcs.Blocks.net cctxt.rpc_config block >>=? fun net -> + Client_proto_rpcs.Context.Contract.counter cctxt.rpc_config block source >>=? fun pcounter -> let counter = Int32.succ pcounter in cctxt.message "Acquired the source's sequence counter (%ld -> %ld)." pcounter counter >>= fun () -> - Client_proto_rpcs.Helpers.Forge.Manager.delegation cctxt block + Client_proto_rpcs.Helpers.Forge.Manager.delegation cctxt.rpc_config block ~net ~source ?sourcePubKey:src_pk ~counter ~fee delegate_opt >>=? fun bytes -> cctxt.Client_commands.message "Forged the raw origination frame." >>= fun () -> - Client_node_rpcs.Blocks.predecessor cctxt block >>= fun predecessor -> + Client_node_rpcs.Blocks.predecessor cctxt.rpc_config block >>=? fun predecessor -> let signature = Environment.Ed25519.sign manager_sk bytes in let signed_bytes = MBytes.concat bytes signature in let oph = Operation_hash.hash_bytes [ signed_bytes ] in - Client_proto_rpcs.Helpers.apply_operation cctxt block + Client_proto_rpcs.Helpers.apply_operation cctxt.rpc_config block predecessor oph bytes (Some signature) >>=? function | [] -> - Client_node_rpcs.inject_operation cctxt ?force signed_bytes >>=? fun injected_oph -> + Client_node_rpcs.inject_operation cctxt.rpc_config ?force signed_bytes >>=? fun injected_oph -> assert (Operation_hash.equal oph injected_oph) ; cctxt.message "Operation successfully injected in the node." >>= fun () -> cctxt.message "Operation hash is '%a'." Operation_hash.pp oph >>= fun () -> @@ -199,13 +201,13 @@ let delegate_contract cctxt cctxt.error "The origination introduced %d contracts instead of one." (List.length contracts) let dictate cctxt block command seckey = - Client_node_rpcs.Blocks.net cctxt block >>= fun net -> + Client_node_rpcs.Blocks.net cctxt.rpc_config block >>=? fun net -> Client_proto_rpcs.Helpers.Forge.Dictator.operation - cctxt block ~net command >>=? fun bytes -> + cctxt.rpc_config block ~net command >>=? fun bytes -> let signature = Ed25519.sign seckey bytes in let signed_bytes = MBytes.concat bytes signature in let oph = Operation_hash.hash_bytes [ signed_bytes ] in - Client_node_rpcs.inject_operation cctxt signed_bytes >>=? fun injected_oph -> + Client_node_rpcs.inject_operation cctxt.rpc_config signed_bytes >>=? fun injected_oph -> assert (Operation_hash.equal oph injected_oph) ; cctxt.message "Operation successfully injected in the node." >>= fun () -> cctxt.message "Operation hash is '%a'." Operation_hash.pp oph >>= fun () -> @@ -224,30 +226,30 @@ let commands () = command ~group ~desc: "lists all non empty contracts of the block" (fixed [ "list" ; "contracts" ]) (fun cctxt -> - list_contract_labels cctxt cctxt.config.block >>= fun res -> - Client_proto_rpcs.handle_error cctxt res >>= fun contracts -> + list_contract_labels cctxt cctxt.config.block >>=? fun contracts -> Lwt_list.iter_s (fun (alias, hash, kind) -> cctxt.message "%s%s%s" hash kind alias) - contracts) ; + contracts >>= fun () -> + return ()) ; command ~group ~desc: "get the balance of a contract" (prefixes [ "get" ; "balance" ] @@ ContractAlias.destination_param ~name:"src" ~desc:"source contract" @@ stop) (fun (_, contract) cctxt -> - get_balance cctxt cctxt.config.block contract - >>= Client_proto_rpcs.handle_error cctxt >>= fun amount -> - cctxt.answer "%a %s" Tez.pp amount tez_sym) ; + get_balance cctxt.rpc_config cctxt.config.block contract >>=? fun amount -> + cctxt.answer "%a %s" Tez.pp amount tez_sym >>= fun () -> + return ()) ; command ~group ~desc: "get the manager of a block" (prefixes [ "get" ; "manager" ] @@ ContractAlias.destination_param ~name:"src" ~desc:"source contract" @@ stop) (fun (_, contract) cctxt -> - Client_proto_rpcs.Context.Contract.manager cctxt cctxt.config.block contract - >>= Client_proto_rpcs.handle_error cctxt >>= fun manager -> + Client_proto_rpcs.Context.Contract.manager cctxt.rpc_config cctxt.config.block contract >>=? fun manager -> Public_key_hash.rev_find cctxt manager >>= fun mn -> Public_key_hash.to_source cctxt manager >>= fun m -> cctxt.message "%s (%s)" m - (match mn with None -> "unknown" | Some n -> "known as " ^ n)); + (match mn with None -> "unknown" | Some n -> "known as " ^ n) >>= fun () -> + return ()); command ~group ~desc: "open a new account" ~args: ([ fee_arg ; delegate_arg ; force_arg ] @ delegatable_args @ spendable_args) @@ -267,15 +269,16 @@ let commands () = (fun neu (_, manager) balance (_, source) cctxt -> check_contract cctxt neu >>= fun () -> get_delegate_pkh cctxt !delegate >>= fun delegate -> - (Client_proto_contracts.get_manager cctxt cctxt.config.block source >>=? fun src_pkh -> + (Client_proto_contracts.get_manager cctxt.rpc_config cctxt.config.block source >>=? fun src_pkh -> Client_keys.get_key cctxt src_pkh >>=? fun (src_name, src_pk, src_sk) -> cctxt.message "Got the source's manager keys (%s)." src_name >>= fun () -> originate_account cctxt cctxt.config.block ~force:!force ~source ~src_pk ~src_sk ~manager_pkh:manager ~balance ~fee:!fee ~delegatable:!delegatable ~spendable:!spendable ?delegate:delegate - ()) >>= Client_proto_rpcs.handle_error cctxt >>= fun contract -> - RawContractAlias.add cctxt neu contract) ; + ()) >>=? fun contract -> + RawContractAlias.add cctxt neu contract >>= fun () -> + return ()) ; command ~group ~desc: "open a new scripted account" ~args: ([ fee_arg ; delegate_arg ; force_arg ] @ delegatable_args @ spendable_args @ [ init_arg ]) @@ -299,15 +302,16 @@ let commands () = (fun neu (_, manager) balance (_, source) code cctxt -> check_contract cctxt neu >>= fun () -> get_delegate_pkh cctxt !delegate >>= fun delegate -> - (Client_proto_contracts.get_manager cctxt cctxt.config.block source >>=? fun src_pkh -> + (Client_proto_contracts.get_manager cctxt.rpc_config cctxt.config.block source >>=? fun src_pkh -> Client_keys.get_key cctxt src_pkh >>=? fun (src_name, src_pk, src_sk) -> cctxt.message "Got the source's manager keys (%s)." src_name >>= fun () -> originate_contract cctxt cctxt.config.block ~force:!force ~source ~src_pk ~src_sk ~manager_pkh:manager ~balance ~fee:!fee ~delegatable:!delegatable ?delegatePubKey:delegate ~code ~init:!init - ()) >>= Client_proto_rpcs.handle_error cctxt >>= fun contract -> - RawContractAlias.add cctxt neu contract) ; + ()) >>=? fun contract -> + RawContractAlias.add cctxt neu contract >>= fun () -> + return ()) ; command ~group ~desc: "open a new (free) account" ~args: ([ fee_arg ; delegate_arg ; force_arg ] @ delegatable_args @ spendable_args) @@ -320,8 +324,9 @@ let commands () = @@ stop) (fun neu (_, manager) cctxt -> check_contract cctxt neu >>= fun () -> - faucet cctxt cctxt.config.block ~force:!force ~manager_pkh:manager () >>= Client_proto_rpcs.handle_error cctxt >>= fun contract -> - RawContractAlias.add cctxt neu contract) ; + faucet cctxt cctxt.config.block ~force:!force ~manager_pkh:manager () >>=? fun contract -> + RawContractAlias.add cctxt neu contract >>= fun () -> + return ()) ; command ~group ~desc: "transfer tokens" ~args: [ fee_arg ; arg_arg ; force_arg ] (prefixes [ "transfer" ] @@ -335,7 +340,7 @@ let commands () = ~name: "dst" ~desc: "name/literal of the destination contract" @@ stop) (fun amount (_, source) (_, destination) cctxt -> - (Client_proto_contracts.get_manager cctxt cctxt.config.block source >>=? fun src_pkh -> + (Client_proto_contracts.get_manager cctxt.rpc_config cctxt.config.block source >>=? fun src_pkh -> Client_keys.get_key cctxt src_pkh >>=? fun (src_name, src_pk, src_sk) -> cctxt.message "Got the source's manager keys (%s)." src_name >>= fun () -> @@ -344,8 +349,8 @@ let commands () = Lwt_list.iter_s (fun c -> cctxt.message "New contract %a originated from a smart contract." Contract.pp c) - contracts >>= fun () -> return ()) >>= - Client_proto_rpcs.handle_error cctxt) ; + contracts >>= fun () -> + return ())) ; command ~desc: "Activate a protocol" begin prefixes [ "activate" ; "protocol" ] @@ param ~name:"version" ~desc:"Protocol version (b58check)" @@ -357,8 +362,7 @@ let commands () = stop end (fun hash seckey cctxt -> - dictate cctxt cctxt.config.block (Activate hash) seckey >>= - Client_proto_rpcs.handle_error cctxt) ; + dictate cctxt cctxt.config.block (Activate hash) seckey) ; command ~desc: "Fork a test protocol" begin prefixes [ "fork" ; "test" ; "protocol" ] @@ param ~name:"version" ~desc:"Protocol version (b58check)" @@ -370,6 +374,5 @@ let commands () = stop end (fun hash seckey cctxt -> - dictate cctxt cctxt.config.block (Activate_testnet hash) seckey >>= - Client_proto_rpcs.handle_error cctxt) ; + dictate cctxt cctxt.config.block (Activate_testnet hash) seckey) ; ] diff --git a/src/client/embedded/alpha/client_proto_context.mli b/src/client/embedded/alpha/client_proto_context.mli index b17b74112..092449d6f 100644 --- a/src/client/embedded/alpha/client_proto_context.mli +++ b/src/client/embedded/alpha/client_proto_context.mli @@ -14,7 +14,7 @@ val list_contracts: list tzresult Lwt.t val get_balance: - Client_commands.context -> + Client_rpcs.config -> Client_proto_rpcs.block -> Contract.t -> Tez.t tzresult Lwt.t diff --git a/src/client/embedded/alpha/client_proto_contracts.ml b/src/client/embedded/alpha/client_proto_contracts.ml index 356d18306..a25d2ef1c 100644 --- a/src/client/embedded/alpha/client_proto_contracts.ml +++ b/src/client/embedded/alpha/client_proto_contracts.ml @@ -158,12 +158,16 @@ let commands () = @@ RawContractAlias.fresh_alias_param @@ RawContractAlias.source_param @@ stop) - (fun name hash cctxt -> RawContractAlias.add cctxt name hash) ; + (fun name hash cctxt -> + RawContractAlias.add cctxt name hash >>= fun () -> + return ()) ; command ~group ~desc: "remove a contract from the wallet" (prefixes [ "forget" ; "contract" ] @@ RawContractAlias.alias_param @@ stop) - (fun (name, _) cctxt -> RawContractAlias.del cctxt name) ; + (fun (name, _) cctxt -> + RawContractAlias.del cctxt name >>= fun () -> + return ()) ; command ~group ~desc: "lists all known contracts" (fixed [ "list" ; "known" ; "contracts" ]) (fun cctxt -> @@ -171,20 +175,25 @@ let commands () = Lwt_list.iter_s (fun (prefix, alias, contract) -> cctxt.message "%s%s: %s" prefix alias (Contract.to_b58check contract)) - contracts) ; + contracts >>= fun () -> + return ()) ; command ~group ~desc: "forget all known contracts" (fixed [ "forget" ; "all" ; "contracts" ]) (fun cctxt -> - if not cctxt.config.force then - cctxt.Client_commands.error "this can only used with option -force true" - else - RawContractAlias.save cctxt []) ; + if not cctxt.config.force then + cctxt.Client_commands.error "this can only used with option -force true" >>= fun () -> + return () + else + RawContractAlias.save cctxt [] >>= fun () -> + return () + ) ; command ~group ~desc: "display a contract from the wallet" (prefixes [ "show" ; "known" ; "contract" ] @@ RawContractAlias.alias_param @@ stop) (fun (_, contract) cctxt -> - cctxt.message "%a\n%!" Contract.pp contract) ; + cctxt.message "%a\n%!" Contract.pp contract >>= fun () -> + return ()) ; command ~group ~desc: "tag a contract in the wallet" (prefixes [ "tag" ; "contract" ] @@ RawContractAlias.alias_param @@ -196,7 +205,8 @@ let commands () = let new_tags = match tags with | None -> new_tags | Some tags -> Utils.merge_list2 tags new_tags in - Contract_tags.update cctxt alias new_tags) ; + Contract_tags.update cctxt alias new_tags >>= fun () -> + return ()) ; command ~group ~desc: "remove tag(s) from a contract in the wallet" (prefixes [ "untag" ; "contract" ] @@ RawContractAlias.alias_param @@ -214,5 +224,6 @@ let commands () = | None, Some _ -> None | Some t1, Some t2 when t1 = t2 -> None | Some t1, _ -> Some t1) tags new_tags in - Contract_tags.update cctxt alias new_tags) ; + Contract_tags.update cctxt alias new_tags >>= fun () -> + return ()) ; ] diff --git a/src/client/embedded/alpha/client_proto_contracts.mli b/src/client/embedded/alpha/client_proto_contracts.mli index c510dce3f..c1d1eeb7c 100644 --- a/src/client/embedded/alpha/client_proto_contracts.mli +++ b/src/client/embedded/alpha/client_proto_contracts.mli @@ -17,13 +17,13 @@ module ContractAlias : sig val alias_param: ?name:string -> ?desc:string -> - ('a, Client_commands.context, unit) Cli_entries.params -> - (Lwt_io.file_name * Contract.t -> 'a, Client_commands.context, unit) Cli_entries.params + ('a, Client_commands.context, 'ret) Cli_entries.params -> + (Lwt_io.file_name * Contract.t -> 'a, Client_commands.context, 'ret) Cli_entries.params val destination_param: ?name:string -> ?desc:string -> - ('a, Client_commands.context, unit) Cli_entries.params -> - (Lwt_io.file_name * Contract.t -> 'a, Client_commands.context, unit) Cli_entries.params + ('a, Client_commands.context, 'ret) Cli_entries.params -> + (Lwt_io.file_name * Contract.t -> 'a, Client_commands.context, 'ret) Cli_entries.params val rev_find: Client_commands.context -> Contract.t -> string option Lwt.t @@ -37,19 +37,19 @@ val list_contracts: (string * string * Contract.t) list Lwt.t val get_manager: - Client_commands.context -> + Client_rpcs.config -> Client_proto_rpcs.block -> Contract.t -> public_key_hash tzresult Lwt.t val get_delegate: - Client_commands.context -> + Client_rpcs.config -> Client_proto_rpcs.block -> Contract.t -> public_key_hash tzresult Lwt.t val check_public_key : - Client_commands.context -> + Client_rpcs.config -> Client_proto_rpcs.block -> ?src_pk:public_key -> public_key_hash -> diff --git a/src/client/embedded/alpha/client_proto_programs.ml b/src/client/embedded/alpha/client_proto_programs.ml index 3f1e7c634..0bdbf37d5 100644 --- a/src/client/embedded/alpha/client_proto_programs.ml +++ b/src/client/embedded/alpha/client_proto_programs.ml @@ -538,27 +538,31 @@ let commands () = command ~group ~desc: "lists all known programs" (fixed [ "list" ; "known" ; "programs" ]) (fun cctxt -> Program.load cctxt >>= fun list -> - Lwt_list.iter_s (fun (n, _) -> cctxt.message "%s" n) list) ; + Lwt_list.iter_s (fun (n, _) -> cctxt.message "%s" n) list >>= fun () -> + return ()) ; command ~group ~desc: "remember a program under some name" (prefixes [ "remember" ; "program" ] @@ Program.fresh_alias_param @@ Program.source_param @@ stop) (fun name hash cctxt -> - Program.add cctxt name hash) ; + Program.add cctxt name hash >>= fun () -> + return ()) ; command ~group ~desc: "forget a remembered program" (prefixes [ "forget" ; "program" ] @@ Program.alias_param @@ stop) (fun (name, _) cctxt -> - Program.del cctxt name) ; + Program.del cctxt name >>= fun () -> + return ()) ; command ~group ~desc: "display a program" (prefixes [ "show" ; "known" ; "program" ] @@ Program.alias_param @@ stop) (fun (_, program) cctxt -> Program.to_source cctxt program >>= fun source -> - cctxt.message "%s\n" source) ; + cctxt.message "%s\n" source >>= fun () -> + return ()) ; command ~group ~desc: "ask the node to run a program" ~args: [ trace_stack_arg ] (prefixes [ "run" ; "program" ] @@ -571,7 +575,7 @@ let commands () = (fun program storage input cctxt -> let open Data_encoding in if !trace_stack then - Client_proto_rpcs.Helpers.trace_code cctxt + Client_proto_rpcs.Helpers.trace_code cctxt.rpc_config cctxt.config.block program (storage, input) >>= function | Ok (storage, output, trace) -> cctxt.message "@[@[storage@,%a@]@,@[output@,%a@]@,@[trace@,%a@]@]@." @@ -584,20 +588,24 @@ let commands () = loc gas (Format.pp_print_list (print_expr no_locations)) stack)) - trace + trace >>= fun () -> + return () | Error errs -> cctxt.warning "%a" pp_print_error errs >>= fun () -> - cctxt.error "error running program" + cctxt.error "error running program" >>= fun () -> + return () else - Client_proto_rpcs.Helpers.run_code cctxt + Client_proto_rpcs.Helpers.run_code cctxt.rpc_config cctxt.config.block program (storage, input) >>= function | Ok (storage, output) -> cctxt.message "@[@[storage@,%a@]@,@[output@,%a@]@]@." (print_expr no_locations) storage - (print_expr no_locations) output + (print_expr no_locations) output >>= fun () -> + return () | Error errs -> cctxt.warning "%a" pp_print_error errs >>= fun () -> - cctxt.error "error running program") ; + cctxt.error "error running program" >>= fun () -> + return ()) ; command ~group ~desc: "ask the node to typecheck a program" ~args: [ show_types_arg ] (prefixes [ "typecheck" ; "program" ] @@ -605,13 +613,14 @@ let commands () = @@ stop) (fun program cctxt -> let open Data_encoding in - Client_proto_rpcs.Helpers.typecheck_code cctxt cctxt.config.block program >>= function + Client_proto_rpcs.Helpers.typecheck_code cctxt.rpc_config cctxt.config.block program >>= function | Ok type_map -> let type_map, program = unexpand_macros type_map program in cctxt.message "Well typed" >>= fun () -> if !show_types then - cctxt.message "%a" (print_program no_locations) (program, type_map) - else Lwt.return () + cctxt.message "%a" (print_program no_locations) (program, type_map) >>= fun () -> + return () + else return () | Error errs -> report_typechecking_errors cctxt errs >>= fun () -> cctxt.error "ill-typed program") ; @@ -623,13 +632,15 @@ let commands () = @@ stop) (fun data exp_ty cctxt -> let open Data_encoding in - Client_proto_rpcs.Helpers.typecheck_data cctxt + Client_proto_rpcs.Helpers.typecheck_data cctxt.rpc_config cctxt.config.block (data, exp_ty) >>= function | Ok () -> - cctxt.message "Well typed" + cctxt.message "Well typed" >>= fun () -> + return () | Error errs -> report_typechecking_errors cctxt errs >>= fun () -> - cctxt.error "ill-typed data") ; + cctxt.error "ill-typed data" >>= fun () -> + return ()) ; command ~group ~desc: "ask the node to compute the hash of a data expression \ using the same algorithm as script instruction H" @@ -638,13 +649,15 @@ let commands () = @@ stop) (fun data cctxt -> let open Data_encoding in - Client_proto_rpcs.Helpers.hash_data cctxt + Client_proto_rpcs.Helpers.hash_data cctxt.rpc_config cctxt.config.block data >>= function | Ok hash -> - cctxt.message "%S" hash + cctxt.message "%S" hash >>= fun () -> + return () | Error errs -> cctxt.warning "%a" pp_print_error errs >>= fun () -> - cctxt.error "ill-formed data") ; + cctxt.error "ill-formed data" >>= fun () -> + return ()) ; command ~group ~desc: "ask the node to compute the hash of a data expression \ using the same algorithm as script instruction H, sign it using \ @@ -657,7 +670,7 @@ let commands () = @@ stop) (fun data (_, key) cctxt -> let open Data_encoding in - Client_proto_rpcs.Helpers.hash_data cctxt + Client_proto_rpcs.Helpers.hash_data cctxt.rpc_config cctxt.config.block data >>= function | Ok hash -> let signature = Ed25519.sign key (MBytes.of_string hash) in @@ -665,8 +678,10 @@ let commands () = hash (signature |> Data_encoding.Binary.to_bytes Ed25519.Signature.encoding |> - Hex_encode.hex_of_bytes) + Hex_encode.hex_of_bytes) >>= fun () -> + return () | Error errs -> cctxt.warning "%a" pp_print_error errs >>= fun () -> - cctxt.error "ill-formed data") ; + cctxt.error "ill-formed data" >>= fun () -> + return ()) ; ] diff --git a/src/client/embedded/alpha/client_proto_rpcs.ml b/src/client/embedded/alpha/client_proto_rpcs.ml index 30d1e139f..6cd27cb3d 100644 --- a/src/client/embedded/alpha/client_proto_rpcs.ml +++ b/src/client/embedded/alpha/client_proto_rpcs.ml @@ -24,23 +24,21 @@ type block = [ ] let call_service1 cctxt s block a1 = - Client_node_rpcs.call_service1 cctxt + Client_rpcs.call_service1 cctxt (s Node_rpc_services.Blocks.proto_path) block a1 let call_error_service1 cctxt s block a1 = - Lwt.catch begin fun () -> - call_service1 cctxt s block a1 >|= wrap_error - end begin fun exn -> - Lwt.return (Error [Exn exn]) - end + call_service1 cctxt s block a1 >>= function + | Ok (Error _ as err) -> Lwt.return (wrap_error err) + | Ok (Ok v) -> return v + | Error _ as err -> Lwt.return err let call_service2 cctxt s block a1 a2 = - Client_node_rpcs.call_service2 cctxt + Client_rpcs.call_service2 cctxt (s Node_rpc_services.Blocks.proto_path) block a1 a2 let call_error_service2 cctxt s block a1 a2 = - Lwt.catch begin fun () -> - call_service2 cctxt s block a1 a2 >|= wrap_error - end begin fun exn -> - Lwt.return (Error [Exn exn]) - end + call_service2 cctxt s block a1 a2 >>= function + | Ok (Error _ as err) -> Lwt.return (wrap_error err) + | Ok (Ok v) -> return v + | Error _ as err -> Lwt.return err module Constants = struct let errors cctxt block = diff --git a/src/client/embedded/alpha/client_proto_rpcs.mli b/src/client/embedded/alpha/client_proto_rpcs.mli index 60eb2dbd5..1e76bf803 100644 --- a/src/client/embedded/alpha/client_proto_rpcs.mli +++ b/src/client/embedded/alpha/client_proto_rpcs.mli @@ -19,72 +19,72 @@ type block = [ module Constants : sig val errors: - Client_commands.context -> - block -> Json_schema.schema Lwt.t + Client_rpcs.config -> + block -> Json_schema.schema tzresult Lwt.t val cycle_length: - Client_commands.context -> + Client_rpcs.config -> block -> int32 tzresult Lwt.t val voting_period_length: - Client_commands.context -> + Client_rpcs.config -> block -> int32 tzresult Lwt.t val time_before_reward: - Client_commands.context -> + Client_rpcs.config -> block -> Period.t tzresult Lwt.t val slot_durations: - Client_commands.context -> + Client_rpcs.config -> block -> (Period.t list) tzresult Lwt.t val first_free_mining_slot: - Client_commands.context -> + Client_rpcs.config -> block -> int32 tzresult Lwt.t val max_signing_slot: - Client_commands.context -> + Client_rpcs.config -> block -> int tzresult Lwt.t val instructions_per_transaction: - Client_commands.context -> + Client_rpcs.config -> block -> int tzresult Lwt.t val stamp_threshold: - Client_commands.context -> + Client_rpcs.config -> block -> int64 tzresult Lwt.t end module Context : sig val level: - Client_commands.context -> + Client_rpcs.config -> block -> Level.t tzresult Lwt.t (** [level cctxt blk] returns the (protocol view of the) level of [blk]. *) val next_level: - Client_commands.context -> + Client_rpcs.config -> block -> Level.t tzresult Lwt.t (** [next_level cctxt blk] returns the (protocol view of the) level of the successor of [blk]. *) module Nonce : sig val hash: - Client_commands.context -> + Client_rpcs.config -> block -> Nonce_hash.t tzresult Lwt.t type nonce_info = | Revealed of Nonce.t | Missing of Nonce_hash.t | Forgotten val get: - Client_commands.context -> + Client_rpcs.config -> block -> Raw_level.t -> nonce_info tzresult Lwt.t end module Key : sig val get : - Client_commands.context -> + Client_rpcs.config -> block -> public_key_hash -> (public_key_hash * public_key) tzresult Lwt.t val list : - Client_commands.context -> + Client_rpcs.config -> block -> ((public_key_hash * public_key) list) tzresult Lwt.t end module Contract : sig val list: - Client_commands.context -> + Client_rpcs.config -> block -> Contract.t list tzresult Lwt.t type info = { manager: public_key_hash ; @@ -95,88 +95,88 @@ module Context : sig counter: int32 ; } val get: - Client_commands.context -> + Client_rpcs.config -> block -> Contract.t -> info tzresult Lwt.t val balance: - Client_commands.context -> + Client_rpcs.config -> block -> Contract.t -> Tez.t tzresult Lwt.t val manager: - Client_commands.context -> + Client_rpcs.config -> block -> Contract.t -> public_key_hash tzresult Lwt.t val delegate: - Client_commands.context -> + Client_rpcs.config -> block -> Contract.t -> public_key_hash option tzresult Lwt.t val counter: - Client_commands.context -> + Client_rpcs.config -> block -> Contract.t -> int32 tzresult Lwt.t val spendable: - Client_commands.context -> + Client_rpcs.config -> block -> Contract.t -> bool tzresult Lwt.t val delegatable: - Client_commands.context -> + Client_rpcs.config -> block -> Contract.t -> bool tzresult Lwt.t val script: - Client_commands.context -> + Client_rpcs.config -> block -> Contract.t -> Script.t option tzresult Lwt.t end end module Helpers : sig val minimal_time: - Client_commands.context -> + Client_rpcs.config -> block -> ?prio:int -> unit -> Time.t tzresult Lwt.t (** [minimal_time cctxt blk ?prio ()] is the minimal acceptable timestamp for the successor of [blk]. [?prio] defaults to [0]. *) val apply_operation: - Client_commands.context -> + Client_rpcs.config -> block -> Block_hash.t -> Operation_hash.t -> MBytes.t -> MBytes.t option -> (Contract.t list) tzresult Lwt.t val run_code: - Client_commands.context -> + Client_rpcs.config -> block -> Script.code -> (Script.expr * Script.expr) -> (Script.expr * Script.expr) tzresult Lwt.t val trace_code: - Client_commands.context -> + Client_rpcs.config -> block -> Script.code -> (Script.expr * Script.expr) -> (Script.expr * Script.expr * (Script.location * int * Script.expr list) list) tzresult Lwt.t val typecheck_code: - Client_commands.context -> + Client_rpcs.config -> block -> Script.code -> Script_ir_translator.type_map tzresult Lwt.t val typecheck_data: - Client_commands.context -> + Client_rpcs.config -> block -> Script.expr * Script.expr -> unit tzresult Lwt.t val hash_data: - Client_commands.context -> + Client_rpcs.config -> block -> Script.expr -> string tzresult Lwt.t val level: - Client_commands.context -> + Client_rpcs.config -> block -> ?offset:int32 -> Raw_level.t -> Level.t tzresult Lwt.t val levels: - Client_commands.context -> + Client_rpcs.config -> block -> Cycle.t -> (Raw_level.t * Raw_level.t) tzresult Lwt.t module Rights : sig type mining_slot = Raw_level.t * int * Time.t type endorsement_slot = Raw_level.t * int val mining_rights_for_delegate: - Client_commands.context -> + Client_rpcs.config -> block -> public_key_hash -> ?max_priority:int -> ?first_level:Raw_level.t -> ?last_level:Raw_level.t -> unit -> (mining_slot list) tzresult Lwt.t val endorsement_rights_for_delegate: - Client_commands.context -> + Client_rpcs.config -> block -> public_key_hash -> ?max_priority:int -> ?first_level:Raw_level.t -> ?last_level:Raw_level.t -> unit -> (endorsement_slot list) tzresult Lwt.t @@ -185,7 +185,7 @@ module Helpers : sig module Forge : sig module Manager : sig val operations: - Client_commands.context -> + Client_rpcs.config -> block -> net:Net_id.t -> source:Contract.t -> @@ -195,7 +195,7 @@ module Helpers : sig manager_operation list -> MBytes.t tzresult Lwt.t val transaction: - Client_commands.context -> + Client_rpcs.config -> block -> net:Net_id.t -> source:Contract.t -> @@ -207,7 +207,7 @@ module Helpers : sig fee:Tez.t -> unit -> MBytes.t tzresult Lwt.t val origination: - Client_commands.context -> + Client_rpcs.config -> block -> net:Net_id.t -> source:Contract.t -> @@ -223,7 +223,7 @@ module Helpers : sig unit -> MBytes.t tzresult Lwt.t val delegation: - Client_commands.context -> + Client_rpcs.config -> block -> net:Net_id.t -> source:Contract.t -> @@ -235,19 +235,19 @@ module Helpers : sig end module Dictator : sig val operation: - Client_commands.context -> + Client_rpcs.config -> block -> net:Net_id.t -> dictator_operation -> MBytes.t tzresult Lwt.t val activate: - Client_commands.context -> + Client_rpcs.config -> block -> net:Net_id.t -> Protocol_hash.t -> MBytes.t tzresult Lwt.t val activate_testnet: - Client_commands.context -> + Client_rpcs.config -> block -> net:Net_id.t -> Protocol_hash.t -> @@ -255,14 +255,14 @@ module Helpers : sig end module Delegate : sig val operations: - Client_commands.context -> + Client_rpcs.config -> block -> net:Net_id.t -> source:public_key -> delegate_operation list -> MBytes.t tzresult Lwt.t val endorsement: - Client_commands.context -> + Client_rpcs.config -> block -> net:Net_id.t -> source:public_key -> @@ -272,27 +272,27 @@ module Helpers : sig end module Anonymous : sig val operations: - Client_commands.context -> + Client_rpcs.config -> block -> net:Net_id.t -> anonymous_operation list -> MBytes.t tzresult Lwt.t val seed_nonce_revelation: - Client_commands.context -> + Client_rpcs.config -> block -> net:Net_id.t -> level:Raw_level.t -> nonce:Nonce.t -> unit -> MBytes.t tzresult Lwt.t val faucet: - Client_commands.context -> + Client_rpcs.config -> block -> net:Net_id.t -> id:public_key_hash -> unit -> MBytes.t tzresult Lwt.t end val block: - Client_commands.context -> + Client_rpcs.config -> block -> net:Net_id.t -> predecessor:Block_hash.t -> @@ -319,11 +319,11 @@ module Helpers : sig module Parse : sig val operations: - Client_commands.context -> + Client_rpcs.config -> block -> ?check:bool -> Updater.raw_operation list -> proto_operation list tzresult Lwt.t val block: - Client_commands.context -> + Client_rpcs.config -> block -> Updater.shell_block -> MBytes.t -> Block.proto_header tzresult Lwt.t end diff --git a/src/client/embedded/demo/client_proto_main.ml b/src/client/embedded/demo/client_proto_main.ml index 2a057ad1d..7203c6f70 100644 --- a/src/client/embedded/demo/client_proto_main.ml +++ b/src/client/embedded/demo/client_proto_main.ml @@ -15,11 +15,11 @@ let demo cctxt = let block = Client_commands.(cctxt.config.block) in cctxt.Client_commands.message "Calling the 'echo' RPC." >>= fun () -> let msg = "test" in - Client_proto_rpcs.echo cctxt block msg >>= fun reply -> + Client_proto_rpcs.echo cctxt.rpc_config block msg >>=? fun reply -> fail_unless (reply = msg) (Unclassified "...") >>=? fun () -> begin cctxt.message "Calling the 'failing' RPC." >>= fun () -> - Client_proto_rpcs.failing cctxt block 3 >>= function + Client_proto_rpcs.failing cctxt.rpc_config block 3 >>= function | Error [Ecoproto_error [Error.Demo_error 3]] -> return () | _ -> failwith "..." @@ -39,7 +39,7 @@ let mine cctxt = | `Prevalidation -> `Head 0 | `Test_prevalidation -> `Test_head 0 | b -> b in - Client_node_rpcs.Blocks.info cctxt block >>= fun bi -> + Client_node_rpcs.Blocks.info cctxt.rpc_config block >>=? fun bi -> let fitness = match bi.fitness with | [ v ; b ] -> @@ -50,10 +50,10 @@ let mine cctxt = Lwt.ignore_result (cctxt.message "Cannot parse fitness: %a" Fitness.pp bi.fitness); exit 2 in - Client_node_rpcs.forge_block cctxt + Client_node_rpcs.forge_block cctxt.rpc_config ~net:bi.net ~predecessor:bi.hash - fitness Operation_list_list_hash.empty (MBytes.create 0) >>= fun bytes -> - Client_node_rpcs.inject_block cctxt bytes [] >>=? fun hash -> + fitness Operation_list_list_hash.empty (MBytes.create 0) >>=? fun bytes -> + Client_node_rpcs.inject_block cctxt.rpc_config bytes [] >>=? fun hash -> cctxt.answer "Injected %a" Block_hash.pp_short hash >>= fun () -> return () @@ -70,16 +70,15 @@ let commands () = [ command ~group ~desc: "A demo command" (fixed [ "demo" ]) - (fun cctxt -> demo cctxt >>= handle_error cctxt) ; + (fun cctxt -> demo cctxt) ; command ~group ~desc: "A failing command" (fixed [ "fail" ]) - (fun cctxt -> + (fun _cctxt -> Error.demo_error 101010 - >|= wrap_error - >>= handle_error cctxt) ; + >|= wrap_error) ; command ~group ~desc: "Mine an empty block" (fixed [ "mine" ]) - (fun cctxt -> mine cctxt >>= handle_error cctxt) ; + (fun cctxt -> mine cctxt) ; ] let () = diff --git a/src/client/embedded/demo/client_proto_rpcs.ml b/src/client/embedded/demo/client_proto_rpcs.ml index 49fbc1d8c..026c7ea2b 100644 --- a/src/client/embedded/demo/client_proto_rpcs.ml +++ b/src/client/embedded/demo/client_proto_rpcs.ml @@ -8,10 +8,13 @@ (**************************************************************************) let call_service1 cctxt s block a1 = - Client_node_rpcs.call_service1 cctxt + Client_rpcs.call_service1 cctxt (s Node_rpc_services.Blocks.proto_path) block a1 let call_error_service1 cctxt s block a1 = - call_service1 cctxt s block a1 >|= wrap_error + call_service1 cctxt s block a1 >>= function + | Ok (Error _ as err) -> Lwt.return (wrap_error err) + | Ok (Ok v) -> return v + | Error _ as err -> Lwt.return err let echo cctxt = call_service1 cctxt Services.echo_service let failing cctxt = call_error_service1 cctxt Services.failing_service diff --git a/src/client/embedded/demo/client_proto_rpcs.mli b/src/client/embedded/demo/client_proto_rpcs.mli index 45fa2de27..e9e0321a6 100644 --- a/src/client/embedded/demo/client_proto_rpcs.mli +++ b/src/client/embedded/demo/client_proto_rpcs.mli @@ -10,8 +10,8 @@ open Node_rpc_services val echo: - Client_commands.context -> - Blocks.block -> string -> string Lwt.t + Client_rpcs.config -> + Blocks.block -> string -> string tzresult Lwt.t val failing: - Client_commands.context -> + Client_rpcs.config -> Blocks.block -> int -> unit tzresult Lwt.t diff --git a/src/client/embedded/genesis/client_proto_main.ml b/src/client/embedded/genesis/client_proto_main.ml index c4b0c441a..93e5b0ec7 100644 --- a/src/client/embedded/genesis/client_proto_main.ml +++ b/src/client/embedded/genesis/client_proto_main.ml @@ -7,29 +7,34 @@ (* *) (**************************************************************************) +open Client_commands + let protocol = Protocol_hash.of_b58check "ProtoGenesisGenesisGenesisGenesisGenesisGenesk612im" let call_service1 cctxt s block a1 = - Client_node_rpcs.call_service1 cctxt + Client_rpcs.call_service1 cctxt (s Node_rpc_services.Blocks.proto_path) block a1 let call_error_service1 cctxt s block a1 = - call_service1 cctxt s block a1 >|= wrap_error + call_service1 cctxt s block a1 >>= function + | Ok (Error _ as err) -> Lwt.return (wrap_error err) + | Ok (Ok v) -> return v + | Error _ as err -> Lwt.return err let forge_block cctxt block net_id ?(timestamp = Time.now ()) command fitness = - Client_blocks.get_block_hash cctxt block >>= fun pred -> + Client_blocks.get_block_hash cctxt block >>=? fun pred -> call_service1 cctxt Services.Forge.block block ((net_id, pred, timestamp, fitness), command) let mine cctxt ?timestamp block command fitness seckey = - Client_blocks.get_block_info cctxt block >>= fun bi -> - forge_block cctxt ?timestamp block bi.net command fitness >>= fun blk -> + Client_blocks.get_block_info cctxt.rpc_config block >>=? fun bi -> + forge_block cctxt.rpc_config ?timestamp block bi.net command fitness >>=? fun blk -> let signed_blk = Environment.Ed25519.Signature.append seckey blk in - Client_node_rpcs.inject_block cctxt signed_blk [[]] >>=? fun hash -> + Client_node_rpcs.inject_block cctxt.rpc_config signed_blk [[]] >>=? fun hash -> cctxt.answer "Injected %a" Block_hash.pp_short hash >>= fun () -> return () @@ -66,8 +71,7 @@ let commands () = let fitness = Client_embedded_proto_alpha.Fitness_repr.from_int64 fitness in mine cctxt ?timestamp cctxt.config.block - (Activate hash) fitness seckey >>= - handle_error cctxt + (Activate hash) fitness seckey end ; command ~args ~desc: "Fork a test protocol" begin @@ -88,8 +92,7 @@ let commands () = let fitness = Client_embedded_proto_alpha.Fitness_repr.from_int64 fitness in mine cctxt ?timestamp cctxt.config.block - (Activate_testnet hash) fitness seckey >>= - handle_error cctxt + (Activate_testnet hash) fitness seckey end ; ] diff --git a/src/client_main.ml b/src/client_main.ml index 5e3a86a63..4e6ecb3d0 100644 --- a/src/client_main.ml +++ b/src/client_main.ml @@ -10,10 +10,10 @@ (* Tezos Command line interface - Main Program *) open Lwt.Infix +open Client_commands +open Error_monad -let cctxt = - (* TODO: set config as parameter? *) - let config = Client_commands.default_cfg in +let cctxt config rpc_config = let startup = CalendarLib.Printer.Precise_Calendar.sprint "%Y-%m-%dT%H:%M:%SZ" @@ -33,7 +33,7 @@ let cctxt = ~mode: Lwt_io.Output Client_commands.(config.base_dir // "logs" // log // startup) (fun chan -> Lwt_io.write chan msg) in - Client_commands.make_context log + Client_commands.make_context ~config ~rpc_config log (* Main (lwt) entry *) let main () = @@ -41,16 +41,21 @@ let main () = Sodium.Random.stir () ; Lwt.catch begin fun () -> let parsed_config_file, block = Client_config.preparse_args Sys.argv in - Lwt.catch begin fun () -> - Client_node_rpcs.Blocks.protocol cctxt cctxt.config.block >>= fun version -> - Lwt.return (Some version, Client_commands.commands_for_version version) - end begin fun exn -> - cctxt.warning - "Failed to acquire the protocol version from the node: %s." - (match exn with - | Failure msg -> msg - | exn -> Printexc.to_string exn) >>= fun () -> - Lwt.return (None, []) + let rpc_config : Client_rpcs.config = { + Client_rpcs.default_config with + host = parsed_config_file.node_addr ; + port = parsed_config_file.node_port ; + tls = parsed_config_file.tls ; + } in + begin + Client_node_rpcs.Blocks.protocol rpc_config block >>= function + | Ok version -> + Lwt.return (Some version, Client_commands.commands_for_version version) + | Error err -> + Format.eprintf + "Failed to acquire the protocol version from the node: %a.@." + pp_print_error err ; + Lwt.return (None, []) end >>= fun (_version, commands_for_version) -> let commands = Client_generic_rpcs.commands @ @@ -66,16 +71,23 @@ let main () = Sys.argv in let config : Client_commands.cfg = { base_dir = parsed_config_file.base_dir ; - print_timings = parsed_args.print_timings ; force = parsed_args.force ; block ; - node_addr = parsed_config_file.node_addr ; - node_port = parsed_config_file.node_port ; - tls = parsed_config_file.tls ; web_port = Client_commands.default_cfg.web_port ; } in - command { cctxt with config } >>= fun () -> - Lwt.return 0 + let rpc_config = + if parsed_args.print_timings then + { rpc_config with + logger = Client_rpcs.timings_logger Format.err_formatter } + else + rpc_config + in + command (cctxt config rpc_config) >>= function + | Ok () -> + Lwt.return 0 + | Error err -> + Format.eprintf "Error: %a@." pp_print_error err ; + Lwt.return 1 end begin function | Arg.Help help -> Format.printf "%s%!" help ; @@ -84,22 +96,22 @@ let main () = Format.eprintf "%s%!" help ; Lwt.return 1 | Cli_entries.Command_not_found -> - Format.eprintf "Unknown command, try `-help`.\n%!" ; + Format.eprintf "Unknown command, try `-help`.@." ; Lwt.return 1 | Client_commands.Version_not_found -> - Format.eprintf "Unknown protocol version, try `list versions`.\n%!" ; + Format.eprintf "Unknown protocol version, try `list versions`.@." ; Lwt.return 1 | Cli_entries.Bad_argument (idx, _n, v) -> - Format.eprintf "There's a problem with argument %d, %s.\n%!" idx v ; + Format.eprintf "There's a problem with argument %d, %s.@." idx v ; Lwt.return 1 | Cli_entries.Command_failed message -> - Format.eprintf "Command failed, %s.\n%!" message ; + Format.eprintf "Command failed, %s.@." message ; Lwt.return 1 | Failure message -> - Format.eprintf "Fatal error: %s\n%!" message ; + Format.eprintf "Fatal error: %s@." message ; Lwt.return 1 | exn -> - Format.printf "Fatal internal error: %s\n%!" + Format.printf "Fatal internal error: %s@." (Printexc.to_string exn) ; Lwt.return 1 end diff --git a/src/node/db/persist.ml b/src/node/db/persist.ml index a9c329692..a0024256e 100644 --- a/src/node/db/persist.ml +++ b/src/node/db/persist.ml @@ -9,7 +9,7 @@ (* Tezos - Persistent structures on top of {!Store} or {!Context} *) -open Lwt +open Lwt.Infix (*-- Signatures --------------------------------------------------------------*) @@ -142,7 +142,7 @@ module MakeBytesStore let list s l = S.list s (List.map to_path l) >>= fun res -> - return (List.map of_path res) + Lwt.return (List.map of_path res) let remove_rec s k = S.remove_rec s (to_path k) @@ -161,8 +161,8 @@ module MakeTypedStore let mem = S.mem let get s k = S.get s k >>= function - | None -> return None - | Some v -> return (C.of_bytes v) + | None -> Lwt.return None + | Some v -> Lwt.return (C.of_bytes v) let set s k v = S.set s k (C.to_bytes v) let del = S.del diff --git a/src/node/net/p2p_connection.mli b/src/node/net/p2p_connection.mli index 9b860273b..60aa6dbf5 100644 --- a/src/node/net/p2p_connection.mli +++ b/src/node/net/p2p_connection.mli @@ -38,7 +38,7 @@ type 'msg t val equal: 'mst t -> 'msg t -> bool -val pp : Format.formatter -> 'msg t -> unit +val pp: Format.formatter -> 'msg t -> unit val info: 'msg t -> Connection_info.t (** {1 Low-level functions (do not use directly)} *) diff --git a/src/utils/cli_entries.ml b/src/utils/cli_entries.ml index 385eba2b4..fb7aaf559 100644 --- a/src/utils/cli_entries.ml +++ b/src/utils/cli_entries.ml @@ -9,7 +9,7 @@ (* Tezos Command line interface - Command Line Parsing *) -open Lwt +open Lwt.Infix (* User catchable exceptions *) exception Command_not_found @@ -70,7 +70,7 @@ let command ?group ?(args = []) ~desc params handler = (* Param combinators *) let string ~name ~desc next = - param name desc (fun _ s -> return s) next + param name desc (fun _ s -> Lwt.return s) next (* Command execution *) let exec @@ -86,7 +86,7 @@ let exec let rec do_seq i acc = function | [] -> Lwt.return (List.rev acc) | p :: rest -> - catch + Lwt.catch (fun () -> f last p) (function | Failure msg -> Lwt.fail (Bad_argument (i, p, msg)) @@ -98,7 +98,7 @@ let exec | Prefix (n, next), p :: rest when n = p -> exec (succ i) next cb rest | Param (_, _, f, next), p :: rest -> - catch + Lwt.catch (fun () -> f last p) (function | Failure msg -> Lwt.fail (Bad_argument (i, p, msg)) diff --git a/src/utils/error_monad.ml b/src/utils/error_monad.ml index 46dd1d00f..5f859ecac 100644 --- a/src/utils/error_monad.ml +++ b/src/utils/error_monad.ml @@ -348,7 +348,8 @@ end include Make() -let generic_error s = error (Unclassified s) +let generic_error fmt = + Format.kasprintf (fun s -> error (Unclassified s)) fmt let failwith fmt = Format.kasprintf (fun s -> fail (Unclassified s)) fmt diff --git a/src/utils/error_monad.mli b/src/utils/error_monad.mli index 141dedd47..77c041b6d 100644 --- a/src/utils/error_monad.mli +++ b/src/utils/error_monad.mli @@ -19,7 +19,9 @@ type error_category = include Error_monad_sig.S (** Erroneous result (shortcut for generic errors) *) -val generic_error : string -> 'a tzresult +val generic_error : + ('a, Format.formatter, unit, 'b tzresult) format4 -> + 'a (** Erroneous return (shortcut for generic errors) *) val failwith :