Client: more Error_monad in Client_aliases

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
+    if not (Sys.file_exists filename) then
-      Data_encoding_ezjsonm.read_file filename >>= function
+      return []
-      | Error _ ->
+    else
-          cctxt.Client_commands.error
+      Data_encoding_ezjsonm.read_file filename
-            "couldn't to read the %s alias file" Entity.name
+      |> generic_trace
-      | Ok json ->
+        "couldn't to read the %s alias file" Entity.name >>=? fun json ->
-          match Data_encoding.Json.destruct encoding json with
+      match Data_encoding.Json.destruct encoding json with
-          | exception _ -> (* TODO print_error *)
+      | exception _ -> (* TODO print_error *)
-              cctxt.Client_commands.error
+          failwith "didn't understand the %s alias file" Entity.name
-                "didn't understand the %s alias file" Entity.name
+      | list ->
-          | list ->
+          return list
-              Lwt.return list
 
   let find_opt cctxt name =
-    load cctxt >>= fun list ->
+    load cctxt >>=? fun list ->
-    try Lwt.return (Some (List.assoc name list))
+    try return (Some (List.assoc name list))
-    with Not_found -> Lwt.return_none
+    with Not_found -> return None
 
   let find cctxt name =
-    load cctxt >>= fun list ->
+    load cctxt >>=? fun list ->
-    try Lwt.return (List.assoc name 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 ->
+    load cctxt >>=? fun list ->
-    try Lwt.return (Some (List.find (fun (_, v') -> v = v') list |> fst))
+    try return (Some (List.find (fun (_, v') -> v = v') list |> fst))
-    with Not_found -> Lwt.return_none
+    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
+         Lwt_utils.create_dir dirname >>= fun () ->
-          else Lwt.return ()) >>= fun () ->
          let filename = filename cctxt in
          let json = Data_encoding.Json.construct encoding list in
-         Data_encoding_ezjsonm.write_file filename json >>= function
+         Data_encoding_ezjsonm.write_file filename json)
-         | Error _ -> Lwt.fail (Failure "Json.write_file")
+      (fun exn -> Lwt.return (error_exn exn))
-         | Ok () -> Lwt.return ())
+    |> generic_trace "could not write the %s alias file." Entity.name
-      (fun exn ->
-         cctxt.Client_commands.error
-           "could not write the %s alias file: %s."
-           Entity.name (Printexc.to_string exn))
 
   let add cctxt name value =
     let keep = ref false in
