Shell: Use Error_monad in Data_encoding_ezjsonm

src/Makefile

@@ -168,12 +168,12 @@ UTILS_LIB_INTFS := \
 UTILS_LIB_IMPLS := \
   utils/base48.ml \
   utils/cli_entries.ml \
+  utils/error_monad_sig.ml \
+  utils/error_monad.ml \
   utils/data_encoding_ezjsonm.ml \
   utils/time.ml \
   utils/hash.ml \
   utils/crypto_box.ml \
-  utils/error_monad_sig.ml \
-  utils/error_monad.ml \
   utils/lwt_exit.ml \
   utils/logging.ml \
   utils/lwt_utils.ml \

src/client/client_aliases.ml

@@ -88,10 +88,10 @@ module Alias = functor (Entity : Entity) -> struct
     let filename = filename () in
     if not (Sys.file_exists filename) then return [] else
       Data_encoding_ezjsonm.read_file filename >>= function
-      | None ->
+      | Error _ ->
           cctxt.Client_commands.error
             "couldn't to read the %s alias file" Entity.name
-      | Some json ->
+      | Ok json ->
           match Data_encoding.Json.destruct encoding json with
           | exception _ -> (* TODO print_error *)
               cctxt.Client_commands.error
@@ -132,8 +132,8 @@ module Alias = functor (Entity : Entity) -> struct
          let filename = filename () in
          let json = Data_encoding.Json.construct encoding list in
          Data_encoding_ezjsonm.write_file filename json >>= function
-         | false -> fail (Failure "Json.write_file")
+         | Error _ -> fail (Failure "Json.write_file")
-         | true -> return ())
+         | Ok () -> return ())
       (fun exn ->
          cctxt.Client_commands.error
            "could not write the %s alias file: %s."

src/client/embedded/bootstrap/client_proto_nonces.ml

@@ -29,8 +29,9 @@ let load cctxt =
     Lwt.return []
   else
     Data_encoding_ezjsonm.read_file filename >>= function
-    | None -> cctxt.Client_commands.error "couldn't to read the nonces file"
+    | Error _ ->
-    | Some json ->
+        cctxt.Client_commands.error "couldn't to read the nonces file"
+    | Ok json ->
         match Data_encoding.Json.destruct encoding json with
         | exception _ -> (* TODO print_error *)
             cctxt.Client_commands.error "didn't understand the nonces file"
@@ -51,8 +52,8 @@ let save cctxt list =
        let filename = filename () in
        let json = Data_encoding.Json.construct encoding list in
        Data_encoding_ezjsonm.write_file filename json >>= function
-       | false -> failwith "Json.write_file"
+       | Error _ -> failwith "Json.write_file"
-       | true -> return ())
+       | Ok () -> return ())
     (fun exn ->
        cctxt.Client_commands.error
          "could not write the nonces file: %s." (Printexc.to_string exn))

src/client/embedded/bootstrap/mining/client_mining_endorsement.ml

@@ -51,9 +51,9 @@ end = struct
     let filename = filename () in
     if not (Sys.file_exists filename) then return LevelMap.empty else
       Data_encoding_ezjsonm.read_file filename >>= function
-      | None ->
+      | Error _ ->
           cctxt.Client_commands.error "couldn't to read the endorsement file"
-      | Some json ->
+      | Ok json ->
           match Data_encoding.Json.destruct encoding json with
           | exception _ -> (* TODO print_error *)
               cctxt.Client_commands.error "didn't understand the endorsement file"
@@ -69,8 +69,8 @@ end = struct
          let filename = filename () in
          let json = Data_encoding.Json.construct encoding map in
          Data_encoding_ezjsonm.write_file filename json >>= function
-         | false -> failwith "Json.write_file"
+         | Error _ -> failwith "Json.write_file"
-         | true -> return ())
+         | Ok () -> return ())
       (fun exn ->
          cctxt.Client_commands.error "could not write the endorsement file: %s."
            (Printexc.to_string exn))

src/client/embedded/bootstrap/mining/client_mining_forge.ml

