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

Client: more Error_monad in Client_aliases

Browse Source
This commit is contained in:
Grégoire Henry 2017-04-05 01:02:10 +02:00 committed by Benjamin Canou
parent 3226565b39
commit f5e2f7b481
14 changed files with 469 additions and 359 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

237
src/client/client_aliases.ml
View File

@ -17,10 +17,10 @@ module type Entity = sig
val encoding : t Data_encoding.t
val of_source :
Client_commands.context ->
string -> t Lwt.t
string -> t tzresult Lwt.t
val to_source :
Client_commands.context ->
t -> string Lwt.t
t -> string tzresult Lwt.t
val name : string
end
@ -28,40 +28,40 @@ module type Alias = sig
type t
val load :
Client_commands.context ->
(string * t) list Lwt.t
(string * t) list tzresult Lwt.t
val find :
Client_commands.context ->
string -> t Lwt.t
string -> t tzresult Lwt.t
val find_opt :
Client_commands.context ->
string -> t option Lwt.t
string -> t option tzresult Lwt.t
val rev_find :
Client_commands.context ->
t -> string option Lwt.t
t -> string option tzresult Lwt.t
val name :
Client_commands.context ->
t -> string Lwt.t
t -> string tzresult Lwt.t
val mem :
Client_commands.context ->
string -> bool Lwt.t
string -> bool tzresult Lwt.t
val add :
Client_commands.context ->
string -> t -> unit Lwt.t
string -> t -> unit tzresult Lwt.t
val del :
Client_commands.context ->
string -> unit Lwt.t
string -> unit tzresult Lwt.t
val update :
Client_commands.context ->
string -> t -> unit Lwt.t
string -> t -> unit tzresult Lwt.t
val save :
Client_commands.context ->
(string * t) list -> unit Lwt.t
(string * t) list -> unit tzresult Lwt.t
val of_source :
Client_commands.context ->
string -> t Lwt.t
string -> t tzresult Lwt.t
val to_source :
Client_commands.context ->
t -> string Lwt.t
t -> string tzresult Lwt.t
val alias_param :
?name:string ->
?desc:string ->
@ -97,92 +97,99 @@ module Alias = functor (Entity : Entity) -> struct
let load cctxt =
let filename = filename cctxt in
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 %s alias file" Entity.name
| Ok json ->
match Data_encoding.Json.destruct encoding json with
| exception _ -> (* TODO print_error *)
cctxt.Client_commands.error
"didn't understand the %s alias file" Entity.name
| list ->
Lwt.return list
if not (Sys.file_exists filename) 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 find_opt cctxt name =
load cctxt >>= fun list ->
try Lwt.return (Some (List.assoc name list))
with Not_found -> Lwt.return_none
load cctxt >>=? fun list ->
try return (Some (List.assoc name list))
with Not_found -> return None
let find cctxt name =
load cctxt >>= fun list ->
try Lwt.return (List.assoc name list)
load cctxt >>=? fun list ->
try return (List.assoc name list)
with Not_found ->
cctxt.Client_commands.error "no %s alias named %s" Entity.name name
failwith "no %s alias named %s" Entity.name name
let rev_find cctxt v =
load cctxt >>= fun list ->
try Lwt.return (Some (List.find (fun (_, v') -> v = v') list |> fst))
with Not_found -> Lwt.return_none
load cctxt >>=? fun list ->
try return (Some (List.find (fun (_, v') -> v = v') list |> fst))
with Not_found -> return None
let mem cctxt name =
load cctxt >>= fun list ->
load cctxt >>=? fun list ->
try
ignore (List.assoc name list) ;
Lwt.return_true
return true
with
| Not_found -> Lwt.return_false
| Not_found -> return false
let save cctxt list =
Lwt.catch
(fun () ->
let dirname = dirname cctxt in
(if not (Sys.file_exists dirname) then Lwt_utils.create_dir dirname
else Lwt.return ()) >>= fun () ->
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 >>= function
| Error _ -> Lwt.fail (Failure "Json.write_file")
| Ok () -> Lwt.return ())
(fun exn ->
cctxt.Client_commands.error
"could not write the %s alias file: %s."
Entity.name (Printexc.to_string exn))
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 cctxt name value =
let keep = ref false in
load cctxt >>= fun list ->
(if not cctxt.config.force then
Lwt_list.iter_s (fun (n, v) ->
if n = name && v = value then
(keep := true ;
load cctxt >>=? fun list ->
begin
if cctxt.config.force then
return ()
else
iter_s (fun (n, v) ->
if n = name && v = value then begin
keep := true ;
cctxt.message
"The %s alias %s already exists with the same value." Entity.name n)
else if n = name && v <> value then
cctxt.error
"another %s is already aliased as %s, use -force true to update" Entity.name n
else if n <> name && v = value then
cctxt.error
"this %s is already aliased as %s, use -force true to insert duplicate" Entity.name n
else Lwt.return ())
list else Lwt.return ()) >>= fun () ->
"The %s alias %s already exists with the same value."
Entity.name n >>= fun () ->
return ()
end else if n = name && v <> value then begin
failwith
"another %s is already aliased as %s, \
use -force true to update"
Entity.name n
end else if n <> name && v = value then begin
failwith
"this %s is already aliased as %s, \
use -force true to insert duplicate"
Entity.name n
end else begin
return ()
end)
list
end >>=? fun () ->
let list = List.filter (fun (n, _) -> n <> name) list in
let list = (name, value) :: list in
if !keep then
Lwt.return ()
return ()
else
save cctxt list >>= fun () ->
save cctxt list >>=? fun () ->
cctxt.Client_commands.message
"New %s alias '%s' saved." Entity.name name
"New %s alias '%s' saved." Entity.name name >>= fun () ->
return ()
let del cctxt name =
load cctxt >>= fun list ->
load cctxt >>=? fun list ->
let list = List.filter (fun (n, _) -> n <> name) list in
save cctxt list
let update cctxt name value =
load cctxt >>= fun list ->
load cctxt >>=? fun list ->
let list =
List.map
(fun (n, v) -> (n, if n = name then value else v))
@ -190,30 +197,45 @@ module Alias = functor (Entity : Entity) -> struct
save cctxt list
let save cctxt list =
save cctxt list >>= fun () ->
save cctxt list >>=? fun () ->
cctxt.Client_commands.message
"Successful update of the %s alias file." Entity.name
"Successful update of the %s alias file." Entity.name >>= fun () ->
return ()
include Entity
let alias_param ?(name = "name") ?(desc = "existing " ^ Entity.name ^ " alias") next =
param ~name ~desc
(fun cctxt s -> find cctxt s >>= fun v -> Lwt.return (s, v))
next
let fresh_alias_param ?(name = "new") ?(desc = "new " ^ Entity.name ^ " alias") next =
let alias_param
?(name = "name") ?(desc = "existing " ^ Entity.name ^ " alias") next =
param ~name ~desc
(fun cctxt s ->
load cctxt >>= fun list ->
if not cctxt.config.force then
Lwt_list.iter_s (fun (n, _v) ->
if n = s then
cctxt.Client_commands.error
"the %s alias %s already exists, use -force true to update" Entity.name n
else Lwt.return ())
list >>= fun () ->
Lwt.return s
else Lwt.return s)
find cctxt s >>= function
| Ok v -> Lwt.return (s, v)
| Error err -> cctxt.error "%a" pp_print_error err)
next
let fresh_alias_param
?(name = "new") ?(desc = "new " ^ Entity.name ^ " alias") next =
param ~name ~desc
(fun cctxt s ->
begin
load cctxt >>=? fun list ->
begin
if cctxt.config.force then
return ()
else
iter_s
(fun (n, _v) ->
if n = s then
failwith
"the %s alias %s already exists, use -force true to update"
Entity.name n
else
return ())
list
end
end >>= function
| Ok () -> Lwt.return s
| Error err -> cctxt.error "%a" pp_print_error err)
next
let source_param ?(name = "src") ?(desc = "source " ^ Entity.name) next =
@ -225,28 +247,37 @@ module Alias = functor (Entity : Entity) -> struct
(fun cctxt s ->
let read path =
Lwt.catch
(fun () -> Lwt_io.(with_file ~mode:Input path read))
(fun exn -> Lwt.fail_with @@ Format.asprintf "cannot read file (%s)" (Printexc.to_string exn))
>>= of_source cctxt in
match Utils.split ~limit:1 ':' s with
| [ "alias" ; alias ]->
find cctxt alias
| [ "text" ; text ] ->
of_source cctxt text
| [ "file" ; path ] ->
read path
| _ ->
Lwt.catch
(fun () -> find cctxt s)
(fun _ ->
Lwt.catch
(fun () -> read s)
(fun _ -> of_source cctxt s)))
(fun () ->
Lwt_io.(with_file ~mode:Input path read) >>= fun content ->
return content)
(fun exn ->
failwith
"cannot read file (%s)" (Printexc.to_string exn))
>>=? fun content ->
of_source cctxt content in
begin
match Utils.split ~limit:1 ':' s with
| [ "alias" ; alias ]->
find cctxt alias
| [ "text" ; text ] ->
of_source cctxt text
| [ "file" ; path ] ->
read path
| _ ->
find cctxt s >>= function
| Ok v -> return v
| Error _ ->
read s >>= function
| Ok v -> return v
| Error _ -> of_source cctxt s
end >>= function
| Ok s -> Lwt.return s
| Error err -> cctxt.error "%a" pp_print_error err)
next
let name cctxt d =
rev_find cctxt d >>= function
rev_find cctxt d >>=? function
| None -> Entity.to_source cctxt d
| Some name -> Lwt.return name
| Some name -> return name
end