-    load cctxt >>= fun list ->
+    load cctxt >>=? fun list ->
-    (if not cctxt.config.force then
+    begin
-       Lwt_list.iter_s (fun (n, v) ->
+      if cctxt.config.force then
-           if n = name && v = value then
+        return ()
-             (keep := true ;
+      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)
+                "The %s alias %s already exists with the same value."
-           else if n = name && v <> value then
+                Entity.name n >>= fun () ->
-             cctxt.error
+              return ()
-               "another %s is already aliased as %s, use -force true to update" Entity.name n
+            end else if n = name && v <> value then begin
-           else if n <> name && v = value then
+              failwith
-             cctxt.error
+                "another %s is already aliased as %s, \
-               "this %s is already aliased as %s, use -force true to insert duplicate" Entity.name n
+                 use -force true to update"
-           else Lwt.return ())
+                Entity.name n
-         list else Lwt.return ()) >>= fun () ->
+            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 =
+  let alias_param
-    param ~name ~desc
+      ?(name = "name") ?(desc = "existing " ^ Entity.name ^ " alias") next =
-      (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 =
     param ~name ~desc
       (fun cctxt s ->
-         load cctxt >>= fun list ->
+         find cctxt s >>= function
-         if not cctxt.config.force then
+         | Ok v -> Lwt.return (s, v)
-           Lwt_list.iter_s (fun (n, _v) ->
+         | Error err -> cctxt.error "%a" pp_print_error err)
-               if n = s then
+      next
-                 cctxt.Client_commands.error
+
-                   "the %s alias %s already exists, use -force true to update" Entity.name n
+  let fresh_alias_param
-               else Lwt.return ())
+      ?(name = "new") ?(desc = "new " ^ Entity.name ^ " alias") next =
-             list >>= fun () ->
+    param ~name ~desc
-           Lwt.return s
+      (fun cctxt s ->
-         else Lwt.return 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 () ->
-             (fun exn -> Lwt.fail_with @@ Format.asprintf "cannot read file (%s)" (Printexc.to_string exn))
+                Lwt_io.(with_file ~mode:Input path read) >>= fun content ->
-           >>= of_source cctxt in
+                return content)
-         match Utils.split ~limit:1 ':' s with
+             (fun exn ->
-         | [ "alias" ; alias ]->
+                failwith
-             find cctxt alias
+                  "cannot read file (%s)" (Printexc.to_string exn))
-         | [ "text" ; text ] ->
+           >>=? fun content ->
-             of_source cctxt text
+           of_source cctxt content in
-         | [ "file" ; path ] ->
+         begin
-             read path
+           match Utils.split ~limit:1 ':' s with
-         | _ ->
+           | [ "alias" ; alias ]->
-             Lwt.catch
+               find cctxt alias
-               (fun () -> find cctxt s)
+           | [ "text" ; text ] ->
-               (fun _ ->
+               of_source cctxt text
-                  Lwt.catch
+           | [ "file" ; path ] ->
-                    (fun () -> read s)
+               read path
-                    (fun _ -> of_source cctxt s)))
+           | _ ->
+               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

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

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 of_source _ s =
-    let to_source _ p = Lwt.return (Ed25519.Public_key_hash.to_b58check p)
+      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 of_source _ s =
-    let to_source _ p = Lwt.return (Ed25519.Public_key.to_b58check p)
+      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 of_source _ s =
-    let to_source _ p = Lwt.return (Ed25519.Secret_key.to_b58check p)
+      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 () ->
+  Secret_key.add cctxt name secret_key >>=? fun () ->
-  Public_key.add cctxt name public_key >>= fun () ->
+  Public_key.add cctxt name public_key >>=? fun () ->
-  Public_key_hash.add cctxt name (Ed25519.Public_key.hash public_key) >>= fun () ->
+  Public_key_hash.add
-  cctxt.message "I generated a brand new pair of keys under the name '%s'." name >>= fun () ->
+    cctxt name (Ed25519.Public_key.hash public_key) >>=? fun () ->
+  cctxt.message
+    "I generated a brand new pair of keys under the name '%s'." name >>= fun () ->
   return ()
 
 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 ->
+      Public_key.find cctxt n >>=? fun pk ->
-      Secret_key.find cctxt n >>= fun sk ->
+      Secret_key.find cctxt n >>=? fun sk ->
       return (n, pk, sk)
 
 let get_keys cctxt =
-  Secret_key.load cctxt >>=
+  Secret_key.load cctxt >>=? fun sks ->
-  Lwt_list.filter_map_p begin fun (name, sk) ->
+  map_filter_s
-    Lwt.catch begin fun () ->
+    (fun (name, sk) ->
-      Public_key.find cctxt name >>= fun pk ->
+       Lwt.catch begin fun () ->
-      Public_key_hash.find cctxt name >>= fun pkh ->
+         Public_key.find cctxt name >>=? fun pk ->
-      Lwt.return (Some (name, pkh, pk, sk))
+         Public_key_hash.find cctxt name >>=? fun pkh ->
-    end begin fun _ ->
+         return (Some (name, pkh, pk, sk))
-      Lwt.return_none
+       end begin fun _ ->
-    end
+         return None
-  end
+       end)
+    sks
 
 let list_keys cctxt =
