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

Client library refactor

Browse Source
This commit is contained in:
Milo Davis 2017-11-07 17:38:11 +01:00 committed by Benjamin Canou
parent 0e2ed6f133
commit ae2959b91c
61 changed files with 1980 additions and 1662 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

38
bin_client/main.ml
View File

@ -9,29 +9,8 @@
(* Tezos Command line interface - Main Program *) (* Tezos Command line interface - Main Program *)
open Client_commands let cctxt ~base_dir ~block rpc_config =
Client_commands.make_context ~base_dir ~block ~rpc_config (Client_commands.default_log ~base_dir)
let cctxt config rpc_config =
let startup =
CalendarLib.Printer.Precise_Calendar.sprint
"%Y-%m-%dT%H:%M:%SZ"
(CalendarLib.Calendar.Precise.now ()) in
let log channel msg = match channel with
| "stdout" ->
print_endline msg ;
Lwt.return ()
| "stderr" ->
prerr_endline msg ;
Lwt.return ()
| log ->
let (//) = Filename.concat in
Lwt_utils.create_dir (config.base_dir // "logs" // log) >>= fun () ->
Lwt_io.with_file
~flags: Unix.[ O_APPEND ; O_CREAT ; O_WRONLY ]
~mode: Lwt_io.Output
Client_commands.(config.base_dir // "logs" // log // startup)
(fun chan -> Lwt_io.write chan msg) in
Client_commands.make_context ~config ~rpc_config log
(* Main (lwt) entry *) (* Main (lwt) entry *)
let main () = let main () =
@ -41,7 +20,9 @@ let main () =
let original_args = List.tl (Array.to_list Sys.argv) in let original_args = List.tl (Array.to_list Sys.argv) in
begin begin
Client_config.parse_config_args Client_config.parse_config_args
(cctxt Client_commands.default_cfg Client_rpcs.default_config) (cctxt ~base_dir:Client_commands.default_base_dir
~block:Client_commands.default_block
Client_rpcs.default_config)
original_args original_args
>>=? fun (parsed_config_file, parsed_args, remaining) -> >>=? fun (parsed_config_file, parsed_args, remaining) ->
let rpc_config : Client_rpcs.config = { let rpc_config : Client_rpcs.config = {
@ -51,7 +32,7 @@ let main () =
tls = parsed_config_file.tls ; tls = parsed_config_file.tls ;
} in } in
begin begin
Client_node_rpcs.Blocks.protocol rpc_config parsed_args.block >>= function Client_node_rpcs.Blocks.protocol (new Client_rpcs.rpc rpc_config) parsed_args.block >>= function
| Ok version -> begin | Ok version -> begin
match parsed_args.protocol with match parsed_args.protocol with
| None -> | None ->
@ -87,10 +68,6 @@ let main () =
Client_helpers.commands () @ Client_helpers.commands () @
Client_debug.commands () @ Client_debug.commands () @
commands_for_version in commands_for_version in
let config : Client_commands.cfg = {
base_dir = parsed_config_file.base_dir ;
block = parsed_args.block ;
} in
let rpc_config = let rpc_config =
if parsed_args.print_timings then if parsed_args.print_timings then
{ rpc_config with { rpc_config with
@ -99,7 +76,8 @@ let main () =
then { rpc_config with logger = Client_rpcs.full_logger Format.err_formatter } then { rpc_config with logger = Client_rpcs.full_logger Format.err_formatter }
else rpc_config else rpc_config
in in
let client_config = (cctxt config rpc_config) in let client_config =
cctxt ~block:parsed_args.block ~base_dir:parsed_config_file.base_dir rpc_config in
(Cli_entries.dispatch (Cli_entries.dispatch
~global_options:Client_config.global_options ~global_options:Client_config.global_options
commands commands

155
lib_client_base/client_aliases.ml
View File

@ -16,10 +16,10 @@ module type Entity = sig
type t type t
val encoding : t Data_encoding.t val encoding : t Data_encoding.t
val of_source : val of_source :
Client_commands.context -> #Client_commands.wallet ->
string -> t tzresult Lwt.t string -> t tzresult Lwt.t
val to_source : val to_source :
Client_commands.context -> #Client_commands.wallet ->
t -> string tzresult Lwt.t t -> string tzresult Lwt.t
val name : string val name : string
end end
@ -28,140 +28,116 @@ module type Alias = sig
type t type t
type fresh_param type fresh_param
val load : val load :
Client_commands.context -> #Client_commands.wallet ->
(string * t) list tzresult Lwt.t (string * t) list tzresult Lwt.t
val set :
#Client_commands.wallet ->
(string * t) list ->
unit tzresult Lwt.t
val find : val find :
Client_commands.context -> #Client_commands.wallet ->
string -> t tzresult Lwt.t string -> t tzresult Lwt.t
val find_opt : val find_opt :
Client_commands.context -> #Client_commands.wallet ->
string -> t option tzresult Lwt.t string -> t option tzresult Lwt.t
val rev_find : val rev_find :
Client_commands.context -> #Client_commands.wallet ->
t -> string option tzresult Lwt.t t -> string option tzresult Lwt.t
val name : val name :
Client_commands.context -> #Client_commands.wallet ->
t -> string tzresult Lwt.t t -> string tzresult Lwt.t
val mem : val mem :
Client_commands.context -> #Client_commands.wallet ->
string -> bool tzresult Lwt.t string -> bool tzresult Lwt.t
val add : val add :
force:bool -> force:bool ->
Client_commands.context -> #Client_commands.wallet ->
string -> t -> unit tzresult Lwt.t string -> t -> unit tzresult Lwt.t
val del : val del :
Client_commands.context -> #Client_commands.wallet ->
string -> unit tzresult Lwt.t string -> unit tzresult Lwt.t
val update : val update :
Client_commands.context -> #Client_commands.wallet ->
string -> t -> unit tzresult Lwt.t string -> t -> unit tzresult Lwt.t
val save :
Client_commands.context ->
(string * t) list -> unit tzresult Lwt.t
val of_source : val of_source :
Client_commands.context -> #Client_commands.wallet ->
string -> t tzresult Lwt.t string -> t tzresult Lwt.t
val to_source : val to_source :
Client_commands.context -> #Client_commands.wallet ->
t -> string tzresult Lwt.t t -> string tzresult Lwt.t
val alias_param : val alias_param :
?name:string -> ?name:string ->
?desc:string -> ?desc:string ->
('a, Client_commands.context, 'ret) Cli_entries.params -> ('a, (#Client_commands.wallet as 'b), 'ret) Cli_entries.params ->
(string * t -> 'a, Client_commands.context, 'ret) Cli_entries.params (string * t -> 'a, 'b, 'ret) Cli_entries.params
val fresh_alias_param : val fresh_alias_param :
?name:string -> ?name:string ->
?desc:string -> ?desc:string ->
('a, Client_commands.context, 'ret) Cli_entries.params -> ('a, (< .. > as 'obj), 'ret) Cli_entries.params ->
(fresh_param -> 'a, Client_commands.context, 'ret) Cli_entries.params (fresh_param -> 'a, 'obj, 'ret) Cli_entries.params
val of_fresh : val of_fresh :
Client_commands.context -> #Client_commands.wallet ->
bool -> bool ->
fresh_param -> fresh_param ->
string tzresult Lwt.t string tzresult Lwt.t
val source_param : val source_param :
?name:string -> ?name:string ->
?desc:string -> ?desc:string ->
('a, Client_commands.context, 'ret) Cli_entries.params -> ('a, (#Client_commands.wallet as 'obj), 'ret) Cli_entries.params ->
(t -> 'a, Client_commands.context, 'ret) Cli_entries.params (t -> 'a, 'obj, 'ret) Cli_entries.params
val autocomplete: val autocomplete:
Client_commands.context -> string list tzresult Lwt.t #Client_commands.wallet -> string list tzresult Lwt.t
end end
module Alias = functor (Entity : Entity) -> struct module Alias = functor (Entity : Entity) -> struct
open Client_commands open Client_commands
let encoding = let wallet_encoding : (string * Entity.t) list Data_encoding.encoding =
let open Data_encoding in let open Data_encoding in
list (obj2 list (obj2
(req "name" string) (req "name" string)
(req "value" Entity.encoding)) (req "value" Entity.encoding))
let dirname cctxt = let load (wallet : #wallet) =
cctxt.config.base_dir wallet#load Entity.name ~default:[] wallet_encoding
let filename cctxt = let set (wallet : #wallet) entries =
Filename.concat (dirname cctxt) (Entity.name ^ "s") wallet#write Entity.name entries wallet_encoding
let load cctxt =
let filename = filename cctxt in
if not (Sys.file_exists filename) ||
Unix.(stat filename).st_size = 0 then
return []
else
Data_encoding_ezjsonm.read_file filename
|> generic_trace
"couldn't to read the %s alias file" Entity.name >>=? fun json ->
match Data_encoding.Json.destruct encoding json with
| exception _ -> (* TODO print_error *)
failwith "didn't understand the %s alias file" Entity.name
| list ->
return list
let autocomplete cctxt = let autocomplete wallet =
load cctxt >>= function load wallet >>= function
| Error _ -> return [] | Error _ -> return []
| Ok list -> return (List.map fst list) | Ok list -> return (List.map fst list)
let find_opt cctxt name = let find_opt (wallet : #wallet) name =
load cctxt >>=? fun list -> load wallet >>=? fun list ->
try return (Some (List.assoc name list)) try return (Some (List.assoc name list))
with Not_found -> return None with Not_found -> return None
let find cctxt name = let find (wallet : #wallet) name =
load cctxt >>=? fun list -> load wallet >>=? fun list ->
try return (List.assoc name list) try return (List.assoc name list)
with Not_found -> with Not_found ->
failwith "no %s alias named %s" Entity.name name failwith "no %s alias named %s" Entity.name name
let rev_find cctxt v = let rev_find (wallet : #wallet) v =
load cctxt >>=? fun list -> load wallet >>=? fun list ->
try return (Some (List.find (fun (_, v') -> v = v') list |> fst)) try return (Some (List.find (fun (_, v') -> v = v') list |> fst))
with Not_found -> return None with Not_found -> return None
let mem cctxt name = let mem (wallet : #wallet) name =
load cctxt >>=? fun list -> load wallet >>=? fun list ->
try try
ignore (List.assoc name list) ; ignore (List.assoc name list) ;
return true return true
with with
| Not_found -> return false | Not_found -> return false
let save cctxt list = let add ~force (wallet : #wallet) name value =
Lwt.catch
(fun () ->
let dirname = dirname cctxt in
Lwt_utils.create_dir dirname >>= fun () ->
let filename = filename cctxt in
let json = Data_encoding.Json.construct encoding list in
Data_encoding_ezjsonm.write_file filename json)
(fun exn -> Lwt.return (error_exn exn))
|> generic_trace "could not write the %s alias file." Entity.name
let add ~force cctxt name value =
let keep = ref false in let keep = ref false in
load cctxt >>=? fun list -> load wallet >>=? fun list ->
begin begin
if force then if force then
return () return ()
@ -169,19 +145,16 @@ module Alias = functor (Entity : Entity) -> struct
iter_s (fun (n, v) -> iter_s (fun (n, v) ->
if n = name && v = value then begin if n = name && v = value then begin
keep := true ; keep := true ;
cctxt.message
"The %s alias %s already exists with the same value."
Entity.name n >>= fun () ->
return () return ()
end else if n = name && v <> value then begin end else if n = name && v <> value then begin
failwith failwith
"another %s is already aliased as %s, \ "another %s is already aliased as %s, \
use -force true to update" use -force to update"
Entity.name n Entity.name n
end else if n <> name && v = value then begin end else if n <> name && v = value then begin
failwith failwith
"this %s is already aliased as %s, \ "this %s is already aliased as %s, \
use -force true to insert duplicate" use -force to insert duplicate"
Entity.name n Entity.name n
end else begin end else begin
return () return ()
@ -193,51 +166,45 @@ module Alias = functor (Entity : Entity) -> struct
if !keep then if !keep then
return () return ()
else else
save cctxt list >>=? fun () -> wallet#write Entity.name list wallet_encoding
cctxt.Client_commands.message
"New %s alias '%s' saved." Entity.name name >>= fun () ->
return ()
let del cctxt name = let del (wallet : #wallet) name =
load cctxt >>=? fun list -> load wallet >>=? fun list ->
let list = List.filter (fun (n, _) -> n <> name) list in let list = List.filter (fun (n, _) -> n <> name) list in
save cctxt list wallet#write Entity.name list wallet_encoding
let update cctxt name value = let update (wallet : #wallet) name value =
load cctxt >>=? fun list -> load wallet >>=? fun list ->
let list = let list =
List.map List.map
(fun (n, v) -> (n, if n = name then value else v)) (fun (n, v) -> (n, if n = name then value else v))
list in list in
save cctxt list wallet#write Entity.name list wallet_encoding
let save cctxt list = let save wallet list =
save cctxt list >>=? fun () -> wallet#write Entity.name wallet_encoding list
cctxt.Client_commands.message
"Successful update of the %s alias file." Entity.name >>= fun () ->
return ()
include Entity include Entity
let alias_param let alias_param
?(name = "name") ?(desc = "existing " ^ Entity.name ^ " alias") next = ?(name = "name") ?(desc = "existing " ^ Entity.name ^ " alias") next =
param ~name ~desc param ~name ~desc
(parameter (fun cctxt s -> (parameter (fun (cctxt : #Client_commands.wallet) s ->
find cctxt s >>=? fun v -> find cctxt s >>=? fun v ->
return (s, v))) return (s, v)))
next next
type fresh_param = Fresh of string type fresh_param = Fresh of string
let of_fresh cctxt force (Fresh s) = let of_fresh (wallet : #wallet) force (Fresh s) =
load cctxt >>=? fun list -> load wallet >>=? fun list ->
begin if force then begin if force then
return () return ()
else else
iter_s iter_s
(fun (n, _v) -> (fun (n, _v) ->
if n = s then if n = s then
Entity.to_source cctxt _v >>=? fun value -> Entity.to_source wallet _v >>=? fun value ->
failwith failwith
"@[<v 2>The %s alias %s already exists.@,\ "@[<v 2>The %s alias %s already exists.@,\
The current value is %s.@,\ The current value is %s.@,\
@ -253,7 +220,7 @@ module Alias = functor (Entity : Entity) -> struct
let fresh_alias_param let fresh_alias_param
?(name = "new") ?(desc = "new " ^ Entity.name ^ " alias") next = ?(name = "new") ?(desc = "new " ^ Entity.name ^ " alias") next =
param ~name ~desc param ~name ~desc
(parameter (fun _ s -> return @@ Fresh s)) (parameter (fun (_ : < .. >) s -> return @@ Fresh s))
next next
let source_param ?(name = "src") ?(desc = "source " ^ Entity.name) next = let source_param ?(name = "src") ?(desc = "source " ^ Entity.name) next =
@ -297,9 +264,9 @@ module Alias = functor (Entity : Entity) -> struct
end)) end))
next next
let name cctxt d = let name (wallet : #wallet) d =
rev_find cctxt d >>=? function rev_find wallet d >>=? function
| None -> Entity.to_source cctxt d | None -> Entity.to_source wallet d
| Some name -> return name | Some name -> return name
end end

49
lib_client_base/client_aliases.mli
View File

@ -12,10 +12,10 @@ module type Entity = sig
type t type t
val encoding : t Data_encoding.t val encoding : t Data_encoding.t
val of_source : val of_source :
Client_commands.context -> #Client_commands.wallet ->
string -> t tzresult Lwt.t string -> t tzresult Lwt.t
val to_source : val to_source :
Client_commands.context -> #Client_commands.wallet ->
t -> string tzresult Lwt.t t -> string tzresult Lwt.t
val name : string val name : string
end end
@ -24,63 +24,64 @@ module type Alias = sig
type t type t
type fresh_param type fresh_param
val load : val load :
Client_commands.context -> #Client_commands.wallet ->
(string * t) list tzresult Lwt.t (string * t) list tzresult Lwt.t
val set :
#Client_commands.wallet ->
(string * t) list ->
unit tzresult Lwt.t
val find : val find :
Client_commands.context -> #Client_commands.wallet ->
string -> t tzresult Lwt.t string -> t tzresult Lwt.t
val find_opt : val find_opt :
Client_commands.context -> #Client_commands.wallet ->
string -> t option tzresult Lwt.t string -> t option tzresult Lwt.t
val rev_find : val rev_find :
Client_commands.context -> #Client_commands.wallet ->
t -> string option tzresult Lwt.t t -> string option tzresult Lwt.t
val name : val name :
Client_commands.context -> #Client_commands.wallet ->
t -> string tzresult Lwt.t t -> string tzresult Lwt.t
val mem : val mem :
Client_commands.context -> #Client_commands.wallet ->
string -> bool tzresult Lwt.t string -> bool tzresult Lwt.t
val add : val add :
force:bool -> force:bool ->
Client_commands.context -> #Client_commands.wallet ->
string -> t -> unit tzresult Lwt.t string -> t -> unit tzresult Lwt.t
val del : val del :
Client_commands.context -> #Client_commands.wallet ->
string -> unit tzresult Lwt.t string -> unit tzresult Lwt.t
val update : val update :
Client_commands.context -> #Client_commands.wallet ->
string -> t -> unit tzresult Lwt.t string -> t -> unit tzresult Lwt.t
val save :
Client_commands.context ->
(string * t) list -> unit tzresult Lwt.t
val of_source : val of_source :
Client_commands.context -> #Client_commands.wallet ->
string -> t tzresult Lwt.t string -> t tzresult Lwt.t
val to_source : val to_source :
Client_commands.context -> #Client_commands.wallet ->
t -> string tzresult Lwt.t t -> string tzresult Lwt.t
val alias_param : val alias_param :
?name:string -> ?name:string ->
?desc:string -> ?desc:string ->
('a, Client_commands.context, 'ret) Cli_entries.params -> ('a, (#Client_commands.wallet as 'b), 'ret) Cli_entries.params ->
(string * t -> 'a, Client_commands.context, 'ret) Cli_entries.params (string * t -> 'a, 'b, 'ret) Cli_entries.params
val fresh_alias_param : val fresh_alias_param :
?name:string -> ?name:string ->
?desc:string -> ?desc:string ->
('a, Client_commands.context, 'ret) Cli_entries.params -> ('a, (< .. > as 'obj), 'ret) Cli_entries.params ->
(fresh_param -> 'a, Client_commands.context, 'ret) Cli_entries.params (fresh_param -> 'a, 'obj, 'ret) Cli_entries.params
val of_fresh : val of_fresh :
Client_commands.context -> #Client_commands.wallet ->
bool -> bool ->
fresh_param -> fresh_param ->
string tzresult Lwt.t string tzresult Lwt.t
val source_param : val source_param :
?name:string -> ?name:string ->
?desc:string -> ?desc:string ->
('a, Client_commands.context, 'ret) Cli_entries.params -> ('a, (#Client_commands.wallet as 'obj), 'ret) Cli_entries.params ->
(t -> 'a, Client_commands.context, 'ret) Cli_entries.params (t -> 'a, 'obj, 'ret) Cli_entries.params
val autocomplete: val autocomplete:
Client_commands.context -> string list tzresult Lwt.t #Client_commands.wallet -> string list tzresult Lwt.t
end end
module Alias (Entity : Entity) : Alias with type t = Entity.t module Alias (Entity : Entity) : Alias with type t = Entity.t

159
lib_client_base/client_commands.ml
View File

@ -10,64 +10,141 @@
type ('a, 'b) lwt_format = type ('a, 'b) lwt_format =
('a, Format.formatter, unit, 'b Lwt.t) format4 ('a, Format.formatter, unit, 'b Lwt.t) format4
type cfg = { class type logger_sig = object
base_dir : string ; method error : ('a, 'b) lwt_format -> 'a
block : Node_rpc_services.Blocks.block ; method warning : ('a, unit) lwt_format -> 'a
} method message : ('a, unit) lwt_format -> 'a
method answer : ('a, unit) lwt_format -> 'a
method log : string -> ('a, unit) lwt_format -> 'a
end
type context = { class logger log =
rpc_config : Client_rpcs.config ; let message =
config : cfg ; (fun x ->
error : 'a 'b. ('a, 'b) lwt_format -> 'a ; Format.kasprintf (fun msg -> log "stdout" msg) x) in
warning : 'a. ('a, unit) lwt_format -> 'a ; object
message : 'a. ('a, unit) lwt_format -> 'a ; method error : type a b. (a, b) lwt_format -> a =
answer : 'a. ('a, unit) lwt_format -> 'a ; Format.kasprintf
log : 'a. string -> ('a, unit) lwt_format -> 'a ; (fun msg ->
} Lwt.fail (Failure msg))
method warning : type a. (a, unit) lwt_format -> a =
Format.kasprintf
(fun msg -> log "stderr" msg)
method message : type a. (a, unit) lwt_format -> a = message
method answer : type a. (a, unit) lwt_format -> a = message
method log : type a. string -> (a, unit) lwt_format -> a =
fun name ->
Format.kasprintf
(fun msg -> log name msg)
end
type command = (context, unit) Cli_entries.command class type wallet = object
method load : string -> default:'a -> 'a Data_encoding.encoding -> 'a tzresult Lwt.t
method write : string -> 'a -> 'a Data_encoding.encoding -> unit tzresult Lwt.t
end
class type block = object
method block : Node_rpc_services.Blocks.block
end
class type logging_wallet = object
inherit logger
inherit wallet
end
class type logging_rpcs = object
inherit logger
inherit Client_rpcs.rpc_sig
end
class type full_context = object
inherit logger
inherit wallet
inherit Client_rpcs.rpc_sig
inherit block
end
class file_wallet dir : wallet = object (self)
method private filename alias_name =
Filename.concat
dir
(Str.(global_replace (regexp_string " ") "_" alias_name) ^ "s")
method load : type a. string -> default:a -> a Data_encoding.encoding -> a tzresult Lwt.t =
fun alias_name ~default encoding ->
let filename = self#filename alias_name in
if not (Sys.file_exists filename) then
return default
else
Data_encoding_ezjsonm.read_file filename
|> generic_trace
"couldn't to read the %s file" alias_name >>=? fun json ->
match Data_encoding.Json.destruct encoding json with
| exception _ -> (* TODO print_error *)
failwith "didn't understand the %s file" alias_name
| data ->
return data
method write :
type a. string -> a -> a Data_encoding.encoding -> unit tzresult Lwt.t =
fun alias_name list encoding ->
Lwt.catch
(fun () ->
Lwt_utils.create_dir dir >>= fun () ->
let filename = self#filename alias_name in
let json = Data_encoding.Json.construct encoding list in
Data_encoding_ezjsonm.write_file filename json)
(fun exn -> Lwt.return (error_exn exn))
|> generic_trace "could not write the %s alias file." alias_name
end
type command = (full_context, unit) Cli_entries.command
(* Default config *) (* Default config *)
let (//) = Filename.concat let (//) = Filename.concat
let default_cfg_of_base_dir base_dir = {
base_dir ;
block = `Prevalidation ;
}
let home = let home =
try Sys.getenv "HOME" try Sys.getenv "HOME"
with Not_found -> "/root" with Not_found -> "/root"
let default_base_dir = home // ".tezos-client" let default_base_dir = home // ".tezos-client"
let default_cfg = default_cfg_of_base_dir default_base_dir let default_block = `Prevalidation
let default_log ~base_dir channel msg =
let startup =
CalendarLib.Printer.Precise_Calendar.sprint
"%Y-%m-%dT%H:%M:%SZ"
(CalendarLib.Calendar.Precise.now ()) in
match channel with
| "stdout" ->
print_endline msg ;
Lwt.return ()
| "stderr" ->
prerr_endline msg ;
Lwt.return ()
| log ->
let (//) = Filename.concat in
Lwt_utils.create_dir (base_dir // "logs" // log) >>= fun () ->
Lwt_io.with_file
~flags: Unix.[ O_APPEND ; O_CREAT ; O_WRONLY ]
~mode: Lwt_io.Output
(base_dir // "logs" // log // startup)
(fun chan -> Lwt_io.write chan msg)
let make_context let make_context
?(config = default_cfg) ?(base_dir = default_base_dir)
?(block = default_block)
?(rpc_config = Client_rpcs.default_config) ?(rpc_config = Client_rpcs.default_config)
log = log =
let error fmt = object
Format.kasprintf inherit logger log
(fun msg -> inherit file_wallet base_dir
Lwt.fail (Failure msg)) inherit Client_rpcs.rpc rpc_config
fmt in method block = block
let warning fmt = end
Format.kasprintf
(fun msg -> log "stderr" msg)
fmt in
let message fmt =
Format.kasprintf
(fun msg -> log "stdout" msg)
fmt in
let answer =
message in
let log name fmt =
Format.kasprintf
(fun msg -> log name msg)
fmt in
{ config ; rpc_config ; error ; warning ; message ; answer ; log }
let ignore_context = let ignore_context =
make_context (fun _ _ -> Lwt.return ()) make_context (fun _ _ -> Lwt.return ())

70
lib_client_base/client_commands.mli
View File

@ -10,45 +10,66 @@
type ('a, 'b) lwt_format = type ('a, 'b) lwt_format =
('a, Format.formatter, unit, 'b Lwt.t) format4 ('a, Format.formatter, unit, 'b Lwt.t) format4
type cfg = { class type logger_sig = object
base_dir : string ; method error : ('a, 'b) lwt_format -> 'a
block : Node_rpc_services.Blocks.block ; method warning : ('a, unit) lwt_format -> 'a
} method message : ('a, unit) lwt_format -> 'a
method answer : ('a, unit) lwt_format -> 'a
method log : string -> ('a, unit) lwt_format -> 'a
end
type context = { val default_log : base_dir:string -> string -> string -> unit Lwt.t
rpc_config : Client_rpcs.config ;
config : cfg ; class logger : (string -> string -> unit Lwt.t) -> logger_sig
error : 'a 'b. ('a, 'b) lwt_format -> 'a ;
warning : 'a. ('a, unit) lwt_format -> 'a ; class type wallet = object
message : 'a. ('a, unit) lwt_format -> 'a ; method load : string -> default:'a -> 'a Data_encoding.encoding -> 'a tzresult Lwt.t
answer : 'a. ('a, unit) lwt_format -> 'a ; method write : string -> 'a -> 'a Data_encoding.encoding -> unit tzresult Lwt.t
log : 'a. string -> ('a, unit) lwt_format -> 'a ; end
}
(** This [context] allows the client {!command} handlers to work in class type block = object
method block : Node_rpc_services.Blocks.block
end
class type logging_wallet = object
inherit logger_sig
inherit wallet
end
class type logging_rpcs = object
inherit logger_sig
inherit Client_rpcs.rpc_sig
end
class type full_context = object
inherit logger_sig
inherit wallet
inherit Client_rpcs.rpc_sig
inherit block
end
(** The [full_context] allows the client {!command} handlers to work in
>>>>>>> 3ab6ecd4... Client library refactor
various modes (command line, batch mode, web client, etc.) by various modes (command line, batch mode, web client, etc.) by
abstracting some basic operations such as logging and reading abstracting some basic operations such as logging and reading
configuration options. It is passed as parameter to the command configuration options. It is passed as parameter to the command
handler when running a command, and must be transmitted to all handler when running a command, and must be transmitted to all
basic operations, also making client commands reantrant. *) basic operations, also making client commands reantrant. *)
val default_base_dir : string
val default_cfg_of_base_dir : string -> cfg
val default_cfg : cfg
val make_context : val make_context :
?config:cfg -> ?base_dir:string ->
?block:Node_rpc_services.Blocks.block ->
?rpc_config:Client_rpcs.config -> ?rpc_config:Client_rpcs.config ->
(string -> string -> unit Lwt.t) -> context (string -> string -> unit Lwt.t) -> full_context
(** [make_context ?config log_fun] builds a context whose logging (** [make_context ?config log_fun] builds a context whose logging
callbacks call [log_fun section msg], and whose [error] function callbacks call [log_fun section msg], and whose [error] function
fails with [Failure] and the given message. If not passed, fails with [Failure] and the given message. If not passed,
[config] is {!default_cfg}. *) [config] is {!default_cfg}. *)
val ignore_context : context val ignore_context : full_context
(** [ignore_context] is a context whose logging callbacks do nothing, (** [ignore_context] is a context whose logging callbacks do nothing,
and whose [error] function calls [Lwt.fail_with]. *) and whose [error] function calls [Lwt.fail_with]. *)
type command = (context, unit) Cli_entries.command type command = (full_context, unit) Cli_entries.command
exception Version_not_found exception Version_not_found
@ -58,4 +79,7 @@ val get_versions: unit -> (Protocol_hash.t * (command list)) list
(** Have a command execute ignoring warnings. (** Have a command execute ignoring warnings.
This switch should be used when data will be overwritten. *) This switch should be used when data will be overwritten. *)
val force_switch : (bool, context) Cli_entries.arg val force_switch : (bool, full_context) Cli_entries.arg
val default_base_dir : string
val default_block : Node_rpc_services.Blocks.block

7
lib_client_base/client_config.ml
View File

@ -110,15 +110,16 @@ type cli_args = {
} }
let default_cli_args = { let default_cli_args = {
block = Client_commands.default_cfg.block ; block = Client_commands.default_block ;
protocol = None ; protocol = None ;
print_timings = false ; print_timings = false ;
log_requests = false ; log_requests = false ;
} }
open Cli_entries open Cli_entries
let string_parameter : (string, Client_commands.context) parameter = let string_parameter : (string, Client_commands.full_context) parameter =
parameter (fun _ x -> return x) parameter (fun _ x -> return x)
let block_parameter = let block_parameter =
@ -205,7 +206,7 @@ let global_options =
port_arg port_arg
tls_switch tls_switch
let parse_config_args (ctx : Client_commands.context) argv = let parse_config_args (ctx : Client_commands.full_context) argv =
parse_initial_options parse_initial_options
global_options global_options
ctx ctx

7
lib_client_base/client_debug.ml
View File

@ -50,7 +50,7 @@ let pp_block ppf
operations operations
(Hex_encode.hex_of_bytes data) (Hex_encode.hex_of_bytes data)
let stuck_node_report (cctxt : Client_commands.context) file = let stuck_node_report cctxt file =
let ppf = Format.formatter_of_out_channel (open_out file) in let ppf = Format.formatter_of_out_channel (open_out file) in
let skip_line () = let skip_line () =
Format.pp_print_newline ppf (); Format.pp_print_newline ppf ();
@ -70,7 +70,7 @@ let stuck_node_report (cctxt : Client_commands.context) file =
(Client_commands.get_versions ()) >>=? fun () -> (Client_commands.get_versions ()) >>=? fun () ->
skip_line () >>=? fun () -> skip_line () >>=? fun () ->
print_title "Heads:" 2 >>=? fun () -> print_title "Heads:" 2 >>=? fun () ->
Client_rpcs.call_service0 cctxt.rpc_config Node_rpc_services.Blocks.list Client_rpcs.call_service0 cctxt Node_rpc_services.Blocks.list
{ include_ops = true ; { include_ops = true ;
length = Some 1 ; length = Some 1 ;
heads = None ; heads = None ;
@ -89,8 +89,7 @@ let stuck_node_report (cctxt : Client_commands.context) file =
ppf heads >>=? fun () -> ppf heads >>=? fun () ->
skip_line () >>=? fun () -> skip_line () >>=? fun () ->
print_title "Rejected blocks:" 2 >>=? fun () -> print_title "Rejected blocks:" 2 >>=? fun () ->
Client_rpcs.call_service0 Client_rpcs.call_service0 cctxt
cctxt.rpc_config
Node_rpc_services.Blocks.list_invalid () >>=? fun invalid -> Node_rpc_services.Blocks.list_invalid () >>=? fun invalid ->
return @@ return @@
Format.pp_print_list Format.pp_print_list

2
lib_client_base/client_debug.mli
View File

@ -8,4 +8,4 @@
(**************************************************************************) (**************************************************************************)
val commands : unit -> (Client_commands.context, unit) Cli_entries.command list val commands : unit -> (#Client_commands.logging_rpcs, unit) Cli_entries.command list

59
lib_client_base/client_generic_rpcs.ml
View File

@ -10,7 +10,6 @@
(* Tezos Command line interface - Generic JSON RPC interface *) (* Tezos Command line interface - Generic JSON RPC interface *)
open Lwt.Infix open Lwt.Infix
open Client_commands
open Cli_entries open Cli_entries
open Json_schema open Json_schema
@ -188,9 +187,9 @@ let rec count =
(*-- Commands ---------------------------------------------------------------*) (*-- Commands ---------------------------------------------------------------*)
let list url cctxt = let list url (cctxt : Client_commands.full_context) =
let args = String.split '/' url in let args = String.split '/' url in
Client_node_rpcs.describe cctxt.rpc_config Client_node_rpcs.describe cctxt
~recurse:true args >>=? fun tree -> ~recurse:true args >>=? fun tree ->
let open RPC.Description in let open RPC.Description in
let collected_args = ref [] in let collected_args = ref [] in
@ -278,52 +277,52 @@ let list url cctxt =
Format.pp_print_list Format.pp_print_list
(fun ppf (n,t) -> display ppf ([ n ], tpath @ [ n ], t)) (fun ppf (n,t) -> display ppf ([ n ], tpath @ [ n ], t))
in in
cctxt.message "@ @[<v 2>Available services:@ @ %a@]@." cctxt#message "@ @[<v 2>Available services:@ @ %a@]@."
display (args, args, tree) >>= fun () -> display (args, args, tree) >>= fun () ->
if !collected_args <> [] then begin if !collected_args <> [] then begin
cctxt.message "@,@[<v 2>Dynamic parameter description:@ @ %a@]@." cctxt#message "@,@[<v 2>Dynamic parameter description:@ @ %a@]@."
(Format.pp_print_list display_arg) !collected_args >>= fun () -> (Format.pp_print_list display_arg) !collected_args >>= fun () ->
return () return ()
end else return () end else return ()
let schema url cctxt = let schema url (cctxt : Client_commands.full_context) =
let args = String.split '/' url in let args = String.split '/' url in
let open RPC.Description in let open RPC.Description in
Client_node_rpcs.describe cctxt.rpc_config ~recurse:false args >>=? function Client_node_rpcs.describe cctxt ~recurse:false args >>=? function
| Static { services } -> begin | Static { services } -> begin
match RPC.MethMap.find `POST services with match RPC.MethMap.find `POST services with
| exception Not_found -> | exception Not_found ->
cctxt.message cctxt#message
"No service found at this URL (but this is a valid prefix)\n%!" >>= fun () -> "No service found at this URL (but this is a valid prefix)\n%!" >>= fun () ->
return () return ()
| { input = Some input ; output } -> | { input = Some input ; output } ->
let json = `O [ "input", Json_schema.to_json input ; let json = `O [ "input", Json_schema.to_json input ;
"output", Json_schema.to_json output ] in "output", Json_schema.to_json output ] in
cctxt.message "%a" Json_repr.(pp (module Ezjsonm)) json >>= fun () -> cctxt#message "%a" Json_repr.(pp (module Ezjsonm)) json >>= fun () ->
return () return ()
| { input = None ; output } -> | { input = None ; output } ->
let json = `O [ "output", Json_schema.to_json output ] in let json = `O [ "output", Json_schema.to_json output ] in
cctxt.message "%a" Json_repr.(pp (module Ezjsonm)) json >>= fun () -> cctxt#message "%a" Json_repr.(pp (module Ezjsonm)) json >>= fun () ->
return () return ()
end end
| _ -> | _ ->
cctxt.message cctxt#message
"No service found at this URL (but this is a valid prefix)\n%!" >>= fun () -> "No service found at this URL (but this is a valid prefix)\n%!" >>= fun () ->
return () return ()
let format url cctxt = let format url (cctxt : #Client_commands.logging_rpcs) =
let args = String.split '/' url in let args = String.split '/' url in
let open RPC.Description in let open RPC.Description in
Client_node_rpcs.describe cctxt.rpc_config ~recurse:false args >>=? function Client_node_rpcs.describe cctxt ~recurse:false args >>=? function
| Static { services } -> begin | Static { services } -> begin
match RPC.MethMap.find `POST services with match RPC.MethMap.find `POST services with
| exception Not_found -> | exception Not_found ->
cctxt.message cctxt#message
"No service found at this URL (but this is a valid prefix)\n%!" >>= fun () -> "No service found at this URL (but this is a valid prefix)\n%!" >>= fun () ->
return () return ()
| { input = Some input ; output } -> | { input = Some input ; output } ->
cctxt.message cctxt#message
"@[<v 0>\ "@[<v 0>\
@[<v 2>Input format:@,%a@]@,\ @[<v 2>Input format:@,%a@]@,\
@[<v 2>Output format:@,%a@]@,\ @[<v 2>Output format:@,%a@]@,\
@ -332,7 +331,7 @@ let format url cctxt =
Json_schema.pp output >>= fun () -> Json_schema.pp output >>= fun () ->
return () return ()
| { input = None ; output } -> | { input = None ; output } ->
cctxt.message cctxt#message
"@[<v 0>\ "@[<v 0>\
@[<v 2>Output format:@,%a@]@,\ @[<v 2>Output format:@,%a@]@,\
@]" @]"
@ -340,7 +339,7 @@ let format url cctxt =
return () return ()
end end
| _ -> | _ ->
cctxt.message cctxt#message
"No service found at this URL (but this is a valid prefix)\n%!" >>= fun () -> "No service found at this URL (but this is a valid prefix)\n%!" >>= fun () ->
return () return ()
@ -351,43 +350,43 @@ let fill_in schema =
| Any | Object { properties = [] } -> Lwt.return (Ok (`O [])) | Any | Object { properties = [] } -> Lwt.return (Ok (`O []))
| _ -> editor_fill_in schema | _ -> editor_fill_in schema
let call url cctxt = let call url (cctxt : Client_commands.full_context) =
let args = String.split '/' url in let args = String.split '/' url in
let open RPC.Description in let open RPC.Description in
Client_node_rpcs.describe cctxt.rpc_config ~recurse:false args >>=? function Client_node_rpcs.describe cctxt ~recurse:false args >>=? function
| Static { services } -> begin | Static { services } -> begin
match RPC.MethMap.find `POST services with match RPC.MethMap.find `POST services with
| exception Not_found -> | exception Not_found ->
cctxt.message cctxt#message
"No service found at this URL (but this is a valid prefix)\n%!" >>= fun () -> "No service found at this URL (but this is a valid prefix)\n%!" >>= fun () ->
return () return ()
| { input = None } -> assert false (* TODO *) | { input = None } -> assert false (* TODO *)
| { input = Some input } -> | { input = Some input } ->
fill_in input >>= function fill_in input >>= function
| Error msg -> | Error msg ->
cctxt.error "%s" msg >>= fun () -> cctxt#error "%s" msg >>= fun () ->
return () return ()
| Ok json -> | Ok json ->
Client_rpcs.get_json cctxt.rpc_config `POST args json >>=? fun json -> cctxt#get_json `POST args json >>=? fun json ->
cctxt.message "%a" cctxt#message "%a"
Json_repr.(pp (module Ezjsonm)) json >>= fun () -> Json_repr.(pp (module Ezjsonm)) json >>= fun () ->
return () return ()
end end
| _ -> | _ ->
cctxt.message cctxt#message
"No service found at this URL (but this is a valid prefix)\n%!" >>= fun () -> "No service found at this URL (but this is a valid prefix)\n%!" >>= fun () ->
return () return ()
let call_with_json url json (cctxt: Client_commands.context) = let call_with_json url json (cctxt: Client_commands.full_context) =
let args = String.split '/' url in let args = String.split '/' url in
match Data_encoding_ezjsonm.from_string json with match Data_encoding_ezjsonm.from_string json with
| Error err -> | Error err ->
cctxt.error cctxt#error
"Failed to parse the provided json: %s\n%!" "Failed to parse the provided json: %s\n%!"
err err
| Ok json -> | Ok json ->
Client_rpcs.get_json cctxt.rpc_config `POST args json >>=? fun json -> cctxt#get_json `POST args json >>=? fun json ->
cctxt.message "%a" cctxt#message "%a"
Json_repr.(pp (module Ezjsonm)) json >>= fun () -> Json_repr.(pp (module Ezjsonm)) json >>= fun () ->
return () return ()
@ -400,9 +399,9 @@ let commands = [
command ~desc: "list all understood protocol versions" command ~desc: "list all understood protocol versions"
no_options no_options
(fixed [ "list" ; "versions" ]) (fixed [ "list" ; "versions" ])
(fun () cctxt -> (fun () (cctxt : Client_commands.full_context) ->
Lwt_list.iter_s Lwt_list.iter_s
(fun (ver, _) -> cctxt.Client_commands.message "%a" Protocol_hash.pp_short ver) (fun (ver, _) -> cctxt#message "%a" Protocol_hash.pp_short ver)
(Client_commands.get_versions ()) >>= fun () -> (Client_commands.get_versions ()) >>= fun () ->
return ()) ; return ()) ;

16
lib_client_base/client_helpers.ml
View File

@ -7,8 +7,6 @@
(* *) (* *)
(**************************************************************************) (**************************************************************************)
open Client_commands
let unique_switch = let unique_switch =
Cli_entries.switch Cli_entries.switch
~parameter:"-unique" ~parameter:"-unique"
@ -26,9 +24,9 @@ let commands () = Cli_entries.[
~name: "prefix" ~name: "prefix"
~desc: "the prefix of the Base58Check-encoded hash to be completed" @@ ~desc: "the prefix of the Base58Check-encoded hash to be completed" @@
stop) stop)
(fun unique prefix cctxt -> (fun unique prefix (cctxt : Client_commands.full_context) ->
Client_node_rpcs.complete Client_node_rpcs.complete
cctxt.rpc_config ~block:cctxt.config.block prefix >>=? fun completions -> cctxt ~block:cctxt#block prefix >>=? fun completions ->
match completions with match completions with
| [] -> Pervasives.exit 3 | [] -> Pervasives.exit 3
| _ :: _ :: _ when unique -> Pervasives.exit 3 | _ :: _ :: _ when unique -> Pervasives.exit 3
@ -40,18 +38,18 @@ let commands () = Cli_entries.[
no_options no_options
(prefixes [ "bootstrapped" ] @@ (prefixes [ "bootstrapped" ] @@
stop) stop)
(fun () cctxt -> (fun () (cctxt : Client_commands.full_context) ->
Client_node_rpcs.bootstrapped cctxt.rpc_config >>=? fun stream -> Client_node_rpcs.bootstrapped cctxt >>=? fun stream ->
Lwt_stream.iter_s (function Lwt_stream.iter_s (function
| Ok (hash, time) -> | Ok (hash, time) ->
cctxt.message "Current head: %a (%a)" cctxt#message "Current head: %a (%a)"
Block_hash.pp_short hash Block_hash.pp_short hash
Time.pp_hum time Time.pp_hum time
| Error err -> | Error err ->
cctxt.error "Error: %a" cctxt#error "Error: %a"
pp_print_error err pp_print_error err
) stream >>= fun () -> ) stream >>= fun () ->
cctxt.answer "Bootstrapped." >>= fun () -> cctxt#answer "Bootstrapped." >>= fun () ->
return () return ()
) )
] ]

64
lib_client_base/client_keys.ml
View File

@ -31,7 +31,7 @@ module Secret_key = Client_aliases.Alias (struct
let name = "secret key" let name = "secret key"
end) end)
let gen_keys ?(force=false) ?seed cctxt name = let gen_keys ?(force=false) ?seed (cctxt : #Client_commands.wallet) name =
let seed = let seed =
match seed with match seed with
| None -> Ed25519.Seed.generate () | None -> Ed25519.Seed.generate ()
@ -41,16 +41,14 @@ let gen_keys ?(force=false) ?seed cctxt name =
Public_key.add ~force cctxt name public_key >>=? fun () -> Public_key.add ~force cctxt name public_key >>=? fun () ->
Public_key_hash.add ~force Public_key_hash.add ~force
cctxt name (Ed25519.Public_key.hash public_key) >>=? fun () -> cctxt name (Ed25519.Public_key.hash public_key) >>=? fun () ->
cctxt.message
"I generated a brand new pair of keys under the name '%s'." name >>= fun () ->
return () return ()
let gen_keys_containing ?(prefix=false) ?(force=false) ~containing ~name (cctxt : Client_commands.context) = let gen_keys_containing ?(prefix=false) ?(force=false) ~containing ~name (cctxt : Client_commands.full_context) =
let unrepresentable = let unrepresentable =
List.filter (fun s -> not @@ Base58.Alphabet.all_in_alphabet Base58.Alphabet.bitcoin s) containing in List.filter (fun s -> not @@ Base58.Alphabet.all_in_alphabet Base58.Alphabet.bitcoin s) containing in
match unrepresentable with match unrepresentable with
| _ :: _ -> | _ :: _ ->
cctxt.warning cctxt#warning
"The following can't be written in the key alphabet (%a): %a" "The following can't be written in the key alphabet (%a): %a"
Base58.Alphabet.pp Base58.Alphabet.bitcoin Base58.Alphabet.pp Base58.Alphabet.bitcoin
(Format.pp_print_list (Format.pp_print_list
@ -61,11 +59,11 @@ let gen_keys_containing ?(prefix=false) ?(force=false) ~containing ~name (cctxt
Public_key_hash.mem cctxt name >>=? fun name_exists -> Public_key_hash.mem cctxt name >>=? fun name_exists ->
if name_exists && not force if name_exists && not force
then then
cctxt.warning cctxt#warning
"Key for name '%s' already exists. Use -force to update." name >>= return "Key for name '%s' already exists. Use -force to update." name >>= return
else else
begin begin
cctxt.message "This process uses a brute force search and \ cctxt#warning "This process uses a brute force search and \
may take a long time to find a key." >>= fun () -> may take a long time to find a key." >>= fun () ->
let matches = let matches =
if prefix then if prefix then
@ -89,11 +87,11 @@ let gen_keys_containing ?(prefix=false) ?(force=false) ~containing ~name (cctxt
Public_key_hash.add ~force cctxt name (Ed25519.Public_key.hash public_key) >>=? fun () -> Public_key_hash.add ~force cctxt name (Ed25519.Public_key.hash public_key) >>=? fun () ->
return hash return hash
else begin if attempts mod 25_000 = 0 else begin if attempts mod 25_000 = 0
then cctxt.message "Tried %d keys without finding a match" attempts then cctxt#message "Tried %d keys without finding a match" attempts
else Lwt.return () end >>= fun () -> else Lwt.return () end >>= fun () ->
loop (attempts + 1) in loop (attempts + 1) in
loop 1 >>=? fun key_hash -> loop 1 >>=? fun key_hash ->
cctxt.message cctxt#message
"Generated '%s' under the name '%s'." key_hash name >>= fun () -> "Generated '%s' under the name '%s'." key_hash name >>= fun () ->
return () return ()
end end
@ -103,21 +101,21 @@ let check_keys_consistency pk sk =
let signature = Ed25519.sign sk message in let signature = Ed25519.sign sk message in
Ed25519.Signature.check pk signature message Ed25519.Signature.check pk signature message
let get_key cctxt pkh = let get_key (cctxt : #Client_commands.wallet) pkh =
Public_key_hash.rev_find cctxt pkh >>=? function Public_key_hash.rev_find cctxt pkh >>=? function
| None -> cctxt.error "no keys for the source contract manager" | None -> failwith "no keys for the source contract manager"
| Some n -> | Some n ->
Public_key.find cctxt n >>=? fun pk -> Public_key.find cctxt n >>=? fun pk ->
Secret_key.find cctxt n >>=? fun sk -> Secret_key.find cctxt n >>=? fun sk ->
return (n, pk, sk) return (n, pk, sk)
let get_keys cctxt = let get_keys (wallet : #Client_commands.wallet) =
Secret_key.load cctxt >>=? fun sks -> Secret_key.load wallet >>=? fun sks ->
Lwt_list.filter_map_s Lwt_list.filter_map_s
(fun (name, sk) -> (fun (name, sk) ->
begin begin
Public_key.find cctxt name >>=? fun pk -> Public_key.find wallet name >>=? fun pk ->
Public_key_hash.find cctxt name >>=? fun pkh -> Public_key_hash.find wallet name >>=? fun pkh ->
return (name, pkh, pk, sk) return (name, pkh, pk, sk)
end >>= function end >>= function
| Ok r -> Lwt.return (Some r) | Ok r -> Lwt.return (Some r)
@ -165,7 +163,7 @@ let commands () =
(prefixes [ "gen" ; "keys" ] (prefixes [ "gen" ; "keys" ]
@@ Secret_key.fresh_alias_param @@ Secret_key.fresh_alias_param
@@ stop) @@ stop)
(fun force name cctxt -> (fun force name (cctxt : Client_commands.full_context) ->
Secret_key.of_fresh cctxt force name >>=? fun name -> Secret_key.of_fresh cctxt force name >>=? fun name ->
gen_keys ~force cctxt name) ; gen_keys ~force cctxt name) ;
@ -202,6 +200,18 @@ let commands () =
please don't use -force" name) >>=? fun () -> please don't use -force" name) >>=? fun () ->
Secret_key.add ~force cctxt name sk) ; Secret_key.add ~force cctxt name sk) ;
command ~group ~desc: "add a public key to the wallet"
(args1 Client_commands.force_switch)
(prefixes [ "add" ; "public" ; "key" ]
@@ Public_key.fresh_alias_param
@@ Public_key.source_param
@@ stop)
(fun force name key cctxt ->
Public_key.of_fresh cctxt force name >>=? fun name ->
Public_key_hash.add ~force cctxt
name (Ed25519.Public_key.hash key) >>=? fun () ->
Public_key.add ~force cctxt name key) ;
command ~group ~desc: "add a public key to the wallet" command ~group ~desc: "add a public key to the wallet"
(args1 Client_commands.force_switch) (args1 Client_commands.force_switch)
(prefixes [ "add" ; "identity" ] (prefixes [ "add" ; "identity" ]
@ -215,12 +225,12 @@ let commands () =
command ~group ~desc: "list all public key hashes and associated keys" command ~group ~desc: "list all public key hashes and associated keys"
no_options no_options
(fixed [ "list" ; "known" ; "identities" ]) (fixed [ "list" ; "known" ; "identities" ])
(fun () cctxt -> (fun () (cctxt : Client_commands.full_context) ->
list_keys cctxt >>=? fun l -> list_keys cctxt >>=? fun l ->
iter_s iter_s
(fun (name, pkh, pkm, pks) -> (fun (name, pkh, pkm, pks) ->
Public_key_hash.to_source cctxt pkh >>=? fun v -> Public_key_hash.to_source cctxt pkh >>=? fun v ->
cctxt.message "%s: %s%s%s" name v cctxt#message "%s: %s%s%s" name v
(if pkm then " (public key known)" else "") (if pkm then " (public key known)" else "")
(if pks then " (secret key known)" else "") >>= fun () -> (if pks then " (secret key known)" else "") >>= fun () ->
return ()) return ())
@ -231,25 +241,25 @@ let commands () =
(prefixes [ "show" ; "identity"] (prefixes [ "show" ; "identity"]
@@ Public_key_hash.alias_param @@ Public_key_hash.alias_param
@@ stop) @@ stop)
(fun show_private (name, _) cctxt -> (fun show_private (name, _) (cctxt : Client_commands.full_context) ->
let ok_lwt x = x >>= (fun x -> return x) in let ok_lwt x = x >>= (fun x -> return x) in
alias_keys cctxt name >>=? fun key_info -> alias_keys cctxt name >>=? fun key_info ->
match key_info with match key_info with
| None -> ok_lwt @@ cctxt.message "No keys found for identity" | None -> ok_lwt @@ cctxt#message "No keys found for identity"
| Some (hash, pub, priv) -> | Some (hash, pub, priv) ->
Public_key_hash.to_source cctxt hash >>=? fun hash -> Public_key_hash.to_source cctxt hash >>=? fun hash ->
ok_lwt @@ cctxt.message "Hash: %s" hash >>=? fun () -> ok_lwt @@ cctxt#message "Hash: %s" hash >>=? fun () ->
match pub with match pub with
| None -> return () | None -> return ()
| Some pub -> | Some pub ->
Public_key.to_source cctxt pub >>=? fun pub -> Public_key.to_source cctxt pub >>=? fun pub ->
ok_lwt @@ cctxt.message "Public Key: %s" pub >>=? fun () -> ok_lwt @@ cctxt#message "Public Key: %s" pub >>=? fun () ->
if show_private then if show_private then
match priv with match priv with
| None -> return () | None -> return ()
| Some priv -> | Some priv ->
Secret_key.to_source cctxt priv >>=? fun priv -> Secret_key.to_source cctxt priv >>=? fun priv ->
ok_lwt @@ cctxt.message "Secret Key: %s" priv ok_lwt @@ cctxt#message "Secret Key: %s" priv
else return ()) ; else return ()) ;
command ~group ~desc: "forget all keys" command ~group ~desc: "forget all keys"
@ -257,9 +267,9 @@ let commands () =
(fixed [ "forget" ; "all" ; "keys" ]) (fixed [ "forget" ; "all" ; "keys" ])
(fun force cctxt -> (fun force cctxt ->
fail_unless force fail_unless force
(failure "this can only used with option -force true") >>=? fun () -> (failure "this can only used with option -force") >>=? fun () ->
Public_key.save cctxt [] >>=? fun () -> Public_key.set cctxt [] >>=? fun () ->
Secret_key.save cctxt [] >>=? fun () -> Secret_key.set cctxt [] >>=? fun () ->
Public_key_hash.save cctxt []) ; Public_key_hash.set cctxt []) ;
] ]

8
lib_client_base/client_keys.mli
View File

@ -13,22 +13,22 @@ module Public_key : Client_aliases.Alias with type t = Ed25519.Public_key.t
module Secret_key : Client_aliases.Alias with type t = Ed25519.Secret_key.t module Secret_key : Client_aliases.Alias with type t = Ed25519.Secret_key.t
val get_key: val get_key:
Client_commands.context -> Client_commands.full_context ->
Public_key_hash.t -> Public_key_hash.t ->
( string * Public_key.t * Secret_key.t ) tzresult Lwt.t ( string * Public_key.t * Secret_key.t ) tzresult Lwt.t
val get_keys: val get_keys:
Client_commands.context -> #Client_commands.wallet ->
( string * Public_key_hash.t * Public_key.t * Secret_key.t ) list tzresult Lwt.t ( string * Public_key_hash.t * Public_key.t * Secret_key.t ) list tzresult Lwt.t
val list_keys: val list_keys:
Client_commands.context -> Client_commands.full_context ->
(string * Public_key_hash.t * bool * bool) list tzresult Lwt.t (string * Public_key_hash.t * bool * bool) list tzresult Lwt.t
val gen_keys: val gen_keys:
?force:bool -> ?force:bool ->
?seed: Ed25519.Seed.t -> ?seed: Ed25519.Seed.t ->
Client_commands.context -> #Client_commands.wallet ->
string -> string ->
unit tzresult Lwt.t unit tzresult Lwt.t

33
lib_client_base/client_network.ml
View File

@ -7,7 +7,6 @@
(* *) (* *)
(**************************************************************************) (**************************************************************************)
open Client_commands
open P2p_types open P2p_types
let group = let group =
@ -18,36 +17,36 @@ let commands () = [
let open Cli_entries in let open Cli_entries in
command ~group ~desc: "show global network status" command ~group ~desc: "show global network status"
no_options no_options
(prefixes ["network" ; "stat"] stop) begin fun () cctxt -> (prefixes ["network" ; "stat"] stop) begin fun () (cctxt : Client_commands.full_context) ->
Client_node_rpcs.Network.stat cctxt.rpc_config >>=? fun stat -> Client_node_rpcs.Network.stat cctxt >>=? fun stat ->
Client_node_rpcs.Network.connections cctxt.rpc_config >>=? fun conns -> Client_node_rpcs.Network.connections cctxt >>=? fun conns ->
Client_node_rpcs.Network.peers cctxt.rpc_config >>=? fun peers -> Client_node_rpcs.Network.peers cctxt >>=? fun peers ->
Client_node_rpcs.Network.points cctxt.rpc_config >>=? fun points -> Client_node_rpcs.Network.points cctxt >>=? fun points ->
cctxt.message "GLOBAL STATS" >>= fun () -> cctxt#message "GLOBAL STATS" >>= fun () ->
cctxt.message " %a" Stat.pp stat >>= fun () -> cctxt#message " %a" Stat.pp stat >>= fun () ->
cctxt.message "CONNECTIONS" >>= fun () -> cctxt#message "CONNECTIONS" >>= fun () ->
let incoming, outgoing = let incoming, outgoing =
List.partition (fun c -> c.Connection_info.incoming) conns in List.partition (fun c -> c.Connection_info.incoming) conns in
Lwt_list.iter_s begin fun conn -> Lwt_list.iter_s begin fun conn ->
cctxt.message " %a" Connection_info.pp conn cctxt#message " %a" Connection_info.pp conn
end incoming >>= fun () -> end incoming >>= fun () ->
Lwt_list.iter_s begin fun conn -> Lwt_list.iter_s begin fun conn ->
cctxt.message " %a" Connection_info.pp conn cctxt#message " %a" Connection_info.pp conn
end outgoing >>= fun () -> end outgoing >>= fun () ->
cctxt.message "KNOWN PEERS" >>= fun () -> cctxt#message "KNOWN PEERS" >>= fun () ->
Lwt_list.iter_s begin fun (p, pi) -> Lwt_list.iter_s begin fun (p, pi) ->
cctxt.message " %a %.0f %a %a %s" cctxt#message " %a %.0f %a %a %s"
Peer_state.pp_digram pi.Peer_info.state Peer_state.pp_digram pi.Peer_info.state
pi.score pi.score
Peer_id.pp p Peer_id.pp p
Stat.pp pi.stat Stat.pp pi.stat
(if pi.trusted then "★" else " ") (if pi.trusted then "★" else " ")
end peers >>= fun () -> end peers >>= fun () ->
cctxt.message "KNOWN POINTS" >>= fun () -> cctxt#message "KNOWN POINTS" >>= fun () ->
Lwt_list.iter_s begin fun (p, pi) -> Lwt_list.iter_s begin fun (p, pi) ->
match pi.Point_info.state with match pi.Point_info.state with
| Running peer_id -> | Running peer_id ->
cctxt.message " %a %a %a %s" cctxt#message " %a %a %a %s"
Point_state.pp_digram pi.state Point_state.pp_digram pi.state
Point.pp p Point.pp p
Peer_id.pp peer_id Peer_id.pp peer_id
@ -55,14 +54,14 @@ let commands () = [
| _ -> | _ ->
match pi.last_seen with match pi.last_seen with
| Some (peer_id, ts) -> | Some (peer_id, ts) ->
cctxt.message " %a %a (last seen: %a %a) %s" cctxt#message " %a %a (last seen: %a %a) %s"
Point_state.pp_digram pi.state Point_state.pp_digram pi.state
Point.pp p Point.pp p
Peer_id.pp peer_id Peer_id.pp peer_id
Time.pp_hum ts Time.pp_hum ts
(if pi.trusted then "★" else " ") (if pi.trusted then "★" else " ")
| None -> | None ->
cctxt.message " %a %a %s" cctxt#message " %a %a %s"
Point_state.pp_digram pi.state Point_state.pp_digram pi.state
Point.pp p Point.pp p
(if pi.trusted then "★" else " ") (if pi.trusted then "★" else " ")

10
lib_client_base/client_node_rpcs.ml
View File

@ -12,11 +12,11 @@
open Client_rpcs open Client_rpcs
module Services = Node_rpc_services module Services = Node_rpc_services
let errors cctxt = let errors (rpc : #rpc_sig) =
call_service0 cctxt Services.Error.service () call_service0 rpc Services.Error.service ()
let forge_block_header cctxt header = let forge_block_header rpc header =
call_service0 cctxt Services.forge_block_header header call_service0 rpc Services.forge_block_header header
let inject_block cctxt let inject_block cctxt
?(async = false) ?(force = false) ?net_id ?(async = false) ?(force = false) ?net_id
@ -46,7 +46,7 @@ let describe config ?(recurse = true) path =
let { RPC.Service.meth ; path } = let { RPC.Service.meth ; path } =
RPC.Service.forge_request Node_rpc_services.describe RPC.Service.forge_request Node_rpc_services.describe
((), path) { RPC.Description.recurse } in ((), path) { RPC.Description.recurse } in
get_json config meth path (`O []) >>=? fun json -> config#get_json meth path (`O []) >>=? fun json ->
match Data_encoding.Json.destruct (RPC.Service.output_encoding Node_rpc_services.describe) json with match Data_encoding.Json.destruct (RPC.Service.output_encoding Node_rpc_services.describe) json with
| exception msg -> | exception msg ->
let msg = let msg =

60
lib_client_base/client_node_rpcs.mli
View File

@ -10,15 +10,15 @@
open Client_rpcs open Client_rpcs
val errors: val errors:
config -> Json_schema.schema tzresult Lwt.t #rpc_sig -> Json_schema.schema tzresult Lwt.t
val forge_block_header: val forge_block_header:
config -> #rpc_sig ->
Block_header.t -> Block_header.t ->
MBytes.t tzresult Lwt.t MBytes.t tzresult Lwt.t
val inject_block: val inject_block:
config -> #rpc_sig ->
?async:bool -> ?force:bool -> ?net_id:Net_id.t -> ?async:bool -> ?force:bool -> ?net_id:Net_id.t ->
MBytes.t -> Operation.t list list -> MBytes.t -> Operation.t list list ->
Block_hash.t tzresult Lwt.t Block_hash.t tzresult Lwt.t
@ -29,13 +29,13 @@ val inject_block:
fitness. *) fitness. *)
val inject_operation: val inject_operation:
config -> #rpc_sig ->
?async:bool -> ?force:bool -> ?net_id:Net_id.t -> ?async:bool -> ?force:bool -> ?net_id:Net_id.t ->
MBytes.t -> MBytes.t ->
Operation_hash.t tzresult Lwt.t Operation_hash.t tzresult Lwt.t
val inject_protocol: val inject_protocol:
config -> #rpc_sig ->
?async:bool -> ?force:bool -> ?async:bool -> ?force:bool ->
Protocol.t -> Protocol.t ->
Protocol_hash.t tzresult Lwt.t Protocol_hash.t tzresult Lwt.t
@ -45,39 +45,39 @@ module Blocks : sig
type block = Node_rpc_services.Blocks.block type block = Node_rpc_services.Blocks.block
val net_id: val net_id:
config -> #rpc_sig ->
block -> Net_id.t tzresult Lwt.t block -> Net_id.t tzresult Lwt.t
val level: val level:
config -> #rpc_sig ->
block -> Int32.t tzresult Lwt.t block -> Int32.t tzresult Lwt.t
val predecessor: val predecessor:
config -> #rpc_sig ->
block -> Block_hash.t tzresult Lwt.t block -> Block_hash.t tzresult Lwt.t
val predecessors: val predecessors:
config -> #rpc_sig ->
block -> int -> Block_hash.t list tzresult Lwt.t block -> int -> Block_hash.t list tzresult Lwt.t
val hash: val hash:
config -> #rpc_sig ->
block -> Block_hash.t tzresult Lwt.t block -> Block_hash.t tzresult Lwt.t
val timestamp: val timestamp:
config -> #rpc_sig ->
block -> Time.t tzresult Lwt.t block -> Time.t tzresult Lwt.t
val fitness: val fitness:
config -> #rpc_sig ->
block -> MBytes.t list tzresult Lwt.t block -> MBytes.t list tzresult Lwt.t
val operations: val operations:
config -> #rpc_sig ->
?contents:bool -> ?contents:bool ->
block -> (Operation_hash.t * Operation.t option) list list tzresult Lwt.t block -> (Operation_hash.t * Operation.t option) list list tzresult Lwt.t
val protocol: val protocol:
config -> #rpc_sig ->
block -> Protocol_hash.t tzresult Lwt.t block -> Protocol_hash.t tzresult Lwt.t
val test_network: val test_network:
config -> #rpc_sig ->
block -> Test_network_status.t tzresult Lwt.t block -> Test_network_status.t tzresult Lwt.t
val pending_operations: val pending_operations:
config -> #rpc_sig ->
block -> block ->
(error Preapply_result.t * Operation.t Operation_hash.Map.t) tzresult Lwt.t (error Preapply_result.t * Operation.t Operation_hash.Map.t) tzresult Lwt.t
@ -98,17 +98,17 @@ module Blocks : sig
} }
val info: val info:
config -> #rpc_sig ->
?include_ops:bool -> block -> block_info tzresult Lwt.t ?include_ops:bool -> block -> block_info tzresult Lwt.t
val list: val list:
config -> #rpc_sig ->
?include_ops:bool -> ?length:int -> ?heads:Block_hash.t list -> ?include_ops:bool -> ?length:int -> ?heads:Block_hash.t list ->
?delay:int -> ?min_date:Time.t -> ?min_heads:int -> ?delay:int -> ?min_date:Time.t -> ?min_heads:int ->
unit -> block_info list list tzresult Lwt.t unit -> block_info list list tzresult Lwt.t
val monitor: val monitor:
config -> #rpc_sig ->
?include_ops:bool -> ?length:int -> ?heads:Block_hash.t list -> ?include_ops:bool -> ?length:int -> ?heads:Block_hash.t list ->
?delay:int -> ?min_date:Time.t -> ?min_heads:int -> ?delay:int -> ?min_date:Time.t -> ?min_heads:int ->
unit -> block_info list list tzresult Lwt_stream.t tzresult Lwt.t unit -> block_info list list tzresult Lwt_stream.t tzresult Lwt.t
@ -119,7 +119,7 @@ module Blocks : sig
} }
val preapply: val preapply:
config -> #rpc_sig ->
block -> block ->
?timestamp:Time.t -> ?timestamp:Time.t ->
?sort:bool -> ?sort:bool ->
@ -131,7 +131,7 @@ end
module Operations : sig module Operations : sig
val monitor: val monitor:
config -> #rpc_sig ->
?contents:bool -> ?contents:bool ->
unit -> unit ->
(Operation_hash.t * Operation.t option) list list tzresult Lwt_stream.t tzresult Lwt.t (Operation_hash.t * Operation.t option) list list tzresult Lwt_stream.t tzresult Lwt.t
@ -141,42 +141,42 @@ end
module Protocols : sig module Protocols : sig
val contents: val contents:
config -> #rpc_sig ->
Protocol_hash.t -> Protocol.t tzresult Lwt.t Protocol_hash.t -> Protocol.t tzresult Lwt.t
val list: val list:
config -> #rpc_sig ->
?contents:bool -> unit -> ?contents:bool -> unit ->
(Protocol_hash.t * Protocol.t option) list tzresult Lwt.t (Protocol_hash.t * Protocol.t option) list tzresult Lwt.t
end end
val bootstrapped: val bootstrapped:
config -> (Block_hash.t * Time.t) tzresult Lwt_stream.t tzresult Lwt.t #rpc_sig -> (Block_hash.t * Time.t) tzresult Lwt_stream.t tzresult Lwt.t
module Network : sig module Network : sig
open P2p_types open P2p_types
val stat: val stat:
config -> Stat.t tzresult Lwt.t #rpc_sig -> Stat.t tzresult Lwt.t
val connections: val connections:
config -> Connection_info.t list tzresult Lwt.t #rpc_sig -> Connection_info.t list tzresult Lwt.t
val peers: val peers:
config -> (Peer_id.t * P2p_types.Peer_info.t) list tzresult Lwt.t #rpc_sig -> (Peer_id.t * P2p_types.Peer_info.t) list tzresult Lwt.t
val points: val points:
config -> (Point.t * P2p_types.Point_info.t) list tzresult Lwt.t #rpc_sig -> (Point.t * P2p_types.Point_info.t) list tzresult Lwt.t
end end
val complete: val complete:
config -> #rpc_sig ->
?block:Blocks.block -> string -> string list tzresult Lwt.t ?block:Blocks.block -> string -> string list tzresult Lwt.t
val describe: val describe:
config -> #rpc_sig ->
?recurse:bool -> string list -> ?recurse:bool -> string list ->
Data_encoding.json_schema RPC.Description.directory tzresult Lwt.t Data_encoding.json_schema RPC.Description.directory tzresult Lwt.t

28
lib_client_base/client_protocols.ml
View File

@ -7,8 +7,6 @@
(* *) (* *)
(**************************************************************************) (**************************************************************************)
open Client_commands
let group = let group =
{ Cli_entries.name = "protocols" ; { Cli_entries.name = "protocols" ;
title = "Commands for managing protocols" } title = "Commands for managing protocols" }
@ -26,9 +24,9 @@ let commands () =
command ~group ~desc: "list known protocols" command ~group ~desc: "list known protocols"
no_options no_options
(prefixes [ "list" ; "protocols" ] stop) (prefixes [ "list" ; "protocols" ] stop)
(fun () cctxt -> (fun () (cctxt : Client_commands.full_context) ->
Client_node_rpcs.Protocols.list cctxt.rpc_config ~contents:false () >>=? fun protos -> 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 >>= fun () -> Lwt_list.iter_s (fun (ph, _p) -> cctxt#message "%a" Protocol_hash.pp ph) protos >>= fun () ->
return () return ()
); );
@ -37,21 +35,20 @@ let commands () =
(prefixes [ "inject" ; "protocol" ] (prefixes [ "inject" ; "protocol" ]
@@ param ~name:"dir" ~desc:"directory containing a protocol" check_dir_parameter @@ param ~name:"dir" ~desc:"directory containing a protocol" check_dir_parameter
@@ stop) @@ stop)
(fun () dirname cctxt -> (fun () dirname (cctxt : Client_commands.full_context) ->
Lwt.catch Lwt.catch
(fun () -> (fun () ->
let _hash, proto = Tezos_protocol_compiler.Native.read_dir dirname in let _hash, proto = Tezos_protocol_compiler.Native.read_dir dirname in
Client_node_rpcs.inject_protocol cctxt.rpc_config proto >>= function Client_node_rpcs.inject_protocol cctxt proto >>= function
| Ok hash -> | Ok hash ->
cctxt.message "Injected protocol %a successfully" Protocol_hash.pp_short hash >>= fun () -> cctxt#message "Injected protocol %a successfully" Protocol_hash.pp_short hash >>= fun () ->
return () return ()
| Error err -> | Error err ->
cctxt.error "Error while injecting protocol from %s: %a" cctxt#error "Error while injecting protocol from %s: %a"
dirname Error_monad.pp_print_error err >>= fun () -> dirname Error_monad.pp_print_error err >>= fun () ->
return ()) return ())
(fun exn -> (fun exn ->
cctxt.error "Error while injecting protocol from %s: %a" cctxt#error "Error while injecting protocol from %s: %a"
dirname Error_monad.pp_print_error [Error_monad.Exn exn] >>= fun () -> dirname Error_monad.pp_print_error [Error_monad.Exn exn] >>= fun () ->
return ()) return ())
); );
@ -61,13 +58,10 @@ let commands () =
(prefixes [ "dump" ; "protocol" ] (prefixes [ "dump" ; "protocol" ]
@@ Protocol_hash.param ~name:"protocol hash" ~desc:"" @@ Protocol_hash.param ~name:"protocol hash" ~desc:""
@@ stop) @@ stop)
(fun () ph cctxt -> (fun () ph (cctxt : Client_commands.full_context) ->
Client_node_rpcs.Protocols.contents cctxt.rpc_config ph >>=? fun proto -> Client_node_rpcs.Protocols.contents cctxt ph >>=? fun proto ->
Updater.extract (Protocol_hash.to_short_b58check ph) ~hash:ph proto >>= fun () -> Updater.extract (Protocol_hash.to_short_b58check ph) ~hash:ph proto >>= fun () ->
cctxt.message "Extracted protocol %a" Protocol_hash.pp_short ph >>= fun () -> cctxt#message "Extracted protocol %a" Protocol_hash.pp_short ph >>= fun () ->
return () return ()
) ; ) ;
(* | Error err -> *)
(* cctxt.error "Error while dumping protocol %a: %a" *)
(* Protocol_hash.pp_short ph Error_monad.pp_print_error err); *)
] ]

148
lib_client_base/client_rpcs.ml
View File

@ -181,7 +181,43 @@ let () =
let fail config err = fail (RPC_error (config, err)) let fail config err = fail (RPC_error (config, err))
let make_request config log_request meth service json = class type rpc_sig = object
method get_json :
RPC.meth ->
string list -> Data_encoding.json -> Data_encoding.json Error_monad.tzresult Lwt.t
method get_streamed_json :
RPC.meth ->
string list ->
Data_encoding.json ->
(Data_encoding.json, Error_monad.error list) result Lwt_stream.t
Error_monad.tzresult Lwt.t
method make_request :
(Uri.t -> Data_encoding.json -> 'a Lwt.t) ->
RPC.meth ->
string list ->
Data_encoding.json ->
('a * Cohttp.Code.status_code * Cohttp_lwt_body.t)
Error_monad.tzresult Lwt.t
method parse_answer :
(unit, 'b, 'c, 'd) RPC.service ->
string list ->
Data_encoding.json -> 'd Error_monad.tzresult Lwt.t
method parse_err_answer :
(unit, 'e, 'f, 'g Error_monad.tzresult) RPC.service ->
string list ->
Data_encoding.json -> 'g Error_monad.tzresult Lwt.t
end
class rpc config = object (self)
val config = config
method make_request :
type a. (Uri.t -> Data_encoding.json -> a Lwt.t) ->
RPC.meth ->
string list ->
Data_encoding.json ->
(a * Cohttp.Code.status_code * Cohttp_lwt_body.t)
Error_monad.tzresult Lwt.t =
fun log_request meth service json ->
let scheme = if config.tls then "https" else "http" in let scheme = if config.tls then "https" else "http" in
let path = String.concat "/" service in let path = String.concat "/" service in
let uri = let uri =
@ -190,8 +226,7 @@ let make_request config log_request meth service json =
Lwt.catch begin fun () -> Lwt.catch begin fun () ->
let body = Cohttp_lwt_body.of_string reqbody in let body = Cohttp_lwt_body.of_string reqbody in
Cohttp_lwt_unix.Client.call Cohttp_lwt_unix.Client.call
(meth :> Cohttp.Code.meth) (meth :> Cohttp.Code.meth) ~body uri >>= fun (code, ansbody) ->
~body uri >>= fun (code, ansbody) ->
log_request uri json >>= fun reqid -> log_request uri json >>= fun reqid ->
return (reqid, code.Cohttp.Response.status, ansbody) return (reqid, code.Cohttp.Response.status, ansbody)
end begin fun exn -> end begin fun exn ->
@ -201,9 +236,9 @@ let make_request config log_request meth service json =
fail config (Cannot_connect_to_RPC_server msg) fail config (Cannot_connect_to_RPC_server msg)
end end
let get_streamed_json config meth service json = method get_streamed_json meth service json =
let Logger logger = config.logger in let Logger logger = config.logger in
make_request config logger.log_request self#make_request logger.log_request
meth service json >>=? fun (reqid, code, ansbody) -> meth service json >>=? fun (reqid, code, ansbody) ->
match code with match code with
| #Cohttp.Code.success_status -> | #Cohttp.Code.success_status ->
@ -233,9 +268,23 @@ let get_streamed_json config meth service json =
logger.log_error reqid code ansbody >>= fun () -> logger.log_error reqid code ansbody >>= fun () ->
fail config (Request_failed (service, err)) fail config (Request_failed (service, err))
let get_json config meth service json = method parse_answer : type b c d. (unit, b, c, d) RPC.service ->
string list ->
Data_encoding.json -> d Error_monad.tzresult Lwt.t =
fun service path json ->
match Data_encoding.Json.destruct (RPC.Service.output_encoding service) json with
| exception msg ->
let msg =
Format.asprintf "%a" (fun x -> Data_encoding.Json.print_error x) msg in
fail config (Unexpected_json (path, json, msg))
| v -> return v
method get_json : RPC.meth ->
string list -> Data_encoding.json -> Data_encoding.json Error_monad.tzresult Lwt.t =
fun meth service json ->
let Logger logger = config.logger in let Logger logger = config.logger in
make_request config logger.log_request self#make_request logger.log_request
meth service json >>=? fun (reqid, code, ansbody) -> meth service json >>=? fun (reqid, code, ansbody) ->
Cohttp_lwt_body.to_string ansbody >>= fun ansbody -> Cohttp_lwt_body.to_string ansbody >>= fun ansbody ->
match code with match code with
@ -255,36 +304,61 @@ let get_json config meth service json =
logger.log_error reqid code ansbody >>= fun () -> logger.log_error reqid code ansbody >>= fun () ->
fail config (Request_failed (service, err)) fail config (Request_failed (service, err))
let parse_answer config service path json = method parse_err_answer : type e f g.
(unit, e, f, g Error_monad.tzresult) RPC.service ->
string list ->
Data_encoding.json -> g Error_monad.tzresult Lwt.t =
fun service path json ->
match Data_encoding.Json.destruct (RPC.Service.output_encoding service) json with match Data_encoding.Json.destruct (RPC.Service.output_encoding service) json with
| exception msg -> | exception msg -> (* TODO print_error *)
let msg = let msg =
Format.asprintf "%a" (fun x -> Data_encoding.Json.print_error x) msg in Format.asprintf "%a" (fun x -> Data_encoding.Json.print_error x) msg in
fail config (Unexpected_json (path, json, msg)) fail config (Unexpected_json (path, json, msg))
| v -> return v | v -> Lwt.return v
end
let call_service0 cctxt service arg = 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 :> Cohttp.Code.meth)
~body uri >>= fun (code, ansbody) ->
log_request uri json >>= fun reqid ->
return (reqid, code.Cohttp.Response.status, ansbody)
end begin fun exn ->
let msg = match exn 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 call_service0 (rpc : #rpc_sig) service arg =
let meth, path, arg = RPC.forge_request service () arg in let meth, path, arg = RPC.forge_request service () arg in
get_json cctxt meth path arg >>=? fun json -> rpc#get_json meth path arg >>=? fun json ->
parse_answer cctxt service path json rpc#parse_answer service path json
let call_service1 cctxt service a1 arg = let call_service1 (rpc : #rpc_sig) service a1 arg =
let meth, path, arg = RPC.forge_request service ((), a1) arg in let meth, path, arg = RPC.forge_request service ((), a1) arg in
get_json cctxt meth path arg >>=? fun json -> rpc#get_json meth path arg >>=? fun json ->
parse_answer cctxt service path json rpc#parse_answer service path json
let call_service2 cctxt service a1 a2 arg = let call_service2 (rpc : #rpc_sig) service a1 a2 arg =
let meth, path, arg = RPC.forge_request service (((), a1), a2) arg in let meth, path, arg = RPC.forge_request service (((), a1), a2) arg in
get_json cctxt meth path arg >>=? fun json -> rpc#get_json meth path arg >>=? fun json ->
parse_answer cctxt service path json rpc#parse_answer service path json
let call_streamed cctxt service (meth, path, arg) = let call_streamed (rpc : #rpc_sig) service (meth, path, arg) =
get_streamed_json cctxt meth path arg >>=? fun json_st -> rpc#get_streamed_json meth path arg >>=? fun json_st ->
let parsed_st, push = Lwt_stream.create () in let parsed_st, push = Lwt_stream.create () in
let rec loop () = let rec loop () =
Lwt_stream.get json_st >>= function Lwt_stream.get json_st >>= function
| Some (Ok json) -> begin | Some (Ok json) -> begin
parse_answer cctxt service path json >>= function rpc#parse_answer service path json >>= function
| Ok v -> push (Some (Ok v)) ; loop () | Ok v -> push (Some (Ok v)) ; loop ()
| Error _ as err -> | Error _ as err ->
push (Some err) ; push None ; Lwt.return_unit push (Some err) ; push None ; Lwt.return_unit
@ -296,34 +370,26 @@ let call_streamed cctxt service (meth, path, arg) =
Lwt.async loop ; Lwt.async loop ;
return parsed_st return parsed_st
let call_streamed_service0 cctxt service arg = let call_streamed_service0 (rpc : #rpc_sig) service arg =
call_streamed cctxt service (RPC.forge_request service () arg) call_streamed rpc service (RPC.forge_request service () arg)
let call_streamed_service1 cctxt service arg1 arg2 = let call_streamed_service1 cctxt service arg1 arg2 =
call_streamed cctxt service (RPC.forge_request service ((), arg1) arg2) call_streamed cctxt service (RPC.forge_request service ((), arg1) arg2)
let parse_err_answer config service path json = let call_err_service0 (rpc : #rpc_sig) service arg =
match Data_encoding.Json.destruct (RPC.Service.output_encoding service) json with
| exception msg -> (* TODO print_error *)
let msg =
Format.asprintf "%a" (fun x -> Data_encoding.Json.print_error x) msg in
fail config (Unexpected_json (path, json, msg))
| v -> Lwt.return v
let call_err_service0 cctxt service arg =
let meth, path, arg = RPC.forge_request service () arg in let meth, path, arg = RPC.forge_request service () arg in
get_json cctxt meth path arg >>=? fun json -> rpc#get_json meth path arg >>=? fun json ->
parse_err_answer cctxt service path json rpc#parse_err_answer service path json
let call_err_service1 cctxt service a1 arg = let call_err_service1 (rpc : #rpc_sig) service a1 arg =
let meth, path, arg = RPC.forge_request service ((), a1) arg in let meth, path, arg = RPC.forge_request service ((), a1) arg in
get_json cctxt meth path arg >>=? fun json -> rpc#get_json meth path arg >>=? fun json ->
parse_err_answer cctxt service path json rpc#parse_err_answer service path json
let call_err_service2 cctxt service a1 a2 arg = let call_err_service2 (rpc : #rpc_sig) service a1 a2 arg =
let meth, path, arg = RPC.forge_request service (((), a1), a2) arg in let meth, path, arg = RPC.forge_request service (((), a1), a2) arg in
get_json cctxt meth path arg >>=? fun json -> rpc#get_json meth path arg >>=? fun json ->
parse_err_answer cctxt service path json rpc#parse_err_answer service path json
type block = Node_rpc_services.Blocks.block type block = Node_rpc_services.Blocks.block

51
lib_client_base/client_rpcs.mli
View File

@ -23,53 +23,78 @@ and logger =
'a -> Cohttp.Code.status_code -> string -> unit Lwt.t ; 'a -> Cohttp.Code.status_code -> string -> unit Lwt.t ;
} -> logger } -> logger
class type rpc_sig = object
method get_json :
RPC.meth ->
string list -> Data_encoding.json ->
Data_encoding.json Error_monad.tzresult Lwt.t
method get_streamed_json :
RPC.meth ->
string list ->
Data_encoding.json ->
(Data_encoding.json, Error_monad.error list) result Lwt_stream.t
Error_monad.tzresult Lwt.t
method make_request :
(Uri.t -> Data_encoding.json -> 'a Lwt.t) ->
RPC.meth ->
string list ->
Data_encoding.json ->
('a * Cohttp.Code.status_code * Cohttp_lwt_body.t)
Error_monad.tzresult Lwt.t
method parse_answer :
(unit, 'b, 'c, 'd) RPC.service ->
string list ->
Data_encoding.json -> 'd Error_monad.tzresult Lwt.t
method parse_err_answer :
(unit, 'e, 'f, 'g Error_monad.tzresult) RPC.service ->
string list ->
Data_encoding.json -> 'g Error_monad.tzresult Lwt.t
end
class rpc : config -> rpc_sig
val default_config: config val default_config: config
val null_logger: logger val null_logger: logger
val timings_logger: Format.formatter -> logger val timings_logger: Format.formatter -> logger
val full_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: val call_service0:
config -> #rpc_sig ->
(unit, unit, 'i, 'o) RPC.service -> (unit, unit, 'i, 'o) RPC.service ->
'i -> 'o tzresult Lwt.t 'i -> 'o tzresult Lwt.t
val call_service1: val call_service1:
config -> #rpc_sig ->
(unit, unit * 'a, 'i, 'o) RPC.service -> (unit, unit * 'a, 'i, 'o) RPC.service ->
'a -> 'i -> 'o tzresult Lwt.t 'a -> 'i -> 'o tzresult Lwt.t
val call_service2: val call_service2:
config -> #rpc_sig ->
(unit, (unit * 'a) * 'b, 'i, 'o) RPC.service -> (unit, (unit * 'a) * 'b, 'i, 'o) RPC.service ->
'a -> 'b -> 'i -> 'o tzresult Lwt.t 'a -> 'b -> 'i -> 'o tzresult Lwt.t
val call_streamed_service0: val call_streamed_service0:
config -> #rpc_sig ->
(unit, unit, 'a, 'b) RPC.service -> (unit, unit, 'a, 'b) RPC.service ->
'a -> ('b, error list) result Lwt_stream.t tzresult Lwt.t 'a -> ('b, error list) result Lwt_stream.t tzresult Lwt.t
val call_streamed_service1: val call_streamed_service1:
config -> #rpc_sig ->
(unit, unit * 'a, 'b, 'c) RPC.service -> (unit, unit * 'a, 'b, 'c) RPC.service ->
'a -> 'b -> ('c, error list) result Lwt_stream.t tzresult Lwt.t 'a -> 'b -> ('c, error list) result Lwt_stream.t tzresult Lwt.t
val call_err_service0: val call_err_service0:
config -> #rpc_sig ->
(unit, unit, 'i, 'o tzresult) RPC.service -> (unit, unit, 'i, 'o tzresult) RPC.service ->
'i -> 'o tzresult Lwt.t 'i -> 'o tzresult Lwt.t
val call_err_service1: val call_err_service1:
config -> #rpc_sig ->
(unit, unit * 'a, 'i, 'o tzresult) RPC.service -> (unit, unit * 'a, 'i, 'o tzresult) RPC.service ->
'a -> 'i -> 'o tzresult Lwt.t 'a -> 'i -> 'o tzresult Lwt.t
val call_err_service2: val call_err_service2:
config -> #rpc_sig ->
(unit, (unit * 'a) * 'b, 'i, 'o tzresult) RPC.service -> (unit, (unit * 'a) * 'b, 'i, 'o tzresult) RPC.service ->
'a -> 'b -> 'i -> 'o tzresult Lwt.t 'a -> 'b -> 'i -> 'o tzresult Lwt.t

10
lib_client_base/client_tags.mli
View File

@ -28,21 +28,21 @@ module Tags (Entity : Entity) : sig
val tag_param: val tag_param:
?name:string -> ?name:string ->
?desc:string -> ?desc:string ->
('a, Client_commands.context, 'ret) Cli_entries.params -> ('a, Client_commands.full_context, 'ret) Cli_entries.params ->
(Tag.t -> 'a, Client_commands.context, 'ret) Cli_entries.params (Tag.t -> 'a, Client_commands.full_context, 'ret) Cli_entries.params
val rev_find_by_tag: val rev_find_by_tag:
Client_commands.context -> Client_commands.full_context ->
string -> string ->
string option tzresult Lwt.t string option tzresult Lwt.t
val filter: val filter:
Client_commands.context -> Client_commands.full_context ->
(string * t -> bool) -> (string * t -> bool) ->
(string * t) list tzresult Lwt.t (string * t) list tzresult Lwt.t
val filter_by_tag: val filter_by_tag:
Client_commands.context -> Client_commands.full_context ->
string -> string ->
(string * t) list tzresult Lwt.t (string * t) list tzresult Lwt.t

16
lib_embedded_client_alpha/alpha.ml Normal file
View File

@ -0,0 +1,16 @@
(**************************************************************************)
(* *)
(* Copyright (c) 2014 - 2017. *)
(* Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* All rights reserved. No warranty, explicit or implicit, provided. *)
(* *)
(**************************************************************************)
module RPCs = Client_rpcs
module Contracts = Client_proto_contracts
module Context = Client_proto_context
module Programs = Client_proto_programs

16
lib_embedded_client_alpha/alpha.mli Normal file
View File

@ -0,0 +1,16 @@
(**************************************************************************)
(* *)
(* Copyright (c) 2014 - 2017. *)
(* Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* All rights reserved. No warranty, explicit or implicit, provided. *)
(* *)
(**************************************************************************)
module RPCs = Client_rpcs
module Contracts : module type of Client_proto_contracts
module Context : module type of Client_proto_context
module Programs : module type of Client_proto_programs

6
lib_embedded_client_alpha/client_baking_blocks.mli
View File

@ -18,21 +18,21 @@ type block_info = {
} }
val info: val info:
Client_rpcs.config -> #Client_rpcs.rpc_sig ->
?include_ops:bool -> Client_node_rpcs.Blocks.block -> block_info tzresult Lwt.t ?include_ops:bool -> Client_node_rpcs.Blocks.block -> block_info tzresult Lwt.t
val compare: val compare:
block_info -> block_info -> int block_info -> block_info -> int
val monitor: val monitor:
Client_rpcs.config -> #Client_rpcs.rpc_sig ->
?include_ops:bool -> ?length:int -> ?heads:Block_hash.t list -> ?include_ops:bool -> ?length:int -> ?heads:Block_hash.t list ->
?delay:int -> ?min_date:Time.t -> ?min_heads:int -> ?delay:int -> ?min_date:Time.t -> ?min_heads:int ->
?compare:(block_info -> block_info -> int) -> ?compare:(block_info -> block_info -> int) ->
unit -> block_info list tzresult Lwt_stream.t tzresult Lwt.t unit -> block_info list tzresult Lwt_stream.t tzresult Lwt.t
val blocks_from_cycle: val blocks_from_cycle:
Client_rpcs.config -> #Client_rpcs.rpc_sig ->
Client_node_rpcs.Blocks.block -> Client_node_rpcs.Blocks.block ->
Cycle.t -> Cycle.t ->
Block_hash.t list tzresult Lwt.t Block_hash.t list tzresult Lwt.t

12
lib_embedded_client_alpha/client_baking_daemon.ml
View File

@ -7,14 +7,12 @@
(* *) (* *)
(**************************************************************************) (**************************************************************************)
open Client_commands let run (cctxt : Client_commands.full_context) ?max_priority ~delay ?min_date delegates ~endorsement ~denunciation ~baking =
let run cctxt ?max_priority ~delay ?min_date delegates ~endorsement ~denunciation ~baking =
(* TODO really detach... *) (* TODO really detach... *)
let endorsement = let endorsement =
if endorsement then if endorsement then
Client_baking_blocks.monitor Client_baking_blocks.monitor
cctxt.rpc_config ?min_date ~min_heads:1 () >>=? fun block_stream -> cctxt ?min_date ~min_heads:1 () >>=? fun block_stream ->
Client_baking_endorsement.create cctxt ~delay delegates block_stream >>= fun () -> Client_baking_endorsement.create cctxt ~delay delegates block_stream >>= fun () ->
return () return ()
else else
@ -23,7 +21,7 @@ let run cctxt ?max_priority ~delay ?min_date delegates ~endorsement ~denunciatio
let denunciation = let denunciation =
if denunciation then if denunciation then
Client_baking_operations.monitor_endorsement Client_baking_operations.monitor_endorsement
cctxt.rpc_config >>=? fun endorsement_stream -> cctxt >>=? fun endorsement_stream ->
Client_baking_denunciation.create cctxt endorsement_stream >>= fun () -> Client_baking_denunciation.create cctxt endorsement_stream >>= fun () ->
return () return ()
else else
@ -32,9 +30,9 @@ let run cctxt ?max_priority ~delay ?min_date delegates ~endorsement ~denunciatio
let forge = let forge =
if baking then begin if baking then begin
Client_baking_blocks.monitor Client_baking_blocks.monitor
cctxt.rpc_config ?min_date ~min_heads:1 () >>=? fun block_stream -> cctxt ?min_date ~min_heads:1 () >>=? fun block_stream ->
Client_baking_operations.monitor_endorsement Client_baking_operations.monitor_endorsement
cctxt.rpc_config >>=? fun endorsement_stream -> cctxt >>=? fun endorsement_stream ->
Client_baking_forge.create cctxt Client_baking_forge.create cctxt
?max_priority delegates block_stream endorsement_stream >>=? fun () -> ?max_priority delegates block_stream endorsement_stream >>=? fun () ->
return () return ()

2
lib_embedded_client_alpha/client_baking_daemon.mli
View File

@ -8,7 +8,7 @@
(**************************************************************************) (**************************************************************************)
val run: val run:
Client_commands.context -> Client_commands.full_context ->
?max_priority: int -> ?max_priority: int ->
delay: int -> delay: int ->
?min_date: Time.t -> ?min_date: Time.t ->

2
lib_embedded_client_alpha/client_baking_denunciation.mli
View File

@ -8,6 +8,6 @@
(**************************************************************************) (**************************************************************************)
val create: val create:
Client_commands.context -> Client_commands.full_context ->
Client_baking_operations.valid_endorsement tzresult Lwt_stream.t -> Client_baking_operations.valid_endorsement tzresult Lwt_stream.t ->
unit Lwt.t unit Lwt.t

84
lib_embedded_client_alpha/client_baking_endorsement.ml
View File

@ -8,18 +8,17 @@
(**************************************************************************) (**************************************************************************)
open Logging.Client.Endorsement open Logging.Client.Endorsement
open Client_commands
module State : sig module State : sig
val get_endorsement: val get_endorsement:
Client_commands.context -> #Client_commands.wallet ->
Raw_level.t -> Raw_level.t ->
int -> int ->
(Block_hash.t * Operation_hash.t) option tzresult Lwt.t (Block_hash.t * Operation_hash.t) option tzresult Lwt.t
val record_endorsement: val record_endorsement:
Client_commands.context -> #Client_commands.wallet ->
Raw_level.t -> Raw_level.t ->
Block_hash.t -> Block_hash.t ->
int -> Operation_hash.t -> unit tzresult Lwt.t int -> Operation_hash.t -> unit tzresult Lwt.t
@ -45,46 +44,21 @@ end = struct
(req "block" Block_hash.encoding) (req "block" Block_hash.encoding)
(req "operation" Operation_hash.encoding)))))) (req "operation" Operation_hash.encoding))))))
let filename cctxt = let name =
Client_commands.(Filename.concat cctxt.config.base_dir "endorsements") "endorsements"
let load cctxt = let load (wallet : #Client_commands.wallet) =
let filename = filename cctxt in wallet#load name encoding ~default:LevelMap.empty
if not (Sys.file_exists filename) then return LevelMap.empty else
Data_encoding_ezjsonm.read_file filename >>= function
| Error _ ->
cctxt.Client_commands.error
"couldn't to read the endorsement file"
| Ok json ->
match Data_encoding.Json.destruct encoding json with
| exception _ -> (* TODO print_error *)
cctxt.Client_commands.error
"didn't understand the endorsement file"
| map ->
return map
let save cctxt map = let save (wallet : #Client_commands.wallet) map =
Lwt.catch wallet#write name encoding map
(fun () ->
let dirname = Client_commands.(cctxt.config.base_dir) in
(if not (Sys.file_exists dirname) then Lwt_utils.create_dir dirname
else Lwt.return ()) >>= fun () ->
let filename = filename cctxt in
let json = Data_encoding.Json.construct encoding map in
Data_encoding_ezjsonm.write_file filename json >>= function
| Error _ -> failwith "Json.write_file"
| Ok () -> return ())
(fun exn ->
cctxt.Client_commands.error
"could not write the endorsement file: %s."
(Printexc.to_string exn))
let lock = Lwt_mutex.create () let lock = Lwt_mutex.create ()
let get_endorsement cctxt level slot = let get_endorsement (wallet : #Client_commands.wallet) level slot =
Lwt_mutex.with_lock lock Lwt_mutex.with_lock lock
(fun () -> (fun () ->
load cctxt >>=? fun map -> load wallet >>=? fun map ->
try try
let _, block, op = let _, block, op =
LevelMap.find level map LevelMap.find level map
@ -92,15 +66,16 @@ end = struct
return (Some (block, op)) return (Some (block, op))
with Not_found -> return None) with Not_found -> return None)
let record_endorsement cctxt level hash slot oph = let record_endorsement (wallet : #Client_commands.wallet) level hash slot oph =
Lwt_mutex.with_lock lock Lwt_mutex.with_lock lock
(fun () -> (fun () ->
load cctxt >>=? fun map -> load wallet >>=? fun map ->
let previous = let previous =
try LevelMap.find level map try LevelMap.find level map
with Not_found -> [] in with Not_found -> [] in
save cctxt wallet#write name
(LevelMap.add level ((slot, hash, oph) :: previous) map)) (LevelMap.add level ((slot, hash, oph) :: previous) map)
encoding)
end end
@ -113,12 +88,12 @@ let get_signing_slots cctxt ?max_priority block delegate level =
@@ List.filter (fun (l, _) -> l = level) possibilities in @@ List.filter (fun (l, _) -> l = level) possibilities in
return slots return slots
let inject_endorsement cctxt let inject_endorsement (cctxt : Client_commands.full_context)
block level ?async ?force block level ?async ?force
src_sk source slot = src_sk source slot =
let block = Client_rpcs.last_baked_block block in let block = Client_rpcs.last_baked_block block in
Client_node_rpcs.Blocks.info cctxt.rpc_config block >>=? fun bi -> Client_node_rpcs.Blocks.info cctxt block >>=? fun bi ->
Client_proto_rpcs.Helpers.Forge.Delegate.endorsement cctxt.rpc_config Client_proto_rpcs.Helpers.Forge.Delegate.endorsement cctxt
block block
~branch:bi.hash ~branch:bi.hash
~source ~source
@ -127,8 +102,7 @@ let inject_endorsement cctxt
() >>=? fun bytes -> () >>=? fun bytes ->
let signed_bytes = Ed25519.Signature.append src_sk bytes in let signed_bytes = Ed25519.Signature.append src_sk bytes in
Client_node_rpcs.inject_operation Client_node_rpcs.inject_operation
cctxt.rpc_config ?force ?async ~net_id:bi.net_id cctxt ?force ?async ~net_id:bi.net_id signed_bytes >>=? fun oph ->
signed_bytes >>=? fun oph ->
State.record_endorsement cctxt level bi.hash slot oph >>=? fun () -> State.record_endorsement cctxt level bi.hash slot oph >>=? fun () ->
return oph return oph
@ -147,20 +121,20 @@ let check_endorsement cctxt level slot =
Block_hash.pp_short block Raw_level.pp level slot Block_hash.pp_short block Raw_level.pp level slot
let forge_endorsement cctxt let forge_endorsement (cctxt : Client_commands.full_context)
block ?(force = false) block ?(force = false)
~src_sk ?slot ?max_priority src_pk = ~src_sk ?slot ?max_priority src_pk =
let block = Client_rpcs.last_baked_block block in let block = Client_rpcs.last_baked_block block in
let src_pkh = Ed25519.Public_key.hash src_pk in let src_pkh = Ed25519.Public_key.hash src_pk in
Client_proto_rpcs.Context.next_level cctxt.rpc_config block >>=? fun { level } -> Client_proto_rpcs.Context.next_level cctxt block >>=? fun { level } ->
begin begin
match slot with match slot with
| Some slot -> return slot | Some slot -> return slot
| None -> | None ->
get_signing_slots get_signing_slots
cctxt.rpc_config ?max_priority block src_pkh level >>=? function cctxt ?max_priority block src_pkh level >>=? function
| slot::_ -> return slot | slot::_ -> return slot
| [] -> cctxt.error "No slot found at level %a" Raw_level.pp level | [] -> cctxt#error "No slot found at level %a" Raw_level.pp level
end >>=? fun slot -> end >>=? fun slot ->
begin begin
if force then return () if force then return ()
@ -213,14 +187,14 @@ let drop_old_endorsement ~before state =
(fun { block } -> Fitness.compare before block.fitness <= 0) (fun { block } -> Fitness.compare before block.fitness <= 0)
state.to_endorse state.to_endorse
let schedule_endorsements cctxt state bis = let schedule_endorsements (cctxt : Client_commands.full_context) state bis =
let may_endorse (block: Client_baking_blocks.block_info) delegate time = let may_endorse (block: Client_baking_blocks.block_info) delegate time =
Client_keys.Public_key_hash.name cctxt delegate >>=? fun name -> Client_keys.Public_key_hash.name cctxt delegate >>=? fun name ->
lwt_log_info "May endorse block %a for %s" lwt_log_info "May endorse block %a for %s"
Block_hash.pp_short block.hash name >>= fun () -> Block_hash.pp_short block.hash name >>= fun () ->
let b = `Hash block.hash in let b = `Hash block.hash in
let level = Raw_level.succ block.level.level in let level = Raw_level.succ block.level.level in
get_signing_slots cctxt.rpc_config b delegate level >>=? fun slots -> get_signing_slots cctxt b delegate level >>=? fun slots ->
lwt_debug "Found slots for %a/%s (%d)" lwt_debug "Found slots for %a/%s (%d)"
Block_hash.pp_short block.hash name (List.length slots) >>= fun () -> Block_hash.pp_short block.hash name (List.length slots) >>= fun () ->
iter_p iter_p
@ -283,7 +257,7 @@ let schedule_endorsements cctxt state bis =
bis) bis)
delegates delegates
let schedule_endorsements cctxt state bis = let schedule_endorsements (cctxt : Client_commands.full_context) state bis =
schedule_endorsements cctxt state bis >>= function schedule_endorsements cctxt state bis >>= function
| Error exns -> | Error exns ->
lwt_log_error lwt_log_error
@ -318,7 +292,7 @@ let endorse cctxt state =
inject_endorsement cctxt inject_endorsement cctxt
b level ~async:true ~force:true b level ~async:true ~force:true
sk pk slot >>=? fun oph -> sk pk slot >>=? fun oph ->
cctxt.message cctxt#message
"Injected endorsement for block '%a' \ "Injected endorsement for block '%a' \
\ (level %a, slot %d, contract %s) '%a'" \ (level %a, slot %d, contract %s) '%a'"
Block_hash.pp_short hash Block_hash.pp_short hash
@ -338,11 +312,11 @@ let compute_timeout state =
else else
Lwt_unix.sleep (Int64.to_float delay) Lwt_unix.sleep (Int64.to_float delay)
let create cctxt ~delay contracts block_stream = let create (cctxt : Client_commands.full_context) ~delay contracts block_stream =
lwt_log_info "Starting endorsement daemon" >>= fun () -> lwt_log_info "Starting endorsement daemon" >>= fun () ->
Lwt_stream.get block_stream >>= function Lwt_stream.get block_stream >>= function
| None | Some (Ok []) | Some (Error _) -> | None | Some (Ok []) | Some (Error _) ->
cctxt.Client_commands.error "Can't fetch the current block head." cctxt#error "Can't fetch the current block head."
| Some (Ok (bi :: _ as initial_heads)) -> | Some (Ok (bi :: _ as initial_heads)) ->
let last_get_block = ref None in let last_get_block = ref None in
let get_block () = let get_block () =

7
lib_embedded_client_alpha/client_baking_endorsement.mli
View File

@ -8,7 +8,7 @@
(**************************************************************************) (**************************************************************************)
val forge_endorsement: val forge_endorsement:
Client_commands.context -> Client_commands.full_context ->
Client_proto_rpcs.block -> Client_proto_rpcs.block ->
?force:bool -> ?force:bool ->
src_sk:secret_key -> src_sk:secret_key ->
@ -18,8 +18,7 @@ val forge_endorsement:
Operation_hash.t tzresult Lwt.t Operation_hash.t tzresult Lwt.t
val create : val create :
Client_commands.context -> Client_commands.full_context ->
delay:int -> delay:int ->
public_key_hash list -> public_key_hash list ->
Client_baking_blocks.block_info list tzresult Lwt_stream.t -> Client_baking_blocks.block_info list tzresult Lwt_stream.t -> unit Lwt.t
unit Lwt.t

80
lib_embedded_client_alpha/client_baking_forge.ml
View File

@ -7,7 +7,6 @@
(* *) (* *)
(**************************************************************************) (**************************************************************************)
open Client_commands
open Logging.Client.Baking open Logging.Client.Baking
let generate_proof_of_work_nonce () = let generate_proof_of_work_nonce () =
@ -200,11 +199,11 @@ let forge_block cctxt block
module State : sig module State : sig
val get_block: val get_block:
Client_commands.context -> #Client_commands.wallet ->
Raw_level.t -> Block_hash.t list tzresult Lwt.t Raw_level.t -> Block_hash.t list tzresult Lwt.t
val record_block: val record_block:
Client_commands.context -> #Client_commands.wallet ->
Raw_level.t -> Block_hash.t -> Nonce.t -> unit tzresult Lwt.t Raw_level.t -> Block_hash.t -> Nonce.t -> unit tzresult Lwt.t
end = struct end = struct
@ -224,41 +223,18 @@ end = struct
(req "level" Raw_level.encoding) (req "level" Raw_level.encoding)
(req "blocks" (list Block_hash.encoding)))) (req "blocks" (list Block_hash.encoding))))
let filename cctxt = let name =
Client_commands.(Filename.concat cctxt.config.base_dir "blocks") "blocks"
let load cctxt = let load (wallet : #Client_commands.wallet) =
let filename = filename cctxt in wallet#load name ~default:LevelMap.empty encoding
if not (Sys.file_exists filename) then return LevelMap.empty else
Data_encoding_ezjsonm.read_file filename >>= function
| Error _ ->
failwith "couldn't to read the block file"
| Ok json ->
match Data_encoding.Json.destruct encoding json with
| exception _ -> (* TODO print_error *)
failwith "didn't understand the block file"
| map ->
return map
let save cctxt map = let save (wallet : #Client_commands.wallet) map =
Lwt.catch wallet#write name map encoding
(fun () ->
let dirname = Client_commands.(cctxt.config.base_dir) in
(if not (Sys.file_exists dirname) then Lwt_utils.create_dir dirname
else Lwt.return ()) >>= fun () ->
let filename = filename cctxt in
let json = Data_encoding.Json.construct encoding map in
Data_encoding_ezjsonm.write_file filename json >>= function
| Error _ -> failwith "Json.write_file"
| Ok () -> return ())
(fun exn ->
failwith
"could not write the block file: %s."
(Printexc.to_string exn))
let lock = Lwt_mutex.create () let lock = Lwt_mutex.create ()
let get_block cctxt level = let get_block (cctxt : #Client_commands.wallet) level =
Lwt_mutex.with_lock lock Lwt_mutex.with_lock lock
(fun () -> (fun () ->
load cctxt >>=? fun map -> load cctxt >>=? fun map ->
@ -350,33 +326,33 @@ let compute_timeout { future_slots } =
else else
Lwt_unix.sleep (Int64.to_float delay) Lwt_unix.sleep (Int64.to_float delay)
let get_unrevealed_nonces cctxt ?(force = false) block = let get_unrevealed_nonces (cctxt : Client_commands.full_context) ?(force = false) block =
Client_proto_rpcs.Context.next_level cctxt.rpc_config block >>=? fun level -> Client_proto_rpcs.Context.next_level cctxt block >>=? fun level ->
let cur_cycle = level.cycle in let cur_cycle = level.cycle in
match Cycle.pred cur_cycle with match Cycle.pred cur_cycle with
| None -> return [] | None -> return []
| Some cycle -> | Some cycle ->
Client_baking_blocks.blocks_from_cycle Client_baking_blocks.blocks_from_cycle
cctxt.rpc_config block cycle >>=? fun blocks -> cctxt block cycle >>=? fun blocks ->
filter_map_s (fun hash -> filter_map_s (fun hash ->
Client_proto_nonces.find cctxt hash >>= function Client_proto_nonces.find cctxt hash >>=? function
| None -> return None | None -> return None
| Some nonce -> | Some nonce ->
Client_proto_rpcs.Context.level Client_proto_rpcs.Context.level
cctxt.rpc_config (`Hash hash) >>=? fun level -> cctxt (`Hash hash) >>=? fun level ->
if force then if force then
return (Some (hash, (level.level, nonce))) return (Some (hash, (level.level, nonce)))
else else
Client_proto_rpcs.Context.Nonce.get Client_proto_rpcs.Context.Nonce.get
cctxt.rpc_config block level.level >>=? function cctxt block level.level >>=? function
| Missing nonce_hash | Missing nonce_hash
when Nonce.check_hash nonce nonce_hash -> when Nonce.check_hash nonce nonce_hash ->
cctxt.warning "Found nonce for %a (level: %a)@." cctxt#warning "Found nonce for %a (level: %a)@."
Block_hash.pp_short hash Block_hash.pp_short hash
Level.pp level >>= fun () -> Level.pp level >>= fun () ->
return (Some (hash, (level.level, nonce))) return (Some (hash, (level.level, nonce)))
| Missing _nonce_hash -> | Missing _nonce_hash ->
cctxt.error "Incoherent nonce for level %a" cctxt#error "Incoherent nonce for level %a"
Raw_level.pp level.level >>= fun () -> Raw_level.pp level.level >>= fun () ->
return None return None
| Forgotten -> return None | Forgotten -> return None
@ -398,7 +374,7 @@ let get_delegates cctxt state =
| _ :: _ as delegates -> return delegates | _ :: _ as delegates -> return delegates
let insert_block let insert_block
cctxt ?max_priority state (bi: Client_baking_blocks.block_info) = (cctxt : Client_commands.full_context) ?max_priority state (bi: Client_baking_blocks.block_info) =
begin begin
safe_get_unrevealed_nonces cctxt (`Hash bi.hash) >>= fun nonces -> safe_get_unrevealed_nonces cctxt (`Hash bi.hash) >>= fun nonces ->
Client_baking_revelation.forge_seed_nonce_revelation Client_baking_revelation.forge_seed_nonce_revelation
@ -410,7 +386,7 @@ let insert_block
~before:(Time.add state.best.timestamp (-1800L)) state ; ~before:(Time.add state.best.timestamp (-1800L)) state ;
end ; end ;
get_delegates cctxt state >>=? fun delegates -> get_delegates cctxt state >>=? fun delegates ->
get_baking_slot cctxt.rpc_config ?max_priority bi delegates >>= function get_baking_slot cctxt ?max_priority bi delegates >>= function
| None -> | None ->
lwt_debug lwt_debug
"Can't compute slot for %a" Block_hash.pp_short bi.hash >>= fun () -> "Can't compute slot for %a" Block_hash.pp_short bi.hash >>= fun () ->
@ -443,7 +419,7 @@ let insert_blocks cctxt ?max_priority state bis =
Format.eprintf "Error: %a" pp_print_error err ; Format.eprintf "Error: %a" pp_print_error err ;
Lwt.return_unit Lwt.return_unit
let bake cctxt state = let bake (cctxt : Client_commands.full_context) state =
let slots = pop_baking_slots state in let slots = pop_baking_slots state in
let seed_nonce = generate_seed_nonce () in let seed_nonce = generate_seed_nonce () in
let seed_nonce_hash = Nonce.hash seed_nonce in let seed_nonce_hash = Nonce.hash seed_nonce in
@ -459,7 +435,7 @@ let bake cctxt state =
lwt_debug "Try baking after %a (slot %d) for %s (%a)" lwt_debug "Try baking after %a (slot %d) for %s (%a)"
Block_hash.pp_short bi.hash Block_hash.pp_short bi.hash
priority name Time.pp_hum timestamp >>= fun () -> priority name Time.pp_hum timestamp >>= fun () ->
Client_node_rpcs.Blocks.pending_operations cctxt.rpc_config Client_node_rpcs.Blocks.pending_operations cctxt
block >>=? fun (res, ops) -> block >>=? fun (res, ops) ->
let operations = let operations =
List.map snd @@ List.map snd @@
@ -469,7 +445,7 @@ let bake cctxt state =
let request = List.length operations in let request = List.length operations in
let proto_header = let proto_header =
forge_faked_proto_header ~priority ~seed_nonce_hash in forge_faked_proto_header ~priority ~seed_nonce_hash in
Client_node_rpcs.Blocks.preapply cctxt.rpc_config block Client_node_rpcs.Blocks.preapply cctxt block
~timestamp ~sort:true ~proto_header operations >>= function ~timestamp ~sort:true ~proto_header operations >>= function
| Error errs -> | Error errs ->
lwt_log_error "Error while prevalidating operations:\n%a" lwt_log_error "Error while prevalidating operations:\n%a"
@ -502,12 +478,12 @@ let bake cctxt state =
(Fitness.compare state.best.fitness shell_header.fitness = 0 && (Fitness.compare state.best.fitness shell_header.fitness = 0 &&
Time.compare shell_header.timestamp state.best.timestamp < 0) -> begin Time.compare shell_header.timestamp state.best.timestamp < 0) -> begin
let level = Raw_level.succ bi.level.level in let level = Raw_level.succ bi.level.level in
cctxt.message cctxt#message
"Select candidate block after %a (slot %d) fitness: %a" "Select candidate block after %a (slot %d) fitness: %a"
Block_hash.pp_short bi.hash priority Block_hash.pp_short bi.hash priority
Fitness.pp shell_header.fitness >>= fun () -> Fitness.pp shell_header.fitness >>= fun () ->
Client_keys.get_key cctxt delegate >>=? fun (_,_,src_sk) -> Client_keys.get_key cctxt delegate >>=? fun (_,_,src_sk) ->
inject_block cctxt.rpc_config inject_block cctxt
~force:true ~net_id:bi.net_id ~force:true ~net_id:bi.net_id
~shell_header ~priority ~seed_nonce_hash ~src_sk ~shell_header ~priority ~seed_nonce_hash ~src_sk
[List.map snd operations.applied] [List.map snd operations.applied]
@ -515,7 +491,7 @@ let bake cctxt state =
State.record_block cctxt level block_hash seed_nonce State.record_block cctxt level block_hash seed_nonce
|> trace_exn (Failure "Error while recording block") >>=? fun () -> |> trace_exn (Failure "Error while recording block") >>=? fun () ->
Client_keys.Public_key_hash.name cctxt delegate >>=? fun name -> Client_keys.Public_key_hash.name cctxt delegate >>=? fun name ->
cctxt.message cctxt#message
"Injected block %a for %s after %a \ "Injected block %a for %s after %a \
\ (level %a, slot %d, fitness %a, operations %d)" \ (level %a, slot %d, fitness %a, operations %d)"
Block_hash.pp_short block_hash Block_hash.pp_short block_hash
@ -531,16 +507,16 @@ let bake cctxt state =
return () return ()
let create let create
cctxt ?max_priority delegates (cctxt : Client_commands.full_context) ?max_priority delegates
(block_stream: (block_stream:
Client_baking_blocks.block_info list tzresult Lwt_stream.t) Client_baking_blocks.block_info list tzresult Lwt_stream.t)
(endorsement_stream: (endorsement_stream:
Client_baking_operations.valid_endorsement tzresult Lwt_stream.t) = Client_baking_operations.valid_endorsement tzresult Lwt_stream.t) =
Lwt_stream.get block_stream >>= function Lwt_stream.get block_stream >>= function
| None | Some (Ok [] | Error _) -> | None | Some (Ok [] | Error _) ->
cctxt.Client_commands.error "Can't fetch the current block head." cctxt#error "Can't fetch the current block head."
| Some (Ok (bi :: _ as initial_heads)) -> | Some (Ok (bi :: _ as initial_heads)) ->
Client_node_rpcs.Blocks.hash cctxt.rpc_config `Genesis >>=? fun genesis_hash -> Client_node_rpcs.Blocks.hash cctxt `Genesis >>=? fun genesis_hash ->
let last_get_block = ref None in let last_get_block = ref None in
let get_block () = let get_block () =
match !last_get_block with match !last_get_block with

12
lib_embedded_client_alpha/client_baking_forge.mli
View File

@ -14,7 +14,7 @@ val generate_seed_nonce: unit -> Nonce.t
reveal the aforementionned nonce during the next cycle. *) reveal the aforementionned nonce during the next cycle. *)
val inject_block: val inject_block:
Client_rpcs.config -> #Client_rpcs.rpc_sig ->
?force:bool -> ?force:bool ->
?net_id:Net_id.t -> ?net_id:Net_id.t ->
shell_header:Block_header.shell_header -> shell_header:Block_header.shell_header ->
@ -33,7 +33,7 @@ type error +=
| Failed_to_preapply of Tezos_base.Operation.t * error list | Failed_to_preapply of Tezos_base.Operation.t * error list
val forge_block: val forge_block:
Client_rpcs.config -> #Client_rpcs.rpc_sig ->
Client_proto_rpcs.block -> Client_proto_rpcs.block ->
?force:bool -> ?force:bool ->
?operations:Tezos_base.Operation.t list -> ?operations:Tezos_base.Operation.t list ->
@ -65,15 +65,15 @@ val forge_block:
module State : sig module State : sig
val get_block: val get_block:
Client_commands.context -> Client_commands.full_context ->
Raw_level.t -> Block_hash.t list tzresult Lwt.t Raw_level.t -> Block_hash.t list tzresult Lwt.t
val record_block: val record_block:
Client_commands.context -> Client_commands.full_context ->
Raw_level.t -> Block_hash.t -> Nonce.t -> unit tzresult Lwt.t Raw_level.t -> Block_hash.t -> Nonce.t -> unit tzresult Lwt.t
end end
val create: val create:
Client_commands.context -> Client_commands.full_context ->
?max_priority: int -> ?max_priority: int ->
public_key_hash list -> public_key_hash list ->
Client_baking_blocks.block_info list tzresult Lwt_stream.t -> Client_baking_blocks.block_info list tzresult Lwt_stream.t ->
@ -81,7 +81,7 @@ val create:
unit tzresult Lwt.t unit tzresult Lwt.t
val get_unrevealed_nonces: val get_unrevealed_nonces:
Client_commands.context -> Client_commands.full_context ->
?force:bool -> ?force:bool ->
Client_proto_rpcs.block -> Client_proto_rpcs.block ->
(Block_hash.t * (Raw_level.t * Nonce.t)) list tzresult Lwt.t (Block_hash.t * (Raw_level.t * Nonce.t)) list tzresult Lwt.t

97
lib_embedded_client_alpha/client_baking_lib.ml Normal file
View File

@ -0,0 +1,97 @@
(**************************************************************************)
(* *)
(* Copyright (c) 2014 - 2016. *)
(* Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* All rights reserved. No warranty, explicit or implicit, provided. *)
(* *)
(**************************************************************************)
let bake_block (cctxt : Client_commands.full_context) block
?force ?max_priority ?(free_baking=false) ?src_sk delegate =
begin
match src_sk with
| None ->
Client_keys.get_key cctxt delegate >>=? fun (_, _, src_sk) ->
return src_sk
| Some sk -> return sk
end >>=? fun src_sk ->
Client_proto_rpcs.Context.level cctxt block >>=? fun level ->
let level = Raw_level.succ level.level in
let seed_nonce = Client_baking_forge.generate_seed_nonce () in
let seed_nonce_hash = Nonce.hash seed_nonce in
Client_baking_forge.forge_block cctxt
~timestamp:(Time.now ())
?force
~seed_nonce_hash ~src_sk block
~priority:(`Auto (delegate, max_priority, free_baking)) () >>=? fun block_hash ->
Client_baking_forge.State.record_block cctxt level block_hash seed_nonce
|> trace_exn (Failure "Error while recording block") >>=? fun () ->
cctxt#message "Injected block %a" Block_hash.pp_short block_hash >>= fun () ->
return ()
let endorse_block cctxt ?force ?max_priority delegate =
Client_keys.get_key cctxt delegate >>=? fun (_src_name, src_pk, src_sk) ->
Client_baking_endorsement.forge_endorsement cctxt
cctxt#block ?force ?max_priority ~src_sk src_pk >>=? fun oph ->
cctxt#answer "Operation successfully injected in the node." >>= fun () ->
cctxt#answer "Operation hash is '%a'." Operation_hash.pp oph >>= fun () ->
return ()
let get_predecessor_cycle (cctxt : #Client_commands.logger) cycle =
match Cycle.pred cycle with
| None ->
if Cycle.(cycle = root) then
cctxt#error "No predecessor for the first cycle"
else
cctxt#error
"Cannot compute the predecessor of cycle %a"
Cycle.pp cycle
| Some cycle -> Lwt.return cycle
let do_reveal cctxt ?force block blocks =
let nonces = List.map snd blocks in
Client_baking_revelation.forge_seed_nonce_revelation cctxt
block ?force nonces >>=? fun () ->
Client_proto_nonces.dels cctxt (List.map fst blocks) >>=? fun () ->
return ()
let reveal_block_nonces (cctxt : Client_commands.full_context) ?force block_hashes =
Lwt_list.filter_map_p
(fun hash ->
Lwt.catch
(fun () ->
Client_baking_blocks.info cctxt (`Hash hash) >>= function
| Ok bi -> Lwt.return (Some bi)
| Error _ ->
Lwt.fail Not_found)
(fun _ ->
cctxt#warning
"Cannot find block %a in the chain. (ignoring)@."
Block_hash.pp_short hash >>= fun () ->
Lwt.return_none))
block_hashes >>= fun block_infos ->
filter_map_s (fun (bi : Client_baking_blocks.block_info) ->
Client_proto_nonces.find cctxt bi.hash >>=? function
| None ->
cctxt#warning "Cannot find nonces for block %a (ignoring)@."
Block_hash.pp_short bi.hash >>= fun () ->
return None
| Some nonce ->
return (Some (bi.hash, (bi.level.level, nonce))))
block_infos >>=? fun blocks ->
do_reveal cctxt ?force cctxt#block blocks
let reveal_nonces cctxt ?force () =
let block = Client_rpcs.last_baked_block cctxt#block in
Client_baking_forge.get_unrevealed_nonces
cctxt ?force block >>=? fun nonces ->
do_reveal cctxt ?force cctxt#block nonces
let run_daemon cctxt ?max_priority ~endorsement_delay delegates ~endorsement ~baking ~denunciation =
Client_baking_daemon.run cctxt
?max_priority
~delay:endorsement_delay
~min_date:((Time.add (Time.now ()) (Int64.neg 1800L)))
~endorsement ~baking ~denunciation
(List.map snd delegates)

58
lib_embedded_client_alpha/client_baking_lib.mli Normal file
View File

@ -0,0 +1,58 @@
(**************************************************************************)
(* *)
(* Copyright (c) 2014 - 2016. *)
(* Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* All rights reserved. No warranty, explicit or implicit, provided. *)
(* *)
(**************************************************************************)
(** Mine a block *)
val bake_block:
Client_commands.full_context ->
Client_proto_rpcs.block ->
?force:bool ->
?max_priority: int ->
?free_baking: bool ->
?src_sk:secret_key ->
public_key_hash ->
unit tzresult Lwt.t
(** Endorse a block *)
val endorse_block:
Client_commands.full_context ->
?force:bool ->
?max_priority:int ->
Client_keys.Public_key_hash.t ->
unit Error_monad.tzresult Lwt.t
(** Get the previous cycle of the given cycle *)
val get_predecessor_cycle:
Client_commands.full_context ->
Cycle.t ->
Cycle.t Lwt.t
(** Reveal the nonces used to bake each block in the given list *)
val reveal_block_nonces :
Client_commands.full_context ->
?force:bool ->
Block_hash.t list ->
unit Error_monad.tzresult Lwt.t
(** Reveal all unrevealed nonces *)
val reveal_nonces :
Client_commands.full_context ->
?force:bool ->
unit ->
unit Error_monad.tzresult Lwt.t
(** Initialize the baking daemon *)
val run_daemon:
Client_commands.full_context ->
?max_priority:int ->
endorsement_delay:int ->
('a * Tezos_embedded_raw_protocol_alpha.Tezos_context.public_key_hash) list ->
endorsement:bool ->
baking:bool ->
denunciation:bool ->
unit Error_monad.tzresult Lwt.t

100
lib_embedded_client_alpha/client_baking_main.ml
View File

@ -7,98 +7,8 @@
(* *) (* *)
(**************************************************************************) (**************************************************************************)
open Client_commands
let bake_block cctxt block
?force ?max_priority ?(free_baking=false) ?src_sk delegate =
begin
match src_sk with
| None ->
Client_keys.get_key cctxt delegate >>=? fun (_, _, src_sk) ->
return src_sk
| Some sk -> return sk
end >>=? fun src_sk ->
Client_proto_rpcs.Context.level cctxt.rpc_config block >>=? fun level ->
let level = Raw_level.succ level.level in
let seed_nonce = Client_baking_forge.generate_seed_nonce () in
let seed_nonce_hash = Nonce.hash seed_nonce in
Client_baking_forge.forge_block cctxt.rpc_config
~timestamp:(Time.now ())
?force
~seed_nonce_hash ~src_sk block
~priority:(`Auto (delegate, max_priority, free_baking)) () >>=? fun block_hash ->
Client_baking_forge.State.record_block cctxt level block_hash seed_nonce
|> trace_exn (Failure "Error while recording block") >>=? fun () ->
cctxt.message "Injected block %a" Block_hash.pp_short block_hash >>= fun () ->
return ()
let endorse_block cctxt ?force ?max_priority delegate =
Client_keys.get_key cctxt delegate >>=? fun (_src_name, src_pk, src_sk) ->
Client_baking_endorsement.forge_endorsement cctxt
cctxt.config.block ?force ?max_priority ~src_sk src_pk >>=? fun oph ->
cctxt.answer "Operation successfully injected in the node." >>= fun () ->
cctxt.answer "Operation hash is '%a'." Operation_hash.pp oph >>= fun () ->
return ()
let get_predecessor_cycle cctxt cycle =
match Cycle.pred cycle with
| None ->
if Cycle.(cycle = root) then
cctxt.Client_commands.error "No predecessor for the first cycle"
else
cctxt.error
"Cannot compute the predecessor of cycle %a"
Cycle.pp cycle
| Some cycle -> Lwt.return cycle
let do_reveal cctxt ?force block blocks =
let nonces = List.map snd blocks in
Client_baking_revelation.forge_seed_nonce_revelation cctxt
block ?force nonces >>=? fun () ->
Client_proto_nonces.dels cctxt (List.map fst blocks) >>=? fun () ->
return ()
let reveal_block_nonces cctxt ?force block_hashes =
Lwt_list.filter_map_p
(fun hash ->
Lwt.catch
(fun () ->
Client_baking_blocks.info cctxt.rpc_config (`Hash hash) >>= function
| Ok bi -> Lwt.return (Some bi)
| Error _ ->
Lwt.fail Not_found)
(fun _ ->
cctxt.warning
"Cannot find block %a in the chain. (ignoring)@."
Block_hash.pp_short hash >>= fun () ->
Lwt.return_none))
block_hashes >>= fun block_infos ->
filter_map_s (fun (bi : Client_baking_blocks.block_info) ->
Client_proto_nonces.find cctxt bi.hash >>= function
| None ->
cctxt.warning "Cannot find nonces for block %a (ignoring)@."
Block_hash.pp_short bi.hash >>= fun () ->
return None
| Some nonce ->
return (Some (bi.hash, (bi.level.level, nonce))))
block_infos >>=? fun blocks ->
do_reveal cctxt ?force cctxt.config.block blocks
let reveal_nonces cctxt ?force () =
let block = Client_rpcs.last_baked_block cctxt.config.block in
Client_baking_forge.get_unrevealed_nonces
cctxt ?force block >>=? fun nonces ->
do_reveal cctxt ?force cctxt.config.block nonces
open Client_proto_args open Client_proto_args
open Client_baking_lib
let run_daemon cctxt max_priority endorsement_delay delegates ~endorsement ~baking ~denunciation =
Client_baking_daemon.run cctxt
?max_priority
~delay:endorsement_delay
~min_date:((Time.add (Time.now ()) (Int64.neg 1800L)))
~endorsement ~baking ~denunciation
(List.map snd delegates)
let group = let group =
{ Cli_entries.name = "delegate" ; { Cli_entries.name = "delegate" ;
@ -117,7 +27,7 @@ let commands () =
if (not endorsement) && (not baking) && (not denunciation) if (not endorsement) && (not baking) && (not denunciation)
then (true, true, true) then (true, true, true)
else (endorsement, baking, denunciation) in else (endorsement, baking, denunciation) in
run_daemon cctxt max_priority endorsement_delay ~endorsement ~baking ~denunciation delegates) ; run_daemon cctxt ?max_priority ~endorsement_delay ~endorsement ~baking ~denunciation delegates) ;
command ~group ~desc: "Forge and inject an endorsement operation" command ~group ~desc: "Forge and inject an endorsement operation"
(args2 force_switch max_priority_arg) (args2 force_switch max_priority_arg)
(prefixes [ "endorse"; "for" ] (prefixes [ "endorse"; "for" ]
@ -134,7 +44,7 @@ let commands () =
~name:"baker" ~desc: "name of the delegate owning the baking right" ~name:"baker" ~desc: "name of the delegate owning the baking right"
@@ stop) @@ stop)
(fun (max_priority, force, free_baking) (_, delegate) cctxt -> (fun (max_priority, force, free_baking) (_, delegate) cctxt ->
bake_block cctxt cctxt.config.block bake_block cctxt cctxt#block
~force ?max_priority ~free_baking delegate) ; ~force ?max_priority ~free_baking delegate) ;
command ~group ~desc: "Forge and inject a seed-nonce revelation operation" command ~group ~desc: "Forge and inject a seed-nonce revelation operation"
(args1 force_switch) (args1 force_switch)
@ -150,7 +60,3 @@ let commands () =
(fun force cctxt -> (fun force cctxt ->
reveal_nonces cctxt ~force ()) ; reveal_nonces cctxt ~force ()) ;
] ]
let () =
Client_commands.register Client_proto_main.protocol @@
commands ()

10
lib_embedded_client_alpha/client_baking_main.mli
View File

@ -7,14 +7,4 @@
(* *) (* *)
(**************************************************************************) (**************************************************************************)
val bake_block:
Client_commands.context ->
Client_proto_rpcs.block ->
?force:bool ->
?max_priority: int ->
?free_baking: bool ->
?src_sk:secret_key ->
public_key_hash ->
unit tzresult Lwt.t
val commands: unit -> Client_commands.command list val commands: unit -> Client_commands.command list

10
lib_embedded_client_alpha/client_baking_operations.mli
View File

@ -13,7 +13,7 @@ type operation = {
} }
val monitor: val monitor:
Client_rpcs.config -> #Client_rpcs.rpc_sig ->
?contents:bool -> ?check:bool -> unit -> ?contents:bool -> ?check:bool -> unit ->
operation list tzresult Lwt_stream.t tzresult Lwt.t operation list tzresult Lwt_stream.t tzresult Lwt.t
@ -24,13 +24,7 @@ type valid_endorsement = {
slots: int list ; slots: int list ;
} }
(*
val filter_valid_endorsement:
Client_rpcs.config ->
operation -> valid_endorsement option Lwt.t
*)
val monitor_endorsement: val monitor_endorsement:
Client_rpcs.config -> #Client_rpcs.rpc_sig ->
valid_endorsement tzresult Lwt_stream.t tzresult Lwt.t valid_endorsement tzresult Lwt_stream.t tzresult Lwt.t

12
lib_embedded_client_alpha/client_baking_revelation.ml
View File

@ -24,20 +24,20 @@ let inject_seed_nonce_revelation rpc_config block ?force ?async nonces =
return oph return oph
let forge_seed_nonce_revelation let forge_seed_nonce_revelation
(cctxt: Client_commands.context) (cctxt: Client_commands.full_context)
block ?(force = false) nonces = block ?(force = false) nonces =
Client_node_rpcs.Blocks.hash cctxt.rpc_config block >>=? fun hash -> Client_node_rpcs.Blocks.hash cctxt block >>=? fun hash ->
match nonces with match nonces with
| [] -> | [] ->
cctxt.message "No nonce to reveal for block %a" cctxt#message "No nonce to reveal for block %a"
Block_hash.pp_short hash >>= fun () -> Block_hash.pp_short hash >>= fun () ->
return () return ()
| _ -> | _ ->
inject_seed_nonce_revelation cctxt.rpc_config block ~force nonces >>=? fun oph -> inject_seed_nonce_revelation cctxt block ~force nonces >>=? fun oph ->
cctxt.answer cctxt#answer
"Operation successfully injected %d revelation(s) for %a." "Operation successfully injected %d revelation(s) for %a."
(List.length nonces) (List.length nonces)
Block_hash.pp_short hash >>= fun () -> Block_hash.pp_short hash >>= fun () ->
cctxt.answer "Operation hash is '%a'." cctxt#answer "Operation hash is '%a'."
Operation_hash.pp_short oph >>= fun () -> Operation_hash.pp_short oph >>= fun () ->
return () return ()

4
lib_embedded_client_alpha/client_baking_revelation.mli
View File

@ -8,7 +8,7 @@
(**************************************************************************) (**************************************************************************)
val inject_seed_nonce_revelation: val inject_seed_nonce_revelation:
Client_rpcs.config -> #Client_rpcs.rpc_sig ->
Client_proto_rpcs.block -> Client_proto_rpcs.block ->
?force:bool -> ?force:bool ->
?async:bool -> ?async:bool ->
@ -16,7 +16,7 @@ val inject_seed_nonce_revelation:
Operation_hash.t tzresult Lwt.t Operation_hash.t tzresult Lwt.t
val forge_seed_nonce_revelation: val forge_seed_nonce_revelation:
Client_commands.context -> Client_commands.full_context ->
Client_proto_rpcs.block -> Client_proto_rpcs.block ->
?force:bool -> ?force:bool ->
(Raw_level.t * Nonce.t) list -> (Raw_level.t * Nonce.t) list ->

2
lib_embedded_client_alpha/client_proto_args.ml
View File

@ -54,7 +54,7 @@ let tez_sym =
"\xEA\x9C\xA9" "\xEA\x9C\xA9"
let string_parameter = let string_parameter =
parameter (fun _ x -> return x) parameter (fun (_ : Client_commands.full_context) x -> return x)
let init_arg = let init_arg =
default_arg default_arg

38
lib_embedded_client_alpha/client_proto_args.mli
View File

@ -10,36 +10,36 @@
val tez_sym: string val tez_sym: string
open Cli_entries open Cli_entries
val init_arg: (string, Client_commands.context) arg val init_arg: (string, Client_commands.full_context) arg
val fee_arg: (Tez.t, Client_commands.context) arg val fee_arg: (Tez.t, Client_commands.full_context) arg
val arg_arg: (string, Client_commands.context) arg val arg_arg: (string, Client_commands.full_context) arg
val source_arg: (string option, Client_commands.context) arg val source_arg: (string option, Client_commands.full_context) arg
val delegate_arg: (string option, Client_commands.context) arg val delegate_arg: (string option, Client_commands.full_context) arg
val delegatable_switch: (bool, Client_commands.context) arg val delegatable_switch: (bool, Client_commands.full_context) arg
val spendable_switch: (bool, Client_commands.context) arg val spendable_switch: (bool, Client_commands.full_context) arg
val max_priority_arg: (int option, Client_commands.context) arg val max_priority_arg: (int option, Client_commands.full_context) arg
val free_baking_switch: (bool, Client_commands.context) arg val free_baking_switch: (bool, Client_commands.full_context) arg
val force_switch: (bool, Client_commands.context) arg val force_switch: (bool, Client_commands.full_context) arg
val endorsement_delay_arg: (int, Client_commands.context) arg val endorsement_delay_arg: (int, Client_commands.full_context) arg
val no_print_source_flag : (bool, Client_commands.context) arg val no_print_source_flag : (bool, Client_commands.full_context) arg
val tez_arg : val tez_arg :
default:string -> default:string ->
parameter:string -> parameter:string ->
doc:string -> doc:string ->
(Tez.t, Client_commands.context) arg (Tez.t, Client_commands.full_context) arg
val tez_param : val tez_param :
name:string -> name:string ->
desc:string -> desc:string ->
('a, Client_commands.context, 'ret) Cli_entries.params -> ('a, Client_commands.full_context, 'ret) Cli_entries.params ->
(Tez.t -> 'a, Client_commands.context, 'ret) Cli_entries.params (Tez.t -> 'a, Client_commands.full_context, 'ret) Cli_entries.params
module Daemon : sig module Daemon : sig
val baking_switch: (bool, Client_commands.context) arg val baking_switch: (bool, Client_commands.full_context) arg
val endorsement_switch: (bool, Client_commands.context) arg val endorsement_switch: (bool, Client_commands.full_context) arg
val denunciation_switch: (bool, Client_commands.context) arg val denunciation_switch: (bool, Client_commands.full_context) arg
end end
val string_parameter : (string, Client_commands.context) Cli_entries.parameter val string_parameter : (string, Client_commands.full_context) Cli_entries.parameter

404
lib_embedded_client_alpha/client_proto_context.ml
View File

@ -8,17 +8,14 @@
(**************************************************************************) (**************************************************************************)
open Tezos_micheline open Tezos_micheline
open Client_proto_args
open Client_proto_contracts open Client_proto_contracts
open Client_proto_programs
open Client_keys open Client_keys
open Client_commands
let get_balance cctxt block contract = let get_balance (rpc : #Client_rpcs.rpc_sig) block contract =
Client_proto_rpcs.Context.Contract.balance cctxt block contract Client_proto_rpcs.Context.Contract.balance rpc block contract
let get_storage cctxt block contract = let get_storage (rpc : #Client_rpcs.rpc_sig) block contract =
Client_proto_rpcs.Context.Contract.storage cctxt block contract Client_proto_rpcs.Context.Contract.storage rpc block contract
let rec find_predecessor rpc_config h n = let rec find_predecessor rpc_config h n =
if n <= 0 then if n <= 0 then
@ -92,39 +89,36 @@ let originate rpc_config ?force ?net_id ~block ?signature bytes =
"The origination introduced %d contracts instead of one." "The origination introduced %d contracts instead of one."
(List.length contracts) (List.length contracts)
let originate_account rpc_config let operation_submitted_message (cctxt : #Client_commands.logger) ?(force=false) ?(contracts = []) oph =
block ?force ?branch begin
if not force then
cctxt#message "Operation successfully injected in the node."
else
Lwt.return_unit
end >>= fun () ->
cctxt#message "Operation hash is '%a'." Operation_hash.pp oph >>= fun () ->
Lwt_list.iter_s
(fun c ->
cctxt#message
"New contract %a originated from a smart contract."
Contract.pp c)
contracts >>= return
let originate_account ?(force=false) ?branch
~source ~src_pk ~src_sk ~manager_pkh ~source ~src_pk ~src_sk ~manager_pkh
?delegatable ?spendable ?delegate ~balance ~fee () = ?delegatable ?delegate ~balance ~fee block rpc_config () =
get_branch rpc_config block branch >>=? fun (net_id, branch) -> get_branch rpc_config block branch >>=? fun (net_id, branch) ->
Client_proto_rpcs.Context.Contract.counter Client_proto_rpcs.Context.Contract.counter
rpc_config block source >>=? fun pcounter -> rpc_config block source >>=? fun pcounter ->
let counter = Int32.succ pcounter in let counter = Int32.succ pcounter in
Client_proto_rpcs.Helpers.Forge.Manager.origination rpc_config block Client_proto_rpcs.Helpers.Forge.Manager.origination rpc_config block
~branch ~source ~sourcePubKey:src_pk ~managerPubKey:manager_pkh ~branch ~source ~sourcePubKey:src_pk ~managerPubKey:manager_pkh
~counter ~balance ?spendable ~counter ~balance ~spendable:true
?delegatable ?delegatePubKey:delegate ~fee () >>=? fun bytes -> ?delegatable ?delegatePubKey:delegate ~fee () >>=? fun bytes ->
let signature = Ed25519.sign src_sk bytes in let signature = Ed25519.sign src_sk bytes in
originate rpc_config ?force ~block ~net_id ~signature bytes originate rpc_config ~force ~block ~net_id ~signature bytes
let originate_contract rpc_config let faucet ?force ?branch ~manager_pkh block rpc_config () =
block ?force ?branch
~source ~src_pk ~src_sk ~manager_pkh ~balance ?delegatable ?delegatePubKey
~code ~init ~fee ~spendable () =
parse_expression init >>=? fun { expanded = storage } ->
Client_proto_rpcs.Context.Contract.counter
rpc_config block source >>=? fun pcounter ->
let counter = Int32.succ pcounter in
get_branch rpc_config block branch >>=? fun (net_id, branch) ->
Client_proto_rpcs.Helpers.Forge.Manager.origination rpc_config block
~branch ~source ~sourcePubKey:src_pk ~managerPubKey:manager_pkh
~counter ~balance ~spendable:spendable
?delegatable ?delegatePubKey
~script:{ code ; storage } ~fee () >>=? fun bytes ->
let signature = Ed25519.sign src_sk bytes in
originate rpc_config ?force ~net_id ~block ~signature bytes
let faucet rpc_config block ?force ?branch ~manager_pkh () =
get_branch rpc_config block branch >>=? fun (net_id, branch) -> get_branch rpc_config block branch >>=? fun (net_id, branch) ->
Client_proto_rpcs.Helpers.Forge.Anonymous.faucet Client_proto_rpcs.Helpers.Forge.Anonymous.faucet
rpc_config block ~branch ~id:manager_pkh () >>=? fun bytes -> rpc_config block ~branch ~id:manager_pkh () >>=? fun bytes ->
@ -149,9 +143,9 @@ let delegate_contract rpc_config
assert (Operation_hash.equal oph injected_oph) ; assert (Operation_hash.equal oph injected_oph) ;
return oph return oph
let list_contract_labels cctxt block = let list_contract_labels (cctxt : Client_commands.full_context) block =
Client_proto_rpcs.Context.Contract.list Client_proto_rpcs.Context.Contract.list
cctxt.rpc_config block >>=? fun contracts -> cctxt block >>=? fun contracts ->
map_s (fun h -> map_s (fun h ->
begin match Contract.is_default h with begin match Contract.is_default h with
| Some m -> begin | Some m -> begin
@ -175,50 +169,16 @@ let list_contract_labels cctxt block =
return (nm, h_b58, kind)) return (nm, h_b58, kind))
contracts contracts
let message_injection cctxt ~force ?(contracts = []) oph = let message_added_contract (cctxt : Client_commands.full_context) name =
begin cctxt#message "Contract memorized as %s." name
if not force then
cctxt.message "Operation successfully injected in the node."
else
Lwt.return_unit
end >>= fun () ->
cctxt.message "Operation hash is '%a'." Operation_hash.pp oph >>= fun () ->
Lwt_list.iter_s
(fun c ->
cctxt.message
"New contract %a originated from a smart contract."
Contract.pp c)
contracts >>= fun () ->
Lwt.return_unit
let message_added_contract cctxt name = let get_manager (cctxt : Client_commands.full_context) block source =
cctxt.message "Contract memorized as %s." name
let check_contract cctxt new_contract =
RawContractAlias.mem cctxt new_contract >>=? function
| true ->
failwith "contract '%s' already exists" new_contract
| false ->
return ()
let get_delegate_pkh cctxt = function
| None ->
return None
| Some delegate ->
Public_key_hash.find_opt cctxt delegate
let get_manager cctxt source =
Client_proto_contracts.get_manager Client_proto_contracts.get_manager
cctxt.rpc_config cctxt.config.block source >>=? fun src_pkh -> cctxt block source >>=? fun src_pkh ->
Client_keys.get_key cctxt src_pkh >>=? fun (src_name, src_pk, src_sk) -> 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 () ->
return (src_name, src_pkh, src_pk, src_sk) return (src_name, src_pkh, src_pk, src_sk)
let group = let dictate rpc_config block command seckey =
{ Cli_entries.name = "context" ;
title = "Block contextual commands (see option -block)" }
let dictate rpc_config ?force block command seckey =
let block = Client_rpcs.last_baked_block block in let block = Client_rpcs.last_baked_block block in
Client_node_rpcs.Blocks.info Client_node_rpcs.Blocks.info
rpc_config block >>=? fun { net_id ; hash = branch } -> rpc_config block >>=? fun { net_id ; hash = branch } ->
@ -228,274 +188,50 @@ let dictate rpc_config ?force block command seckey =
let signed_bytes = Ed25519.Signature.concat bytes signature in let signed_bytes = Ed25519.Signature.concat bytes signature in
let oph = Operation_hash.hash_bytes [ signed_bytes ] in let oph = Operation_hash.hash_bytes [ signed_bytes ] in
Client_node_rpcs.inject_operation Client_node_rpcs.inject_operation
rpc_config ?force ~net_id signed_bytes >>=? fun injected_oph -> rpc_config ~net_id signed_bytes >>=? fun injected_oph ->
assert (Operation_hash.equal oph injected_oph) ; assert (Operation_hash.equal oph injected_oph) ;
return oph return oph
let default_fee = let set_delegate (cctxt : #Client_rpcs.rpc_sig) block ~fee contract ~src_pk ~manager_sk opt_delegate =
match Tez.of_cents 5L with
| None -> raise (Failure "internal error: Could not parse default_fee literal")
| Some fee -> fee
let commands () =
let open Cli_entries in
let open Client_commands in
[
command ~group ~desc: "access the timestamp of the block"
no_options
(fixed [ "get" ; "timestamp" ])
begin fun () cctxt ->
Client_node_rpcs.Blocks.timestamp
cctxt.rpc_config cctxt.config.block >>=? fun v ->
cctxt.message "%s" (Time.to_notation v) >>= fun () ->
return ()
end ;
command ~group ~desc: "lists all non empty contracts of the block"
no_options
(fixed [ "list" ; "contracts" ])
begin fun () cctxt ->
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 >>= fun () ->
return ()
end ;
command ~group ~desc: "get the balance of a contract"
no_options
(prefixes [ "get" ; "balance" ; "for" ]
@@ ContractAlias.destination_param ~name:"src" ~desc:"source contract"
@@ stop)
begin fun () (_, contract) cctxt ->
get_balance cctxt.rpc_config cctxt.config.block contract >>=? fun amount ->
cctxt.answer "%a %s" Tez.pp amount tez_sym >>= fun () ->
return ()
end ;
command ~group ~desc: "get the storage of a contract"
no_options
(prefixes [ "get" ; "storage" ; "for" ]
@@ ContractAlias.destination_param ~name:"src" ~desc:"source contract"
@@ stop)
begin fun () (_, contract) cctxt ->
get_storage cctxt.rpc_config cctxt.config.block contract >>=? function
| None ->
cctxt.error "This is not a smart contract."
| Some storage ->
cctxt.answer "%a" Michelson_v1_printer.print_expr_unwrapped storage >>= fun () ->
return ()
end ;
command ~group ~desc: "get the manager of a contract"
no_options
(prefixes [ "get" ; "manager" ; "for" ]
@@ ContractAlias.destination_param ~name:"src" ~desc:"source contract"
@@ stop)
begin fun () (_, contract) cctxt ->
Client_proto_contracts.get_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) >>= fun () ->
return ()
end ;
command ~group ~desc: "get the delegate of a contract"
no_options
(prefixes [ "get" ; "delegate" ; "for" ]
@@ ContractAlias.destination_param ~name:"src" ~desc:"source contract"
@@ stop)
begin fun () (_, contract) cctxt ->
Client_proto_contracts.get_delegate
cctxt.rpc_config cctxt.config.block contract >>=? fun delegate ->
Public_key_hash.rev_find cctxt delegate >>=? fun mn ->
Public_key_hash.to_source cctxt delegate >>=? fun m ->
cctxt.message "%s (%s)" m
(match mn with None -> "unknown" | Some n -> "known as " ^ n) >>= fun () ->
return ()
end ;
command ~group ~desc: "set the delegate of a contract"
(args2 fee_arg force_switch)
(prefixes [ "set" ; "delegate" ; "for" ]
@@ ContractAlias.destination_param ~name:"src" ~desc:"source contract"
@@ prefix "to"
@@ Public_key_hash.alias_param
~name: "mgr" ~desc: "New delegate of the contract"
@@ stop)
begin fun (fee, force) (_, contract) (_, delegate) cctxt ->
get_manager cctxt contract >>=? fun (_src_name, _src_pkh, src_pk, src_sk) ->
delegate_contract delegate_contract
cctxt.rpc_config cctxt.config.block ~source:contract cctxt block ~source:contract
~src_pk ~manager_sk:src_sk ~fee (Some delegate) ~src_pk ~manager_sk ~fee opt_delegate
>>=? fun oph ->
message_injection cctxt ~force:force oph >>= fun () ->
return ()
end ;
command ~group ~desc: "open a new account" let source_to_keys (wallet : #Client_commands.full_context) block source =
(args4 fee_arg delegate_arg delegatable_switch force_switch) get_manager wallet block source >>=? fun (_src_name, _src_pkh, src_pk, src_sk) ->
(prefixes [ "originate" ; "account" ] return (src_pk, src_sk)
@@ RawContractAlias.fresh_alias_param
~name: "new" ~desc: "name of the new contract"
@@ prefix "for"
@@ Public_key_hash.alias_param
~name: "mgr" ~desc: "manager of the new contract"
@@ prefix "transferring"
@@ tez_param
~name: "qty" ~desc: "amount taken from source"
@@ prefix "from"
@@ ContractAlias.alias_param
~name:"src" ~desc: "name of the source contract"
@@ stop)
begin fun (fee, delegate, delegatable, force)
new_contract (_, manager) balance (_, source) cctxt ->
RawContractAlias.of_fresh cctxt force new_contract >>=? fun new_contract ->
check_contract cctxt new_contract >>=? fun () ->
get_delegate_pkh cctxt delegate >>=? fun delegate ->
get_manager cctxt source >>=? fun (_src_name, _src_pkh, src_pk, src_sk) ->
originate_account cctxt.rpc_config cctxt.config.block ~force:force
~source ~src_pk ~src_sk ~manager_pkh:manager ~balance ~fee
~delegatable:delegatable ~spendable:true ?delegate:delegate
() >>=? fun (oph, contract) ->
message_injection cctxt
~force:force ~contracts:[contract] oph >>= fun () ->
RawContractAlias.add ~force cctxt new_contract contract >>=? fun () ->
message_added_contract cctxt new_contract >>= fun () ->
return ()
end ;
command ~group ~desc: "Launch a smart contract on the blockchain" let save_contract ~force cctxt alias_name contract =
(args7 RawContractAlias.add ~force cctxt alias_name contract >>=? fun () ->
fee_arg delegate_arg force_switch message_added_contract cctxt alias_name >>= fun () ->
delegatable_switch spendable_switch init_arg no_print_source_flag)
(prefixes [ "originate" ; "contract" ]
@@ RawContractAlias.fresh_alias_param
~name: "new" ~desc: "name of the new contract"
@@ prefix "for"
@@ Public_key_hash.alias_param
~name: "mgr" ~desc: "manager of the new contract"
@@ prefix "transferring"
@@ tez_param
~name: "qty" ~desc: "amount taken from source"
@@ prefix "from"
@@ ContractAlias.alias_param
~name:"src" ~desc: "name of the source contract"
@@ prefix "running"
@@ Program.source_param
~name:"prg" ~desc: "script of the account\n\
combine with -init if the storage type is not unit"
@@ stop)
begin fun (fee, delegate, force, delegatable, spendable, init, no_print_source)
new_contract (_, manager) balance (_, source) program cctxt ->
RawContractAlias.of_fresh cctxt force new_contract >>=? fun new_contract ->
check_contract cctxt new_contract >>=? fun () ->
Lwt.return (Micheline_parser.no_parsing_error program) >>=? fun { expanded = code } ->
get_delegate_pkh cctxt delegate >>=? fun delegate ->
get_manager cctxt source >>=? fun (_src_name, _src_pkh, src_pk, src_sk) ->
originate_contract cctxt.rpc_config cctxt.config.block ~force:force
~source ~src_pk ~src_sk ~manager_pkh:manager ~balance ~fee
~delegatable:delegatable ?delegatePubKey:delegate ~code
~init
~spendable:spendable
() >>=function
| Error errs ->
cctxt.warning "%a"
(Michelson_v1_error_reporter.report_errors
~details:(not no_print_source)
~show_source: (not no_print_source)
?parsed:None) errs >>= fun () ->
cctxt.error "origination simulation failed"
| Ok (oph, contract) ->
message_injection cctxt
~force:force ~contracts:[contract] oph >>= fun () ->
RawContractAlias.add ~force cctxt new_contract contract >>=? fun () ->
message_added_contract cctxt new_contract >>= fun () ->
return () return ()
end ;
command ~group ~desc: "open a new (free) account" let originate_contract
(args1 force_switch) ~fee
(prefixes [ "originate" ; "free" ; "account" ] ~delegate
@@ RawContractAlias.fresh_alias_param ?(force=false)
~name: "new" ~desc: "name of the new contract" ?(delegatable=true)
@@ prefix "for" ?(spendable=false)
@@ Public_key_hash.alias_param ~initial_storage
~name: "mgr" ~desc: "manager of the new contract" ~manager
@@ stop) ~balance
begin fun force new_contract (_, manager) cctxt -> ~source
RawContractAlias.of_fresh cctxt force new_contract >>=? fun new_contract -> ~src_pk
check_contract cctxt new_contract >>=? fun () -> ~src_sk
faucet cctxt.rpc_config cctxt.config.block ~code
~force:force ~manager_pkh:manager () >>=? fun (oph, contract) -> (cctxt : Client_commands.full_context) =
message_injection cctxt Lwt.return (Michelson_v1_parser.parse_expression initial_storage) >>= fun result ->
~force:force ~contracts:[contract] oph >>= fun () -> Lwt.return (Micheline_parser.no_parsing_error result) >>=?
RawContractAlias.add ~force cctxt new_contract contract >>=? fun () -> fun { Michelson_v1_parser.expanded = storage } ->
message_added_contract cctxt new_contract >>= fun () -> let block = cctxt#block in
return () Client_proto_rpcs.Context.Contract.counter
end; cctxt block source >>=? fun pcounter ->
let counter = Int32.succ pcounter in
command ~group ~desc: "transfer tokens" get_branch cctxt block None >>=? fun (_net_id, branch) ->
(args4 fee_arg arg_arg force_switch no_print_source_flag) Client_proto_rpcs.Helpers.Forge.Manager.origination cctxt block
(prefixes [ "transfer" ] ~branch ~source ~sourcePubKey:src_pk ~managerPubKey:manager
@@ tez_param ~counter ~balance ~spendable:spendable
~name: "qty" ~desc: "amount taken from source" ~delegatable ?delegatePubKey:delegate
@@ prefix "from" ~script:{ code ; storage } ~fee () >>=? fun bytes ->
@@ ContractAlias.alias_param let signature = Ed25519.sign src_sk bytes in
~name: "src" ~desc: "name of the source contract" originate cctxt ~force ~block ~signature bytes
@@ prefix "to"
@@ ContractAlias.destination_param
~name: "dst" ~desc: "name/literal of the destination contract"
@@ stop)
begin fun (fee, arg, force, no_print_source) amount (_, source) (_, destination) cctxt ->
get_manager cctxt source >>=? fun (_src_name, _src_pkh, src_pk, src_sk) ->
transfer cctxt.rpc_config cctxt.config.block ~force:force
~source ~src_pk ~src_sk ~destination
~arg ~amount ~fee () >>= function
| Error errs ->
cctxt.warning "%a"
(Michelson_v1_error_reporter.report_errors
~details: false
~show_source:(not no_print_source)
?parsed:None) errs >>= fun () ->
cctxt.error "transfer simulation failed"
| Ok (oph, contracts) ->
message_injection cctxt ~force:force ~contracts oph >>= fun () ->
return ()
end;
command ~desc: "Activate a protocol"
(args1 force_switch)
(prefixes [ "activate" ; "protocol" ]
@@ Protocol_hash.param ~name:"version"
~desc:"Protocol version (b58check)"
@@ prefixes [ "with" ; "key" ]
@@ Ed25519.Secret_key.param
~name:"password" ~desc:"Dictator's key"
@@ stop)
begin fun force hash seckey cctxt ->
dictate cctxt.rpc_config cctxt.config.block
(Activate hash) seckey >>=? fun oph ->
message_injection cctxt ~force:force oph >>= fun () ->
return ()
end ;
command ~desc: "Fork a test protocol"
(args1 force_switch)
(prefixes [ "fork" ; "test" ; "protocol" ]
@@ Protocol_hash.param ~name:"version"
~desc:"Protocol version (b58check)"
@@ prefixes [ "with" ; "key" ]
@@ Ed25519.Secret_key.param
~name:"password" ~desc:"Dictator's key"
@@ stop)
begin fun force hash seckey cctxt ->
dictate cctxt.rpc_config cctxt.config.block
(Activate_testnet hash) seckey >>=? fun oph ->
message_injection cctxt ~force:force oph >>= fun () ->
return ()
end ;
]

150
lib_embedded_client_alpha/client_proto_context.mli
View File

@ -9,70 +9,122 @@
open Environment open Environment
val list_contract_labels :
Client_commands.full_context ->
Client_proto_rpcs.block ->
(string * string * string) list tzresult Lwt.t
val get_storage :
#Client_rpcs.rpc_sig ->
Client_proto_rpcs.block ->
Contract.t ->
Script.expr option tzresult Lwt.t
val get_manager :
Client_commands.full_context ->
Client_proto_rpcs.block ->
Contract.t ->
(string * public_key_hash * public_key * secret_key) tzresult Lwt.t
val get_balance: val get_balance:
Client_rpcs.config -> #Client_rpcs.rpc_sig ->
Client_proto_rpcs.block -> Client_proto_rpcs.block ->
Contract.t -> Contract.t ->
Tez.t tzresult Lwt.t Tez.t tzresult Lwt.t
val set_delegate :
#Client_rpcs.rpc_sig ->
Client_proto_rpcs.block ->
fee:Tez.tez ->
Contract.t ->
src_pk:public_key ->
manager_sk:secret_key ->
public_key_hash option ->
Operation_list_hash.elt tzresult Lwt.t
val operation_submitted_message :
#Client_commands.logger ->
?force:bool ->
Operation_hash.t ->
unit tzresult Lwt.t
val source_to_keys:
Client_commands.full_context ->
Client_proto_rpcs.block ->
Contract.t ->
(public_key * secret_key) tzresult Lwt.t
val originate_account :
?force:bool ->
?branch:int ->
source:Contract.t ->
src_pk:public_key ->
src_sk:Ed25519.Secret_key.t ->
manager_pkh:public_key_hash ->
?delegatable:bool ->
?delegate:public_key_hash ->
balance:Tez.tez ->
fee:Tez.tez ->
Client_rpcs.block ->
#Client_rpcs.rpc_sig ->
unit -> (Operation_list_hash.elt * Contract.t) tzresult Lwt.t
val save_contract :
force:bool ->
Client_commands.full_context ->
string ->
Contract.t ->
unit tzresult Lwt.t
val operation_submitted_message :
#Client_commands.logger ->
?force:bool ->
?contracts:Contract.t list ->
Operation_hash.t ->
unit tzresult Lwt.t
val originate_contract:
fee:Tez.t ->
delegate:public_key_hash option ->
?force:bool ->
?delegatable:bool ->
?spendable:bool ->
initial_storage:string ->
manager:public_key_hash ->
balance:Tez.t ->
source:Contract.t ->
src_pk:public_key ->
src_sk:Ed25519.Secret_key.t ->
code:Script.expr ->
Client_commands.full_context ->
(Operation_hash.t * Contract.t) tzresult Lwt.t
val faucet :
?force:bool ->
?branch:int ->
manager_pkh:public_key_hash ->
Client_rpcs.block ->
#Client_rpcs.rpc_sig ->
unit -> (Operation_list_hash.elt * Contract.t) tzresult Lwt.t
val transfer : val transfer :
Client_rpcs.config -> #Client_rpcs.rpc_sig ->
Client_proto_rpcs.block -> Client_proto_rpcs.block ->
?force:bool -> ?force:bool ->
?branch:int -> ?branch:int ->
source:Contract.t -> source:Contract.t ->
src_pk:public_key -> src_pk:public_key ->
src_sk:secret_key -> src_sk:Ed25519.Secret_key.t ->
destination:Contract.t -> destination:Contract.t ->
?arg:string -> ?arg:string ->
amount:Tez.t -> amount:Tez.t ->
fee:Tez.t -> fee:Tez.t ->
unit -> (Operation_hash.t * Contract.t list) tzresult Lwt.t unit ->
(Operation_hash.t * Contract.t list) tzresult Lwt.t
val originate_account: val dictate :
Client_rpcs.config -> #Client_rpcs.rpc_sig ->
Client_proto_rpcs.block -> Client_proto_rpcs.block ->
?force:bool -> dictator_operation ->
?branch:int -> secret_key ->
source:Contract.t ->
src_pk:public_key ->
src_sk:secret_key ->
manager_pkh:public_key_hash ->
?delegatable:bool ->
?spendable:bool ->
?delegate:public_key_hash ->
balance:Tez.t ->
fee:Tez.t ->
unit -> (Operation_hash.t * Contract.t) tzresult Lwt.t
val originate_contract:
Client_rpcs.config ->
Client_proto_rpcs.block ->
?force:bool ->
?branch:int ->
source:Contract.t ->
src_pk:public_key ->
src_sk:secret_key ->
manager_pkh:public_key_hash ->
balance:Tez.t ->
?delegatable:bool ->
?delegatePubKey:public_key_hash ->
code:Script.expr ->
init:string ->
fee:Tez.t ->
spendable:bool ->
unit -> (Operation_hash.t * Contract.t) tzresult Lwt.t
val delegate_contract:
Client_rpcs.config ->
Client_proto_rpcs.block ->
?force:bool ->
?branch:int ->
source:Contract.t ->
?src_pk:public_key ->
manager_sk:secret_key ->
fee:Tez.t ->
public_key_hash option ->
Operation_hash.t tzresult Lwt.t Operation_hash.t tzresult Lwt.t
val commands: unit -> Client_commands.command list

275
lib_embedded_client_alpha/client_proto_context_commands.ml Normal file
View File

@ -0,0 +1,275 @@
(**************************************************************************)
(* *)
(* Copyright (c) 2014 - 2016. *)
(* Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* All rights reserved. No warranty, explicit or implicit, provided. *)
(* *)
(**************************************************************************)
open Tezos_micheline
open Client_proto_context
open Client_proto_contracts
open Client_proto_programs
open Client_keys
open Client_proto_args
let get_pkh cctxt = function
| None -> return None
| Some x -> Public_key_hash.find_opt cctxt x
let report_michelson_errors ?(no_print_source=false) ~msg (cctxt : #Client_commands.logger) = function
| Error errs ->
cctxt#warning "%a"
(Michelson_v1_error_reporter.report_errors
~details:(not no_print_source)
~show_source: (not no_print_source)
?parsed:None) errs >>= fun () ->
cctxt#error "%s" msg >>= fun () ->
Lwt.return None
| Ok data ->
Lwt.return (Some data)
let group =
{ Cli_entries.name = "context" ;
title = "Block contextual commands (see option -block)" }
let commands () =
let open Cli_entries in
let open Client_commands in
[
command ~group ~desc: "access the timestamp of the block"
no_options
(fixed [ "get" ; "timestamp" ])
begin fun () (cctxt : Client_commands.full_context) ->
Client_node_rpcs.Blocks.timestamp
cctxt cctxt#block >>=? fun v ->
cctxt#message "%s" (Time.to_notation v) >>= fun () ->
return ()
end ;
command ~group ~desc: "lists all non empty contracts of the block"
no_options
(fixed [ "list" ; "contracts" ])
begin fun () (cctxt : Client_commands.full_context) ->
list_contract_labels cctxt cctxt#block >>=? fun contracts ->
Lwt_list.iter_s
(fun (alias, hash, kind) -> cctxt#message "%s%s%s" hash kind alias)
contracts >>= fun () ->
return ()
end ;
command ~group ~desc: "get the balance of a contract"
no_options
(prefixes [ "get" ; "balance" ; "for" ]
@@ ContractAlias.destination_param ~name:"src" ~desc:"source contract"
@@ stop)
begin fun () (_, contract) (cctxt : Client_commands.full_context) ->
get_balance cctxt cctxt#block contract >>=? fun amount ->
cctxt#answer "%a %s" Tez.pp amount Client_proto_args.tez_sym >>= fun () ->
return ()
end ;
command ~group ~desc: "get the storage of a contract"
no_options
(prefixes [ "get" ; "storage" ; "for" ]
@@ ContractAlias.destination_param ~name:"src" ~desc:"source contract"
@@ stop)
begin fun () (_, contract) (cctxt : Client_commands.full_context) ->
get_storage cctxt cctxt#block contract >>=? function
| None ->
cctxt#error "This is not a smart contract."
| Some storage ->
cctxt#answer "%a" Michelson_v1_printer.print_expr_unwrapped storage >>= fun () ->
return ()
end ;
command ~group ~desc: "get the manager of a contract"
no_options
(prefixes [ "get" ; "manager" ; "for" ]
@@ ContractAlias.destination_param ~name:"src" ~desc:"source contract"
@@ stop)
begin fun () (_, contract) (cctxt : Client_commands.full_context) ->
Client_proto_contracts.get_manager
cctxt cctxt#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) >>= fun () ->
return ()
end ;
command ~group ~desc: "get the delegate of a contract"
no_options
(prefixes [ "get" ; "delegate" ; "for" ]
@@ ContractAlias.destination_param ~name:"src" ~desc:"source contract"
@@ stop)
begin fun () (_, contract) (cctxt : Client_commands.full_context) ->
Client_proto_contracts.get_delegate
cctxt cctxt#block contract >>=? fun delegate ->
Public_key_hash.rev_find cctxt delegate >>=? fun mn ->
Public_key_hash.to_source cctxt delegate >>=? fun m ->
cctxt#message "%s (%s)" m
(match mn with None -> "unknown" | Some n -> "known as " ^ n) >>= fun () ->
return ()
end ;
command ~group ~desc: "set the delegate of a contract"
(args2 fee_arg force_switch)
(prefixes [ "set" ; "delegate" ; "for" ]
@@ ContractAlias.destination_param ~name:"src" ~desc:"source contract"
@@ prefix "to"
@@ Public_key_hash.alias_param
~name: "mgr" ~desc: "New delegate of the contract"
@@ stop)
begin fun (fee, force) (_, contract) (_, delegate) cctxt ->
source_to_keys cctxt cctxt#block contract >>=? fun (src_pk, manager_sk) ->
set_delegate ~fee cctxt cctxt#block contract (Some delegate) ~src_pk ~manager_sk >>=? fun oph ->
operation_submitted_message cctxt ~force oph
end ;
command ~group ~desc:"open a new account"
(args4 fee_arg delegate_arg delegatable_switch force_switch)
(prefixes [ "originate" ; "account" ]
@@ RawContractAlias.fresh_alias_param
~name: "new" ~desc: "name of the new contract"
@@ prefix "for"
@@ Public_key_hash.alias_param
~name: "mgr" ~desc: "manager of the new contract"
@@ prefix "transferring"
@@ tez_param
~name: "qty" ~desc: "amount taken from source"
@@ prefix "from"
@@ ContractAlias.alias_param
~name:"src" ~desc: "name of the source contract"
@@ stop)
begin fun (fee, delegate, delegatable, force)
new_contract (_, manager_pkh) balance (_, source) (cctxt : Client_commands.full_context) ->
RawContractAlias.of_fresh cctxt force new_contract >>=? fun alias_name ->
source_to_keys cctxt cctxt#block source >>=? fun (src_pk, src_sk) ->
get_pkh cctxt delegate >>=? fun delegate ->
originate_account
~fee
?delegate
~delegatable
~force
~manager_pkh
~balance
~source
~src_pk
~src_sk
cctxt#block
cctxt
() >>=? fun (oph, contract) ->
save_contract ~force cctxt alias_name contract >>=? fun () ->
operation_submitted_message ~force ~contracts:[ contract ] cctxt oph
end ;
command ~group ~desc: "Launch a smart contract on the blockchain"
(args7
fee_arg delegate_arg force_switch
delegatable_switch spendable_switch init_arg no_print_source_flag)
(prefixes [ "originate" ; "contract" ]
@@ RawContractAlias.fresh_alias_param
~name: "new" ~desc: "name of the new contract"
@@ prefix "for"
@@ Public_key_hash.alias_param
~name: "mgr" ~desc: "manager of the new contract"
@@ prefix "transferring"
@@ tez_param
~name: "qty" ~desc: "amount taken from source"
@@ prefix "from"
@@ ContractAlias.alias_param
~name:"src" ~desc: "name of the source contract"
@@ prefix "running"
@@ Program.source_param
~name:"prg" ~desc: "script of the account\n\
combine with -init if the storage type is not unit"
@@ stop)
begin fun (fee, delegate, force, delegatable, spendable, initial_storage, no_print_source)
alias_name (_, manager) balance (_, source) program (cctxt : Client_commands.full_context) ->
RawContractAlias.of_fresh cctxt force alias_name >>=? fun alias_name ->
Lwt.return (Micheline_parser.no_parsing_error program) >>=? fun { expanded = code } ->
source_to_keys cctxt cctxt#block source >>=? fun (src_pk, src_sk) ->
get_pkh cctxt delegate >>=? fun delegate ->
originate_contract ~fee ~delegate ~force ~delegatable ~spendable ~initial_storage
~manager ~balance ~source ~src_pk ~src_sk ~code cctxt >>= fun errors ->
report_michelson_errors ~no_print_source ~msg:"origination simulation failed" cctxt errors >>= function
| None -> return ()
| Some (oph, contract) ->
save_contract ~force cctxt alias_name contract >>=? fun () ->
operation_submitted_message cctxt
~force ~contracts:[contract] oph
end ;
command ~group ~desc: "open a new (free) account"
(args1 force_switch)
(prefixes [ "originate" ; "free" ; "account" ]
@@ RawContractAlias.fresh_alias_param
~name: "new" ~desc: "name of the new contract"
@@ prefix "for"
@@ Public_key_hash.alias_param
~name: "mgr" ~desc: "manager of the new contract"
@@ stop)
begin fun force alias_name (_, manager_pkh) cctxt ->
RawContractAlias.of_fresh cctxt force alias_name >>=? fun alias_name ->
faucet ~force ~manager_pkh cctxt#block cctxt () >>=? fun (oph, contract) ->
operation_submitted_message cctxt
~force ~contracts:[contract] oph >>=? fun () ->
save_contract ~force cctxt alias_name contract
end;
command ~group ~desc: "transfer tokens"
(args4 fee_arg arg_arg force_switch no_print_source_flag)
(prefixes [ "transfer" ]
@@ tez_param
~name: "qty" ~desc: "amount taken from source"
@@ prefix "from"
@@ ContractAlias.alias_param
~name: "src" ~desc: "name of the source contract"
@@ prefix "to"
@@ ContractAlias.destination_param
~name: "dst" ~desc: "name/literal of the destination contract"
@@ stop)
begin fun (fee, arg, force, no_print_source) amount (_, source) (_, destination) cctxt ->
source_to_keys cctxt cctxt#block source >>=? fun (src_pk, src_sk) ->
transfer ~force cctxt ~fee cctxt#block
~source ~src_pk ~src_sk ~destination ~arg ~amount () >>=
report_michelson_errors ~no_print_source ~msg:"transfer simulation failed" cctxt >>= function
| None -> return ()
| Some (oph, contracts) ->
operation_submitted_message cctxt ~force ~contracts oph
end;
command ~desc: "Activate a protocol"
(args1 force_switch)
(prefixes [ "activate" ; "protocol" ]
@@ Protocol_hash.param ~name:"version"
~desc:"Protocol version (b58check)"
@@ prefixes [ "with" ; "key" ]
@@ Environment.Ed25519.Secret_key.param
~name:"password" ~desc:"Dictator's key"
@@ stop)
begin fun force hash seckey cctxt ->
dictate cctxt cctxt#block
(Activate hash) seckey >>=? fun oph ->
operation_submitted_message cctxt ~force:force oph
end ;
command ~desc: "Fork a test protocol"
(args1 force_switch)
(prefixes [ "fork" ; "test" ; "protocol" ]
@@ Protocol_hash.param ~name:"version"
~desc:"Protocol version (b58check)"
@@ prefixes [ "with" ; "key" ]
@@ Environment.Ed25519.Secret_key.param
~name:"password" ~desc:"Dictator's key"
@@ stop)
begin fun force hash seckey cctxt ->
dictate cctxt cctxt#block
(Activate_testnet hash) seckey >>=? fun oph ->
operation_submitted_message cctxt ~force:force oph
end ;
]

95
lib_embedded_client_alpha/client_proto_contracts.ml
View File

@ -112,7 +112,6 @@ module Contract_tags = Client_tags.Tags (struct
end) end)
let list_contracts cctxt = let list_contracts cctxt =
(* List contracts *)
RawContractAlias.load cctxt >>=? fun raw_contracts -> RawContractAlias.load cctxt >>=? fun raw_contracts ->
Lwt_list.map_s Lwt_list.map_s
(fun (n, v) -> Lwt.return ("", n, v)) (fun (n, v) -> Lwt.return ("", n, v))
@ -166,97 +165,3 @@ let check_public_key cctxt block ?src_pk src_pk_hash =
return (Some key) return (Some key)
end end
| Ok _ -> return None | Ok _ -> return None
let group =
{ Cli_entries.name = "contracts" ;
title = "Commands for managing the record of known contracts" }
let commands () =
let open Cli_entries in
let open Client_commands in
[
command ~group ~desc: "add a contract to the wallet"
(args1 Client_commands.force_switch)
(prefixes [ "remember" ; "contract" ]
@@ RawContractAlias.fresh_alias_param
@@ RawContractAlias.source_param
@@ stop)
(fun force name hash cctxt ->
RawContractAlias.of_fresh cctxt force name >>=? fun name ->
RawContractAlias.add ~force cctxt name hash) ;
command ~group ~desc: "remove a contract from the wallet"
no_options
(prefixes [ "forget" ; "contract" ]
@@ RawContractAlias.alias_param
@@ stop)
(fun () (name, _) cctxt -> RawContractAlias.del cctxt name) ;
command ~group ~desc: "lists all known contracts"
no_options
(fixed [ "list" ; "known" ; "contracts" ])
(fun () cctxt ->
list_contracts cctxt >>=? fun contracts ->
iter_s
(fun (prefix, alias, contract) ->
cctxt.message "%s%s: %s" prefix alias
(Contract.to_b58check contract) >>= fun () ->
return ())
contracts) ;
command ~group ~desc: "forget all known contracts"
(args1 Client_commands.force_switch)
(fixed [ "forget" ; "all" ; "contracts" ])
(fun force cctxt ->
fail_unless
force
(failure "this can only used with option -force true") >>=? fun () ->
RawContractAlias.save cctxt []) ;
command ~group ~desc: "display a contract from the wallet"
no_options
(prefixes [ "show" ; "known" ; "contract" ]
@@ RawContractAlias.alias_param
@@ stop)
(fun () (_, contract) cctxt ->
cctxt.message "%a\n%!" Contract.pp contract >>= fun () ->
return ()) ;
command ~group ~desc: "tag a contract in the wallet"
no_options
(prefixes [ "tag" ; "contract" ]
@@ RawContractAlias.alias_param
@@ prefixes [ "with" ]
@@ Contract_tags.tag_param
@@ stop)
(fun () (alias, _contract) new_tags cctxt ->
Contract_tags.find_opt cctxt alias >>=? fun tags ->
let new_tags =
match tags with
| None -> new_tags
| Some tags -> List.merge2 tags new_tags in
Contract_tags.update cctxt alias new_tags) ;
command ~group ~desc: "remove tag(s) from a contract in the wallet"
no_options
(prefixes [ "untag" ; "contract" ]
@@ RawContractAlias.alias_param
@@ prefixes [ "with" ]
@@ Contract_tags.tag_param
@@ stop)
(fun () (alias, _contract) new_tags cctxt ->
Contract_tags.find_opt cctxt alias >>=? fun tags ->
let new_tags =
match tags with
| None -> []
| Some tags ->
List.merge_filter2
~f:(fun x1 x2 -> match x1, x2 with
| None, None -> assert false
| 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) ;
]

30
lib_embedded_client_alpha/client_proto_contracts.mli
View File

@ -12,48 +12,50 @@ module RawContractAlias :
module ContractAlias : sig module ContractAlias : sig
val get_contract: val get_contract:
Client_commands.context -> #Client_commands.wallet ->
string -> (string * Contract.t) tzresult Lwt.t string -> (string * Contract.t) tzresult Lwt.t
val alias_param: val alias_param:
?name:string -> ?name:string ->
?desc:string -> ?desc:string ->
('a, Client_commands.context, 'ret) Cli_entries.params -> ('a, (#Client_commands.wallet as 'wallet), 'ret) Cli_entries.params ->
(Lwt_io.file_name * Contract.t -> 'a, Client_commands.context, 'ret) Cli_entries.params (Lwt_io.file_name * Contract.t -> 'a, 'wallet, 'ret) Cli_entries.params
val destination_param: val destination_param:
?name:string -> ?name:string ->
?desc:string -> ?desc:string ->
('a, Client_commands.context, 'ret) Cli_entries.params -> ('a, (#Client_commands.wallet as 'wallet), 'ret) Cli_entries.params ->
(Lwt_io.file_name * Contract.t -> 'a, Client_commands.context, 'ret) Cli_entries.params (Lwt_io.file_name * Contract.t -> 'a, 'wallet, 'ret) Cli_entries.params
val rev_find: val rev_find:
Client_commands.context -> #Client_commands.wallet ->
Contract.t -> string option tzresult Lwt.t Contract.t -> string option tzresult Lwt.t
val name: val name:
Client_commands.context -> #Client_commands.wallet ->
Contract.t -> string tzresult Lwt.t Contract.t -> string tzresult Lwt.t
val autocomplete: Client_commands.context -> string list tzresult Lwt.t val autocomplete: #Client_commands.wallet -> string list tzresult Lwt.t
end end
val list_contracts: val list_contracts:
Client_commands.context -> #Client_commands.wallet ->
(string * string * Contract.t) list tzresult Lwt.t (string * string * RawContractAlias.t) list tzresult Lwt.t
val get_manager: val get_manager:
Client_rpcs.config -> #Client_rpcs.rpc_sig ->
Client_proto_rpcs.block -> Client_proto_rpcs.block ->
Contract.t -> Contract.t ->
public_key_hash tzresult Lwt.t public_key_hash tzresult Lwt.t
val get_delegate: val get_delegate:
Client_rpcs.config -> #Client_rpcs.rpc_sig ->
Client_proto_rpcs.block -> Client_proto_rpcs.block ->
Contract.t -> Contract.t ->
public_key_hash tzresult Lwt.t public_key_hash tzresult Lwt.t
val check_public_key : val check_public_key :
Client_rpcs.config -> #Client_rpcs.rpc_sig ->
Client_proto_rpcs.block -> Client_proto_rpcs.block ->
?src_pk:public_key -> ?src_pk:public_key ->
public_key_hash -> public_key_hash ->
public_key option tzresult Lwt.t public_key option tzresult Lwt.t
val commands: unit -> Client_commands.command list module Contract_tags : module type of Client_tags.Tags (struct
let name = "contract"
end)

94
lib_embedded_client_alpha/client_proto_contracts_commands.ml Normal file
View File

@ -0,0 +1,94 @@
open Client_proto_contracts
let group =
{ Cli_entries.name = "contracts" ;
title = "Commands for managing the record of known contracts" }
let commands () =
let open Cli_entries in
[
command ~group ~desc: "add a contract to the wallet"
(args1 Client_commands.force_switch)
(prefixes [ "remember" ; "contract" ]
@@ RawContractAlias.fresh_alias_param
@@ RawContractAlias.source_param
@@ stop)
(fun force name hash cctxt ->
RawContractAlias.of_fresh cctxt force name >>=? fun name ->
RawContractAlias.add ~force cctxt name hash) ;
command ~group ~desc: "remove a contract from the wallet"
no_options
(prefixes [ "forget" ; "contract" ]
@@ RawContractAlias.alias_param
@@ stop)
(fun () (name, _) cctxt ->
RawContractAlias.del cctxt name) ;
command ~group ~desc: "lists all known contracts"
no_options
(fixed [ "list" ; "known" ; "contracts" ])
(fun () (cctxt : Client_commands.full_context) ->
list_contracts cctxt >>=? fun contracts ->
iter_s
(fun (prefix, alias, contract) ->
cctxt#message "%s%s: %s" prefix alias
(Contract.to_b58check contract) >>= return)
contracts) ;
command ~group ~desc: "forget all known contracts"
(args1 Client_commands.force_switch)
(fixed [ "forget" ; "all" ; "contracts" ])
(fun force cctxt ->
fail_unless
force
(failure "this can only used with option -force") >>=? fun () ->
RawContractAlias.set cctxt []) ;
command ~group ~desc: "display a contract from the wallet"
no_options
(prefixes [ "show" ; "known" ; "contract" ]
@@ RawContractAlias.alias_param
@@ stop)
(fun () (_, contract) (cctxt : Client_commands.full_context) ->
cctxt#message "%a\n%!" Contract.pp contract >>= fun () ->
return ()) ;
command ~group ~desc: "tag a contract in the wallet"
no_options
(prefixes [ "tag" ; "contract" ]
@@ RawContractAlias.alias_param
@@ prefixes [ "with" ]
@@ Contract_tags.tag_param
@@ stop)
(fun () (alias, _contract) new_tags cctxt ->
Contract_tags.find_opt cctxt alias >>=? fun tags ->
let new_tags =
match tags with
| None -> new_tags
| Some tags -> List.merge2 tags new_tags in
Contract_tags.update cctxt alias new_tags) ;
command ~group ~desc: "remove tag(s) from a contract in the wallet"
no_options
(prefixes [ "untag" ; "contract" ]
@@ RawContractAlias.alias_param
@@ prefixes [ "with" ]
@@ Contract_tags.tag_param
@@ stop)
(fun () (alias, _contract) new_tags cctxt ->
Contract_tags.find_opt cctxt alias >>=? fun tags ->
let new_tags =
match tags with
| None -> []
| Some tags ->
List.merge_filter2
~f:(fun x1 x2 -> match x1, x2 with
| None, None -> assert false
| 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) ;
]

7
lib_embedded_client_alpha/client_proto_main.ml
View File

@ -13,6 +13,7 @@ let protocol =
let () = let () =
Client_commands.register protocol @@ Client_commands.register protocol @@
Client_proto_programs.commands () @ Client_proto_programs_commands.commands () @
Client_proto_contracts.commands () @ Client_proto_contracts_commands.commands () @
Client_proto_context.commands () Client_proto_context_commands.commands () @
Client_baking_main.commands ()

66
lib_embedded_client_alpha/client_proto_nonces.ml
View File

@ -18,65 +18,35 @@ let encoding : t Data_encoding.t =
(req "block" Block_hash.encoding) (req "block" Block_hash.encoding)
(req "nonce" Nonce.encoding)) (req "nonce" Nonce.encoding))
let filename cctxt = let name = "nonces"
Client_commands.(Filename.concat cctxt.config.base_dir "nonces")
let load cctxt = let load (wallet : #Client_commands.wallet) =
let filename = filename cctxt in wallet#load ~default:[] name encoding
if not (Sys.file_exists filename) then
Lwt.return []
else
Data_encoding_ezjsonm.read_file filename >>= function
| Error _ ->
cctxt.Client_commands.error "couldn't to read the nonces file"
| Ok json ->
match Data_encoding.Json.destruct encoding json with
| exception _ -> (* TODO print_error *)
cctxt.Client_commands.error "didn't understand the nonces file"
| list ->
Lwt.return list
let check_dir dirname = let save (wallet : #Client_commands.wallet) list =
if not (Sys.file_exists dirname) then wallet#write name list encoding
Lwt_utils.create_dir dirname
else
Lwt.return ()
let save cctxt list = let mem (wallet : #Client_commands.wallet) block_hash =
Lwt.catch load wallet >>|? fun data ->
(fun () ->
let dirname = Client_commands.(cctxt.config.base_dir) in
check_dir dirname >>= fun () ->
let filename = filename cctxt in
let json = Data_encoding.Json.construct encoding list in
Data_encoding_ezjsonm.write_file filename json >>= function
| Error _ -> failwith "Json.write_file"
| Ok () -> return ())
(fun exn ->
cctxt.Client_commands.error
"could not write the nonces file: %s." (Printexc.to_string exn))
let mem cctxt block_hash =
load cctxt >|= fun data ->
List.mem_assoc block_hash data List.mem_assoc block_hash data
let find cctxt block_hash = let find wallet block_hash =
load cctxt >|= fun data -> load wallet >>|? fun data ->
try Some (List.assoc block_hash data) try Some (List.assoc block_hash data)
with Not_found -> None with Not_found -> None
let add cctxt block_hash nonce = let add wallet block_hash nonce =
load cctxt >>= fun data -> load wallet >>=? fun data ->
save cctxt ((block_hash, nonce) :: save wallet ((block_hash, nonce) ::
List.remove_assoc block_hash data) List.remove_assoc block_hash data)
let del cctxt block_hash = let del wallet block_hash =
load cctxt >>= fun data -> load wallet >>=? fun data ->
save cctxt (List.remove_assoc block_hash data) save wallet (List.remove_assoc block_hash data)
let dels cctxt hashes = let dels wallet hashes =
load cctxt >>= fun data -> load wallet >>=? fun data ->
save cctxt @@ save wallet @@
List.fold_left List.fold_left
(fun data hash -> List.remove_assoc hash data) (fun data hash -> List.remove_assoc hash data)
data hashes data hashes

14
lib_embedded_client_alpha/client_proto_nonces.mli
View File

@ -8,17 +8,17 @@
(**************************************************************************) (**************************************************************************)
val mem: val mem:
Client_commands.context -> #Client_commands.wallet ->
Block_hash.t -> bool Lwt.t Block_hash.t -> bool tzresult Lwt.t
val find: val find:
Client_commands.context -> #Client_commands.wallet ->
Block_hash.t -> Nonce.t option Lwt.t Block_hash.t -> Nonce.t option tzresult Lwt.t
val add: val add:
Client_commands.context -> #Client_commands.wallet ->
Block_hash.t -> Nonce.t -> unit tzresult Lwt.t Block_hash.t -> Nonce.t -> unit tzresult Lwt.t
val del: val del:
Client_commands.context -> #Client_commands.wallet ->
Block_hash.t -> unit tzresult Lwt.t Block_hash.t -> unit tzresult Lwt.t
val dels: val dels:
Client_commands.context -> #Client_commands.wallet ->
Block_hash.t list -> unit tzresult Lwt.t Block_hash.t list -> unit tzresult Lwt.t

266
lib_embedded_client_alpha/client_proto_programs.ml
View File

@ -8,7 +8,6 @@
(**************************************************************************) (**************************************************************************)
open Tezos_micheline open Tezos_micheline
open Client_proto_args
open Michelson_v1_printer open Michelson_v1_printer
@ -25,99 +24,28 @@ module Program = Client_aliases.Alias (struct
let name = "program" let name = "program"
end) end)
let group = let print_errors (cctxt : #Client_commands.logger) errs ~show_source ~parsed =
{ Cli_entries.name = "programs" ; cctxt#warning "%a"
title = "Commands for managing the record of known programs" }
let data_parameter =
Cli_entries.parameter (fun _ data -> return (Michelson_v1_parser.parse_expression data))
let commands () =
let open Cli_entries in
let show_types_switch =
switch
~parameter:"-details"
~doc:"Show the types of each instruction" in
let emacs_mode_switch =
switch
~parameter:"-emacs"
~doc:"Output in michelson-mode.el compatible format" in
let trace_stack_switch =
switch
~parameter:"-trace-stack"
~doc:"Show the stack after each step" in
let amount_arg =
Client_proto_args.tez_arg
~parameter:"-amount"
~doc:"The amount of the transfer in \xEA\x9C\xA9."
~default:"0.05" in
[
command ~group ~desc: "lists all known programs"
no_options
(fixed [ "list" ; "known" ; "programs" ])
(fun () cctxt ->
Program.load cctxt >>=? fun list ->
Lwt_list.iter_s (fun (n, _) -> cctxt.message "%s" n) list >>= fun () ->
return ()) ;
command ~group ~desc: "remember a program under some name"
(args1 Client_commands.force_switch)
(prefixes [ "remember" ; "program" ]
@@ Program.fresh_alias_param
@@ Program.source_param
@@ stop)
(fun force name program cctxt ->
Program.of_fresh cctxt force name >>=? fun name ->
Lwt.return (Micheline_parser.no_parsing_error program) >>=? fun program ->
Program.add ~force cctxt name (program, [])) ;
command ~group ~desc: "forget a remembered program"
no_options
(prefixes [ "forget" ; "program" ]
@@ Program.alias_param
@@ stop)
(fun () (name, _) cctxt -> Program.del cctxt name) ;
command ~group ~desc: "display a program"
no_options
(prefixes [ "show" ; "known" ; "program" ]
@@ Program.alias_param
@@ stop)
(fun () (_, program) cctxt ->
Lwt.return (Micheline_parser.no_parsing_error program) >>=? fun program ->
cctxt.message "%s\n" program.source >>= fun () ->
return ()) ;
command ~group ~desc: "ask the node to run a program"
(args3 trace_stack_switch amount_arg no_print_source_flag)
(prefixes [ "run" ; "program" ]
@@ Program.source_param
@@ prefixes [ "on" ; "storage" ]
@@ Cli_entries.param ~name:"storage" ~desc:"the storage data"
data_parameter
@@ prefixes [ "and" ; "input" ]
@@ Cli_entries.param ~name:"storage" ~desc:"the input data"
data_parameter
@@ stop)
(fun (trace_stack, amount, no_print_source) program storage input cctxt ->
Lwt.return (Micheline_parser.no_parsing_error program) >>=? fun program ->
Lwt.return (Micheline_parser.no_parsing_error storage) >>=? fun storage ->
Lwt.return (Micheline_parser.no_parsing_error input) >>=? fun input ->
let print_errors errs =
cctxt.warning "%a"
(Michelson_v1_error_reporter.report_errors (Michelson_v1_error_reporter.report_errors
~details:false ~details:false
~show_source: (not no_print_source) ~show_source
~parsed: program) errs >>= fun () -> ~parsed) errs >>= fun () ->
cctxt.error "error running program" >>= fun () -> cctxt#error "error running program" >>= fun () ->
return () in return ()
begin
if trace_stack then let print_run_result (cctxt : #Client_commands.logger) ~show_source ~parsed = function
Client_proto_rpcs.Helpers.trace_code cctxt.rpc_config | Ok (storage, output) ->
cctxt.config.block program.expanded cctxt#message "@[<v 0>@[<v 2>storage@,%a@]@,@[<v 2>output@,%a@]@]@."
(storage.expanded, input.expanded, amount) >>=? fun (storage, output, trace) -> print_expr storage
cctxt.message print_expr output >>= fun () ->
return ()
| Error errs ->
print_errors cctxt errs ~show_source ~parsed
let print_trace_result (cctxt : #Client_commands.logger) ~show_source ~parsed =
function
| Ok (storage, output, trace) ->
cctxt#message
"@[<v 0>@[<v 2>storage@,%a@]@,\ "@[<v 0>@[<v 2>storage@,%a@]@,\
@[<v 2>output@,%a@]@,@[<v 2>trace@,%a@]@]@." @[<v 2>output@,%a@]@,@[<v 2>trace@,%a@]@]@."
print_expr storage print_expr storage
@ -132,32 +60,50 @@ let commands () =
stack)) stack))
trace >>= fun () -> trace >>= fun () ->
return () return ()
else
Client_proto_rpcs.Helpers.run_code cctxt.rpc_config
cctxt.config.block program.expanded
(storage.expanded, input.expanded, amount) >>=? fun (storage, output) ->
cctxt.message "@[<v 0>@[<v 2>storage@,%a@]@,@[<v 2>output@,%a@]@]@."
print_expr storage
print_expr output >>= fun () ->
return ()
end >>= function
| Ok () -> return ()
| Error errs -> | Error errs ->
print_errors errs); print_errors cctxt errs ~show_source ~parsed
command ~group ~desc: "ask the node to typecheck a program" let run
(args3 show_types_switch emacs_mode_switch no_print_source_flag) ?(amount = Tez.default_fee)
(prefixes [ "typecheck" ; "program" ] ~(program : Michelson_v1_parser.parsed)
@@ Program.source_param ~(storage : Michelson_v1_parser.parsed)
@@ stop) ~(input : Michelson_v1_parser.parsed)
(fun (show_types, emacs_mode, no_print_source) (program, errors) cctxt -> block
begin match errors with (cctxt : #Client_rpcs.rpc_sig) =
| [] -> Client_proto_rpcs.Helpers.run_code cctxt
Client_proto_rpcs.Helpers.typecheck_code block program.expanded (storage.expanded, input.expanded, amount)
cctxt.rpc_config cctxt.config.block program.expanded
| errors -> Lwt.return (Error errors) let trace
end >>= fun res -> ?(amount = Tez.default_fee)
if emacs_mode then ~(program : Michelson_v1_parser.parsed)
~(storage : Michelson_v1_parser.parsed)
~(input : Michelson_v1_parser.parsed)
block
(cctxt : #Client_rpcs.rpc_sig) =
Client_proto_rpcs.Helpers.trace_code cctxt
block program.expanded (storage.expanded, input.expanded, amount)
let hash_and_sign (data : Michelson_v1_parser.parsed) key block cctxt =
Client_proto_rpcs.Helpers.hash_data cctxt block (data.expanded) >>=? fun hash ->
let signature = Ed25519.sign key (MBytes.of_string hash) in
return (hash,
signature |>
Data_encoding.Binary.to_bytes Ed25519.Signature.encoding |>
Hex_encode.hex_of_bytes)
let typecheck_data
~(data : Michelson_v1_parser.parsed)
~(ty : Michelson_v1_parser.parsed)
block cctxt =
Client_proto_rpcs.Helpers.typecheck_data cctxt block (data.expanded, ty.expanded)
let typecheck_program (program : Michelson_v1_parser.parsed) block cctxt =
Client_proto_rpcs.Helpers.typecheck_code cctxt block program.expanded
let print_typecheck_result
~emacs ~show_types ~print_source_on_error
program res (cctxt : #Client_commands.logger) =
if emacs then
let type_map, errs = match res with let type_map, errs = match res with
| Ok type_map -> type_map, [] | Ok type_map -> type_map, []
| Error (Environment.Ecoproto_error | Error (Environment.Ecoproto_error
@ -166,7 +112,7 @@ let commands () =
type_map, errs type_map, errs
| Error errs -> | Error errs ->
[], errs in [], errs in
cctxt.message cctxt#message
"(@[<v 0>(types . %a)@ (errors . %a)@])" "(@[<v 0>(types . %a)@ (errors . %a)@])"
Michelson_v1_emacs.print_type_map (program, type_map) Michelson_v1_emacs.print_type_map (program, type_map)
Michelson_v1_emacs.report_errors (program, errs) >>= fun () -> Michelson_v1_emacs.report_errors (program, errs) >>= fun () ->
@ -174,90 +120,16 @@ let commands () =
else else
match res with match res with
| Ok type_map -> | Ok type_map ->
let program = inject_types type_map program in let program = Michelson_v1_printer.inject_types type_map program in
cctxt.message "Well typed" >>= fun () -> cctxt#message "Well typed" >>= fun () ->
if show_types then if show_types then
cctxt.message "%a" Micheline_printer.print_expr program >>= fun () -> cctxt#message "%a" Micheline_printer.print_expr program >>= fun () ->
return () return ()
else return () else return ()
| Error errs -> | Error errs ->
cctxt.warning "%a" cctxt#warning "%a"
(Michelson_v1_error_reporter.report_errors (Michelson_v1_error_reporter.report_errors
~details: show_types ~details: show_types
~show_source: (not no_print_source) ~show_source:print_source_on_error
~parsed:program) errs >>= fun () -> ~parsed:program) errs >>= fun () ->
cctxt.error "ill-typed program") ; cctxt#error "ill-typed program"
command ~group ~desc: "ask the node to typecheck a data expression"
(args1 no_print_source_flag)
(prefixes [ "typecheck" ; "data" ]
@@ Cli_entries.param ~name:"data" ~desc:"the data to typecheck"
data_parameter
@@ prefixes [ "against" ; "type" ]
@@ Cli_entries.param ~name:"type" ~desc:"the expected type"
data_parameter
@@ stop)
(fun no_print_source data exp_ty cctxt ->
Lwt.return (Micheline_parser.no_parsing_error data) >>=? fun data ->
Lwt.return (Micheline_parser.no_parsing_error exp_ty) >>=? fun exp_ty ->
Client_proto_rpcs.Helpers.typecheck_data cctxt.Client_commands.rpc_config
cctxt.config.block (data.expanded, exp_ty.expanded) >>= function
| Ok () ->
cctxt.message "Well typed" >>= fun () ->
return ()
| Error errs ->
cctxt.warning "%a"
(Michelson_v1_error_reporter.report_errors
~details:false
~show_source:(not no_print_source)
?parsed:None) errs >>= fun () ->
cctxt.error "ill-typed data") ;
command ~group
~desc: "ask the node to compute the hash of a data expression \
using the same algorithm as script instruction H"
no_options
(prefixes [ "hash" ; "data" ]
@@ Cli_entries.param ~name:"data" ~desc:"the data to hash"
data_parameter
@@ stop)
(fun () data cctxt ->
Lwt.return (Micheline_parser.no_parsing_error data) >>=? fun data ->
Client_proto_rpcs.Helpers.hash_data cctxt.Client_commands.rpc_config
cctxt.config.block (data.expanded) >>= function
| Ok hash ->
cctxt.message "%S" hash >>= fun () ->
return ()
| Error errs ->
cctxt.warning "%a" pp_print_error errs >>= fun () ->
cctxt.error "ill-formed data") ;
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 \
a given secret key, and display it using the format expected by \
script instruction CHECK_SIGNATURE"
no_options
(prefixes [ "hash" ; "and" ; "sign" ; "data" ]
@@ Cli_entries.param ~name:"data" ~desc:"the data to hash"
data_parameter
@@ prefixes [ "for" ]
@@ Client_keys.Secret_key.alias_param
@@ stop)
(fun () data (_, key) cctxt ->
Lwt.return (Micheline_parser.no_parsing_error data) >>=? fun data ->
Client_proto_rpcs.Helpers.hash_data cctxt.rpc_config
cctxt.config.block (data.expanded) >>= function
| Ok hash ->
let signature = Ed25519.sign key (MBytes.of_string hash) in
cctxt.message "Hash: %S@.Signature: %S"
hash
(signature |>
Data_encoding.Binary.to_bytes Ed25519.Signature.encoding |>
Hex_encode.hex_of_bytes) >>= fun () ->
return ()
| Error errs ->
cctxt.warning "%a" pp_print_error errs >>= fun () ->
cctxt.error "ill-formed data") ;
]

62
lib_embedded_client_alpha/client_proto_programs.mli
View File

@ -12,4 +12,64 @@ open Tezos_micheline
module Program : Client_aliases.Alias module Program : Client_aliases.Alias
with type t = Michelson_v1_parser.parsed Micheline_parser.parsing_result with type t = Michelson_v1_parser.parsed Micheline_parser.parsing_result
val commands: unit -> Client_commands.command list val run :
?amount:Tez.t ->
program:Michelson_v1_parser.parsed ->
storage:Michelson_v1_parser.parsed ->
input:Michelson_v1_parser.parsed ->
Client_rpcs.block ->
#Client_rpcs.rpc_sig ->
(Script.expr * Script.expr) tzresult Lwt.t
val trace :
?amount:Tez.t ->
program:Michelson_v1_parser.parsed ->
storage:Michelson_v1_parser.parsed ->
input:Michelson_v1_parser.parsed ->
Client_rpcs.block ->
#Client_rpcs.rpc_sig ->
(Script.expr * Script.expr * (int * int * Script.expr list) list) tzresult Lwt.t
val print_trace_result :
#Client_commands.logger ->
show_source:bool ->
parsed:Michelson_v1_parser.parsed ->
(Script_repr.expr * Script_repr.expr *
(int * int * Script_repr.expr list) list)
tzresult -> unit tzresult Lwt.t
val print_run_result :
#Client_commands.logger ->
show_source:bool ->
parsed:Michelson_v1_parser.parsed ->
(Script.expr * Script.expr) tzresult ->
unit tzresult Lwt.t
val hash_and_sign :
Michelson_v1_parser.parsed ->
Ed25519.Secret_key.t ->
Client_proto_rpcs.block ->
#Client_rpcs.rpc_sig ->
(string * string) tzresult Lwt.t
val typecheck_data :
data:Michelson_v1_parser.parsed ->
ty:Michelson_v1_parser.parsed ->
Client_proto_rpcs.block ->
#Client_rpcs.rpc_sig ->
unit tzresult Lwt.t
val typecheck_program :
Michelson_v1_parser.parsed ->
Client_proto_rpcs.block ->
#Client_rpcs.rpc_sig ->
Script_ir_translator.type_map tzresult Lwt.t
val print_typecheck_result :
emacs:bool ->
show_types:bool ->
print_source_on_error:bool ->
Michelson_v1_parser.parsed ->
(Script_ir_translator.type_map, error list) result ->
#Client_commands.logger ->
unit tzresult Lwt.t

176
lib_embedded_client_alpha/client_proto_programs_commands.ml Normal file
View File

@ -0,0 +1,176 @@
(**************************************************************************)
(* *)
(* Copyright (c) 2014 - 2017. *)
(* Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* All rights reserved. No warranty, explicit or implicit, provided. *)
(* *)
(**************************************************************************)
let group =
{ Cli_entries.name = "programs" ;
title = "Commands for managing the record of known programs" }
open Tezos_micheline
open Client_proto_programs
open Client_proto_args
let commands () =
let open Cli_entries in
let show_types_switch =
switch
~parameter:"-details"
~doc:"Show the types of each instruction" in
let emacs_mode_switch =
switch
~parameter:"-emacs"
~doc:"Output in michelson-mode.el compatible format" in
let trace_stack_switch =
switch
~parameter:"-trace-stack"
~doc:"Show the stack after each step" in
let amount_arg =
Client_proto_args.tez_arg
~parameter:"-amount"
~doc:"The amount of the transfer in \xEA\x9C\xA9."
~default:"0.05" in
let data_parameter =
Cli_entries.parameter (fun _ data ->
Lwt.return (Micheline_parser.no_parsing_error
@@ Michelson_v1_parser.parse_expression data)) in
[
command ~group ~desc: "lists all known programs"
no_options
(fixed [ "list" ; "known" ; "programs" ])
(fun () (cctxt : Client_commands.full_context) ->
Program.load cctxt >>=? fun list ->
Lwt_list.iter_s (fun (n, _) -> cctxt#message "%s" n) list >>= fun () ->
return ()) ;
command ~group ~desc: "remember a program under some name"
(args1 Client_commands.force_switch)
(prefixes [ "remember" ; "program" ]
@@ Program.fresh_alias_param
@@ Program.source_param
@@ stop)
(fun force name hash (cctxt : Client_commands.full_context) ->
Program.of_fresh cctxt force name >>=? fun name ->
Program.add ~force cctxt name hash) ;
command ~group ~desc: "forget a remembered program"
no_options
(prefixes [ "forget" ; "program" ]
@@ Program.alias_param
@@ stop)
(fun () (name, _) cctxt -> Program.del cctxt name) ;
command ~group ~desc: "display a program"
no_options
(prefixes [ "show" ; "known" ; "program" ]
@@ Program.alias_param
@@ stop)
(fun () (_, program) (cctxt : Client_commands.full_context) ->
Program.to_source cctxt program >>=? fun source ->
cctxt#message "%s\n" source >>= fun () ->
return ()) ;
command ~group ~desc: "ask the node to run a program"
(args3 trace_stack_switch amount_arg no_print_source_flag)
(prefixes [ "run" ; "program" ]
@@ Program.source_param
@@ prefixes [ "on" ; "storage" ]
@@ Cli_entries.param ~name:"storage" ~desc:"the storage data"
data_parameter
@@ prefixes [ "and" ; "input" ]
@@ Cli_entries.param ~name:"storage" ~desc:"the input data"
data_parameter
@@ stop)
(fun (trace_exec, amount, no_print_source) program storage input cctxt ->
Lwt.return @@ Micheline_parser.no_parsing_error program >>=? fun program ->
let show_source = not no_print_source in
(if trace_exec then
trace ~amount ~program ~storage ~input cctxt#block cctxt >>= fun res ->
print_trace_result cctxt ~show_source ~parsed:program res
else
run ~amount ~program ~storage ~input cctxt#block cctxt >>= fun res ->
print_run_result cctxt ~show_source ~parsed:program res)) ;
command ~group ~desc: "ask the node to typecheck a program"
(args3 show_types_switch emacs_mode_switch no_print_source_flag)
(prefixes [ "typecheck" ; "program" ]
@@ Program.source_param
@@ stop)
(fun (show_types, emacs_mode, no_print_source) program cctxt ->
Lwt.return @@ Micheline_parser.no_parsing_error program >>=? fun program ->
typecheck_program program cctxt#block cctxt >>= fun res ->
print_typecheck_result
~emacs:emacs_mode
~show_types
~print_source_on_error:(not no_print_source)
program
res
cctxt) ;
command ~group ~desc: "ask the node to typecheck a data expression"
(args1 no_print_source_flag)
(prefixes [ "typecheck" ; "data" ]
@@ Cli_entries.param ~name:"data" ~desc:"the data to typecheck"
data_parameter
@@ prefixes [ "against" ; "type" ]
@@ Cli_entries.param ~name:"type" ~desc:"the expected type"
data_parameter
@@ stop)
(fun no_print_source data ty cctxt ->
Client_proto_programs.typecheck_data ~data ~ty cctxt#block cctxt >>= function
| Ok () ->
cctxt#message "Well typed" >>= fun () ->
return ()
| Error errs ->
cctxt#warning "%a"
(Michelson_v1_error_reporter.report_errors
~details:false
~show_source:(not no_print_source)
?parsed:None) errs >>= fun () ->
cctxt#error "ill-typed data") ;
command ~group
~desc: "ask the node to compute the hash of a data expression \
using the same algorithm as script instruction H"
no_options
(prefixes [ "hash" ; "data" ]
@@ Cli_entries.param ~name:"data" ~desc:"the data to hash"
data_parameter
@@ stop)
(fun () data cctxt ->
Client_proto_rpcs.Helpers.hash_data cctxt
cctxt#block (data.expanded) >>= function
| Ok hash ->
cctxt#message "%S" hash >>= fun () ->
return ()
| Error errs ->
cctxt#warning "%a" pp_print_error errs >>= fun () ->
cctxt#error "ill-formed data") ;
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 \
a given secret key, and display it using the format expected by \
script instruction CHECK_SIGNATURE"
no_options
(prefixes [ "hash" ; "and" ; "sign" ; "data" ]
@@ Cli_entries.param ~name:"data" ~desc:"the data to hash"
data_parameter
@@ prefixes [ "for" ]
@@ Client_keys.Secret_key.alias_param
@@ stop)
(fun () data (_, key) cctxt ->
Client_proto_programs.hash_and_sign data key cctxt#block cctxt >>= begin function
|Ok (hash, signature) ->
cctxt#message "Hash: %S@.Signature: %S" hash signature
| Error errs ->
cctxt#warning "%a" pp_print_error errs >>= fun () ->
cctxt#error "ill-formed data"
end >>= return) ;
]

10
lib_embedded_client_alpha/client_proto_programs_commands.mli Normal file
View File

@ -0,0 +1,10 @@
(**************************************************************************)
(* *)
(* Copyright (c) 2014 - 2017. *)
(* Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* All rights reserved. No warranty, explicit or implicit, provided. *)
(* *)
(**************************************************************************)
val commands: unit -> Client_commands.command list

4
lib_embedded_client_alpha/client_proto_rpcs.ml
View File

@ -10,11 +10,11 @@
let string_of_errors exns = let string_of_errors exns =
Format.asprintf " @[<v>%a@]" pp_print_error exns Format.asprintf " @[<v>%a@]" pp_print_error exns
let handle_error cctxt = function let handle_error (cctxt : #Client_commands.logger) = function
| Ok res -> Lwt.return res | Ok res -> Lwt.return res
| Error exns -> | Error exns ->
pp_print_error Format.err_formatter exns ; pp_print_error Format.err_formatter exns ;
cctxt.Client_commands.error "%s" "cannot continue" cctxt#error "%s" "cannot continue"
let call_service0 cctxt s block = let call_service0 cctxt s block =
Client_rpcs.call_service0 cctxt Client_rpcs.call_service0 cctxt

116
lib_embedded_client_alpha/client_proto_rpcs.mli
View File

@ -8,94 +8,94 @@
(**************************************************************************) (**************************************************************************)
val string_of_errors: error list -> string val string_of_errors: error list -> string
val handle_error: Client_commands.context -> 'a tzresult -> 'a Lwt.t val handle_error: Client_commands.full_context -> 'a tzresult -> 'a Lwt.t
type block = Node_rpc_services.Blocks.block type block = Node_rpc_services.Blocks.block
val header: val header:
Client_rpcs.config -> block -> Block_header.t tzresult Lwt.t Client_rpcs.rpc -> block -> Block_header.t tzresult Lwt.t
module Header : sig module Header : sig
val priority: val priority:
Client_rpcs.config -> block -> int tzresult Lwt.t Client_rpcs.rpc -> block -> int tzresult Lwt.t
val seed_nonce_hash: val seed_nonce_hash:
Client_rpcs.config -> block -> Nonce_hash.t tzresult Lwt.t Client_rpcs.rpc -> block -> Nonce_hash.t tzresult Lwt.t
end end
module Constants : sig module Constants : sig
val errors: val errors:
Client_rpcs.config -> #Client_rpcs.rpc_sig ->
block -> Json_schema.schema tzresult Lwt.t block -> Json_schema.schema tzresult Lwt.t
val cycle_length: val cycle_length:
Client_rpcs.config -> #Client_rpcs.rpc_sig ->
block -> int32 tzresult Lwt.t block -> int32 tzresult Lwt.t
val voting_period_length: val voting_period_length:
Client_rpcs.config -> #Client_rpcs.rpc_sig ->
block -> int32 tzresult Lwt.t block -> int32 tzresult Lwt.t
val time_before_reward: val time_before_reward:
Client_rpcs.config -> #Client_rpcs.rpc_sig ->
block -> Period.t tzresult Lwt.t block -> Period.t tzresult Lwt.t
val slot_durations: val slot_durations:
Client_rpcs.config -> #Client_rpcs.rpc_sig ->
block -> (Period.t list) tzresult Lwt.t block -> (Period.t list) tzresult Lwt.t
val first_free_baking_slot: val first_free_baking_slot:
Client_rpcs.config -> #Client_rpcs.rpc_sig ->
block -> int tzresult Lwt.t block -> int tzresult Lwt.t
val max_signing_slot: val max_signing_slot:
Client_rpcs.config -> #Client_rpcs.rpc_sig ->
block -> int tzresult Lwt.t block -> int tzresult Lwt.t
val instructions_per_transaction: val instructions_per_transaction:
Client_rpcs.config -> #Client_rpcs.rpc_sig ->
block -> int tzresult Lwt.t block -> int tzresult Lwt.t
val stamp_threshold: val stamp_threshold:
Client_rpcs.config -> #Client_rpcs.rpc_sig ->
block -> int64 tzresult Lwt.t block -> int64 tzresult Lwt.t
end end
module Context : sig module Context : sig
val level: val level:
Client_rpcs.config -> #Client_rpcs.rpc_sig ->
block -> Level.t tzresult Lwt.t block -> Level.t tzresult Lwt.t
(** [level cctxt blk] returns the (protocol view of the) level of (** [level cctxt blk] returns the (protocol view of the) level of
[blk]. *) [blk]. *)
val next_level: val next_level:
Client_rpcs.config -> #Client_rpcs.rpc_sig ->
block -> Level.t tzresult Lwt.t block -> Level.t tzresult Lwt.t
(** [next_level cctxt blk] returns the (protocol view of the) level (** [next_level cctxt blk] returns the (protocol view of the) level
of the successor of [blk]. *) of the successor of [blk]. *)
val voting_period_kind: val voting_period_kind:
Client_rpcs.config -> #Client_rpcs.rpc_sig ->
block -> Voting_period.kind tzresult Lwt.t block -> Voting_period.kind tzresult Lwt.t
(** [voting_period_kind cctxt blk] returns the voting period kind (** [voting_period_kind cctxt blk] returns the voting period kind
of [blk]. *) of [blk]. *)
module Nonce : sig module Nonce : sig
val hash: val hash:
Client_rpcs.config -> #Client_rpcs.rpc_sig ->
block -> Nonce_hash.t tzresult Lwt.t block -> Nonce_hash.t tzresult Lwt.t
type nonce_info = type nonce_info =
| Revealed of Nonce.t | Revealed of Nonce.t
| Missing of Nonce_hash.t | Missing of Nonce_hash.t
| Forgotten | Forgotten
val get: val get:
Client_rpcs.config -> #Client_rpcs.rpc_sig ->
block -> Raw_level.t -> nonce_info tzresult Lwt.t block -> Raw_level.t -> nonce_info tzresult Lwt.t
end end
module Key : sig module Key : sig
val get : val get :
Client_rpcs.config -> #Client_rpcs.rpc_sig ->
block -> block ->
public_key_hash -> (public_key_hash * public_key) tzresult Lwt.t public_key_hash -> (public_key_hash * public_key) tzresult Lwt.t
val list : val list :
Client_rpcs.config -> #Client_rpcs.rpc_sig ->
block -> block ->
((public_key_hash * public_key) list) tzresult Lwt.t ((public_key_hash * public_key) list) tzresult Lwt.t
end end
module Contract : sig module Contract : sig
val list: val list:
Client_rpcs.config -> #Client_rpcs.rpc_sig ->
block -> Contract.t list tzresult Lwt.t block -> Contract.t list tzresult Lwt.t
type info = { type info = {
manager: public_key_hash ; manager: public_key_hash ;
@ -106,91 +106,91 @@ module Context : sig
counter: int32 ; counter: int32 ;
} }
val get: val get:
Client_rpcs.config -> #Client_rpcs.rpc_sig ->
block -> Contract.t -> info tzresult Lwt.t block -> Contract.t -> info tzresult Lwt.t
val balance: val balance:
Client_rpcs.config -> #Client_rpcs.rpc_sig ->
block -> Contract.t -> block -> Contract.t ->
Tez.t tzresult Lwt.t Tez.t tzresult Lwt.t
val manager: val manager:
Client_rpcs.config -> #Client_rpcs.rpc_sig ->
block -> Contract.t -> block -> Contract.t ->
public_key_hash tzresult Lwt.t public_key_hash tzresult Lwt.t
val delegate: val delegate:
Client_rpcs.config -> #Client_rpcs.rpc_sig ->
block -> Contract.t -> block -> Contract.t ->
public_key_hash option tzresult Lwt.t public_key_hash option tzresult Lwt.t
val counter: val counter:
Client_rpcs.config -> #Client_rpcs.rpc_sig ->
block -> Contract.t -> block -> Contract.t ->
int32 tzresult Lwt.t int32 tzresult Lwt.t
val spendable: val spendable:
Client_rpcs.config -> #Client_rpcs.rpc_sig ->
block -> Contract.t -> block -> Contract.t ->
bool tzresult Lwt.t bool tzresult Lwt.t
val delegatable: val delegatable:
Client_rpcs.config -> #Client_rpcs.rpc_sig ->
block -> Contract.t -> block -> Contract.t ->
bool tzresult Lwt.t bool tzresult Lwt.t
val script: val script:
Client_rpcs.config -> #Client_rpcs.rpc_sig ->
block -> Contract.t -> Script.t option tzresult Lwt.t block -> Contract.t -> Script.t option tzresult Lwt.t
val storage: val storage:
Client_rpcs.config -> #Client_rpcs.rpc_sig ->
block -> Contract.t -> Script.expr option tzresult Lwt.t block -> Contract.t -> Script.expr option tzresult Lwt.t
end end
end end
module Helpers : sig module Helpers : sig
val minimal_time: val minimal_time:
Client_rpcs.config -> #Client_rpcs.rpc_sig ->
block -> ?prio:int -> unit -> Time.t tzresult Lwt.t block -> ?prio:int -> unit -> Time.t tzresult Lwt.t
(** [minimal_time cctxt blk ?prio ()] is the minimal acceptable (** [minimal_time cctxt blk ?prio ()] is the minimal acceptable
timestamp for the successor of [blk]. [?prio] defaults to timestamp for the successor of [blk]. [?prio] defaults to
[0]. *) [0]. *)
val apply_operation: val apply_operation:
Client_rpcs.config -> #Client_rpcs.rpc_sig ->
block -> Block_hash.t -> Operation_hash.t -> MBytes.t -> Ed25519.Signature.t option -> block -> Block_hash.t -> Operation_hash.t -> MBytes.t -> Ed25519.Signature.t option ->
(Contract.t list) tzresult Lwt.t (Contract.t list) tzresult Lwt.t
val run_code: val run_code:
Client_rpcs.config -> #Client_rpcs.rpc_sig ->
block -> Script.expr -> block -> Script.expr ->
(Script.expr * Script.expr * Tez.t) -> (Script.expr * Script.expr * Tez.t) ->
(Script.expr * Script.expr) tzresult Lwt.t (Script.expr * Script.expr) tzresult Lwt.t
val trace_code: val trace_code:
Client_rpcs.config -> #Client_rpcs.rpc_sig ->
block -> Script.expr -> block -> Script.expr ->
(Script.expr * Script.expr * Tez.t) -> (Script.expr * Script.expr * Tez.t) ->
(Script.expr * Script.expr * (Script.expr * Script.expr *
(Script.location * int * Script.expr list) list) tzresult Lwt.t (Script.location * int * Script.expr list) list) tzresult Lwt.t
val typecheck_code: val typecheck_code:
Client_rpcs.config -> #Client_rpcs.rpc_sig ->
block -> Script.expr -> Script_ir_translator.type_map tzresult Lwt.t block -> Script.expr -> Script_ir_translator.type_map tzresult Lwt.t
val typecheck_data: val typecheck_data:
Client_rpcs.config -> #Client_rpcs.rpc_sig ->
block -> Script.expr * Script.expr -> unit tzresult Lwt.t block -> Script.expr * Script.expr -> unit tzresult Lwt.t
val hash_data: val hash_data:
Client_rpcs.config -> #Client_rpcs.rpc_sig ->
block -> Script.expr -> string tzresult Lwt.t block -> Script.expr -> string tzresult Lwt.t
val level: val level:
Client_rpcs.config -> #Client_rpcs.rpc_sig ->
block -> ?offset:int32 -> Raw_level.t -> Level.t tzresult Lwt.t block -> ?offset:int32 -> Raw_level.t -> Level.t tzresult Lwt.t
val levels: val levels:
Client_rpcs.config -> #Client_rpcs.rpc_sig ->
block -> Cycle.t -> (Raw_level.t * Raw_level.t) tzresult Lwt.t block -> Cycle.t -> (Raw_level.t * Raw_level.t) tzresult Lwt.t
module Rights : sig module Rights : sig
type baking_slot = Raw_level.t * int * Time.t type baking_slot = Raw_level.t * int * Time.t
type endorsement_slot = Raw_level.t * int type endorsement_slot = Raw_level.t * int
val baking_rights_for_delegate: val baking_rights_for_delegate:
Client_rpcs.config -> #Client_rpcs.rpc_sig ->
block -> public_key_hash -> block -> public_key_hash ->
?max_priority:int -> ?first_level:Raw_level.t -> ?max_priority:int -> ?first_level:Raw_level.t ->
?last_level:Raw_level.t -> unit -> ?last_level:Raw_level.t -> unit ->
(baking_slot list) tzresult Lwt.t (baking_slot list) tzresult Lwt.t
val endorsement_rights_for_delegate: val endorsement_rights_for_delegate:
Client_rpcs.config -> #Client_rpcs.rpc_sig ->
block -> public_key_hash -> block -> public_key_hash ->
?max_priority:int -> ?first_level:Raw_level.t -> ?last_level:Raw_level.t -> unit -> ?max_priority:int -> ?first_level:Raw_level.t -> ?last_level:Raw_level.t -> unit ->
(endorsement_slot list) tzresult Lwt.t (endorsement_slot list) tzresult Lwt.t
@ -199,7 +199,7 @@ module Helpers : sig
module Forge : sig module Forge : sig
module Manager : sig module Manager : sig
val operations: val operations:
Client_rpcs.config -> #Client_rpcs.rpc_sig ->
block -> block ->
branch:Block_hash.t -> branch:Block_hash.t ->
source:Contract.t -> source:Contract.t ->
@ -209,7 +209,7 @@ module Helpers : sig
manager_operation list -> manager_operation list ->
MBytes.t tzresult Lwt.t MBytes.t tzresult Lwt.t
val transaction: val transaction:
Client_rpcs.config -> #Client_rpcs.rpc_sig ->
block -> block ->
branch:Block_hash.t -> branch:Block_hash.t ->
source:Contract.t -> source:Contract.t ->
@ -221,7 +221,7 @@ module Helpers : sig
fee:Tez.t -> fee:Tez.t ->
unit -> MBytes.t tzresult Lwt.t unit -> MBytes.t tzresult Lwt.t
val origination: val origination:
Client_rpcs.config -> #Client_rpcs.rpc_sig ->
block -> block ->
branch:Block_hash.t -> branch:Block_hash.t ->
source:Contract.t -> source:Contract.t ->
@ -237,7 +237,7 @@ module Helpers : sig
unit -> unit ->
MBytes.t tzresult Lwt.t MBytes.t tzresult Lwt.t
val delegation: val delegation:
Client_rpcs.config -> #Client_rpcs.rpc_sig ->
block -> block ->
branch:Block_hash.t -> branch:Block_hash.t ->
source:Contract.t -> source:Contract.t ->
@ -249,19 +249,19 @@ module Helpers : sig
end end
module Dictator : sig module Dictator : sig
val operation: val operation:
Client_rpcs.config -> #Client_rpcs.rpc_sig ->
block -> block ->
branch:Block_hash.t -> branch:Block_hash.t ->
dictator_operation -> dictator_operation ->
MBytes.t tzresult Lwt.t MBytes.t tzresult Lwt.t
val activate: val activate:
Client_rpcs.config -> #Client_rpcs.rpc_sig ->
block -> block ->
branch:Block_hash.t -> branch:Block_hash.t ->
Protocol_hash.t -> Protocol_hash.t ->
MBytes.t tzresult Lwt.t MBytes.t tzresult Lwt.t
val activate_testnet: val activate_testnet:
Client_rpcs.config -> #Client_rpcs.rpc_sig ->
block -> block ->
branch:Block_hash.t -> branch:Block_hash.t ->
Protocol_hash.t -> Protocol_hash.t ->
@ -269,14 +269,14 @@ module Helpers : sig
end end
module Delegate : sig module Delegate : sig
val operations: val operations:
Client_rpcs.config -> #Client_rpcs.rpc_sig ->
block -> block ->
branch:Block_hash.t -> branch:Block_hash.t ->
source:public_key -> source:public_key ->
delegate_operation list -> delegate_operation list ->
MBytes.t tzresult Lwt.t MBytes.t tzresult Lwt.t
val endorsement: val endorsement:
Client_rpcs.config -> #Client_rpcs.rpc_sig ->
block -> block ->
branch:Block_hash.t -> branch:Block_hash.t ->
source:public_key -> source:public_key ->
@ -284,7 +284,7 @@ module Helpers : sig
slot:int -> slot:int ->
unit -> MBytes.t tzresult Lwt.t unit -> MBytes.t tzresult Lwt.t
val proposals: val proposals:
Client_rpcs.config -> #Client_rpcs.rpc_sig ->
block -> block ->
branch:Block_hash.t -> branch:Block_hash.t ->
source:public_key -> source:public_key ->
@ -292,7 +292,7 @@ module Helpers : sig
proposals:Protocol_hash.t list -> proposals:Protocol_hash.t list ->
unit -> MBytes.t tzresult Lwt.t unit -> MBytes.t tzresult Lwt.t
val ballot: val ballot:
Client_rpcs.config -> #Client_rpcs.rpc_sig ->
block -> block ->
branch:Block_hash.t -> branch:Block_hash.t ->
source:public_key -> source:public_key ->
@ -303,27 +303,27 @@ module Helpers : sig
end end
module Anonymous : sig module Anonymous : sig
val operations: val operations:
Client_rpcs.config -> #Client_rpcs.rpc_sig ->
block -> block ->
branch:Block_hash.t -> branch:Block_hash.t ->
anonymous_operation list -> anonymous_operation list ->
MBytes.t tzresult Lwt.t MBytes.t tzresult Lwt.t
val seed_nonce_revelation: val seed_nonce_revelation:
Client_rpcs.config -> #Client_rpcs.rpc_sig ->
block -> block ->
branch:Block_hash.t -> branch:Block_hash.t ->
level:Raw_level.t -> level:Raw_level.t ->
nonce:Nonce.t -> nonce:Nonce.t ->
unit -> MBytes.t tzresult Lwt.t unit -> MBytes.t tzresult Lwt.t
val faucet: val faucet:
Client_rpcs.config -> #Client_rpcs.rpc_sig ->
block -> block ->
branch:Block_hash.t -> branch:Block_hash.t ->
id:public_key_hash -> id:public_key_hash ->
unit -> MBytes.t tzresult Lwt.t unit -> MBytes.t tzresult Lwt.t
end end
val block_proto_header: val block_proto_header:
Client_rpcs.config -> #Client_rpcs.rpc_sig ->
block -> block ->
priority: int -> priority: int ->
seed_nonce_hash: Nonce_hash.t -> seed_nonce_hash: Nonce_hash.t ->
@ -333,11 +333,11 @@ module Helpers : sig
module Parse : sig module Parse : sig
val operations: val operations:
Client_rpcs.config -> #Client_rpcs.rpc_sig ->
block -> ?check:bool -> Operation.raw list -> block -> ?check:bool -> Operation.raw list ->
Operation.t list tzresult Lwt.t Operation.t list tzresult Lwt.t
val block: val block:
Client_rpcs.config -> #Client_rpcs.rpc_sig ->
block -> Block_header.shell_header -> MBytes.t -> block -> Block_header.shell_header -> MBytes.t ->
Block_header.proto_header tzresult Lwt.t Block_header.proto_header tzresult Lwt.t
end end

14
lib_embedded_client_genesis/client_proto_main.ml
View File

@ -7,7 +7,6 @@
(* *) (* *)
(**************************************************************************) (**************************************************************************)
open Client_commands
open Tezos_embedded_raw_protocol_genesis open Tezos_embedded_raw_protocol_genesis
let protocol = let protocol =
@ -84,13 +83,12 @@ let commands () =
@@ Client_keys.Secret_key.source_param @@ Client_keys.Secret_key.source_param
~name:"password" ~desc:"Dictator's key" ~name:"password" ~desc:"Dictator's key"
@@ stop) @@ stop)
begin fun timestamp hash fitness validation_passes seckey cctxt -> begin fun timestamp hash fitness validation_passes seckey (cctxt : Client_commands.full_context) ->
let fitness = let fitness =
Tezos_embedded_raw_protocol_alpha.Fitness_repr.from_int64 fitness in Tezos_embedded_raw_protocol_alpha.Fitness_repr.from_int64 fitness in
bake cctxt.rpc_config ?timestamp cctxt.config.block bake cctxt ?timestamp cctxt#block
(Activate { protocol = hash ; validation_passes }) (Activate { protocol = hash ; validation_passes }) fitness seckey >>=? fun hash ->
fitness seckey >>=? fun hash -> cctxt#answer "Injected %a" Block_hash.pp_short hash >>= fun () ->
cctxt.answer "Injected %a" Block_hash.pp_short hash >>= fun () ->
return () return ()
end ; end ;
@ -113,12 +111,12 @@ let commands () =
begin fun timestamp hash fitness validation_passes seckey cctxt -> begin fun timestamp hash fitness validation_passes seckey cctxt ->
let fitness = let fitness =
Tezos_embedded_raw_protocol_alpha.Fitness_repr.from_int64 fitness in Tezos_embedded_raw_protocol_alpha.Fitness_repr.from_int64 fitness in
bake cctxt.rpc_config ?timestamp cctxt.config.block bake cctxt ?timestamp cctxt#block
(Activate_testnet { protocol = hash ; (Activate_testnet { protocol = hash ;
validation_passes ; validation_passes ;
delay = Int64.mul 24L 3600L }) delay = Int64.mul 24L 3600L })
fitness seckey >>=? fun hash -> fitness seckey >>=? fun hash ->
cctxt.answer "Injected %a" Block_hash.pp_short hash >>= fun () -> cctxt#answer "Injected %a" Block_hash.pp_short hash >>= fun () ->
return () return ()
end ; end ;

2
lib_embedded_client_genesis/client_proto_main.mli
View File

@ -10,7 +10,7 @@
open Tezos_embedded_raw_protocol_genesis open Tezos_embedded_raw_protocol_genesis
val bake: val bake:
Client_rpcs.config -> #Client_rpcs.rpc_sig ->
?timestamp: Time.t -> ?timestamp: Time.t ->
Client_node_rpcs.Blocks.block -> Client_node_rpcs.Blocks.block ->
Data.Command.t -> Data.Command.t ->

8
lib_embedded_protocol_alpha/src/tezos_context.ml
View File

@ -17,7 +17,13 @@ module type BASIC_DATA = sig
val pp: Format.formatter -> t -> unit val pp: Format.formatter -> t -> unit
end end
module Tez = Tez_repr module Tez = struct
include Tez_repr
let default_fee =
match of_cents 5L with
| None -> raise (Failure "internal error: Could not parse default_fee literal")
| Some fee -> fee
end
module Period = Period_repr module Period = Period_repr
module Timestamp = struct module Timestamp = struct

2
lib_embedded_protocol_alpha/src/tezos_context.mli
View File

@ -47,6 +47,8 @@ module Tez : sig
val of_cents: int64 -> tez option val of_cents: int64 -> tez option
val to_cents: tez -> int64 val to_cents: tez -> int64
val default_fee : t
end end
module Period : sig module Period : sig

87
test/proto_alpha/proto_alpha_helpers.ml
View File

@ -20,6 +20,19 @@ let rpc_config = ref {
logger = Client_rpcs.null_logger ; logger = Client_rpcs.null_logger ;
} }
(* Context that does not write to alias files *)
let no_write_context config block : Client_commands.full_context = object
inherit Client_rpcs.rpc config
inherit Client_commands.logger (fun _ _ -> Lwt.return_unit)
method load : type a. string -> default:a -> a Data_encoding.encoding -> a Error_monad.tzresult Lwt.t =
fun _ ~default _ -> return default
method write : type a. string ->
a ->
a Data_encoding.encoding -> unit Error_monad.tzresult Lwt.t =
fun _ _ _ -> return ()
method block = block
end
let dictator_sk = let dictator_sk =
Ed25519.Secret_key.of_b58check_exn Ed25519.Secret_key.of_b58check_exn
"edskRhxswacLW6jF6ULavDdzwqnKJVS4UcDTNiCyiH6H8ZNnn2pmNviL7\ "edskRhxswacLW6jF6ULavDdzwqnKJVS4UcDTNiCyiH6H8ZNnn2pmNviL7\
@ -28,7 +41,7 @@ let dictator_sk =
let activate_alpha () = let activate_alpha () =
let fitness = Fitness_repr.from_int64 0L in let fitness = Fitness_repr.from_int64 0L in
Tezos_embedded_client_genesis.Client_proto_main.bake Tezos_embedded_client_genesis.Client_proto_main.bake
!rpc_config (`Head 0) (new Client_rpcs.rpc !rpc_config) (`Head 0)
(Activate { protocol = Client_proto_main.protocol ; validation_passes = 1}) (Activate { protocol = Client_proto_main.protocol ; validation_passes = 1})
fitness dictator_sk fitness dictator_sk
@ -54,7 +67,7 @@ let init ?(sandbox = "sandbox.json") ?rpc_port () =
return (pid, hash) return (pid, hash)
let level block = let level block =
Client_proto_rpcs.Context.level !rpc_config block Client_proto_rpcs.Context.level (new Client_rpcs.rpc !rpc_config) block
module Account = struct module Account = struct
@ -183,7 +196,7 @@ module Account = struct
~amount () = ~amount () =
let amount = match Tez.of_cents amount with None -> Tez.zero | Some a -> a in let amount = match Tez.of_cents amount with None -> Tez.zero | Some a -> a in
let fee = match Tez.of_cents fee with None -> Tez.zero | Some a -> a in let fee = match Tez.of_cents fee with None -> Tez.zero | Some a -> a in
Client_proto_context.transfer !rpc_config Client_proto_context.transfer (new Client_rpcs.rpc !rpc_config)
block block
~source:account.contract ~source:account.contract
~src_pk:account.pk ~src_pk:account.pk
@ -198,7 +211,6 @@ module Account = struct
?(fee=5L) ?(fee=5L)
~(src:t) ~(src:t)
~manager_pkh ~manager_pkh
~spendable
~balance ~balance
() = () =
let fee = match Tez.of_cents fee with let fee = match Tez.of_cents fee with
@ -210,41 +222,45 @@ module Account = struct
let delegatable, delegate = match delegate with let delegatable, delegate = match delegate with
| None -> false, None | None -> false, None
| Some delegate -> true, Some delegate in | Some delegate -> true, Some delegate in
Client_proto_context.originate_account !rpc_config block Client_proto_context.originate_account
~source:src.contract ~source:src.contract
~src_pk:src.pk ~src_pk:src.pk
~src_sk:src.sk ~src_sk:src.sk
~manager_pkh ~manager_pkh
~spendable
~balance ~balance
~delegatable ~delegatable
?delegate ?delegate
~fee () ~fee
block
(new Client_rpcs.rpc !rpc_config)
()
let set_delegate let set_delegate
?(block = `Prevalidation) ?(block = `Prevalidation)
?(fee = 5L) ?(fee = 5L)
?src_pk
~contract ~contract
~manager_sk ~manager_sk
~src_pk
delegate_opt = delegate_opt =
let fee = match Tez.of_cents fee with let fee = match Tez.of_cents fee with
| None -> Tez.zero | None -> Tez.zero
| Some amount -> amount in | Some amount -> amount in
Client_proto_context.delegate_contract !rpc_config block Client_proto_context.set_delegate
~source:contract (new Client_rpcs.rpc !rpc_config)
~manager_sk block
~fee ~fee
?src_pk contract
~src_pk
~manager_sk
delegate_opt delegate_opt
let balance ?(block = `Prevalidation) (account : t) = let balance ?(block = `Prevalidation) (account : t) =
Client_proto_rpcs.Context.Contract.balance !rpc_config Client_proto_rpcs.Context.Contract.balance (new Client_rpcs.rpc !rpc_config)
block account.contract block account.contract
(* TODO: gather contract related functions in a Contract module? *) (* TODO: gather contract related functions in a Contract module? *)
let delegate ?(block = `Prevalidation) (contract : Contract.t) = let delegate ?(block = `Prevalidation) (contract : Contract.t) =
Client_proto_rpcs.Context.Contract.delegate !rpc_config Client_proto_rpcs.Context.Contract.delegate (new Client_rpcs.rpc !rpc_config)
block contract block contract
end end
@ -254,12 +270,12 @@ module Protocol = struct
open Account open Account
let voting_period_kind ?(block = `Prevalidation) () = let voting_period_kind ?(block = `Prevalidation) () =
Client_proto_rpcs.Context.voting_period_kind !rpc_config block Client_proto_rpcs.Context.voting_period_kind (new Client_rpcs.rpc !rpc_config) block
let proposals ?(block = `Prevalidation) ~src:({ pk; sk } : Account.t) proposals = let proposals ?(block = `Prevalidation) ~src:({ pk; sk } : Account.t) proposals =
Client_node_rpcs.Blocks.info !rpc_config block >>=? fun block_info -> Client_node_rpcs.Blocks.info (new Client_rpcs.rpc !rpc_config) block >>=? fun block_info ->
Client_proto_rpcs.Context.next_level !rpc_config block >>=? fun next_level -> Client_proto_rpcs.Context.next_level (new Client_rpcs.rpc !rpc_config) block >>=? fun next_level ->
Client_proto_rpcs.Helpers.Forge.Delegate.proposals !rpc_config block Client_proto_rpcs.Helpers.Forge.Delegate.proposals (new Client_rpcs.rpc !rpc_config) block
~branch:block_info.hash ~branch:block_info.hash
~source:pk ~source:pk
~period:next_level.voting_period ~period:next_level.voting_period
@ -269,9 +285,10 @@ module Protocol = struct
return (Tezos_base.Operation.of_bytes_exn signed_bytes) return (Tezos_base.Operation.of_bytes_exn signed_bytes)
let ballot ?(block = `Prevalidation) ~src:({ pk; sk } : Account.t) ~proposal ballot = let ballot ?(block = `Prevalidation) ~src:({ pk; sk } : Account.t) ~proposal ballot =
Client_node_rpcs.Blocks.info !rpc_config block >>=? fun block_info -> let rpc = new Client_rpcs.rpc !rpc_config in
Client_proto_rpcs.Context.next_level !rpc_config block >>=? fun next_level -> Client_node_rpcs.Blocks.info rpc block >>=? fun block_info ->
Client_proto_rpcs.Helpers.Forge.Delegate.ballot !rpc_config block Client_proto_rpcs.Context.next_level rpc block >>=? fun next_level ->
Client_proto_rpcs.Helpers.Forge.Delegate.ballot rpc block
~branch:block_info.hash ~branch:block_info.hash
~source:pk ~source:pk
~period:next_level.voting_period ~period:next_level.voting_period
@ -402,7 +419,7 @@ module Assert = struct
end end
let check_protocol ?msg ~block h = let check_protocol ?msg ~block h =
Client_node_rpcs.Blocks.protocol !rpc_config block >>=? fun block_proto -> Client_node_rpcs.Blocks.protocol (new Client_rpcs.rpc !rpc_config) block >>=? fun block_proto ->
return @@ Assert.equal return @@ Assert.equal
?msg:(Assert.format_msg msg) ?msg:(Assert.format_msg msg)
~prn:Protocol_hash.to_b58check ~prn:Protocol_hash.to_b58check
@ -410,7 +427,7 @@ module Assert = struct
block_proto h block_proto h
let check_voting_period_kind ?msg ~block kind = let check_voting_period_kind ?msg ~block kind =
Client_proto_rpcs.Context.voting_period_kind !rpc_config block Client_proto_rpcs.Context.voting_period_kind (new Client_rpcs.rpc !rpc_config) block
>>=? fun current_kind -> >>=? fun current_kind ->
return @@ Assert.equal return @@ Assert.equal
?msg:(Assert.format_msg msg) ?msg:(Assert.format_msg msg)
@ -428,7 +445,7 @@ module Baking = struct
| Ok nonce -> nonce in | Ok nonce -> nonce in
let seed_nonce_hash = Nonce.hash seed_nonce in let seed_nonce_hash = Nonce.hash seed_nonce in
Client_baking_forge.forge_block Client_baking_forge.forge_block
!rpc_config (new Client_rpcs.rpc !rpc_config)
block block
~operations ~operations
~force:true ~force:true
@ -440,7 +457,7 @@ module Baking = struct
() ()
let endorsement_reward block = let endorsement_reward block =
Client_proto_rpcs.Header.priority !rpc_config block >>=? fun prio -> Client_proto_rpcs.Header.priority (new Client_rpcs.rpc !rpc_config) block >>=? fun prio ->
Baking.endorsement_reward ~block_priority:prio >|= Baking.endorsement_reward ~block_priority:prio >|=
Environment.wrap_error >>|? Environment.wrap_error >>|?
Tez.to_cents Tez.to_cents
@ -455,8 +472,9 @@ module Endorse = struct
source source
slot = slot =
let block = Client_rpcs.last_baked_block block in let block = Client_rpcs.last_baked_block block in
Client_node_rpcs.Blocks.info !rpc_config block >>=? fun { hash } -> let rpc = new Client_rpcs.rpc !rpc_config in
Client_proto_rpcs.Helpers.Forge.Delegate.endorsement !rpc_config Client_node_rpcs.Blocks.info rpc block >>=? fun { hash ; _ } ->
Client_proto_rpcs.Helpers.Forge.Delegate.endorsement rpc
block block
~branch:hash ~branch:hash
~source ~source
@ -472,7 +490,7 @@ module Endorse = struct
delegate delegate
level = level =
Client_proto_rpcs.Helpers.Rights.endorsement_rights_for_delegate Client_proto_rpcs.Helpers.Rights.endorsement_rights_for_delegate
!rpc_config ~max_priority ~first_level:level ~last_level:level (new Client_rpcs.rpc !rpc_config) ~max_priority ~first_level:level ~last_level:level
block delegate () >>=? fun possibilities -> block delegate () >>=? fun possibilities ->
let slots = let slots =
List.map (fun (_,slot) -> slot) List.map (fun (_,slot) -> slot)
@ -483,7 +501,7 @@ module Endorse = struct
?slot ?slot
(contract : Account.t) (contract : Account.t)
block = block =
Client_proto_rpcs.Context.next_level !rpc_config block >>=? fun { level } -> Client_proto_rpcs.Context.next_level (new Client_rpcs.rpc !rpc_config) block >>=? fun { level } ->
begin begin
match slot with match slot with
| Some slot -> return slot | Some slot -> return slot
@ -502,7 +520,7 @@ module Endorse = struct
let endorsers_list block = let endorsers_list block =
let get_endorser_list result (account : Account.t) level block = let get_endorser_list result (account : Account.t) level block =
Client_proto_rpcs.Helpers.Rights.endorsement_rights_for_delegate Client_proto_rpcs.Helpers.Rights.endorsement_rights_for_delegate
!rpc_config block account.pkh (new Client_rpcs.rpc !rpc_config) block account.pkh
~max_priority:16 ~max_priority:16
~first_level:level ~first_level:level
~last_level:level () >>|? fun slots -> ~last_level:level () >>|? fun slots ->
@ -510,7 +528,7 @@ module Endorse = struct
in in
let { Account.b1 ; b2 ; b3 ; b4 ; b5 } = Account.bootstrap_accounts in let { Account.b1 ; b2 ; b3 ; b4 ; b5 } = Account.bootstrap_accounts in
let result = Array.make 16 b1 in let result = Array.make 16 b1 in
Client_proto_rpcs.Context.level !rpc_config block >>=? fun level -> Client_proto_rpcs.Context.level (new Client_rpcs.rpc !rpc_config) block >>=? fun level ->
let level = Raw_level.succ @@ level.level in let level = Raw_level.succ @@ level.level in
get_endorser_list result b1 level block >>=? fun () -> get_endorser_list result b1 level block >>=? fun () ->
get_endorser_list result b2 level block >>=? fun () -> get_endorser_list result b2 level block >>=? fun () ->
@ -522,11 +540,12 @@ module Endorse = struct
let endorsement_rights let endorsement_rights
?(max_priority = 1024) ?(max_priority = 1024)
(contract : Account.t) block = (contract : Account.t) block =
Client_proto_rpcs.Context.level !rpc_config block >>=? fun level -> let rpc = new Client_rpcs.rpc !rpc_config in
Client_proto_rpcs.Context.level rpc block >>=? fun level ->
let delegate = contract.pkh in let delegate = contract.pkh in
let level = level.level in let level = level.level in
Client_proto_rpcs.Helpers.Rights.endorsement_rights_for_delegate Client_proto_rpcs.Helpers.Rights.endorsement_rights_for_delegate
!rpc_config rpc
~max_priority ~max_priority
~first_level:level ~first_level:level
~last_level:level ~last_level:level
@ -535,6 +554,6 @@ module Endorse = struct
end end
let display_level block = let display_level block =
Client_proto_rpcs.Context.level !rpc_config block >>=? fun lvl -> Client_proto_rpcs.Context.level (new Client_rpcs.rpc !rpc_config) block >>=? fun lvl ->
Format.eprintf "Level: %a@." Level.pp_full lvl ; Format.eprintf "Level: %a@." Level.pp_full lvl ;
return () return ()

3
test/proto_alpha/proto_alpha_helpers.mli
View File

@ -71,16 +71,15 @@ module Account : sig
?fee:int64 -> ?fee:int64 ->
src:t -> src:t ->
manager_pkh:public_key_hash -> manager_pkh:public_key_hash ->
spendable:bool ->
balance:int64 -> balance:int64 ->
unit -> (Operation_hash.t * Contract.t) tzresult Lwt.t unit -> (Operation_hash.t * Contract.t) tzresult Lwt.t
val set_delegate : val set_delegate :
?block:Client_proto_rpcs.block -> ?block:Client_proto_rpcs.block ->
?fee:int64 -> ?fee:int64 ->
?src_pk:public_key ->
contract:Contract.t -> contract:Contract.t ->
manager_sk:secret_key -> manager_sk:secret_key ->
src_pk:public_key ->
public_key_hash option -> public_key_hash option ->
Operation_hash.t tzresult Lwt.t Operation_hash.t tzresult Lwt.t

11
test/proto_alpha/test_origination.ml
View File

@ -19,7 +19,6 @@ let run blkid ({ b1 ; b2 ; _ } : Helpers.Account.bootstrap_accounts) =
Helpers.Account.originate Helpers.Account.originate
~src:foo ~src:foo
~manager_pkh:foo.pkh ~manager_pkh:foo.pkh
~spendable:true
~balance:0L () >>= fun result -> ~balance:0L () >>= fun result ->
Assert.unknown_contract ~msg:__LOC__ result ; Assert.unknown_contract ~msg:__LOC__ result ;
@ -27,7 +26,6 @@ let run blkid ({ b1 ; b2 ; _ } : Helpers.Account.bootstrap_accounts) =
Helpers.Account.originate Helpers.Account.originate
~src:b1 ~src:b1
~manager_pkh:foo.pkh ~manager_pkh:foo.pkh
~spendable:true
~balance:50L () >>= fun result -> ~balance:50L () >>= fun result ->
Assert.initial_amount_too_low ~msg:__LOC__ result ; Assert.initial_amount_too_low ~msg:__LOC__ result ;
@ -35,7 +33,6 @@ let run blkid ({ b1 ; b2 ; _ } : Helpers.Account.bootstrap_accounts) =
Helpers.Account.originate Helpers.Account.originate
~src:b1 ~src:b1
~manager_pkh:foo.pkh ~manager_pkh:foo.pkh
~spendable:true
~balance:99L () >>= fun result -> ~balance:99L () >>= fun result ->
Assert.initial_amount_too_low ~msg:__LOC__ result ; Assert.initial_amount_too_low ~msg:__LOC__ result ;
@ -43,7 +40,6 @@ let run blkid ({ b1 ; b2 ; _ } : Helpers.Account.bootstrap_accounts) =
Helpers.Account.originate Helpers.Account.originate
~src:b1 ~src:b1
~manager_pkh:foo.pkh ~manager_pkh:foo.pkh
~spendable:true
~balance:100L () >>= fun _result -> ~balance:100L () >>= fun _result ->
(* TODO: test if new contract exists *) (* TODO: test if new contract exists *)
@ -51,30 +47,29 @@ let run blkid ({ b1 ; b2 ; _ } : Helpers.Account.bootstrap_accounts) =
Helpers.Account.originate Helpers.Account.originate
~src:b1 ~src:b1
~manager_pkh:b1.pkh ~manager_pkh:b1.pkh
~spendable:true
~balance:500L () >>=? fun (_oph, nd_contract) -> ~balance:500L () >>=? fun (_oph, nd_contract) ->
(* Delegatable contract *) (* Delegatable contract *)
Helpers.Account.originate Helpers.Account.originate
~src:b1 ~src:b1
~manager_pkh:b1.pkh ~manager_pkh:b1.pkh
~spendable:true
~delegate:b1.pkh ~delegate:b1.pkh
~balance:500L () >>=? fun (_oph, d_contract) -> ~balance:500L () >>=? fun (_oph, d_contract) ->
(* Change delegate of a non-delegatable contract *) (* Change delegate of a non-delegatable contract *)
Helpers.Account.set_delegate Helpers.Account.set_delegate
~src_pk:b1.pk ~fee:5L
~contract:nd_contract ~contract:nd_contract
~manager_sk:b1.sk ~manager_sk:b1.sk
~src_pk:b1.pk
(Some b2.pkh) >>= fun result -> (Some b2.pkh) >>= fun result ->
Assert.non_delegatable ~msg:__LOC__ result ; Assert.non_delegatable ~msg:__LOC__ result ;
(* Change delegate of a delegatable contract *) (* Change delegate of a delegatable contract *)
Helpers.Account.set_delegate Helpers.Account.set_delegate
~src_pk:b1.pk
~contract:d_contract ~contract:d_contract
~manager_sk:b1.sk ~manager_sk:b1.sk
~src_pk:b1.pk
(Some b2.pkh) >>= fun _result -> (Some b2.pkh) >>= fun _result ->
Assert.delegate_equal ~msg:__LOC__ d_contract (Some b2.pkh) >>=? fun () -> Assert.delegate_equal ~msg:__LOC__ d_contract (Some b2.pkh) >>=? fun () ->

16
test/proto_alpha/test_transaction.ml
View File

@ -49,26 +49,10 @@ let run blkid ({ b1 ; b2 ; b3 ; _ } : Helpers.Account.bootstrap_accounts) =
~amount:1000_00L () >>= fun result -> ~amount:1000_00L () >>= fun result ->
Assert.balance_too_low ~msg:__LOC__ result ; Assert.balance_too_low ~msg:__LOC__ result ;
(* Check non-spendability of a non-spendable contract *)
(* TODO: Unspecified economic error: should be more specific. *)
Helpers.Account.originate
~src:foo
~manager_pkh:foo.pkh
~spendable:false
~balance:50_00L () >>=? fun (_oph, non_spendable) ->
Format.printf "Created non-spendable contract %a@." Contract.pp non_spendable ;
let account = { foo with contract = non_spendable } in
Helpers.Account.transfer
~account
~destination:bar.contract
~amount:10_00L () >>= fun result ->
Assert.non_spendable ~msg:__LOC__ result ;
(* Check spendability of a spendable contract *) (* Check spendability of a spendable contract *)
Helpers.Account.originate Helpers.Account.originate
~src:foo ~src:foo
~manager_pkh:foo.pkh ~manager_pkh:foo.pkh
~spendable:true
~balance:50_00L () >>=? fun (_oph, spendable) -> ~balance:50_00L () >>=? fun (_oph, spendable) ->
Format.printf "Created contract %a@." Contract.pp spendable ; Format.printf "Created contract %a@." Contract.pp spendable ;
let account = { foo with contract = spendable } in let account = { foo with contract = spendable } in