28
src/client/client_aliases.mli
View File

@ -13,10 +13,10 @@ module type Entity = sig
val encoding : t Data_encoding.t
val of_source :
Client_commands.context ->
string -> t Lwt.t
string -> t tzresult Lwt.t
val to_source :
Client_commands.context ->
t -> string Lwt.t
t -> string tzresult Lwt.t
val name : string
end
@ -24,40 +24,40 @@ module type Alias = sig
type t
val load :
Client_commands.context ->
(string * t) list Lwt.t
(string * t) list tzresult Lwt.t
val find :
Client_commands.context ->
string -> t Lwt.t
string -> t tzresult Lwt.t
val find_opt :
Client_commands.context ->
string -> t option Lwt.t
string -> t option tzresult Lwt.t
val rev_find :
Client_commands.context ->
t -> string option Lwt.t
t -> string option tzresult Lwt.t
val name :
Client_commands.context ->
t -> string Lwt.t
t -> string tzresult Lwt.t
val mem :
Client_commands.context ->
string -> bool Lwt.t
string -> bool tzresult Lwt.t
val add :
Client_commands.context ->
string -> t -> unit Lwt.t
string -> t -> unit tzresult Lwt.t
val del :
Client_commands.context ->
string -> unit Lwt.t
string -> unit tzresult Lwt.t
val update :
Client_commands.context ->
string -> t -> unit Lwt.t
string -> t -> unit tzresult Lwt.t
val save :
Client_commands.context ->
(string * t) list -> unit Lwt.t
(string * t) list -> unit tzresult Lwt.t
val of_source :
Client_commands.context ->
string -> t Lwt.t
string -> t tzresult Lwt.t
val to_source :
Client_commands.context ->
t -> string Lwt.t
t -> string tzresult Lwt.t
val alias_param :
?name:string ->
?desc:string ->

147
src/client/client_keys.ml
View File