-  Public_key_hash.load cctxt >>= fun l ->
+  Public_key_hash.load cctxt >>=? fun l ->
-  Lwt_list.map_s (fun (name, pkh) ->
+  map_s
-      Public_key.mem cctxt name >>= fun pkm ->
+    (fun (name, pkh) ->
-      Secret_key.mem cctxt name >>= fun pks ->
+       Public_key.mem cctxt name >>=? fun pkm ->
-      Lwt.return (name, pkh, pkm, pks))
+       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
+         Public_key.find_opt cctxt name >>=? function
-           Lwt.catch (fun () ->
+         | None ->
-               Public_key.find cctxt name >>= fun pk ->
+             failwith
-               if check_keys_consistency pk sk || cctxt.config.force then
+               "no public key named '%s', add it before adding the secret key"
-                 Secret_key.add cctxt name sk
+               name
-               else
+         | Some pk ->
-                 cctxt.error
+             fail_unless
-                   "public and secret keys '%s' don't correspond, \
+               (check_keys_consistency pk sk || cctxt.config.force)
-                  please don't use -force true" name)
+               (failure
-             (function
+                  "public and secret keys '%s' don't correspond, \
-               | Not_found ->
+                   please don't use -force true" name) >>=? fun () ->
-                   cctxt.error
+             Secret_key.add cctxt name sk) ;
-                     "no public key named '%s', add it before adding the secret key" name
+
-               | exn -> Lwt.fail exn)
-         end >>= fun () ->
-         return ()) ;
     command ~group ~desc: "add a public key to the wallet"
       (prefixes [ "add" ; "public" ; "key" ]
        @@ Public_key.fresh_alias_param
        @@ Public_key.source_param
        @@ stop)
       (fun name key cctxt ->
-         Public_key_hash.add cctxt name (Ed25519.Public_key.hash key) >>= fun () ->
+         Public_key_hash.add cctxt
-         Public_key.add cctxt name key >>= fun () ->
+           name (Ed25519.Public_key.hash key) >>=? fun () ->
-         return ()) ;
+         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 ->
+      (fun name hash cctxt -> Public_key_hash.add cctxt name hash) ;
-         Public_key_hash.add cctxt name hash >>= fun () ->
+
-         return ()) ;
     command ~group ~desc: "list all public key hashes and associated keys"
       (fixed [ "list" ; "known" ; "identities" ])
       (fun cctxt ->
-         list_keys cctxt >>= fun l ->
+         list_keys cctxt >>=? fun l ->
-         Lwt_list.iter_s (fun (name, pkh, pkm, pks) ->
+         iter_s
-             Public_key_hash.to_source cctxt pkh >>= fun v ->
+           (fun (name, pkh, pkm, pks) ->
-             cctxt.message "%s: %s%s%s" name v
+              Public_key_hash.to_source cctxt pkh >>=? fun v ->
-               (if pkm then " (public key known)" else "")
+              cctxt.message "%s: %s%s%s" name v
-               (if pks then " (secret key known)" else ""))
+                (if pkm then " (public key known)" else "")
-           l >>= fun () ->
+                (if pks then " (secret key known)" else "") >>= fun () ->
-         return ()) ;
+              return ())
+           l) ;
+
     command ~group ~desc: "forget all keys"
       (fixed [ "forget" ; "all" ; "keys" ])
       (fun cctxt ->
-         begin
+         fail_unless cctxt.config.force
-           if not cctxt.config.force then
+           (failure "this can only used with option -force true") >>=? fun () ->
-             cctxt.Client_commands.error "this can only used with option -force true"
+         Public_key.save cctxt [] >>=? fun () ->
-           else
+         Secret_key.save cctxt [] >>=? fun () ->
-             Public_key.save cctxt [] >>= fun () ->
+         Public_key_hash.save cctxt []) ;
-             Secret_key.save cctxt [] >>= fun () ->
+
-             Public_key_hash.save cctxt []
+  ]
-         end >>= fun () ->
-         return ()) ;
-     ]

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

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 =

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 ->
+          e.Client_mining_operations.source >>= function
-        lwt_debug
+        | Ok source ->
-          "Discovered endorsement for block %a by %s (slot @[<h>%a@])"
+            lwt_debug
-          Block_hash.pp_short e.block
+              "Discovered endorsement for block %a by %s (slot @[<h>%a@])"
-          source
+              Block_hash.pp_short e.block
-          Format.(pp_print_list pp_print_int) e.slots >>= fun () ->
+              source
-        worker_loop () in
+              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 ()

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
         "@[<v 2>Error(s) while scheduling endorsements@,%a@]"

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

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
+      Public_key_hash.find_opt cctxt delegate
-        (fun () ->
-           Public_key_hash.find cctxt delegate >>= fun r ->
-           Lwt.return (Some r))
-        (fun _ -> Lwt.return None)
 
 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
+            Public_key_hash.rev_find cctxt m >>=? function
-            | None -> ""
+            | None -> return ""
-            | Some nm -> nm
+            | Some nm -> return nm
           end
         | None -> begin
-            RawContractAlias.rev_find cctxt h >|= function
+            RawContractAlias.rev_find cctxt h >>=? function
-            | None -> ""
+            | None -> return ""
-            | Some nm -> nm
+            | 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
+            Public_key_hash.rev_find cctxt m >>=? function
-            | None -> Lwt.return ""
+            | None -> return ""
             | Some nm ->
-                RawContractAlias.find_opt cctxt nm >|= function
+                RawContractAlias.find_opt cctxt nm >>=? function
-                | None -> " (known as " ^ nm ^ ")"
+                | None -> return (" (known as " ^ nm ^ ")")
-                | Some _ -> " (known as key:" ^ nm ^ ")"
+                | Some _ -> return (" (known as key:" ^ nm ^ ")")
           end
         | None -> begin
