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

Shell: Use Error_monad in Data_encoding_ezjsonm

Browse Source
This commit is contained in:
Grégoire Henry 2017-01-23 11:09:45 +01:00
parent a65ad52620
commit 5e1eddf681
16 changed files with 109 additions and 71 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
src/Makefile
View File

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

8
src/client/client_aliases.ml
View File

@ -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."

9
src/client/embedded/bootstrap/client_proto_nonces.ml
View File

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

8
src/client/embedded/bootstrap/mining/client_mining_endorsement.ml
View File

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

8
src/client/embedded/bootstrap/mining/client_mining_forge.ml
View File

@ -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."

12
src/node/net/p2p_connection_pool.ml
View File

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

8
src/node/net/p2p_connection_pool_types.ml
View File

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

4
src/node/net/p2p_connection_pool_types.mli
View File

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

10
src/node_main.ml
View File

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

33
src/utils/data_encoding_ezjsonm.ml
View File

@ -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 ->
protect begin fun () ->
Lwt_io.with_file ~mode:Output file begin fun chan ->
let str = to_string json in
write chan str >>= fun _ ->
return true)))
(fun _ -> return false)
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

6
src/utils/data_encoding_ezjsonm.mli
View File

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

25
src/utils/error_monad.ml
View File

@ -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 () =

7
src/utils/error_monad.mli
View File

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

10
test/lib/assert.ml
View File

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

4
test/lib/assert.mli
View File

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

14
test/test_data_encoding.ml
View File

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