@ -12,24 +12,30 @@ module Ed25519 = Environment.Ed25519
module Public_key_hash = Client_aliases.Alias (struct
type t = Ed25519.Public_key_hash.t
let encoding = Ed25519.Public_key_hash.encoding
let of_source _ s = Lwt.return (Ed25519.Public_key_hash.of_b58check s)
let to_source _ p = Lwt.return (Ed25519.Public_key_hash.to_b58check p)
let of_source _ s =
try return (Ed25519.Public_key_hash.of_b58check s)
with exn -> Lwt.return (Error_monad.error_exn exn)
let to_source _ p = return (Ed25519.Public_key_hash.to_b58check p)
let name = "public key hash"
end)
module Public_key = Client_aliases.Alias (struct
type t = Ed25519.Public_key.t
let encoding = Ed25519.Public_key.encoding
let of_source _ s = Lwt.return (Ed25519.Public_key.of_b58check s)
let to_source _ p = Lwt.return (Ed25519.Public_key.to_b58check p)
let of_source _ s =
try return (Ed25519.Public_key.of_b58check s)
with exn -> Lwt.return (Error_monad.error_exn exn)
let to_source _ p = return (Ed25519.Public_key.to_b58check p)
let name = "public key"
end)
module Secret_key = Client_aliases.Alias (struct
type t = Ed25519.Secret_key.t
let encoding = Ed25519.Secret_key.encoding
let of_source _ s = Lwt.return (Ed25519.Secret_key.of_b58check s)
let to_source _ p = Lwt.return (Ed25519.Secret_key.to_b58check p)
let of_source _ s =
try return (Ed25519.Secret_key.of_b58check s)
with exn -> Lwt.return (Error_monad.error_exn exn)
let to_source _ p = return (Ed25519.Secret_key.to_b58check p)
let name = "secret key"
end)
@ -60,10 +66,12 @@ let gen_keys ?seed cctxt name =
| None -> Seed.generate ()
| Some s -> s in
let secret_key, public_key = Sodium.Sign.seed_keypair seed in
Secret_key.add cctxt name secret_key >>= fun () ->
Public_key.add cctxt name public_key >>= fun () ->
Public_key_hash.add cctxt name (Ed25519.Public_key.hash public_key) >>= fun () ->
cctxt.message "I generated a brand new pair of keys under the name '%s'." name >>= fun () ->
Secret_key.add cctxt name secret_key >>=? fun () ->
Public_key.add cctxt name public_key >>=? fun () ->
Public_key_hash.add
cctxt name (Ed25519.Public_key.hash public_key) >>=? fun () ->
cctxt.message
"I generated a brand new pair of keys under the name '%s'." name >>= fun () ->
return ()
let check_keys_consistency pk sk =
@ -72,31 +80,33 @@ let check_keys_consistency pk sk =
Ed25519.Signature.check pk signature message
let get_key cctxt 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"
| Some n ->
Public_key.find cctxt n >>= fun pk ->
Secret_key.find cctxt n >>= fun sk ->
Public_key.find cctxt n >>=? fun pk ->
Secret_key.find cctxt n >>=? fun sk ->
return (n, pk, sk)
let get_keys cctxt =
Secret_key.load cctxt >>=
Lwt_list.filter_map_p begin fun (name, sk) ->
Lwt.catch begin fun () ->
Public_key.find cctxt name >>= fun pk ->
Public_key_hash.find cctxt name >>= fun pkh ->
Lwt.return (Some (name, pkh, pk, sk))
end begin fun _ ->
Lwt.return_none
end
end
Secret_key.load cctxt >>=? fun sks ->
map_filter_s
(fun (name, sk) ->
Lwt.catch begin fun () ->
Public_key.find cctxt name >>=? fun pk ->
Public_key_hash.find cctxt name >>=? fun pkh ->
return (Some (name, pkh, pk, sk))
end begin fun _ ->
return None
end)
sks
let list_keys cctxt =
Public_key_hash.load cctxt >>= fun l ->
Lwt_list.map_s (fun (name, pkh) ->
Public_key.mem cctxt name >>= fun pkm ->
Secret_key.mem cctxt name >>= fun pks ->
Lwt.return (name, pkh, pkm, pks))
Public_key_hash.load cctxt >>=? fun l ->
map_s
(fun (name, pkh) ->
Public_key.mem cctxt name >>=? fun pkm ->
Secret_key.mem cctxt name >>=? fun pks ->
return (name, pkh, pkm, pks))
l
let group =
@ -106,71 +116,70 @@ let group =
let commands () =
let open Cli_entries in
let open Client_commands in
[ command ~group ~desc: "generate a pair of keys"
[
command ~group ~desc: "generate a pair of keys"
(prefixes [ "gen" ; "keys" ]
@@ Secret_key.fresh_alias_param
@@ stop)
(fun name cctxt -> gen_keys cctxt name) ;
command ~group ~desc: "add a secret key to the wallet"
(prefixes [ "add" ; "secret" ; "key" ]
@@ Secret_key.fresh_alias_param
@@ Secret_key.source_param
@@ stop)
(fun name sk cctxt ->
begin
Lwt.catch (fun () ->
Public_key.find cctxt name >>= fun pk ->
if check_keys_consistency pk sk || cctxt.config.force then
Secret_key.add cctxt name sk
else
cctxt.error
"public and secret keys '%s' don't correspond, \
please don't use -force true" name)
(function
| Not_found ->
cctxt.error
"no public key named '%s', add it before adding the secret key" name
| exn -> Lwt.fail exn)
end >>= fun () ->
return ()) ;
Public_key.find_opt cctxt name >>=? function
| None ->
failwith
"no public key named '%s', add it before adding the secret key"
name
| Some pk ->
fail_unless
(check_keys_consistency pk sk || cctxt.config.force)
(failure
"public and secret keys '%s' don't correspond, \
please don't use -force true" name) >>=? fun () ->
Secret_key.add cctxt name sk) ;
command ~group ~desc: "add a public key to the wallet"
(prefixes [ "add" ; "public" ; "key" ]
@@ Public_key.fresh_alias_param
@@ Public_key.source_param
@@ stop)
(fun name key cctxt ->
Public_key_hash.add cctxt name (Ed25519.Public_key.hash key) >>= fun () ->
Public_key.add cctxt name key >>= fun () ->
return ()) ;
Public_key_hash.add cctxt
name (Ed25519.Public_key.hash key) >>=? fun () ->
Public_key.add cctxt name key) ;
command ~group ~desc: "add an ID a public key hash to the wallet"
(prefixes [ "add" ; "identity" ]
@@ Public_key_hash.fresh_alias_param
@@ Public_key_hash.source_param
@@ stop)
(fun name hash cctxt ->
Public_key_hash.add cctxt name hash >>= fun () ->
return ()) ;
(fun name hash cctxt -> Public_key_hash.add cctxt name hash) ;
command ~group ~desc: "list all public key hashes and associated keys"
(fixed [ "list" ; "known" ; "identities" ])
(fun cctxt ->
list_keys cctxt >>= fun l ->
Lwt_list.iter_s (fun (name, pkh, pkm, pks) ->
Public_key_hash.to_source cctxt pkh >>= fun v ->
cctxt.message "%s: %s%s%s" name v
(if pkm then " (public key known)" else "")
(if pks then " (secret key known)" else ""))
l >>= fun () ->
return ()) ;
list_keys cctxt >>=? fun l ->
iter_s
(fun (name, pkh, pkm, pks) ->
Public_key_hash.to_source cctxt pkh >>=? fun v ->
cctxt.message "%s: %s%s%s" name v
(if pkm then " (public key known)" else "")
(if pks then " (secret key known)" else "") >>= fun () ->
return ())
l) ;
command ~group ~desc: "forget all keys"
(fixed [ "forget" ; "all" ; "keys" ])
(fun cctxt ->
begin
if not cctxt.config.force then
cctxt.Client_commands.error "this can only used with option -force true"
else
Public_key.save cctxt [] >>= fun () ->
Secret_key.save cctxt [] >>= fun () ->
Public_key_hash.save cctxt []
end >>= fun () ->
return ()) ;
]
fail_unless cctxt.config.force
(failure "this can only used with option -force true") >>=? fun () ->
Public_key.save cctxt [] >>=? fun () ->
Secret_key.save cctxt [] >>=? fun () ->
Public_key_hash.save cctxt []) ;
]