-            RawContractAlias.rev_find cctxt h >|= function
+            RawContractAlias.rev_find cctxt h >>=? function
-            | None -> ""
+            | None -> return ""
-            | Some nm ->  " (known as " ^ nm ^ ")"
+            | 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) ->
+         Lwt_list.iter_s
-             cctxt.message "%s%s%s" hash kind alias)
+           (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.rev_find cctxt manager >>=? fun mn ->
-         Public_key_hash.to_source cctxt manager >>= fun m ->
+         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 () ->
+         check_contract cctxt neu >>=? fun () ->
-         get_delegate_pkh cctxt !delegate >>= fun delegate ->
+         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 () ->
+         RawContractAlias.add cctxt neu contract) ;
-         return ()) ;
+
     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 () ->
+         check_contract cctxt neu >>=? fun () ->
-         get_delegate_pkh cctxt !delegate >>= fun delegate ->
+         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 () ->
+         RawContractAlias.add cctxt neu contract) ;
-         return ()) ;
+
     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 () ->
+         RawContractAlias.add cctxt neu contract) ;
-         return ()) ;
+
     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)"

src/client/embedded/alpha/client_proto_contracts.ml

@@ -9,39 +9,43 @@
 
 module Ed25519 = Environment.Ed25519
 
-module RawContractAlias = Client_aliases.Alias (struct
+module ContractEntity = struct
-    type t = Contract.t
+  type t = Contract.t
-    let encoding = Contract.encoding
+  let encoding = Contract.encoding
-    let of_source _ s =
+  let of_source _ s =
-      match Contract.of_b58check s with
+    match Contract.of_b58check s with
-      | Error _ -> Lwt.fail (Failure "bad contract notation")
+    | Error _ as err ->
-      | Ok s -> Lwt.return s
+        Lwt.return (wrap_error err)
-    let to_source _ s =
+        |> trace (failure "bad contract notation")
-      Lwt.return (Contract.to_b58check s)
+    | Ok s -> return s
-    let name = "contract"
+  let to_source _ s = return (Contract.to_b58check s)
-  end)
+  let name = "contract"
+end
+
+module RawContractAlias = Client_aliases.Alias (ContractEntity)
 
 module ContractAlias = struct
+
   let find cctxt s =
-    RawContractAlias.find_opt cctxt s >>= function
+    RawContractAlias.find_opt cctxt s >>=? function
-    | Some v -> Lwt.return (s, v)
+    | 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
+            failwith "no contract alias nor key alias names %s" s
-              "no contract alias nor key alias names %s" s
+
   let find_key cctxt name =
