diff --git a/src/client/client_aliases.ml b/src/client/client_aliases.ml index 7287ff180..6e2f7fe0a 100644 --- a/src/client/client_aliases.ml +++ b/src/client/client_aliases.ml @@ -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 diff --git a/src/client/client_aliases.mli b/src/client/client_aliases.mli index eaa8bc50c..8f832a587 100644 --- a/src/client/client_aliases.mli +++ b/src/client/client_aliases.mli @@ -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 -> diff --git a/src/client/client_keys.ml b/src/client/client_keys.ml index 2d219070c..1d2ef70aa 100644 --- a/src/client/client_keys.ml +++ b/src/client/client_keys.ml @@ -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 []) ; + + ] diff --git a/src/client/client_keys.mli b/src/client/client_keys.mli index edc4289c6..0da4d6dcb 100644 --- a/src/client/client_keys.mli +++ b/src/client/client_keys.mli @@ -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 -> diff --git a/src/client/client_tags.ml b/src/client/client_tags.ml index fb82e31a8..9eaa7ed26 100644 --- a/src/client/client_tags.ml +++ b/src/client/client_tags.ml @@ -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 = diff --git a/src/client/embedded/alpha/baker/client_mining_denunciation.ml b/src/client/embedded/alpha/baker/client_mining_denunciation.ml index 7c640c251..1454c1a56 100644 --- a/src/client/embedded/alpha/baker/client_mining_denunciation.ml +++ b/src/client/embedded/alpha/baker/client_mining_denunciation.ml @@ -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 @[%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 @[%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 () diff --git a/src/client/embedded/alpha/baker/client_mining_endorsement.ml b/src/client/embedded/alpha/baker/client_mining_endorsement.ml index 098974b75..179b91e71 100644 --- a/src/client/embedded/alpha/baker/client_mining_endorsement.ml +++ b/src/client/embedded/alpha/baker/client_mining_endorsement.ml @@ -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 "@[Error(s) while scheduling endorsements@,%a@]" diff --git a/src/client/embedded/alpha/baker/client_mining_forge.ml b/src/client/embedded/alpha/baker/client_mining_forge.ml index 51f96bd6e..3ec313828 100644 --- a/src/client/embedded/alpha/baker/client_mining_forge.ml +++ b/src/client/embedded/alpha/baker/client_mining_forge.ml @@ -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)" diff --git a/src/client/embedded/alpha/client_proto_context.ml b/src/client/embedded/alpha/client_proto_context.ml index f76310720..2a51c3598 100644 --- a/src/client/embedded/alpha/client_proto_context.ml +++ b/src/client/embedded/alpha/client_proto_context.ml @@ -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)" diff --git a/src/client/embedded/alpha/client_proto_contracts.ml b/src/client/embedded/alpha/client_proto_contracts.ml index a25d2ef1c..25d9d359b 100644 --- a/src/client/embedded/alpha/client_proto_contracts.ml +++ b/src/client/embedded/alpha/client_proto_contracts.ml @@ -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) ; + ] diff --git a/src/client/embedded/alpha/client_proto_contracts.mli b/src/client/embedded/alpha/client_proto_contracts.mli index c1d1eeb7c..4d2065802 100644 --- a/src/client/embedded/alpha/client_proto_contracts.mli +++ b/src/client/embedded/alpha/client_proto_contracts.mli @@ -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 -> diff --git a/src/client/embedded/alpha/client_proto_programs.ml b/src/client/embedded/alpha/client_proto_programs.ml index 0bdbf37d5..f39e75b56 100644 --- a/src/client/embedded/alpha/client_proto_programs.ml +++ b/src/client/embedded/alpha/client_proto_programs.ml @@ -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 "@[@[storage@,%a@]@,@[output@,%a@]@,@[trace@,%a@]@]@." + cctxt.message + "@[@[storage@,%a@]@,\ + @[output@,%a@]@,@[trace@,%a@]@]@." (print_expr no_locations) storage (print_expr no_locations) output (Format.pp_print_list (fun ppf (loc, gas, stack) -> Format.fprintf ppf - "- @[location: %d (remaining gas: %d)@,[ @[%a ]@]@]" + "- @[location: %d (remaining gas: %d)@,\ + [ @[%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 ()) ; + ] diff --git a/src/utils/error_monad.ml b/src/utils/error_monad.ml index 5f859ecac..85dd780c4 100644 --- a/src/utils/error_monad.ml +++ b/src/utils/error_monad.ml @@ -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 diff --git a/src/utils/error_monad.mli b/src/utils/error_monad.mli index 77c041b6d..0b8bef0f7 100644 --- a/src/utils/error_monad.mli +++ b/src/utils/error_monad.mli @@ -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