From 5e1eddf681b40d9883dbc10c4d7d5fdbb142ec59 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Gr=C3=A9goire=20Henry?= Date: Mon, 23 Jan 2017 11:09:45 +0100 Subject: [PATCH] Shell: Use Error_monad in `Data_encoding_ezjsonm` --- src/Makefile | 4 +-- src/client/client_aliases.ml | 8 ++--- .../embedded/bootstrap/client_proto_nonces.ml | 9 ++--- .../mining/client_mining_endorsement.ml | 8 ++--- .../bootstrap/mining/client_mining_forge.ml | 8 ++--- src/node/net/p2p_connection_pool.ml | 20 +++++------ src/node/net/p2p_connection_pool_types.ml | 8 +++-- src/node/net/p2p_connection_pool_types.mli | 4 +-- src/node_main.ml | 10 +++--- src/utils/data_encoding_ezjsonm.ml | 35 ++++++++++--------- src/utils/data_encoding_ezjsonm.mli | 6 ++-- src/utils/error_monad.ml | 25 +++++++++---- src/utils/error_monad.mli | 7 ++++ test/lib/assert.ml | 10 ++++++ test/lib/assert.mli | 4 +++ test/test_data_encoding.ml | 14 ++++---- 16 files changed, 109 insertions(+), 71 deletions(-) diff --git a/src/Makefile b/src/Makefile index 2617fc8af..e91e9af96 100644 --- a/src/Makefile +++ b/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 \ diff --git a/src/client/client_aliases.ml b/src/client/client_aliases.ml index 1a80cc78c..b4899d5de 100644 --- a/src/client/client_aliases.ml +++ b/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") - | true -> return ()) + | Error _ -> fail (Failure "Json.write_file") + | Ok () -> return ()) (fun exn -> cctxt.Client_commands.error "could not write the %s alias file: %s." diff --git a/src/client/embedded/bootstrap/client_proto_nonces.ml b/src/client/embedded/bootstrap/client_proto_nonces.ml index a9acf47f3..26e8af42a 100644 --- a/src/client/embedded/bootstrap/client_proto_nonces.ml +++ b/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" - | Some json -> + | Error _ -> + cctxt.Client_commands.error "couldn't to read the nonces file" + | Ok json -> match Data_encoding.Json.destruct encoding json with | exception _ -> (* TODO print_error *) cctxt.Client_commands.error "didn't understand the nonces file" @@ -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" - | true -> return ()) + | Error _ -> failwith "Json.write_file" + | Ok () -> return ()) (fun exn -> cctxt.Client_commands.error "could not write the nonces file: %s." (Printexc.to_string exn)) diff --git a/src/client/embedded/bootstrap/mining/client_mining_endorsement.ml b/src/client/embedded/bootstrap/mining/client_mining_endorsement.ml index 0d268a2c4..a9d005cf7 100644 --- a/src/client/embedded/bootstrap/mining/client_mining_endorsement.ml +++ b/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" - | true -> return ()) + | Error _ -> failwith "Json.write_file" + | Ok () -> return ()) (fun exn -> cctxt.Client_commands.error "could not write the endorsement file: %s." (Printexc.to_string exn)) diff --git a/src/client/embedded/bootstrap/mining/client_mining_forge.ml b/src/client/embedded/bootstrap/mining/client_mining_forge.ml index 3ea587027..e21ee087d 100644 --- a/src/client/embedded/bootstrap/mining/client_mining_forge.ml +++ b/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" - | true -> return ()) + | Error _ -> failwith "Json.write_file" + | Ok () -> return ()) (fun exn -> Error_monad.failwith "could not write the block file: %s." diff --git a/src/node/net/p2p_connection_pool.ml b/src/node/net/p2p_connection_pool.ml index dc437985a..53826a029 100644 --- a/src/node/net/p2p_connection_pool.ml +++ b/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 - (fun () -> - Gid_info.File.load config.peers_file meta_config.encoding) - (fun _ -> - (* TODO log error *) - Lwt.return_nil) >>= fun gids -> - List.iter - (fun gi -> Gid.Table.add pool.known_gids (Gid_info.gid gi) gi) - gids ; - Lwt.return pool + Gid_info.File.load config.peers_file meta_config.encoding >>= function + | Ok gids -> + List.iter + (fun gi -> Gid.Table.add pool.known_gids (Gid_info.gid gi) gi) + gids ; + Lwt.return pool + | Error err -> + log_error "@[Failed to parsed peers file:@ %a@]" + pp_print_error err ; + Lwt.return pool let destroy pool = Point.Table.fold (fun _point pi acc -> diff --git a/src/node/net/p2p_connection_pool_types.ml b/src/node/net/p2p_connection_pool_types.ml index 2d48bed66..d2d0bec6c 100644 --- a/src/node/net/p2p_connection_pool_types.ml +++ b/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 >|= - map_option ~f:(Data_encoding.Json.destruct enc) >|= - unopt ~default:[] + if Sys.file_exists path then + Data_encoding_ezjsonm.read_file path >>=? fun json -> + return (Data_encoding.Json.destruct enc json) + else + return [] let save path metadata_encoding peers = let open Data_encoding in diff --git a/src/node/net/p2p_connection_pool_types.mli b/src/node/net/p2p_connection_pool_types.mli index 8c2c3a584..be56dcd56 100644 --- a/src/node/net/p2p_connection_pool_types.mli +++ b/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 diff --git a/src/node_main.ml b/src/node_main.ml index a2c9f9701..0d6ea52ad 100644 --- a/src/node_main.ml +++ b/src/node_main.ml @@ -238,8 +238,8 @@ module Cfg_file = struct let read fp = Data_encoding_ezjsonm.read_file fp >|= function - | None -> None - | Some json -> Some (Data_encoding.Json.destruct t json) + | Error _ -> None + | 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 -> - Lwt.return (Some (patch_context json)) + | Ok json -> + Lwt.return (Some (patch_context (Some json))) end >>= fun patch_context -> let net_params = let open P2p in diff --git a/src/utils/data_encoding_ezjsonm.ml b/src/utils/data_encoding_ezjsonm.ml index 0b3c36ebf..8fb4ffcc8 100644 --- a/src/utils/data_encoding_ezjsonm.ml +++ b/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 - catch - (fun () -> - Lwt_io.(with_file ~mode:Output file (fun chan -> - let str = to_string json in - write chan str >>= fun _ -> - return true))) - (fun _ -> return false) + protect begin fun () -> + Lwt_io.with_file ~mode:Output file begin fun chan -> + let str = to_string json in + Lwt_io.write chan str >>= fun _ -> + return () + end + end let read_file file = - let open Lwt in - catch - (fun () -> - Lwt_io.(with_file ~mode:Input file (fun chan -> - read chan >>= fun str -> - return (Some (Ezjsonm.from_string str :> Data_encoding.json))))) - (fun _ -> - (* TODO log error or use Error_monad. *) - return None) + protect begin fun () -> + Lwt_io.with_file ~mode:Input file begin fun chan -> + Lwt_io.read chan >>= fun str -> + return (Ezjsonm.from_string str :> Data_encoding.json) + end + end + +let () = + Error_monad.json_to_string := to_string diff --git a/src/utils/data_encoding_ezjsonm.mli b/src/utils/data_encoding_ezjsonm.mli index a195f10a0..51b41776b 100644 --- a/src/utils/data_encoding_ezjsonm.mli +++ b/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 diff --git a/src/utils/error_monad.ml b/src/utils/error_monad.ml index 45d84349d..e67c27b9c 100644 --- a/src/utils/error_monad.ml +++ b/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 @@ - Data_encoding.Json.(construct encoding x) + !json_to_string @@ + 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 () = diff --git a/src/utils/error_monad.mli b/src/utils/error_monad.mli index 11e607101..141dedd47 100644 --- a/src/utils/error_monad.mli +++ b/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 diff --git a/test/lib/assert.ml b/test/lib/assert.ml index 8201fdf82..707179f0f 100644 --- a/test/lib/assert.ml +++ b/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 = diff --git a/test/lib/assert.mli b/test/lib/assert.mli index 28ee6a19f..7c01a393c 100644 --- a/test/lib/assert.mli +++ b/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 diff --git a/test/test_data_encoding.ml b/test/test_data_encoding.ml index 848419be9..1d264c358 100644 --- a/test/test_data_encoding.ml +++ b/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\"." - | Some json -> + | Error _ -> Assert.fail_msg "Cannot parse \"good.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\"." - | Some json -> + | Error _ -> Assert.fail_msg "Cannot parse \"unknown.json\"." + | Ok json -> Assert.test_fail ~msg:__LOC__ (fun () -> ignore (Json.destruct enc json)) (function