4
src/client/client_keys.mli
View File

@ -28,11 +28,11 @@ val get_key:
val get_keys:
Client_commands.context ->
( string * Public_key_hash.t * Public_key.t * Secret_key.t ) list Lwt.t
( string * Public_key_hash.t * Public_key.t * Secret_key.t ) list tzresult Lwt.t
val list_keys:
Client_commands.context ->
(string * Public_key_hash.t * bool * bool) list Lwt.t
(string * Public_key_hash.t * bool * bool) list tzresult Lwt.t
val gen_keys:
?seed: Sodium.Sign.seed ->

16
src/client/client_tags.ml
View File

@ -49,12 +49,12 @@ module Tags (Entity : Entity) = struct
aux (tag :: tags) tail
with
| Not_found ->
String.(trim s) :: tags
String.(trim s) :: tags
in
Lwt.return (aux [] tags_str)
return (aux [] tags_str)
let to_source _ tags =
Lwt.return (String.concat ", " tags)
return (String.concat ", " tags)
let name = Entity.name ^ " tag"
@ -64,15 +64,19 @@ module Tags (Entity : Entity) = struct
let desc =
desc ^ "\n"
^ "can be one or multiple tags separated by commas" in
Cli_entries.param ~name ~desc of_source next
Cli_entries.param ~name ~desc
(fun cctxt s -> of_source cctxt s >>= function
| Ok r -> Lwt.return r
| Error err -> cctxt.error "%a" pp_print_error err)
next
let rev_find_by_tag cctxt tag =
load cctxt >>= fun tags ->
load cctxt >>=? fun tags ->
try return (Some (List.find (fun (_, v) -> List.mem tag v) tags |> fst))
with Not_found -> return None
let filter cctxt pred =
load cctxt >>= fun tags ->
load cctxt >>=? fun tags ->
return (List.filter pred tags)
let filter_by_tag cctxt tag =

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

@ -29,12 +29,17 @@ let create cctxt endorsement_stream =
| `Endorsement (Some (Ok e)) ->
last_get_endorsement := None ;
Client_keys.Public_key_hash.name cctxt
e.Client_mining_operations.source >>= fun source ->
lwt_debug
"Discovered endorsement for block %a by %s (slot @[<h>%a@])"
Block_hash.pp_short e.block
source
Format.(pp_print_list pp_print_int) e.slots >>= fun () ->
worker_loop () in
e.Client_mining_operations.source >>= function
| Ok source ->
lwt_debug
"Discovered endorsement for block %a by %s (slot @[<h>%a@])"
Block_hash.pp_short e.block
source
Format.(pp_print_list pp_print_int) e.slots >>= fun () ->
worker_loop ()
| Error _ ->
(* TODO log *)
worker_loop ()
in
lwt_log_info "Starting denunciation daemon" >>= fun () ->
worker_loop ()

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

@ -208,8 +208,11 @@ let rec insert ({time} as e) = function
let get_delegates cctxt state =
match state.delegates with
| [] -> Client_keys.get_keys cctxt >|= List.map (fun (_,pkh,_,_) -> pkh)
| _ :: _ as delegates -> Lwt.return delegates
| [] ->
Client_keys.get_keys cctxt >>=? fun keys ->
return (List.map (fun (_,pkh,_,_) -> pkh) keys)
| _ :: _ as delegates ->
return delegates
let drop_old_endorsement ~before state =
state.to_endorse <-
@ -219,7 +222,7 @@ let drop_old_endorsement ~before state =
let schedule_endorsements cctxt state bis =
let may_endorse (block: Client_mining_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"
Block_hash.pp_short block.hash name >>= fun () ->
let b = `Hash block.hash in
@ -279,13 +282,16 @@ let schedule_endorsements cctxt state bis =
return ())
slots in
let time = Time.(add (now ()) state.delay) in
get_delegates cctxt state >>= fun delegates ->
get_delegates cctxt state >>=? fun delegates ->
iter_p
(fun delegate ->
iter_p
(fun bi -> may_endorse bi delegate time)
bis)
delegates >>= function
delegates
let schedule_endorsements cctxt state bis =
schedule_endorsements cctxt state bis >>= function
| Error exns ->
lwt_log_error
"@[<v 2>Error(s) while scheduling endorsements@,%a@]"

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

@ -348,8 +348,10 @@ let safe_get_unrevealed_nonces cctxt block =
let get_delegates cctxt state =
match state.delegates with
| [] -> Client_keys.get_keys cctxt >|= List.map (fun (_,pkh,_,_) -> pkh)
| _ :: _ as delegates -> Lwt.return delegates
| [] ->
Client_keys.get_keys cctxt >>=? fun keys ->
return (List.map (fun (_,pkh,_,_) -> pkh) keys)
| _ :: _ as delegates -> return delegates
let insert_block
cctxt ?max_priority state (bi: Client_mining_blocks.block_info) =
@ -363,20 +365,20 @@ let insert_block
drop_old_slots
~before:(Time.add state.best.timestamp (-1800L)) state ;
end ;
get_delegates cctxt state >>= fun delegates ->
get_delegates cctxt state >>=? fun delegates ->
get_mining_slot cctxt.rpc_config ?max_priority bi delegates >>= function
| None ->
lwt_debug
"Can't compute slot for %a" Block_hash.pp_short bi.hash >>= fun () ->
Lwt.return_unit
return ()
| Some ((timestamp, (_,_,delegate)) as slot) ->
Client_keys.Public_key_hash.name cctxt delegate >>= fun name ->
Client_keys.Public_key_hash.name cctxt delegate >>=? fun name ->
lwt_log_info "New mining slot at %a for %s after %a"
Time.pp_hum timestamp
name
Block_hash.pp_short bi.hash >>= fun () ->
state.future_slots <- insert_mining_slot slot state.future_slots ;
Lwt.return_unit
return ()
let pop_mining_slots state =
let now = Time.now () in
@ -390,7 +392,12 @@ let pop_mining_slots state =
slots
let insert_blocks cctxt ?max_priority state bis =
Lwt_list.iter_s (insert_block cctxt ?max_priority state) bis
iter_s (insert_block cctxt ?max_priority state) bis >>= function
| Ok () ->
Lwt.return_unit
| Error err ->
Format.eprintf "Error: %a" pp_print_error err ;
Lwt.return_unit
let mine cctxt state =
let slots = pop_mining_slots state in
@ -402,7 +409,7 @@ let mine cctxt state =
Time.now ()
else
timestamp in
Client_keys.Public_key_hash.name cctxt delegate >>= fun name ->
Client_keys.Public_key_hash.name cctxt delegate >>=? fun name ->
lwt_debug "Try mining after %a (slot %d) for %s (%a)"
Block_hash.pp_short bi.hash
prio name Time.pp_hum timestamp >>= fun () ->
@ -437,7 +444,7 @@ let mine cctxt state =
| (bi, priority, fitness, timestamp, operations, delegate) :: _
when Fitness.compare state.best.fitness fitness < 0 -> begin
let level = Raw_level.succ bi.level.level in
lwt_log_info
cctxt.message
"Select candidate block after %a (slot %d) fitness: %a"
Block_hash.pp_short bi.hash priority
Fitness.pp fitness >>= fun () ->
@ -449,7 +456,7 @@ let mine cctxt state =
|> trace_exn (Failure "Error while injecting block") >>=? fun block_hash ->
State.record_block cctxt level block_hash seed_nonce
|> 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
"Injected block %a for %s after %a \
\ (level %a, slot %d, fitness %a, operations %d)"

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