@@ -171,9 +171,9 @@ end = struct
     let filename = filename () in
     if not (Sys.file_exists filename) then return LevelMap.empty else
       Data_encoding_ezjsonm.read_file filename >>= function
-      | None ->
+      | Error _ ->
           failwith "couldn't to read the block file"
-      | Some json ->
+      | Ok json ->
           match Data_encoding.Json.destruct encoding json with
           | exception _ -> (* TODO print_error *)
               failwith "didn't understand the block file"
@@ -189,8 +189,8 @@ end = struct
          let filename = filename () in
          let json = Data_encoding.Json.construct encoding map in
          Data_encoding_ezjsonm.write_file filename json >>= function
-         | false -> failwith "Json.write_file"
+         | Error _ -> failwith "Json.write_file"
-         | true -> return ())
+         | Ok () -> return ())
       (fun exn ->
          Error_monad.failwith
            "could not write the block file: %s."

src/node/net/p2p_connection_pool.ml

@@ -634,16 +634,16 @@ let create config meta_config message_config io_sched =
     events ;
   } in
   List.iter (Points.set_trusted pool) config.trusted_points ;
-  Lwt.catch
+  Gid_info.File.load config.peers_file meta_config.encoding >>= function
-    (fun () ->
+  | Ok gids ->
-       Gid_info.File.load config.peers_file meta_config.encoding)
+      List.iter
-    (fun _ ->
+        (fun gi -> Gid.Table.add pool.known_gids (Gid_info.gid gi) gi)
-       (* TODO log error *)
+        gids ;
-       Lwt.return_nil) >>= fun gids ->
+      Lwt.return pool
-  List.iter
+  | Error err ->
-    (fun gi -> Gid.Table.add pool.known_gids (Gid_info.gid gi) gi)
+      log_error "@[Failed to parsed peers file:@ %a@]"
-    gids ;
+        pp_print_error err ;
-  Lwt.return pool
+      Lwt.return pool
 
 let destroy pool =
   Point.Table.fold (fun _point pi acc ->

src/node/net/p2p_connection_pool_types.ml

@@ -449,9 +449,11 @@ module Gid_info = struct
 
     let load path metadata_encoding =
       let enc = Data_encoding.list (encoding metadata_encoding) in
-      Data_encoding_ezjsonm.read_file path >|=
+      if Sys.file_exists path then
-      map_option ~f:(Data_encoding.Json.destruct enc) >|=
+        Data_encoding_ezjsonm.read_file path >>=? fun json ->
-      unopt ~default:[]
+        return (Data_encoding.Json.destruct enc json)
+      else
+        return []
 
     let save path metadata_encoding peers =
       let open Data_encoding in

src/node/net/p2p_connection_pool_types.mli

@@ -256,10 +256,10 @@ module Gid_info : sig
   module File : sig
     val load :
       string -> 'meta Data_encoding.t ->
-      ('conn, 'meta) gid_info list Lwt.t
+      ('conn, 'meta) gid_info list tzresult Lwt.t
     val save :
       string -> 'meta Data_encoding.t ->
-      ('conn, 'meta) gid_info list -> bool Lwt.t
+      ('conn, 'meta) gid_info list -> unit tzresult Lwt.t
   end
 
 end

src/node_main.ml

@@ -238,8 +238,8 @@ module Cfg_file = struct
 
   let read fp =
     Data_encoding_ezjsonm.read_file fp >|= function
-    | None -> None
+    | Error _ -> None
-    | Some json -> Some (Data_encoding.Json.destruct t json)
+    | Ok json -> Some (Data_encoding.Json.destruct t json)
 
   let from_json json = Data_encoding.Json.destruct t json
   let write out cfg =
@@ -439,12 +439,12 @@ let init_node
         | None -> Lwt.return (Some (patch_context None))
         | Some file ->
             Data_encoding_ezjsonm.read_file file >>= function
-            | None ->
+            | Error _ ->
                 lwt_warn
                   "Can't parse sandbox parameters. (%s)" file >>= fun () ->
                 Lwt.return (Some (patch_context None))
-            | Some _ as json ->
+            | Ok json ->
-                Lwt.return (Some (patch_context json))
+                Lwt.return (Some (patch_context (Some json)))
   end >>= fun patch_context ->
   let net_params =
     let open P2p in

src/utils/data_encoding_ezjsonm.ml

@@ -7,6 +7,8 @@
 (*                                                                        *)
 (**************************************************************************)
 
+open Error_monad
+
 let to_root = function
   | `O ctns -> `O ctns
   | `A ctns -> `A ctns
@@ -35,22 +37,21 @@ let from_stream (stream: string Lwt_stream.t) =
 
 let write_file file json =
   let json = to_root json in
-  let open Lwt in
+  protect begin fun () ->
-  catch
+    Lwt_io.with_file ~mode:Output file begin fun chan ->
-    (fun () ->
+      let str = to_string json in
-       Lwt_io.(with_file ~mode:Output file (fun chan ->
+      Lwt_io.write chan str >>= fun _ ->
-           let str = to_string json in
+      return ()
-           write chan str >>= fun _ ->
+    end
-           return true)))
+  end
-    (fun _ -> return false)
 
 let read_file file =
-  let open Lwt in
+  protect begin fun () ->
-  catch
+    Lwt_io.with_file ~mode:Input file begin fun chan ->
-    (fun () ->
+      Lwt_io.read chan >>= fun str ->
-       Lwt_io.(with_file ~mode:Input file (fun chan ->
+      return (Ezjsonm.from_string str :> Data_encoding.json)
-           read chan >>= fun str ->
+    end
-           return (Some (Ezjsonm.from_string str :> Data_encoding.json)))))
+  end
-    (fun _ ->
+
-       (* TODO log error or use Error_monad. *)
+let () =
-       return None)
+  Error_monad.json_to_string := to_string

src/utils/data_encoding_ezjsonm.mli

@@ -7,6 +7,8 @@
 (*                                                                        *)
 (**************************************************************************)
 
+open Error_monad
+
 (** Read a JSON document from a string. *)
 val from_string : string -> (Data_encoding.json, string) result
 
@@ -20,7 +22,7 @@ val from_stream : string Lwt_stream.t -> (Data_encoding.json, string) result Lwt
 val to_string : Data_encoding.json -> string
 
 (** Loads a JSON file in memory *)
-val read_file : string -> Data_encoding.json option Lwt.t
+val read_file : string -> Data_encoding.json tzresult Lwt.t
 
 (** (Over)write a JSON file from in memory data *)
-val write_file : string -> Data_encoding.json -> bool Lwt.t
+val write_file : string -> Data_encoding.json -> unit tzresult Lwt.t

src/utils/error_monad.ml

@@ -16,10 +16,13 @@ type error_category = [ `Branch | `Temporary | `Permanent ]
 type 'err full_error_category =
   [ error_category | `Wrapped of 'err -> error_category ]
 
+(* HACK: forward reference from [Data_encoding_ezjsonm] *)
+let json_to_string = ref (fun _ -> "")
+
 let json_pp encoding ppf x =
   Format.pp_print_string ppf @@
-  Data_encoding_ezjsonm.to_string @@
+  !json_to_string @@
-  Data_encoding.Json.(construct encoding x)
+  Data_encoding.Json.construct encoding x
 
 module Make() = struct
 
@@ -174,11 +177,6 @@ module Make() = struct
 
   let fail s = Lwt.return (Error [ s ])
 
-  let protect ~on_error t =
-    t >>= function
-    | Ok res -> return res
-    | Error err -> on_error err
-
   let (>>?) v f =
     match v with
     | Error _ as err -> err
@@ -325,6 +323,11 @@ let () =
   error_kinds :=
     Error_kind { id; from_error ; category; encoding_case ; pp } :: !error_kinds
 
+let protect ~on_error t =
+  t  >>= function
+  | Ok res -> return res
+  | Error err -> on_error err
+
 end
 
 include Make()
@@ -340,6 +343,14 @@ let error_exn s = Error [ Exn s ]
 let trace_exn exn f = trace (Exn exn) f
 let record_trace_exn exn f = record_trace (Exn exn) f
 
+let protect ?on_error t =
+  Lwt.catch t (fun exn -> fail (Exn exn)) >>= function
+  | Ok res -> return res
+  | Error err ->
+      match on_error with
+      | Some f -> f err
+      | None -> Lwt.return (Error err)
+
 let pp_exn ppf exn = pp ppf (Exn exn)
 
 let () =

src/utils/error_monad.mli

@@ -26,6 +26,10 @@ val failwith :
   ('a, Format.formatter, unit, 'b tzresult Lwt.t) format4 ->
   'a
 
+val protect :
+  ?on_error: (error list -> 'a tzresult Lwt.t) ->
+  (unit -> 'a tzresult Lwt.t) -> 'a tzresult Lwt.t
+
 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
@@ -35,3 +39,6 @@ type error += Exn of exn
 type error += Unclassified of string
 
 module Make() : Error_monad_sig.S
+
+(**/**)
+val json_to_string : (Data_encoding.json -> string) ref

test/lib/assert.ml

@@ -14,6 +14,16 @@ include Kaputt.Assertion
 
 let format_msg = function None -> None | Some msg -> Some (msg ^ "\n")
 
+let is_error ?(msg="") x =
+  match x with
+  | Error _ -> ()
+  | Ok _ -> fail "Error _" "Ok _" msg
+
+let is_ok ?(msg="") x =
+  match x with
+  | Ok _ -> ()
+  | Error _ -> fail "Ok _" "Error _" msg
+
 let equal_persist_list ?msg l1 l2 =
   let msg = format_msg msg in
   let pr_persist l =

test/lib/assert.mli

@@ -8,8 +8,12 @@
 (**************************************************************************)
 
 open Hash
+open Error_monad
 include (module type of struct include Kaputt.Assertion end)
 
+val is_ok : ?msg:string -> 'a tzresult -> unit
+val is_error : ?msg:string -> 'a tzresult -> unit
+
 val fail_msg : ('a, Format.formatter, unit, 'b) format4 -> 'a
 
 val fail : string -> string -> ('a, Format.formatter, unit, 'b) format4 -> 'a

test/test_data_encoding.ml

@@ -110,11 +110,11 @@ let test_json testdir =
   let f_str = to_string v in
   Assert.equal_string  ~msg:__LOC__ f_str "[\n  42\n]";
   read_file (testdir // "NONEXISTINGFILE") >>= fun rf ->
-  Assert.is_none ~msg:__LOC__ rf;
+  Assert.is_error ~msg:__LOC__ rf ;
   write_file file v >>= fun success ->
-  Assert.is_true ~msg:__LOC__ success;
+  Assert.is_ok ~msg:__LOC__ success ;
   read_file file >>= fun opt ->
-  Assert.is_some ~msg:__LOC__ opt;
+  Assert.is_ok ~msg:__LOC__ opt ;
   Lwt.return ()
 
 type t = A of int | B of string | C of int | D of string | E
@@ -269,8 +269,8 @@ let test_json_input testdir =
 |}
     in
     Data_encoding_ezjsonm.read_file file >>= function
-      None -> Assert.fail_msg "Cannot parse \"good.json\"."
+    | Error _ -> Assert.fail_msg "Cannot parse \"good.json\"."
-    | Some json ->
+    | Ok json ->
         let (id, value, popup) = Json.destruct enc json in
         Assert.equal_string ~msg:__LOC__ "file" id;
         Assert.equal_string ~msg:__LOC__ "File" value;
@@ -295,8 +295,8 @@ let test_json_input testdir =
 |}
     in
     Data_encoding_ezjsonm.read_file file >>= function
-      None -> Assert.fail_msg "Cannot parse \"unknown.json\"."
+    | Error _ -> Assert.fail_msg "Cannot parse \"unknown.json\"."
-    | Some json ->
+    | Ok json ->
         Assert.test_fail ~msg:__LOC__
           (fun () -> ignore (Json.destruct enc json))
           (function