-    Client_keys.Public_key_hash.find cctxt name >>= fun v ->
+    Client_keys.Public_key_hash.find cctxt name >>=? fun v ->
-    Lwt.return (name, Contract.default_contract 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
+        Client_keys.Public_key_hash.rev_find cctxt hash >>=? function
-        | Some name -> Lwt.return (Some ("key:" ^ name))
+        | Some name -> return (Some ("key:" ^ name))
-        | None -> Lwt.return_none
+        | 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
+         begin
-         | [ "alias" ; alias ]->
+           match Utils.split ~limit:1 ':' s with
-             find cctxt alias
+           | [ "alias" ; alias ]->
-         | [ "key" ; text ] ->
+               find cctxt alias
-             Client_keys.Public_key_hash.find cctxt text >>= fun v ->
+           | [ "key" ; text ] ->
-             Lwt.return (s, Contract.default_contract v)
+               Client_keys.Public_key_hash.find cctxt text >>=? fun v ->
-         | _ ->
+               return (s, Contract.default_contract v)
-             Lwt.catch
+           | _ ->
-               (fun () -> find cctxt s)
+               find  cctxt s >>= function
-               (fun _ ->
+               | Ok v -> return v
-                  match Contract.of_b58check s with
+               | Error _ ->
-                  | Error _ -> Lwt.fail (Failure "bad contract notation")
+                   ContractEntity.of_source cctxt s >>=? fun v ->
-                  | Ok v -> Lwt.return (s, 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
+     rev_find cctxt contract >>=? function
-     | None -> Contract.to_b58check contract
+     | None -> return (Contract.to_b58check contract)
-     | Some name -> name
+     | 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 ->
+  RawContractAlias.load cctxt >>=? fun raw_contracts ->
-  Lwt_list.map_s (fun (n, v) ->
+  Lwt_list.map_s
-      Lwt.return ("", n, v))
+    (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) ->
+  map_s (fun (n, v) ->
-      RawContractAlias.mem cctxt n >>= fun mem ->
+      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'))
+      return (p, n, v'))
-    keys >>= fun accounts ->
+    keys >>=? fun accounts ->
-  Lwt.return (contracts @ 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
+      Client_proto_rpcs.Context.Contract.delegate cctxt
-      | Some delegate -> return delegate
+        block source >>=? function
-      | None -> Client_proto_rpcs.Context.Contract.manager cctxt block source
+      | 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)
+      fail_unless
-      then
+        (Ed25519.Public_key_hash.equal
-        failwith "Invalid public key in `client_proto_endorsement`"
+           (Ed25519.Public_key.hash sourcePubKey) sourcePubKeyHash)
-      else
+        (failure "Invalid public key in `client_proto_endorsement`")
-        return ()
+  | None ->
-  | None -> return ()
+      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 () ->
+         RawContractAlias.add cctxt name hash) ;
-         return ()) ;
+
     command ~group ~desc: "remove a contract from the wallet"
       (prefixes [ "forget" ; "contract" ]
        @@ RawContractAlias.alias_param
        @@ stop)
-      (fun (name, _) cctxt ->
+      (fun (name, _) cctxt -> RawContractAlias.del cctxt name) ;
-         RawContractAlias.del cctxt name >>= fun () ->
+
-         return ()) ;
     command ~group ~desc: "lists all known contracts"
       (fixed [ "list" ; "known" ; "contracts" ])
       (fun cctxt ->
-         list_contracts cctxt >>= fun contracts ->
+         list_contracts cctxt >>=? fun contracts ->
-         Lwt_list.iter_s (fun (prefix, alias, contract) ->
+         iter_s
-             cctxt.message "%s%s: %s" prefix alias
+           (fun (prefix, alias, contract) ->
-               (Contract.to_b58check contract))
+              cctxt.message "%s%s: %s" prefix alias
-           contracts >>= fun () ->
+                (Contract.to_b58check contract) >>= fun () ->
-         return ()) ;
+              return ())
+           contracts) ;
+
     command ~group ~desc: "forget all known contracts"
       (fixed [ "forget" ; "all" ; "contracts" ])
       (fun cctxt ->
-           if not cctxt.config.force then
+         fail_unless
-             cctxt.Client_commands.error "this can only used with option -force true" >>= fun () ->
+           cctxt.config.force
-             return ()
+           (failure "this can only used with option -force true") >>=? fun () ->
-           else
+         RawContractAlias.save cctxt []) ;
-             RawContractAlias.save cctxt [] >>= fun () ->
+
-             return ()
-      ) ;
     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 ->
+         Contract_tags.find_opt cctxt alias >>=? fun tags ->
-         let new_tags = match tags with
+         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 () ->
+         Contract_tags.update cctxt alias new_tags) ;
-         return ()) ;
+
     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 ->
+         Contract_tags.find_opt cctxt alias >>=? fun tags ->
-         let new_tags = match tags with
+         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 () ->
+         Contract_tags.update cctxt alias new_tags) ;
-         return ()) ;
+
   ]

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

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 of_source cctxt s =
-    let to_source _ p = Lwt.return (Format.asprintf "%a" (print_program no_locations) (p, []))
+      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 ->
+      (fun cctxt ->
-        Lwt_list.iter_s (fun (n, _) -> cctxt.message "%s" n) list >>= fun () ->
+         Program.load cctxt >>=? fun list ->
-        return ()) ;
+         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 ->
+      (fun name hash cctxt -> Program.add cctxt name hash) ;
-         Program.add cctxt name hash >>= fun () ->
+
-        return ()) ;
     command ~group ~desc: "forget a remembered program"
       (prefixes [ "forget" ; "program" ]
        @@ Program.alias_param
        @@ stop)
-      (fun (name, _) cctxt ->
+      (fun (name, _) cctxt -> Program.del cctxt name) ;
-         Program.del cctxt name >>= fun () ->
+
-        return ()) ;
     command ~group ~desc: "display a program"
       (prefixes [ "show" ; "known" ; "program" ]
        @@ Program.alias_param
        @@ stop)
       (fun (_, program) cctxt ->
-         Program.to_source cctxt program >>= fun source ->
+         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 ()) ;
+
   ]

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

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