@ -15,20 +15,17 @@ open Client_commands
module Ed25519 = Environment.Ed25519
let check_contract cctxt neu =
RawContractAlias.mem cctxt neu >>= function
RawContractAlias.mem cctxt neu >>=? function
| true ->
cctxt.error "contract '%s' already exists" neu
failwith "contract '%s' already exists" neu
| false ->
Lwt.return ()
return ()
let get_delegate_pkh cctxt = function
| None -> Lwt.return None
| None ->
return None
| Some delegate ->
Lwt.catch
(fun () ->
Public_key_hash.find cctxt delegate >>= fun r ->
Lwt.return (Some r))
(fun _ -> Lwt.return None)
Public_key_hash.find_opt cctxt delegate
let get_timestamp cctxt block =
Client_node_rpcs.Blocks.timestamp cctxt.rpc_config block >>=? fun v ->
@ -40,37 +37,38 @@ let list_contracts cctxt block =
map_s (fun h ->
begin match Contract.is_default h with
| Some m -> begin
Public_key_hash.rev_find cctxt m >|= function
| None -> ""
| Some nm -> nm
Public_key_hash.rev_find cctxt m >>=? function
| None -> return ""
| Some nm -> return nm
end
| None -> begin
RawContractAlias.rev_find cctxt h >|= function
| None -> ""
| Some nm -> nm
RawContractAlias.rev_find cctxt h >>=? function
| None -> return ""
| Some nm -> return nm
end
end >>= fun alias ->
end >>=? fun alias ->
return (alias, h, Contract.is_default h))
contracts
let list_contract_labels cctxt block =
Client_proto_rpcs.Context.Contract.list cctxt.rpc_config block >>=? fun contracts ->
Client_proto_rpcs.Context.Contract.list
cctxt.rpc_config block >>=? fun contracts ->
map_s (fun h ->
begin match Contract.is_default h with
| Some m -> begin
Public_key_hash.rev_find cctxt m >>= function
| None -> Lwt.return ""
Public_key_hash.rev_find cctxt m >>=? function
| None -> return ""
| Some nm ->
RawContractAlias.find_opt cctxt nm >|= function
| None -> " (known as " ^ nm ^ ")"
| Some _ -> " (known as key:" ^ nm ^ ")"
RawContractAlias.find_opt cctxt nm >>=? function
| None -> return (" (known as " ^ nm ^ ")")
| Some _ -> return (" (known as key:" ^ nm ^ ")")
end
| None -> begin
RawContractAlias.rev_find cctxt h >|= function
| None -> ""
| Some nm -> " (known as " ^ nm ^ ")"
RawContractAlias.rev_find cctxt h >>=? function
| None -> return ""
| Some nm -> return (" (known as " ^ nm ^ ")")
end
end >>= fun nm ->
end >>=? fun nm ->
let kind = match Contract.is_default h with
| Some _ -> " (default)"
| None -> "" in
@ -220,17 +218,21 @@ let group =
let commands () =
let open Cli_entries in
let open Client_commands in
[ command ~group ~desc: "access the timestamp of the block"
[
command ~group ~desc: "access the timestamp of the block"
(fixed [ "get" ; "timestamp" ])
(fun cctxt -> get_timestamp cctxt cctxt.config.block) ;
command ~group ~desc: "lists all non empty contracts of the block"
(fixed [ "list" ; "contracts" ])
(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)
Lwt_list.iter_s
(fun (alias, hash, kind) -> cctxt.message "%s%s%s" hash kind alias)
contracts >>= fun () ->
return ()) ;
command ~group ~desc: "get the balance of a contract"
(prefixes [ "get" ; "balance" ]
@@ ContractAlias.destination_param ~name:"src" ~desc:"source contract"
@ -239,17 +241,19 @@ let commands () =
get_balance cctxt.rpc_config cctxt.config.block contract >>=? fun amount ->
cctxt.answer "%a %s" Tez.pp amount tez_sym >>= fun () ->
return ()) ;
command ~group ~desc: "get the manager of a block"
(prefixes [ "get" ; "manager" ]
@@ ContractAlias.destination_param ~name:"src" ~desc:"source contract"
@@ stop)
(fun (_, contract) cctxt ->
Client_proto_rpcs.Context.Contract.manager cctxt.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 ->
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 ());
command ~group ~desc: "open a new account"
~args: ([ fee_arg ; delegate_arg ; force_arg ]
@ delegatable_args @ spendable_args)
@ -267,8 +271,8 @@ let commands () =
~name:"src" ~desc: "name of the source contract"
@@ stop)
(fun neu (_, manager) balance (_, source) cctxt ->
check_contract cctxt neu >>= fun () ->
get_delegate_pkh cctxt !delegate >>= fun delegate ->
check_contract cctxt neu >>=? fun () ->
get_delegate_pkh cctxt !delegate >>=? fun delegate ->
(Client_proto_contracts.get_manager cctxt.rpc_config cctxt.config.block source >>=? fun src_pkh ->
Client_keys.get_key cctxt src_pkh
>>=? fun (src_name, src_pk, src_sk) ->
@ -277,8 +281,8 @@ let commands () =
~source ~src_pk ~src_sk ~manager_pkh:manager ~balance ~fee:!fee
~delegatable:!delegatable ~spendable:!spendable ?delegate:delegate
()) >>=? fun contract ->
RawContractAlias.add cctxt neu contract >>= fun () ->
return ()) ;
RawContractAlias.add cctxt neu contract) ;
command ~group ~desc: "open a new scripted account"
~args: ([ fee_arg ; delegate_arg ; force_arg ] @
delegatable_args @ spendable_args @ [ init_arg ])
@ -300,8 +304,8 @@ let commands () =
combine with -init if the storage type is not unit"
@@ stop)
(fun neu (_, manager) balance (_, source) code cctxt ->
check_contract cctxt neu >>= fun () ->
get_delegate_pkh cctxt !delegate >>= fun delegate ->
check_contract cctxt neu >>=? fun () ->
get_delegate_pkh cctxt !delegate >>=? fun delegate ->
(Client_proto_contracts.get_manager cctxt.rpc_config cctxt.config.block source >>=? fun src_pkh ->
Client_keys.get_key cctxt src_pkh
>>=? fun (src_name, src_pk, src_sk) ->
@ -310,8 +314,8 @@ let commands () =
~source ~src_pk ~src_sk ~manager_pkh:manager ~balance ~fee:!fee
~delegatable:!delegatable ?delegatePubKey:delegate ~code ~init:!init
()) >>=? fun contract ->
RawContractAlias.add cctxt neu contract >>= fun () ->
return ()) ;
RawContractAlias.add cctxt neu contract) ;
command ~group ~desc: "open a new (free) account"
~args: ([ fee_arg ; delegate_arg ; force_arg ]
@ delegatable_args @ spendable_args)
@ -323,10 +327,10 @@ let commands () =
~name: "mgr" ~desc: "manager of the new contract"
@@ stop)
(fun neu (_, manager) cctxt ->
check_contract cctxt neu >>= fun () ->
check_contract cctxt neu >>=? fun () ->
faucet cctxt cctxt.config.block ~force:!force ~manager_pkh:manager () >>=? fun contract ->
RawContractAlias.add cctxt neu contract >>= fun () ->
return ()) ;
RawContractAlias.add cctxt neu contract) ;
command ~group ~desc: "transfer tokens"
~args: [ fee_arg ; arg_arg ; force_arg ]
(prefixes [ "transfer" ]
@ -351,6 +355,7 @@ let commands () =
Contract.pp c)
contracts >>= fun () ->
return ())) ;
command ~desc: "Activate a protocol" begin
prefixes [ "activate" ; "protocol" ] @@
param ~name:"version" ~desc:"Protocol version (b58check)"
@ -363,6 +368,7 @@ let commands () =
end
(fun hash seckey cctxt ->
dictate cctxt cctxt.config.block (Activate hash) seckey) ;
command ~desc: "Fork a test protocol" begin
prefixes [ "fork" ; "test" ; "protocol" ] @@
param ~name:"version" ~desc:"Protocol version (b58check)"

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

