balsoft/ligo
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Client: more Error_monad in Client_{node,proto}_rpcs

Browse Source
This commit is contained in:
Grégoire Henry 2017-04-04 23:35:41 +02:00 committed by Benjamin Canou
parent f26dfdbe8e
commit 3226565b39
50 changed files with 1025 additions and 723 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
src/Makefile
View File

@ -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 \

54
src/client/client_aliases.ml
View File

@ -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

15
src/client/client_blocks.ml
View File

@ -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

8
src/client/client_blocks.mli
View File

@ -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

36
src/client/client_commands.ml
View File

@ -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 ())

25
src/client/client_commands.mli
View File

@ -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

124
src/client/client_generic_rpcs.ml
View File

@ -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 "@ @[<v 2>Available services:@ @ %a@]@."
display (args, args, tree) >>= fun () ->
if !collected_args <> [] then
if !collected_args <> [] then begin
cctxt.message "@,@[<v 2>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 "/");

23
src/client/client_helpers.ml
View File

@ -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 ()
)
]

54
src/client/client_keys.ml
View File

@ -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 ()) ;
]

2
src/client/client_keys.mli
View File

@ -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

12
src/client/client_network.ml
View File

@ -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
]

195
src/client/client_node_rpcs.ml
View File

@ -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

133
src/client/client_node_rpcs.mli
View File

@ -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

25
src/client/client_protocols.ml
View File

@ -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); *)

231
src/client/client_rpcs.ml Normal file
View File

@ -0,0 +1,231 @@
(**************************************************************************)
(* *)
(* Copyright (c) 2014 - 2016. *)
(* Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* 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

74
src/client/client_rpcs.mli Normal file
View File

@ -0,0 +1,74 @@
(**************************************************************************)
(* *)
(* Copyright (c) 2014 - 2016. *)
(* Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* 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

4
src/client/client_tags.mli
View File

@ -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 ->

12
src/client/embedded/alpha/baker/client_mining_blocks.ml
View File

@ -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

8
src/client/embedded/alpha/baker/client_mining_blocks.mli
View File

@ -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

26
src/client/embedded/alpha/baker/client_mining_daemon.ml
View File

@ -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

2
src/client/embedded/alpha/baker/client_mining_daemon.mli
View File

@ -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

4
src/client/embedded/alpha/baker/client_mining_denunciation.ml
View File

@ -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 ->

2
src/client/embedded/alpha/baker/client_mining_denunciation.mli
View File

@ -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

23
src/client/embedded/alpha/baker/client_mining_endorsement.ml
View File

@ -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 () ->

2
src/client/embedded/alpha/baker/client_mining_endorsement.mli
View File

@ -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

61
src/client/embedded/alpha/baker/client_mining_forge.ml
View File

@ -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

10
src/client/embedded/alpha/baker/client_mining_forge.mli
View File

@ -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 ->

19
src/client/embedded/alpha/baker/client_mining_main.ml
View File

@ -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 () =

49
src/client/embedded/alpha/baker/client_mining_operations.ml
View File

@ -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
"@[<v 2>Error while parsing operations@[" >>= fun () ->
Lwt.return None
| Error err ->
lwt_log_error
"@[<v 2>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

10
src/client/embedded/alpha/baker/client_mining_operations.mli
View File

@ -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

6
src/client/embedded/alpha/baker/client_mining_revelation.ml
View File

@ -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)

2
src/client/embedded/alpha/baker/client_mining_revelation.mli
View File

@ -8,7 +8,7 @@
(**************************************************************************)
val inject_seed_nonce_revelation:
Client_commands.context ->
Client_rpcs.config ->
Client_proto_rpcs.block ->
?force:bool ->
?async:bool ->

4
src/client/embedded/alpha/client_proto_args.mli
View File

@ -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

111
src/client/embedded/alpha/client_proto_context.ml
View File

@ -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) ;
]

2
src/client/embedded/alpha/client_proto_context.mli
View File

@ -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

31
src/client/embedded/alpha/client_proto_contracts.ml
View File

@ -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 ()) ;
]

14
src/client/embedded/alpha/client_proto_contracts.mli
View File

@ -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 ->

59
src/client/embedded/alpha/client_proto_programs.ml
View File

@ -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 "@[<v 0>@[<v 2>storage@,%a@]@,@[<v 2>output@,%a@]@,@[<v 2>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 "@[<v 0>@[<v 2>storage@,%a@]@,@[<v 2>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 ()) ;
]

22
src/client/embedded/alpha/client_proto_rpcs.ml
View File

@ -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 =

102
src/client/embedded/alpha/client_proto_rpcs.mli
View File

@ -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

21
src/client/embedded/demo/client_proto_main.ml
View File

@ -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 () =

7
src/client/embedded/demo/client_proto_rpcs.ml
View File

@ -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

6
src/client/embedded/demo/client_proto_rpcs.mli
View File

@ -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

23
src/client/embedded/genesis/client_proto_main.ml
View File

@ -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 ;
]

64
src/client_main.ml
View File

@ -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

8
src/node/db/persist.ml
View File

@ -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

2
src/node/net/p2p_connection.mli
View File

@ -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)} *)

8
src/utils/cli_entries.ml
View File

@ -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))

3
src/utils/error_monad.ml
View File

@ -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

4
src/utils/error_monad.mli
View File

@ -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 :