@ -9,39 +9,43 @@
module Ed25519 = Environment.Ed25519
module RawContractAlias = Client_aliases.Alias (struct
type t = Contract.t
let encoding = Contract.encoding
let of_source _ s =
match Contract.of_b58check s with
| Error _ -> Lwt.fail (Failure "bad contract notation")
| Ok s -> Lwt.return s
let to_source _ s =
Lwt.return (Contract.to_b58check s)
let name = "contract"
end)
module ContractEntity = struct
type t = Contract.t
let encoding = Contract.encoding
let of_source _ s =
match Contract.of_b58check s with
| Error _ as err ->
Lwt.return (wrap_error err)
|> trace (failure "bad contract notation")
| Ok s -> return s
let to_source _ s = return (Contract.to_b58check s)
let name = "contract"
end
module RawContractAlias = Client_aliases.Alias (ContractEntity)
module ContractAlias = struct
let find cctxt s =
RawContractAlias.find_opt cctxt s >>= function
| Some v -> Lwt.return (s, v)
RawContractAlias.find_opt cctxt s >>=? function
| Some v -> return (s, v)
| None ->
Client_keys.Public_key_hash.find_opt cctxt s >>= function
Client_keys.Public_key_hash.find_opt cctxt s >>=? function
| Some v ->
Lwt.return (s, Contract.default_contract v)
return (s, Contract.default_contract v)
| None ->
cctxt.error
"no contract alias nor key alias names %s" s
failwith "no contract alias nor key alias names %s" s
let find_key cctxt name =
Client_keys.Public_key_hash.find cctxt name >>= fun v ->
Lwt.return (name, Contract.default_contract v)
Client_keys.Public_key_hash.find cctxt name >>=? fun v ->
return (name, Contract.default_contract v)
let rev_find cctxt c =
match Contract.is_default c with
| Some hash -> begin
Client_keys.Public_key_hash.rev_find cctxt hash >>= function
| Some name -> Lwt.return (Some ("key:" ^ name))
| None -> Lwt.return_none
Client_keys.Public_key_hash.rev_find cctxt hash >>=? function
| Some name -> return (Some ("key:" ^ name))
| None -> return None
end
| None -> RawContractAlias.rev_find cctxt c
@ -56,7 +60,12 @@ module ContractAlias = struct
desc ^ "\n"
^ "can be an contract alias or a key alias (autodetected in this order)\n\
use 'key:name' to force the later" in
Cli_entries.param ~name ~desc get_contract next
Cli_entries.param ~name ~desc
(fun cctxt p ->
get_contract cctxt p >>= function
| Ok v -> Lwt.return v
| Error err -> cctxt.error "%a" pp_print_error err)
next
let destination_param ?(name = "dst") ?(desc = "destination contract") next =
let desc =
@ -65,25 +74,28 @@ module ContractAlias = struct
use 'text:literal', 'alias:name', 'key:name' to force" in
Cli_entries.param ~name ~desc
(fun cctxt s ->
match Utils.split ~limit:1 ':' s with
| [ "alias" ; alias ]->
find cctxt alias
| [ "key" ; text ] ->
Client_keys.Public_key_hash.find cctxt text >>= fun v ->
Lwt.return (s, Contract.default_contract v)
| _ ->
Lwt.catch
(fun () -> find cctxt s)
(fun _ ->
match Contract.of_b58check s with
| Error _ -> Lwt.fail (Failure "bad contract notation")
| Ok v -> Lwt.return (s, v)))
begin
match Utils.split ~limit:1 ':' s with
| [ "alias" ; alias ]->
find cctxt alias
| [ "key" ; text ] ->
Client_keys.Public_key_hash.find cctxt text >>=? fun v ->
return (s, Contract.default_contract v)
| _ ->
find cctxt s >>= function
| Ok v -> return v
| Error _ ->
ContractEntity.of_source cctxt s >>=? fun v ->
return (s, v)
end >>= function
| Ok v -> Lwt.return v
| Error err -> cctxt.error "%a" pp_print_error err)
next
let name cctxt contract =
rev_find cctxt contract >|= function
| None -> Contract.to_b58check contract
| Some name -> name
rev_find cctxt contract >>=? function
| None -> return (Contract.to_b58check contract)
| Some name -> return name
end
@ -93,19 +105,19 @@ module Contract_tags = Client_tags.Tags (struct
let list_contracts cctxt =
(* List contracts *)
RawContractAlias.load cctxt >>= fun raw_contracts ->
Lwt_list.map_s (fun (n, v) ->
Lwt.return ("", n, v))
RawContractAlias.load cctxt >>=? fun raw_contracts ->
Lwt_list.map_s
(fun (n, v) -> Lwt.return ("", n, v))
raw_contracts >>= fun contracts ->
Client_keys.Public_key_hash.load cctxt >>= fun keys ->
Client_keys.Public_key_hash.load cctxt >>=? fun keys ->
(* List accounts (default contracts of identities) *)
Lwt_list.map_s (fun (n, v) ->
RawContractAlias.mem cctxt n >>= fun mem ->
map_s (fun (n, v) ->
RawContractAlias.mem cctxt n >>=? fun mem ->
let p = if mem then "key:" else "" in
let v' = Contract.default_contract v in
Lwt.return (p, n, v'))
keys >>= fun accounts ->
Lwt.return (contracts @ accounts)
return (p, n, v'))
keys >>=? fun accounts ->
return (contracts @ accounts)
let get_manager cctxt block source =
match Contract.is_default source with
@ -117,19 +129,22 @@ let get_delegate cctxt block source =
match Contract.is_default source with
| Some hash -> return hash
| None ->
Client_proto_rpcs.Context.Contract.delegate cctxt block source >>=? function
| Some delegate -> return delegate
| None -> Client_proto_rpcs.Context.Contract.manager cctxt block source
Client_proto_rpcs.Context.Contract.delegate cctxt
block source >>=? function
| Some delegate ->
return delegate
| None ->
Client_proto_rpcs.Context.Contract.manager cctxt block source
let may_check_key sourcePubKey sourcePubKeyHash =
match sourcePubKey with
| Some sourcePubKey ->
if not (Ed25519.Public_key_hash.equal (Ed25519.Public_key.hash sourcePubKey) sourcePubKeyHash)
then
failwith "Invalid public key in `client_proto_endorsement`"
else
return ()
| None -> return ()
fail_unless
(Ed25519.Public_key_hash.equal
(Ed25519.Public_key.hash sourcePubKey) sourcePubKeyHash)
(failure "Invalid public key in `client_proto_endorsement`")
| None ->
return ()
let check_public_key cctxt block ?src_pk src_pk_hash =
Client_proto_rpcs.Context.Key.get cctxt block src_pk_hash >>= function
@ -153,40 +168,40 @@ let commands () =
let open Cli_entries in
let open Client_commands in
[
command ~group ~desc: "add a contract to the wallet"
(prefixes [ "remember" ; "contract" ]
@@ RawContractAlias.fresh_alias_param
@@ RawContractAlias.source_param
@@ stop)
(fun name hash cctxt ->
RawContractAlias.add cctxt name hash >>= fun () ->
return ()) ;
RawContractAlias.add cctxt name hash) ;
command ~group ~desc: "remove a contract from the wallet"
(prefixes [ "forget" ; "contract" ]
@@ RawContractAlias.alias_param
@@ stop)
(fun (name, _) cctxt ->
RawContractAlias.del cctxt name >>= fun () ->
return ()) ;
(fun (name, _) cctxt -> RawContractAlias.del cctxt name) ;
command ~group ~desc: "lists all known contracts"
(fixed [ "list" ; "known" ; "contracts" ])
(fun cctxt ->
list_contracts cctxt >>= fun contracts ->
Lwt_list.iter_s (fun (prefix, alias, contract) ->
cctxt.message "%s%s: %s" prefix alias
(Contract.to_b58check contract))
contracts >>= fun () ->
return ()) ;
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"
(fixed [ "forget" ; "all" ; "contracts" ])
(fun cctxt ->
if not cctxt.config.force then
cctxt.Client_commands.error "this can only used with option -force true" >>= fun () ->
return ()
else
RawContractAlias.save cctxt [] >>= fun () ->
return ()
) ;
fail_unless
cctxt.config.force
(failure "this can only used with option -force true") >>=? fun () ->
RawContractAlias.save cctxt []) ;
command ~group ~desc: "display a contract from the wallet"
(prefixes [ "show" ; "known" ; "contract" ]
@@ RawContractAlias.alias_param
@ -194,6 +209,7 @@ let commands () =
(fun (_, contract) cctxt ->
cctxt.message "%a\n%!" Contract.pp contract >>= fun () ->
return ()) ;
command ~group ~desc: "tag a contract in the wallet"
(prefixes [ "tag" ; "contract" ]
@@ RawContractAlias.alias_param
@ -201,12 +217,13 @@ let commands () =
@@ 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
Contract_tags.find_opt cctxt alias >>=? fun tags ->
let new_tags =
match tags with
| None -> new_tags
| Some tags -> Utils.merge_list2 tags new_tags in
Contract_tags.update cctxt alias new_tags >>= fun () ->
return ()) ;
Contract_tags.update cctxt alias new_tags) ;
command ~group ~desc: "remove tag(s) from a contract in the wallet"
(prefixes [ "untag" ; "contract" ]
@@ RawContractAlias.alias_param
@ -214,8 +231,9 @@ let commands () =
@@ 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
Contract_tags.find_opt cctxt alias >>=? fun tags ->
let new_tags =
match tags with
| None -> []
| Some tags ->
Utils.merge_filter_list2
@ -224,6 +242,6 @@ let commands () =
| None, Some _ -> None
| Some t1, Some t2 when t1 = t2 -> None
| Some t1, _ -> Some t1) tags new_tags in
Contract_tags.update cctxt alias new_tags >>= fun () ->
return ()) ;
Contract_tags.update cctxt alias new_tags) ;
]

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

@ -13,7 +13,7 @@ module RawContractAlias :
module ContractAlias : sig
val get_contract:
Client_commands.context ->
string -> (string * Contract.t) Lwt.t
string -> (string * Contract.t) tzresult Lwt.t
val alias_param:
?name:string ->
?desc:string ->
@ -26,15 +26,15 @@ module ContractAlias : sig
(Lwt_io.file_name * Contract.t -> 'a, Client_commands.context, 'ret) Cli_entries.params
val rev_find:
Client_commands.context ->
Contract.t -> string option Lwt.t
Contract.t -> string option tzresult Lwt.t
val name:
Client_commands.context ->
Contract.t -> string Lwt.t
Contract.t -> string tzresult Lwt.t
end
val list_contracts:
Client_commands.context ->
(string * string * Contract.t) list Lwt.t
(string * string * Contract.t) list tzresult Lwt.t
val get_manager:
Client_rpcs.config ->

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

@ -513,8 +513,11 @@ let unexpand_macros type_map (program : Script.code) =
module Program = Client_aliases.Alias (struct
type t = Script.code
let encoding = Script.code_encoding
let of_source cctxt s = parse_program cctxt s
let to_source _ p = Lwt.return (Format.asprintf "%a" (print_program no_locations) (p, []))
let of_source cctxt s =
parse_program cctxt s >>= fun code ->
return code
let to_source _ p =
return (Format.asprintf "%a" (print_program no_locations) (p, []))
let name = "program"
end)
@ -535,34 +538,36 @@ let commands () =
Arg.Set trace_stack,
"Show the stack after each step" in
[
command ~group ~desc: "lists all known programs"
(fixed [ "list" ; "known" ; "programs" ])
(fun cctxt -> Program.load cctxt >>= fun list ->
Lwt_list.iter_s (fun (n, _) -> cctxt.message "%s" n) list >>= fun () ->
return ()) ;
(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"
(prefixes [ "remember" ; "program" ]
@@ Program.fresh_alias_param
@@ Program.source_param
@@ stop)
(fun name hash cctxt ->
Program.add cctxt name hash >>= fun () ->
return ()) ;
(fun name hash cctxt -> Program.add cctxt name hash) ;
command ~group ~desc: "forget a remembered program"
(prefixes [ "forget" ; "program" ]
@@ Program.alias_param
@@ stop)
(fun (name, _) cctxt ->
Program.del cctxt name >>= fun () ->
return ()) ;
(fun (name, _) cctxt -> Program.del cctxt name) ;
command ~group ~desc: "display a program"
(prefixes [ "show" ; "known" ; "program" ]
@@ Program.alias_param
@@ stop)
(fun (_, program) cctxt ->
Program.to_source cctxt program >>= fun source ->
Program.to_source cctxt program >>=? fun source ->
cctxt.message "%s\n" source >>= fun () ->
return ()) ;
command ~group ~desc: "ask the node to run a program"
~args: [ trace_stack_arg ]
(prefixes [ "run" ; "program" ]
@ -578,13 +583,16 @@ let commands () =
Client_proto_rpcs.Helpers.trace_code cctxt.rpc_config
cctxt.config.block program (storage, input) >>= function
| Ok (storage, output, trace) ->
cctxt.message "@[<v 0>@[<v 2>storage@,%a@]@,@[<v 2>output@,%a@]@,@[<v 2>trace@,%a@]@]@."
cctxt.message
"@[<v 0>@[<v 2>storage@,%a@]@,\
@[<v 2>output@,%a@]@,@[<v 2>trace@,%a@]@]@."
(print_expr no_locations) storage
(print_expr no_locations) output
(Format.pp_print_list
(fun ppf (loc, gas, stack) ->
Format.fprintf ppf
"- @[<v 0>location: %d (remaining gas: %d)@,[ @[<v 0>%a ]@]@]"
"- @[<v 0>location: %d (remaining gas: %d)@,\
[ @[<v 0>%a ]@]@]"
loc gas
(Format.pp_print_list (print_expr no_locations))
stack))
@ -606,6 +614,7 @@ let commands () =
cctxt.warning "%a" pp_print_error errs >>= fun () ->
cctxt.error "error running program" >>= fun () ->
return ()) ;
command ~group ~desc: "ask the node to typecheck a program"
~args: [ show_types_arg ]
(prefixes [ "typecheck" ; "program" ]
@ -624,6 +633,7 @@ let commands () =
| Error errs ->
report_typechecking_errors cctxt errs >>= fun () ->
cctxt.error "ill-typed program") ;
command ~group ~desc: "ask the node to typecheck a data expression"
(prefixes [ "typecheck" ; "data" ]
@@ Cli_entries.param ~name:"data" ~desc:"the data to typecheck" parse_data
@ -641,6 +651,7 @@ let commands () =
report_typechecking_errors cctxt errs >>= fun () ->
cctxt.error "ill-typed data" >>= fun () ->
return ()) ;
command ~group
~desc: "ask the node to compute the hash of a data expression \
using the same algorithm as script instruction H"
@ -658,6 +669,7 @@ let commands () =
cctxt.warning "%a" pp_print_error errs >>= fun () ->
cctxt.error "ill-formed data" >>= fun () ->
return ()) ;
command ~group
~desc: "ask the node to compute the hash of a data expression \
using the same algorithm as script instruction H, sign it using \
@ -684,4 +696,5 @@ let commands () =
cctxt.warning "%a" pp_print_error errs >>= fun () ->
cctxt.error "ill-formed data" >>= fun () ->
return ()) ;
]

6
src/utils/error_monad.ml
View File

@ -358,8 +358,14 @@ type error += Exn of exn
let error s = Error [ s ]
let error_exn s = Error [ Exn s ]
let trace_exn exn f = trace (Exn exn) f
let generic_trace fmt =
Format.kasprintf (fun str -> trace_exn (Failure str)) fmt
let record_trace_exn exn f = record_trace (Exn exn) f
let failure fmt =
Format.kasprintf (fun str -> Exn (Failure str)) fmt
let protect ?on_error t =
Lwt.catch t (fun exn -> fail (Exn exn)) >>= function
| Ok res -> return res

5
src/utils/error_monad.mli
View File

@ -35,8 +35,13 @@ val protect :
val error_exn : exn -> 'a tzresult
val record_trace_exn : exn -> 'a tzresult -> 'a tzresult
val trace_exn : exn -> 'b tzresult Lwt.t -> 'b tzresult Lwt.t
val generic_trace :
('a, Format.formatter, unit,
('b, error list) result Lwt.t -> ('b, error list) result Lwt.t) format4 -> 'a
val pp_exn : Format.formatter -> exn -> unit
val failure : ('a, Format.formatter, unit, error) format4 -> 'a
type error += Exn of exn
type error += Unclassified of string