From e7c39578b4d45a3842cab1b4563e78090a2ef7f0 Mon Sep 17 00:00:00 2001 From: Benjamin Canou Date: Thu, 1 Dec 2016 18:27:53 +0100 Subject: [PATCH] Extract the js_of_ocaml compatible part of utils. --- src/.merlin | 2 + src/Makefile | 82 +++++++++++++------ src/client/client_aliases.ml | 6 +- src/client/client_config.ml | 2 +- src/client/client_generic_rpcs.ml | 10 +-- src/client/client_node_rpcs.ml | 10 +-- src/client/embedded/Makefile.shared | 1 + .../embedded/bootstrap/client_proto_nonces.ml | 6 +- .../mining/client_mining_endorsement.ml | 6 +- .../bootstrap/mining/client_mining_forge.ml | 6 +- src/client_main.ml | 2 +- src/compiler/tezos_compiler.ml | 13 +-- src/minutils/RPC.ml | 24 ++++++ src/{node/net => minutils}/RPC.mli | 47 ++--------- src/{utils => minutils}/compare.ml | 0 src/{utils => minutils}/compare.mli | 0 src/{utils => minutils}/data_encoding.ml | 80 ++++++------------ src/{utils => minutils}/data_encoding.mli | 18 ---- src/{utils => minutils}/hex_encode.ml | 0 src/{utils => minutils}/hex_encode.mli | 0 src/{utils => minutils}/mBytes.ml | 0 src/{utils => minutils}/mBytes.mli | 0 src/{utils => minutils}/utils.ml | 49 ----------- src/{utils => minutils}/utils.mli | 8 -- src/node/db/context.ml | 4 +- src/node/db/store.ml | 4 +- src/node/net/{RPC.ml => RPC_server.ml} | 61 +------------- src/node/net/RPC_server.mli | 40 +++++++++ src/node/net/p2p.ml | 4 +- src/node/shell/node_rpc.ml | 2 +- src/node/shell/node_rpc_services.ml | 56 ++++++++++--- src/node/shell/node_rpc_services.mli | 7 ++ src/node/updater/updater.ml | 8 +- src/node_main.ml | 21 ++--- src/proto/bootstrap/storage.ml | 12 +-- src/proto/environment/data_encoding.mli | 7 -- src/utils/data_encoding_ezjsonm.ml | 56 +++++++++++++ src/utils/data_encoding_ezjsonm.mli | 26 ++++++ src/utils/error_monad.ml | 2 +- src/utils/logging.ml | 2 +- src/utils/lwt_exit.ml | 23 ++++++ src/utils/lwt_exit.mli | 18 ++++ src/utils/lwt_utils.ml | 34 ++++++++ src/utils/lwt_utils.mli | 4 + test/.merlin | 2 + test/Makefile | 8 +- test/test_basic.ml | 12 ++- test/test_data_encoding.ml | 13 +-- 48 files changed, 458 insertions(+), 340 deletions(-) create mode 100644 src/minutils/RPC.ml rename src/{node/net => minutils}/RPC.mli (80%) rename src/{utils => minutils}/compare.ml (100%) rename src/{utils => minutils}/compare.mli (100%) rename src/{utils => minutils}/data_encoding.ml (95%) rename src/{utils => minutils}/data_encoding.mli (91%) rename src/{utils => minutils}/hex_encode.ml (100%) rename src/{utils => minutils}/hex_encode.mli (100%) rename src/{utils => minutils}/mBytes.ml (100%) rename src/{utils => minutils}/mBytes.mli (100%) rename src/{utils => minutils}/utils.ml (71%) rename src/{utils => minutils}/utils.mli (90%) rename src/node/net/{RPC.ml => RPC_server.ml} (78%) create mode 100644 src/node/net/RPC_server.mli create mode 100644 src/utils/data_encoding_ezjsonm.ml create mode 100644 src/utils/data_encoding_ezjsonm.mli create mode 100644 src/utils/lwt_exit.ml create mode 100644 src/utils/lwt_exit.mli diff --git a/src/.merlin b/src/.merlin index b7aa57076..8df5bcee0 100644 --- a/src/.merlin +++ b/src/.merlin @@ -6,6 +6,8 @@ S node/shell B node/shell S node/db B node/db +S minutils +B minutils S utils B utils S proto/environment diff --git a/src/Makefile b/src/Makefile index 003346a14..9082ce468 100644 --- a/src/Makefile +++ b/src/Makefile @@ -92,23 +92,58 @@ clean:: rm -f compiler/embedded_cmis.ml rm -rf tmp +############################################################################ +## Minimal utils library compatible with js_of_ocaml +############################################################################ + +MINUTILS_LIB_INTFS := \ + minutils/mBytes.mli \ + minutils/hex_encode.mli \ + minutils/utils.mli \ + minutils/compare.mli \ + minutils/data_encoding.mli \ + minutils/RPC.mli \ + +MINUTILS_LIB_IMPLS := \ + minutils/mBytes.ml \ + minutils/hex_encode.ml \ + minutils/utils.ml \ + minutils/compare.ml \ + minutils/data_encoding.ml \ + minutils/RPC.ml \ + +MINUTILS_PACKAGES := \ + cstruct \ + lwt \ + ocplib-json-typed.bson \ + ocplib-resto.directory \ + $(COVERAGEPKG) \ + +MINUTILS_OBJS := \ + ${MINUTILS_LIB_IMPLS:.ml=.cmx} ${MINUTILS_LIB_IMPLS:.ml=.ml.deps} \ + ${MINUTILS_LIB_INTFS:.mli=.cmi} ${MINUTILS_LIB_INTFS:.mli=.mli.deps} +${MINUTILS_OBJS}: PACKAGES=${MINUTILS_PACKAGES} +${MINUTILS_OBJS}: SOURCE_DIRECTORIES=minutils +${MINUTILS_OBJS}: TARGET="(minutils.cmxa)" +${MINUTILS_OBJS}: OPENED_MODULES= + +minutils.cmxa: ${MINUTILS_LIB_IMPLS:.ml=.cmx} + @echo LINK $(notdir $@) + @${OCAMLOPT} ${OCAMLFLAGS} -a -o $@ $^ ############################################################################ -## Node protocol compiler (also embedded in the main program) +## Utils library ############################################################################ UTILS_LIB_INTFS := \ - utils/mBytes.mli \ - utils/utils.mli \ utils/base48.mli \ - utils/hex_encode.mli \ utils/cli_entries.mli \ - utils/compare.mli \ - utils/data_encoding.mli \ + utils/data_encoding_ezjsonm.mli \ utils/crypto_box.mli \ utils/time.mli \ utils/hash.mli \ utils/error_monad.mli \ + utils/lwt_exit.mli \ utils/logging.mli \ utils/lwt_utils.mli \ utils/lwt_pipe.mli \ @@ -116,18 +151,15 @@ UTILS_LIB_INTFS := \ utils/moving_average.mli \ UTILS_LIB_IMPLS := \ - utils/mBytes.ml \ - utils/utils.ml \ - utils/hex_encode.ml \ utils/base48.ml \ utils/cli_entries.ml \ - utils/compare.ml \ - utils/data_encoding.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 \ utils/lwt_pipe.ml \ @@ -135,12 +167,10 @@ UTILS_LIB_IMPLS := \ utils/moving_average.ml \ UTILS_PACKAGES := \ + ${MINUTILS_PACKAGES} \ base64 \ calendar \ - cstruct \ ezjsonm \ - lwt \ - ocplib-json-typed \ sodium \ zarith \ $(COVERAGEPKG) \ @@ -149,7 +179,7 @@ UTILS_OBJS := \ ${UTILS_LIB_IMPLS:.ml=.cmx} ${UTILS_LIB_IMPLS:.ml=.ml.deps} \ ${UTILS_LIB_INTFS:.mli=.cmi} ${UTILS_LIB_INTFS:.mli=.mli.deps} ${UTILS_OBJS}: PACKAGES=${UTILS_PACKAGES} -${UTILS_OBJS}: SOURCE_DIRECTORIES=utils +${UTILS_OBJS}: SOURCE_DIRECTORIES=minutils utils ${UTILS_OBJS}: TARGET="(utils.cmxa)" ${UTILS_OBJS}: OPENED_MODULES= @@ -157,7 +187,6 @@ utils.cmxa: ${UTILS_LIB_IMPLS:.ml=.cmx} @echo LINK $(notdir $@) @${OCAMLOPT} ${OCAMLFLAGS} -a -o $@ $^ - ############################################################################ ## Node protocol compiler (also embedded in the main program) ############################################################################ @@ -188,7 +217,7 @@ COMPILER_OBJS := \ ${COMPILER_LIB_INTFS:.mli=.cmi} ${COMPILER_LIB_INTFS:.mli=.mli.deps} \ ${TZCOMPILER} ${COMPILER_OBJS}: PACKAGES=${COMPILER_PACKAGES} -${COMPILER_OBJS}: SOURCE_DIRECTORIES=utils compiler +${COMPILER_OBJS}: SOURCE_DIRECTORIES=utils minutils compiler ${COMPILER_OBJS}: TARGET="(compiler.cmxa)" ${COMPILER_OBJS}: \ OPENED_MODULES=Error_monad Hash Utils @@ -197,7 +226,7 @@ compiler.cmxa: ${COMPILER_LIB_IMPLS:.ml=.cmx} @echo LINK $(notdir $@) @${OCAMLOPT} ${OCAMLFLAGS} -a -o $@ $^ -${TZCOMPILER}: utils.cmxa compiler.cmxa ${COMPILER_IMPLS:.ml=.cmx} +${TZCOMPILER}: minutils.cmxa utils.cmxa compiler.cmxa ${COMPILER_IMPLS:.ml=.cmx} @echo LINK $(notdir $@) @$(OCAMLOPT) -linkpkg $(patsubst %, -package %, $(COMPILER_PACKAGES)) -o $@ $^ @@ -212,7 +241,7 @@ clean:: NODE_LIB_INTFS := \ \ node/net/p2p.mli \ - node/net/RPC.mli \ + node/net/RPC_server.mli \ \ node/updater/fitness.mli \ \ @@ -242,7 +271,7 @@ NODE_LIB_IMPLS := \ compiler/node_compiler_main.ml \ \ node/net/p2p.ml \ - node/net/RPC.ml \ + node/net/RPC_server.ml \ \ node/updater/fitness.ml \ \ @@ -291,7 +320,7 @@ NODE_OBJS := \ ${NODE_LIB_INTFS:.mli=.cmi} ${NODE_LIB_INTFS:.mli=.mli.deps} \ ${TZNODE} ${NODE_OBJS}: PACKAGES=${NODE_PACKAGES} -${NODE_OBJS}: SOURCE_DIRECTORIES=utils compiler node/db node/net node/updater node/shell +${NODE_OBJS}: SOURCE_DIRECTORIES=minutils utils compiler node/db node/net node/updater node/shell ${NODE_OBJS}: TARGET="(node.cmxa)" ${NODE_OBJS}: OPENED_MODULES=Error_monad Hash Utils @@ -300,7 +329,7 @@ node.cmxa: ${NODE_LIB_IMPLS:.ml=.cmx} @${OCAMLOPT} ${OCAMLFLAGS} -a -o $@ $^ ${NODE_IMPLS:.ml=.cmx}: ${EMBEDDED_CLIENT_PROTOCOLS} -${TZNODE}: utils.cmxa compiler.cmxa node.cmxa ${EMBEDDED_NODE_PROTOCOLS} ${NODE_IMPLS:.ml=.cmx} +${TZNODE}: minutils.cmxa utils.cmxa compiler.cmxa node.cmxa ${EMBEDDED_NODE_PROTOCOLS} ${NODE_IMPLS:.ml=.cmx} @echo LINK $(notdir $@) @${OCAMLOPT} -linkall -linkpkg ${OCAMLFLAGS} -o $@ $^ @@ -318,7 +347,7 @@ proto/embedded_proto_%.cmxa: \ @${TZCOMPILER} -static -build-dir proto/$*/_tzbuild $@ proto/$*/ CLIENT_PROTO_INCLUDES := \ - utils node/updater node/db node/net node/shell client \ + minutils utils node/updater node/db node/net node/shell client \ $(shell ocamlfind query lwt ocplib-json-typed sodium) proto/client_embedded_proto_%.cmxa: \ @@ -382,7 +411,7 @@ CLIENT_OBJS := \ ${CLIENT_LIB_INTFS:.mli=.cmi} ${CLIENT_LIB_INTFS:.mli=.mli.deps} \ ${TZCLIENT} ${CLIENT_OBJS}: PACKAGES=${CLIENT_PACKAGES} -${CLIENT_OBJS}: SOURCE_DIRECTORIES=client client/embedded utils node/net node/shell node/updater node/db compiler +${CLIENT_OBJS}: SOURCE_DIRECTORIES=client client/embedded minutils utils node/net node/shell node/updater node/db compiler ${CLIENT_OBJS}: TARGET="(client.cmxa)" ${CLIENT_OBJS}: OPENED_MODULES=Error_monad Hash Utils @@ -393,7 +422,7 @@ client.cmxa: ${CLIENT_LIB_IMPLS:.ml=.cmx} ${EMBEDDED_CLIENT_PROTOCOLS}: client.cmxa ${CLIENT_IMPLS:.ml=.cmx}: ${EMBEDDED_CLIENT_PROTOCOLS} -${TZCLIENT}: utils.cmxa compiler.cmxa node.cmxa \ +${TZCLIENT}: minutils.cmxa utils.cmxa compiler.cmxa node.cmxa \ client.cmxa ${EMBEDDED_CLIENT_PROTOCOLS} \ ${CLIENT_IMPLS:.ml=.cmx} @echo LINK $(notdir $@) @@ -446,7 +475,8 @@ ifneq ($(MAKECMDGOALS),build-deps) -include .depend endif endif -DEPENDS := $(filter-out $(NO_DEPS), $(UTILS_LIB_INTFS) $(UTILS_LIB_IMPLS) \ +DEPENDS := $(filter-out $(NO_DEPS), $(MINUTILS_LIB_INTFS) $(MINUTILS_LIB_IMPLS) \ + $(UTILS_LIB_INTFS) $(UTILS_LIB_IMPLS) \ $(COMPILER_LIB_INTFS) $(COMPILER_LIB_IMPLS) \ $(COMPILER_INTFS) $(COMPILER_IMPLS) \ $(NODE_LIB_INTFS) $(NODE_LIB_IMPLS) \ diff --git a/src/client/client_aliases.ml b/src/client/client_aliases.ml index a7821178f..4d30c3dda 100644 --- a/src/client/client_aliases.ml +++ b/src/client/client_aliases.ml @@ -61,7 +61,7 @@ module Alias = functor (Entity : Entity) -> struct let load () = let filename = filename () in if not (Sys.file_exists filename) then return [] else - Data_encoding.Json.read_file filename >>= function + Data_encoding_ezjsonm.read_file filename >>= function | None -> error "couldn't to read the %s alias file" Entity.name | Some json -> @@ -98,11 +98,11 @@ module Alias = functor (Entity : Entity) -> struct catch (fun () -> let dirname = Client_config.base_dir#get in - (if not (Sys.file_exists dirname) then Utils.create_dir dirname + (if not (Sys.file_exists dirname) then Lwt_utils.create_dir dirname else return ()) >>= fun () -> let filename = filename () in let json = Data_encoding.Json.construct encoding list in - Data_encoding.Json.write_file filename json >>= function + Data_encoding_ezjsonm.write_file filename json >>= function | false -> fail (Failure "Json.write_file") | true -> return ()) (fun exn -> diff --git a/src/client/client_config.ml b/src/client/client_config.ml index 21560a74e..6dd9b287e 100644 --- a/src/client/client_config.ml +++ b/src/client/client_config.ml @@ -135,7 +135,7 @@ let parse_args ?version usage dispatcher = (* parse once again with contextual options *) Arg.parse_argv_dynamic ~current:(ref 0) Sys.argv args (anon dispatch) (usage base_args) ; - Utils.create_dir (Filename.dirname config_file#get) >>= fun () -> + Lwt_utils.create_dir (Filename.dirname config_file#get) >>= fun () -> file_group#write config_file#get ; Lwt.return () with Sys_error msg -> diff --git a/src/client/client_generic_rpcs.ml b/src/client/client_generic_rpcs.ml index a31473050..19d5fa803 100644 --- a/src/client/client_generic_rpcs.ml +++ b/src/client/client_generic_rpcs.ml @@ -132,7 +132,7 @@ let editor_fill_in schema = | Error msg -> return (Error msg) | Ok json -> Lwt_io.(with_file Output tmp (fun fp -> - write_line fp (Data_encoding.Json.to_string json))) >>= fun () -> + write_line fp (Data_encoding_ezjsonm.to_string json))) >>= fun () -> edit () and edit () = (* launch the user's editor on it *) @@ -160,7 +160,7 @@ let editor_fill_in schema = and reread () = (* finally reread the file *) Lwt_io.(with_file Input tmp (fun fp -> read fp)) >>= fun text -> - match Data_encoding.Json.from_string text with + match Data_encoding_ezjsonm.from_string text with | Ok r -> return (Ok r) | Error msg -> return (Error (Printf.sprintf "bad input: %s" msg)) and delete () = @@ -286,8 +286,8 @@ let schema url () = Client_node_rpcs.describe ~recurse:false args >>= function | Static { service = Some { input ; output } } -> Cli_entries.message "Input schema:\n%s\nOutput schema:\n%s\n%!" - (Data_encoding.Json.to_string (Json_schema.to_json input)) - (Data_encoding.Json.to_string (Json_schema.to_json output)) + (Data_encoding_ezjsonm.to_string (Json_schema.to_json input)) + (Data_encoding_ezjsonm.to_string (Json_schema.to_json output)) | _ -> Cli_entries.message "No service found at this URL (but this is a valid prefix)\n%!" @@ -309,7 +309,7 @@ let call url () = error "%s" msg | Ok json -> Client_node_rpcs.get_json args json >>= fun json -> - Cli_entries.message "Output:\n%s\n%!" (Data_encoding.Json.to_string json) + Cli_entries.message "Output:\n%s\n%!" (Data_encoding_ezjsonm.to_string json) end | _ -> Cli_entries.message diff --git a/src/client/client_node_rpcs.ml b/src/client/client_node_rpcs.ml index def106a08..b3092747a 100644 --- a/src/client/client_node_rpcs.ml +++ b/src/client/client_node_rpcs.ml @@ -29,7 +29,7 @@ let make_request service json = ^ ":" ^ string_of_int Client_config.incoming_port#get in let string_uri = String.concat "/" (serv :: service) in let uri = Uri.of_string string_uri in - let reqbody = Data_encoding.Json.to_string json in + let reqbody = Data_encoding_ezjsonm.to_string json in let tzero = Unix.gettimeofday () in catch (fun () -> @@ -61,7 +61,7 @@ let get_streamed_json service json = lwt_log_error "Failed to parse json: %s" msg >>= fun () -> Lwt.return None) - (Data_encoding.Json.from_stream ansbody)) + (Data_encoding_ezjsonm.from_stream ansbody)) | err, _ansbody -> (if Client_config.print_timings#get then message "Request to /%s failed in %gs" @@ -83,7 +83,7 @@ let get_json service json = else Lwt.return ()) >>= fun () -> log_response cpt code ansbody >>= fun () -> if ansbody = "" then Lwt.return `Null - else match Data_encoding.Json.from_string ansbody with + else match Data_encoding_ezjsonm.from_string ansbody with | Error _ -> error "the RPC server returned malformed JSON" | Ok res -> Lwt.return res end @@ -103,7 +103,7 @@ let parse_answer service path json = match RPC.read_answer service json with | Error msg -> (* TODO print_error *) error "request to /%s returned wrong JSON (%s)\n%s" - (String.concat "/" path) msg (Data_encoding.Json.to_string json) + (String.concat "/" path) msg (Data_encoding_ezjsonm.to_string json) | Ok v -> return v let call_service0 service arg = @@ -124,7 +124,7 @@ let call_streamed_service0 service arg = Lwt_stream.map_s (parse_answer service path) st module Services = Node_rpc_services -let errors = call_service0 RPC.Error.service +let errors = call_service0 Services.Error.service let forge_block ?net ?predecessor ?timestamp fitness ops header = call_service0 Services.forge_block (net, predecessor, timestamp, fitness, ops, header) diff --git a/src/client/embedded/Makefile.shared b/src/client/embedded/Makefile.shared index e2aa12c45..083d8cf4a 100644 --- a/src/client/embedded/Makefile.shared +++ b/src/client/embedded/Makefile.shared @@ -5,6 +5,7 @@ include ../../../Makefile.config NODE_DIRECTORIES = \ $(addprefix ../../../, \ + minutils \ utils \ node/updater \ node/db \ diff --git a/src/client/embedded/bootstrap/client_proto_nonces.ml b/src/client/embedded/bootstrap/client_proto_nonces.ml index 5e2f3dcf7..526f51fce 100644 --- a/src/client/embedded/bootstrap/client_proto_nonces.ml +++ b/src/client/embedded/bootstrap/client_proto_nonces.ml @@ -28,7 +28,7 @@ let load () = if not (Sys.file_exists filename) then Lwt.return [] else - Data_encoding.Json.read_file filename >>= function + Data_encoding_ezjsonm.read_file filename >>= function | None -> error "couldn't to read the nonces file" | Some json -> match Data_encoding.Json.destruct encoding json with @@ -39,7 +39,7 @@ let load () = let check_dir dirname = if not (Sys.file_exists dirname) then - Utils.create_dir dirname + Lwt_utils.create_dir dirname else Lwt.return () @@ -50,7 +50,7 @@ let save list = check_dir dirname >>= fun () -> let filename = filename () in let json = Data_encoding.Json.construct encoding list in - Data_encoding.Json.write_file filename json >>= function + Data_encoding_ezjsonm.write_file filename json >>= function | false -> failwith "Json.write_file" | true -> return ()) (fun exn -> diff --git a/src/client/embedded/bootstrap/mining/client_mining_endorsement.ml b/src/client/embedded/bootstrap/mining/client_mining_endorsement.ml index 26361c782..425967e60 100644 --- a/src/client/embedded/bootstrap/mining/client_mining_endorsement.ml +++ b/src/client/embedded/bootstrap/mining/client_mining_endorsement.ml @@ -48,7 +48,7 @@ end = struct let load () = let filename = filename () in if not (Sys.file_exists filename) then return LevelMap.empty else - Data_encoding.Json.read_file filename >>= function + Data_encoding_ezjsonm.read_file filename >>= function | None -> error "couldn't to read the endorsement file" | Some json -> @@ -62,11 +62,11 @@ end = struct Lwt.catch (fun () -> let dirname = Client_config.base_dir#get in - (if not (Sys.file_exists dirname) then Utils.create_dir dirname + (if not (Sys.file_exists dirname) then Lwt_utils.create_dir dirname else Lwt.return ()) >>= fun () -> let filename = filename () in let json = Data_encoding.Json.construct encoding map in - Data_encoding.Json.write_file filename json >>= function + Data_encoding_ezjsonm.write_file filename json >>= function | false -> failwith "Json.write_file" | true -> return ()) (fun exn -> diff --git a/src/client/embedded/bootstrap/mining/client_mining_forge.ml b/src/client/embedded/bootstrap/mining/client_mining_forge.ml index 0457252d5..7d023ec61 100644 --- a/src/client/embedded/bootstrap/mining/client_mining_forge.ml +++ b/src/client/embedded/bootstrap/mining/client_mining_forge.ml @@ -168,7 +168,7 @@ end = struct let load () = let filename = filename () in if not (Sys.file_exists filename) then return LevelMap.empty else - Data_encoding.Json.read_file filename >>= function + Data_encoding_ezjsonm.read_file filename >>= function | None -> failwith "couldn't to read the block file" | Some json -> @@ -182,11 +182,11 @@ end = struct Lwt.catch (fun () -> let dirname = Client_config.base_dir#get in - (if not (Sys.file_exists dirname) then Utils.create_dir dirname + (if not (Sys.file_exists dirname) then Lwt_utils.create_dir dirname else Lwt.return ()) >>= fun () -> let filename = filename () in let json = Data_encoding.Json.construct encoding map in - Data_encoding.Json.write_file filename json >>= function + Data_encoding_ezjsonm.write_file filename json >>= function | false -> failwith "Json.write_file" | true -> return ()) (fun exn -> diff --git a/src/client_main.ml b/src/client_main.ml index 1ab0e9ec3..408f60546 100644 --- a/src/client_main.ml +++ b/src/client_main.ml @@ -24,7 +24,7 @@ let () = prerr_endline msg ; Lwt.return () | log -> - Utils.create_dir Client_config.(base_dir#get // "logs" // log) >>= fun () -> + Lwt_utils.create_dir Client_config.(base_dir#get // "logs" // log) >>= fun () -> Lwt_io.with_file ~flags: Unix.[ O_APPEND ; O_CREAT ; O_WRONLY ] ~mode: Lwt_io.Output diff --git a/src/compiler/tezos_compiler.ml b/src/compiler/tezos_compiler.ml index 6f868a5cc..e833929ee 100644 --- a/src/compiler/tezos_compiler.ml +++ b/src/compiler/tezos_compiler.ml @@ -113,15 +113,16 @@ module Meta = struct (req "modules" ~description:"Modules comprising the protocol" (list string)) let to_file dirname ?hash modules = - let open Data_encoding.Json in - let config_file = construct config_file_encoding (hash, modules) in - Utils.write_file ~bin:false (dirname // name) @@ to_string config_file + let config_file = + Data_encoding.Json.construct config_file_encoding (hash, modules) in + Utils.write_file ~bin:false (dirname // name) @@ + Data_encoding_ezjsonm.to_string config_file let of_file dirname = - let open Data_encoding.Json in - Utils.read_file ~bin:false (dirname // name) |> from_string |> function + Utils.read_file ~bin:false (dirname // name) |> + Data_encoding_ezjsonm.from_string |> function | Error err -> Pervasives.failwith err - | Ok json -> destruct config_file_encoding json + | Ok json -> Data_encoding.Json.destruct config_file_encoding json end module Protocol = struct diff --git a/src/minutils/RPC.ml b/src/minutils/RPC.ml new file mode 100644 index 000000000..313fad0b4 --- /dev/null +++ b/src/minutils/RPC.ml @@ -0,0 +1,24 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +module Arg = Resto.Arg +module Path = Resto.Path +module Description = Resto.Description +let read_answer = Resto.read_answer +let forge_request = Resto.forge_request +let service ?description ~input ~output path = + Resto.service + ?description + ~input:(Data_encoding.Json.convert input) + ~output:(Data_encoding.Json.convert output) + path +type ('prefix, 'params, 'input, 'output) service = + ('prefix, 'params, 'input, 'output) Resto.service + +include RestoDirectory diff --git a/src/node/net/RPC.mli b/src/minutils/RPC.mli similarity index 80% rename from src/node/net/RPC.mli rename to src/minutils/RPC.mli index 0a8c5432b..d00770358 100644 --- a/src/node/net/RPC.mli +++ b/src/minutils/RPC.mli @@ -7,11 +7,7 @@ (* *) (**************************************************************************) -(** View over the RPC service, restricted to types. A protocol - implementation can define a set of remote procedures which are - registered when the protocol is activated via its [rpcs] - function. However, it cannot register new or update existing - procedures afterwards, neither can it see other procedures. *) +(** Typed RPC services: definition, binding and dispatch. *) (** Typed path argument. *) module Arg : sig @@ -278,40 +274,9 @@ val register_describe_directory_service: ('prefix, 'prefix, bool option, Description.directory_descr) service -> 'prefix directory -(** A handle on the server worker. *) -type server +exception Cannot_parse of Arg.descr * string * string list -(** Promise a running RPC serve ; takes the port. To call - an RPC at /p/a/t/h/ in the provided service, one must call the URI - /call/p/a/t/h/. Calling /list/p/a/t/h/ will list the services - prefixed by /p/a/t/h/, if any. Calling /schema/p/a/t/h/ will - describe the input and output of the service, if it is - callable. Calling /pipe will read a sequence of services to call in - sequence from the request body, see {!pipe_encoding}. - - The optional [pre_hook] is called with the path part of the URL - before resolving each request, to delegate the answering to - another resolution mechanism. Its result is ignored if the return - code is [404]. The optional [post_hook] is called if both the - [pre_hook] and the serviced answered with a [404] code. *) -val launch : int -> - ?pre_hook: (string -> string Answer.answer Lwt.t) -> - ?post_hook: (string -> string Answer.answer Lwt.t) -> - unit directory -> server Lwt.t - -(** Kill an RPC server. *) -val shutdown : server -> unit Lwt.t - -(** Retrieve the root service of the server *) -val root_service : server -> unit directory - -(** Change the root service of the server *) -val set_root_service : server -> unit directory -> unit - -module Error : sig - val service: (unit, unit, unit, Json_schema.schema) service - val encoding: error list Data_encoding.t - val wrap: - 'a Data_encoding.t -> 'a tzresult Data_encoding.encoding - -end +(** Resolve a service. *) +val lookup: + 'prefix directory -> 'prefix -> string list -> + (Data_encoding.json option -> Data_encoding.json Answer.answer Lwt.t) Lwt.t diff --git a/src/utils/compare.ml b/src/minutils/compare.ml similarity index 100% rename from src/utils/compare.ml rename to src/minutils/compare.ml diff --git a/src/utils/compare.mli b/src/minutils/compare.mli similarity index 100% rename from src/utils/compare.mli rename to src/minutils/compare.mli diff --git a/src/utils/data_encoding.ml b/src/minutils/data_encoding.ml similarity index 95% rename from src/utils/data_encoding.ml rename to src/minutils/data_encoding.ml index f106d869b..3de84af44 100644 --- a/src/utils/data_encoding.ml +++ b/src/minutils/data_encoding.ml @@ -213,54 +213,6 @@ module Json = struct type nonrec json = json - let to_root = function - | `O ctns -> `O ctns - | `A ctns -> `A ctns - | `Null -> `O [] - | oth -> `A [ oth ] - - let to_string j = Ezjsonm.to_string ~minify:false (to_root j) - - let from_string s = - try Ok (Ezjsonm.from_string s :> json) - with Ezjsonm.Parse_error (_, msg) -> Error msg - - let from_stream (stream: string Lwt_stream.t) = - let buffer = ref "" in - Lwt_stream.filter_map - (fun str -> - buffer := !buffer ^ str ; - try - let json = Ezjsonm.from_string !buffer in - buffer := "" ; - Some (Ok json) - with Ezjsonm.Parse_error (_, msg) -> - if String.length str = 32 * 1024 then None - else Some (Error msg)) - stream - - 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) - - 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 :> json))))) - (fun _ -> - (* TODO log error or use Error_monad. *) - return None) - let wrap_error f = fun str -> try f str @@ -523,19 +475,35 @@ module Encoding = struct let json = Json.convert json in raw_splitted ~binary ~json - let raw_json json = + let json = let binary = conv - (fun v -> Json_encoding.construct json v |> Json.to_string) - (fun s -> - match Json.from_string s with - | Error msg -> raise (Json.Parse_error msg) - | Ok v -> Json_encoding.destruct json v) + (fun json -> + Json_repr.convert + (module Json_repr.Ezjsonm) + (module Json_repr_bson.Repr) + json |> + Json_repr_bson.bson_to_bytes |> + Bytes.to_string) + (fun s -> try + Bytes.of_string s |> + Json_repr_bson.bytes_to_bson ~copy:false |> + Json_repr.convert + (module Json_repr_bson.Repr) + (module Json_repr.Ezjsonm) + with + | Json_repr_bson.Bson_decoding_error (msg, _, _) -> + raise (Json.Parse_error msg)) string in + let json = + Json_encoding.any_ezjson_value in raw_splitted ~binary ~json - let json = raw_json Json_encoding.any_ezjson_value - let json_schema = raw_json Json_encoding.any_schema + let json_schema = + conv + Json_schema.to_json + Json_schema.of_json + json let raw_merge_objs e1 e2 = let kind = Kind.combine "objects" (classify e1) (classify e2) in diff --git a/src/utils/data_encoding.mli b/src/minutils/data_encoding.mli similarity index 91% rename from src/utils/data_encoding.mli rename to src/minutils/data_encoding.mli index 86ba4403f..be410b820 100644 --- a/src/utils/data_encoding.mli +++ b/src/minutils/data_encoding.mli @@ -180,24 +180,6 @@ val mu : string -> ('a encoding -> 'a encoding) -> 'a encoding module Json : sig - (** Read a JSON document from a string. *) - val from_string : string -> (json, string) result - - (** Read a stream of JSON documents from a stream of strings. - A single JSON document may be represented in multiple consecutive - strings. But only the first document of a string is considered. *) - val from_stream : string Lwt_stream.t -> (json, string) result Lwt_stream.t - - (** Write a JSON document to a string. This goes via an intermediate - buffer and so may be slow on large documents. *) - val to_string : json -> string - - (** Loads a JSON file in memory *) - val read_file : string -> json option Lwt.t - - (** (Over)write a JSON file from in memory data *) - val write_file : string -> json -> bool Lwt.t - val convert : 'a encoding -> 'a Json_encoding.encoding val schema : 'a encoding -> json_schema diff --git a/src/utils/hex_encode.ml b/src/minutils/hex_encode.ml similarity index 100% rename from src/utils/hex_encode.ml rename to src/minutils/hex_encode.ml diff --git a/src/utils/hex_encode.mli b/src/minutils/hex_encode.mli similarity index 100% rename from src/utils/hex_encode.mli rename to src/minutils/hex_encode.mli diff --git a/src/utils/mBytes.ml b/src/minutils/mBytes.ml similarity index 100% rename from src/utils/mBytes.ml rename to src/minutils/mBytes.ml diff --git a/src/utils/mBytes.mli b/src/minutils/mBytes.mli similarity index 100% rename from src/utils/mBytes.mli rename to src/minutils/mBytes.mli diff --git a/src/utils/utils.ml b/src/minutils/utils.ml similarity index 71% rename from src/utils/utils.ml rename to src/minutils/utils.ml index b52aab3c9..d083f5cb4 100644 --- a/src/utils/utils.ml +++ b/src/minutils/utils.ml @@ -7,55 +7,6 @@ (* *) (**************************************************************************) -let (>>=) = Lwt.bind - -let remove_dir dir = - let rec remove dir = - let files = Lwt_unix.files_of_directory dir in - Lwt_stream.iter_s - (fun file -> - if file = "." || file = ".." then - Lwt.return () - else begin - let file = Filename.concat dir file in - if Sys.is_directory file - then remove file - else Lwt_unix.unlink file - end) - files >>= fun () -> - Lwt_unix.rmdir dir in - if Sys.file_exists dir && Sys.is_directory dir then - remove dir - else - Lwt.return () - -let rec create_dir ?(perm = 0o755) dir = - if Sys.file_exists dir then - Lwt.return () - else begin - create_dir (Filename.dirname dir) >>= fun () -> - Lwt_unix.mkdir dir perm - end - -let create_file ?(perm = 0o644) name content = - Lwt_unix.openfile name Unix.([O_TRUNC; O_CREAT; O_WRONLY]) perm >>= fun fd -> - Lwt_unix.write_string fd content 0 (String.length content) >>= fun _ -> - Lwt_unix.close fd - - -exception Exit -let termination_thread, exit_wakener = Lwt.wait () -let exit x = Lwt.wakeup exit_wakener x; raise Exit - -let () = - Lwt.async_exception_hook := - (function - | Exit -> () - | exn -> - Printf.eprintf "Uncaught (asynchronous) exception: %S\n%s\n%!" - (Printexc.to_string exn) (Printexc.get_backtrace ()); - Lwt.wakeup exit_wakener 1) - module StringMap = Map.Make (String) let split delim ?(limit = max_int) path = diff --git a/src/utils/utils.mli b/src/minutils/utils.mli similarity index 90% rename from src/utils/utils.mli rename to src/minutils/utils.mli index e42aaa302..1c5a3f00a 100644 --- a/src/utils/utils.mli +++ b/src/minutils/utils.mli @@ -7,14 +7,6 @@ (* *) (**************************************************************************) -val remove_dir: string -> unit Lwt.t - -val create_dir: ?perm:int -> string -> unit Lwt.t -val create_file: ?perm:int -> string -> string -> unit Lwt.t - -val termination_thread: int Lwt.t -val exit: int -> 'a - module StringMap : Map.S with type key = string (** Splits a string on slashes, grouping multiple slashes, and diff --git a/src/node/db/context.ml b/src/node/db/context.ml index 982623809..0d5eea8ba 100644 --- a/src/node/db/context.ml +++ b/src/node/db/context.ml @@ -112,7 +112,7 @@ let checkout ((module GitStore : STORE) as index) key = GitStore.patch_context (pack (module GitStore) store v) >>= fun ctxt -> Lwt.return (Some (Ok ctxt)) | Some bytes -> - match Data_encoding.Json.from_string (MBytes.to_string bytes) with + match Data_encoding_ezjsonm.from_string (MBytes.to_string bytes) with | Ok (`A errors) -> Lwt.return (Some (Error (List.map error_of_json errors))) | Error _ | Ok _-> @@ -166,7 +166,7 @@ let commit_invalid (module GitStore : STORE) block key exns = GitStore.clone Irmin.Task.none store (Block_hash.to_b48check key) >>= function | `Empty_head -> GitStore.update store invalid_context_key - (MBytes.of_string @@ Data_encoding.Json.to_string @@ + (MBytes.of_string @@ Data_encoding_ezjsonm.to_string @@ `A (List.map json_of_error exns)) | `Duplicated_branch | `Ok _ -> Lwt.fail (Preexistent_context (GitStore.path, key)) diff --git a/src/node/db/store.ml b/src/node/db/store.ml index 92a342922..171b1fa54 100644 --- a/src/node/db/store.ml +++ b/src/node/db/store.ml @@ -631,7 +631,7 @@ let read_genesis, store_genesis = get t key >>= function | None -> Lwt.return None | Some v -> - match Data_encoding.Json.from_string (MBytes.to_string v) with + match Data_encoding_ezjsonm.from_string (MBytes.to_string v) with | Error _ -> fatal_error "Store.read_genesis: invalid json object." @@ -643,7 +643,7 @@ let read_genesis, store_genesis = "Store.read_genesis: cannot parse json object." in let store t h = set t key ( MBytes.of_string @@ - Data_encoding.Json.to_string @@ + Data_encoding_ezjsonm.to_string @@ Data_encoding.Json.construct genesis_encoding h ) in (read, store) diff --git a/src/node/net/RPC.ml b/src/node/net/RPC_server.ml similarity index 78% rename from src/node/net/RPC.ml rename to src/node/net/RPC_server.ml index 1b56982f3..8d532e411 100644 --- a/src/node/net/RPC.ml +++ b/src/node/net/RPC_server.ml @@ -7,24 +7,9 @@ (* *) (**************************************************************************) +open RPC open Logging.RPC -module Arg = Resto.Arg -module Path = Resto.Path -module Description = Resto.Description -let read_answer = Resto.read_answer -let forge_request = Resto.forge_request -let service ?description ~input ~output path = - Resto.service - ?description - ~input:(Data_encoding.Json.convert input) - ~output:(Data_encoding.Json.convert output) - path -type ('prefix, 'params, 'input, 'output) service = - ('prefix, 'params, 'input, 'output) Resto.service - -include RestoDirectory - (* public types *) type server = (* hidden *) { shutdown : unit -> unit Lwt.t ; @@ -99,7 +84,7 @@ let launch port ?pre_hook ?post_hook root = match req.meth with | `POST -> begin Cohttp_lwt_body.to_string body >>= fun body -> - match Data_encoding.Json.from_string body with + match Data_encoding_ezjsonm.from_string body with | Error msg -> Lwt.fail (Cannot_parse_body msg) | Ok body -> Lwt.return (Some body) end @@ -111,10 +96,10 @@ let launch port ?pre_hook ?post_hook root = | Empty -> Cohttp_lwt_body.empty | Single json -> - Cohttp_lwt_body.of_string (Data_encoding.Json.to_string json) + Cohttp_lwt_body.of_string (Data_encoding_ezjsonm.to_string json) | Stream s -> let stream = - create_stream io con Data_encoding.Json.to_string s in + create_stream io con Data_encoding_ezjsonm.to_string s in Cohttp_lwt_body.of_stream stream in lwt_log_info "(%s) RPC %s" (Cohttp.Connection.to_string con) @@ -171,41 +156,3 @@ let set_root_service server root = server.root <- root let shutdown server = server.shutdown () - -module Error = struct - - let service = - service - ~description: "Schema for all the RPC errors from the shell" - ~input: Data_encoding.empty - ~output: Data_encoding.json_schema - Path.(root / "errors") - - let encoding = - let open Data_encoding in - let path, _ = forge_request service () () in - describe - ~description: - (Printf.sprintf - "The full list of error is available with \ - the global RPC `/%s`" (String.concat "/" path)) - (conv - ~schema:Json_schema.any - (fun exn -> `A (List.map json_of_error exn)) - (function `A exns -> List.map error_of_json exns | _ -> []) - json) - - let wrap param_encoding = - let open Data_encoding in - union [ - case - (obj1 (req "ok" param_encoding)) - (function Ok x -> Some x | _ -> None) - (fun x -> Ok x) ; - case - (obj1 (req "error" encoding)) - (function Error x -> Some x | _ -> None) - (fun x -> Error x) ; - ] - -end diff --git a/src/node/net/RPC_server.mli b/src/node/net/RPC_server.mli new file mode 100644 index 000000000..9366b3606 --- /dev/null +++ b/src/node/net/RPC_server.mli @@ -0,0 +1,40 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +(** Typed RPC services: server implementation. *) + +(** A handle on the server worker. *) +type server + +(** Promise a running RPC serve ; takes the port. To call + an RPC at /p/a/t/h/ in the provided service, one must call the URI + /call/p/a/t/h/. Calling /list/p/a/t/h/ will list the services + prefixed by /p/a/t/h/, if any. Calling /schema/p/a/t/h/ will + describe the input and output of the service, if it is + callable. Calling /pipe will read a sequence of services to call in + sequence from the request body, see {!pipe_encoding}. + + The optional [pre_hook] is called with the path part of the URL + before resolving each request, to delegate the answering to + another resolution mechanism. Its result is ignored if the return + code is [404]. The optional [post_hook] is called if both the + [pre_hook] and the serviced answered with a [404] code. *) +val launch : int -> + ?pre_hook: (string -> string RPC.Answer.answer Lwt.t) -> + ?post_hook: (string -> string RPC.Answer.answer Lwt.t) -> + unit RPC.directory -> server Lwt.t + +(** Kill an RPC server. *) +val shutdown : server -> unit Lwt.t + +(** Retrieve the root service of the server *) +val root_service : server -> unit RPC.directory + +(** Change the root service of the server *) +val set_root_service : server -> unit RPC.directory -> unit diff --git a/src/node/net/p2p.ml b/src/node/net/p2p.ml index 90bca1bf8..5f28add55 100644 --- a/src/node/net/p2p.ml +++ b/src/node/net/p2p.ml @@ -773,7 +773,7 @@ module Make (P: PARAMS) = struct (* create the external message pipe *) let messages = Lwt_pipe.create 100 in (* fill the known peers pools from last time *) - Data_encoding.Json.read_file config.peers_file >>= fun res -> + Data_encoding_ezjsonm.read_file config.peers_file >>= fun res -> let known_peers, black_list, my_gid, my_public_key, my_secret_key, my_proof_of_work = let init_peers () = @@ -872,7 +872,7 @@ module Make (P: PARAMS) = struct if source.white_listed then (addr, port) :: w else w)) !known_peers ([], BlackList.bindings !black_list, [])) in - Data_encoding.Json.write_file config.peers_file json >>= fun _ -> + Data_encoding_ezjsonm.write_file config.peers_file json >>= fun _ -> debug "(%a) peer cache saved" pp_gid my_gid ; Lwt.return_unit) ; (* storage of active and not yet active peers *) diff --git a/src/node/shell/node_rpc.ml b/src/node/shell/node_rpc.ml index 354187527..d555bcbdd 100644 --- a/src/node/shell/node_rpc.ml +++ b/src/node/shell/node_rpc.ml @@ -433,7 +433,7 @@ let build_rpc_directory node = let dir = let implementation () = RPC.Answer.return Data_encoding.Json.(schema (Error_monad.error_encoding ())) in - RPC.register0 dir RPC.Error.service implementation in + RPC.register0 dir Services.Error.service implementation in let dir = RPC.register1 dir Services.complete (fun s () -> diff --git a/src/node/shell/node_rpc_services.ml b/src/node/shell/node_rpc_services.ml index c1046755a..ba6be7dcb 100644 --- a/src/node/shell/node_rpc_services.ml +++ b/src/node/shell/node_rpc_services.ml @@ -9,6 +9,42 @@ open Data_encoding +module Error = struct + + let service = + RPC.service + ~description: "Schema for all the RPC errors from the shell" + ~input: Data_encoding.empty + ~output: Data_encoding.json_schema + RPC.Path.(root / "errors") + + let encoding = + let path, _ = RPC.forge_request service () () in + describe + ~description: + (Printf.sprintf + "The full list of error is available with \ + the global RPC `/%s`" (String.concat "/" path)) + (conv + ~schema:Json_schema.any + (fun exn -> `A (List.map json_of_error exn)) + (function `A exns -> List.map error_of_json exns | _ -> []) + json) + + let wrap param_encoding = + union [ + case + (obj1 (req "ok" param_encoding)) + (function Ok x -> Some x | _ -> None) + (fun x -> Ok x) ; + case + (obj1 (req "error" encoding)) + (function Error x -> Some x | _ -> None) + (fun x -> Error x) ; + ] + +end + module Blocks = struct type block = [ @@ -128,7 +164,7 @@ module Blocks = struct (obj3 (req "timestamp" Time.encoding) (req "fitness" Fitness.encoding) - (req "operations" (Updater.preapply_result_encoding RPC.Error.encoding)))) + (req "operations" (Updater.preapply_result_encoding Error.encoding)))) let block_path : (unit, unit * block) RPC.Path.path = RPC.Path.(root / "blocks" /: blocks_arg ) @@ -237,9 +273,9 @@ module Blocks = struct (obj4 (req "applied" (list Operation_hash.encoding)) (req "branch_delayed" - (list (tup2 Operation_hash.encoding RPC.Error.encoding))) + (list (tup2 Operation_hash.encoding Error.encoding))) (req "branch_refused" - (list (tup2 Operation_hash.encoding RPC.Error.encoding))) + (list (tup2 Operation_hash.encoding Error.encoding))) (req "unprocessed" (list Operation_hash.encoding)))) RPC.Path.(block_path / "pending_operations") @@ -252,7 +288,7 @@ module Blocks = struct "Simulate the validation of a block that would contain \ the given operations and return the resulting fitness." ~input: preapply_param_encoding - ~output: (RPC.Error.wrap preapply_result_encoding) + ~output: (Error.wrap preapply_result_encoding) RPC.Path.(block_path / "preapply") let complete = @@ -365,7 +401,7 @@ module Operations = struct (obj1 (req "data" (describe ~title: "Tezos signed operation (hex encoded)" (Time.timed_encoding @@ - RPC.Error.wrap @@ + Error.wrap @@ Updater.raw_operation_encoding)))) RPC.Path.(root / "operations" /: operations_arg) @@ -416,7 +452,7 @@ module Protocols = struct (obj1 (req "data" (describe ~title: "Tezos protocol" (Time.timed_encoding @@ - RPC.Error.wrap @@ + Error.wrap @@ Store.protocol_encoding)))) RPC.Path.(root / "protocols" /: protocols_arg) @@ -471,7 +507,7 @@ let validate_block = (req "net" Blocks.net_encoding) (req "hash" Block_hash.encoding)) ~output: - (RPC.Error.wrap @@ empty) + (Error.wrap @@ empty) RPC.Path.(root / "validate_block") let inject_block = @@ -504,7 +540,7 @@ let inject_block = the current head. (default: false)" bool)))) ~output: - (RPC.Error.wrap @@ + (Error.wrap @@ (obj1 (req "block_hash" Block_hash.encoding))) RPC.Path.(root / "inject_block") @@ -539,7 +575,7 @@ let inject_operation = or \"branch_delayed\". (default: false)" bool)))) ~output: - (RPC.Error.wrap @@ + (Error.wrap @@ describe ~title: "Hash of the injected operation" @@ (obj1 (req "injectedOperation" Operation_hash.encoding))) @@ -592,7 +628,7 @@ let inject_protocol = "Should we inject protocol that is invalid. (default: false)" bool)))) ~output: - (RPC.Error.wrap @@ + (Error.wrap @@ describe ~title: "Hash of the injected protocol" @@ (obj1 (req "injectedProtocol" Protocol_hash.encoding))) diff --git a/src/node/shell/node_rpc_services.mli b/src/node/shell/node_rpc_services.mli index bc2e5e86b..5ad9771a9 100644 --- a/src/node/shell/node_rpc_services.mli +++ b/src/node/shell/node_rpc_services.mli @@ -7,6 +7,12 @@ (* *) (**************************************************************************) +module Error : sig + val service: (unit, unit, unit, Json_schema.schema) RPC.service + val encoding: error list Data_encoding.t + val wrap: 'a Data_encoding.t -> 'a tzresult Data_encoding.encoding +end + module Blocks : sig type block = [ @@ -15,6 +21,7 @@ module Blocks : sig | `Test_head of int | `Test_prevalidation | `Hash of Block_hash.t ] + val blocks_arg : block RPC.Arg.arg val parse_block: string -> (block, string) result type net = Store.net_id = Net of Block_hash.t diff --git a/src/node/updater/updater.ml b/src/node/updater/updater.ml index 3ca23c774..608019be4 100644 --- a/src/node/updater/updater.ml +++ b/src/node/updater/updater.ml @@ -140,18 +140,18 @@ type component = Tezos_compiler.Protocol.component = { } let create_files dir units = - Utils.remove_dir dir >>= fun () -> - Utils.create_dir dir >>= fun () -> + Lwt_utils.remove_dir dir >>= fun () -> + Lwt_utils.create_dir dir >>= fun () -> Lwt_list.map_s (fun { name; interface; implementation } -> let name = String.lowercase_ascii name in let ml = dir // (name ^ ".ml") in let mli = dir // (name ^ ".mli") in - Utils.create_file ml implementation >>= fun () -> + Lwt_utils.create_file ml implementation >>= fun () -> match interface with | None -> Lwt.return [ml] | Some content -> - Utils.create_file mli content >>= fun () -> + Lwt_utils.create_file mli content >>= fun () -> Lwt.return [mli;ml]) units >>= fun files -> let files = List.concat files in diff --git a/src/node_main.ml b/src/node_main.ml index 2134b5c9a..b73e398b2 100644 --- a/src/node_main.ml +++ b/src/node_main.ml @@ -206,14 +206,15 @@ module Cfg_file = struct (req "log" log)) let read fp = - let open Data_encoding.Json in - read_file fp >|= function + Data_encoding_ezjsonm.read_file fp >|= function | None -> None - | Some json -> Some (destruct t json) + | Some json -> Some (Data_encoding.Json.destruct t json) let from_json json = Data_encoding.Json.destruct t json let write out cfg = - Utils.write_file ~bin:false out Data_encoding.Json.(construct t cfg |> to_string) + Utils.write_file ~bin:false out + (Data_encoding.Json.construct t cfg |> + Data_encoding_ezjsonm.to_string) end module Cmdline = struct @@ -289,7 +290,7 @@ module Cmdline = struct default_cfg_of_base_dir base_dir in let cfg = - match Utils.read_file ~bin:false config_file |> Data_encoding.Json.from_string with + match Utils.read_file ~bin:false config_file |> Data_encoding_ezjsonm.from_string with | exception _ -> no_config () | Error msg -> corrupted_config msg | Ok cfg -> try Cfg_file.from_json cfg with @@ -382,7 +383,7 @@ let init_node { sandbox ; sandbox_param ; match sandbox_param with | None -> Lwt.return (Some (patch_context None)) | Some file -> - Data_encoding.Json.read_file file >>= function + Data_encoding_ezjsonm.read_file file >>= function | None -> lwt_warn "Can't parse sandbox parameters. (%s)" file >>= fun () -> @@ -427,11 +428,11 @@ let init_rpc { rpc_addr } node = | Some (_addr, port) -> lwt_log_notice "Starting the RPC server listening on port %d." port >>= fun () -> let dir = Node_rpc.build_rpc_directory node in - RPC.(launch port dir) >>= fun server -> + RPC_server.launch port dir >>= fun server -> Lwt.return (Some server) let init_signal () = - let handler id = try Utils.exit id with _ -> () in + let handler id = try Lwt_exit.exit id with _ -> () in ignore (Lwt_unix.on_signal Sys.sigint handler : Lwt_unix.signal_handler_id) let main cfg = @@ -444,11 +445,11 @@ let main cfg = init_rpc cfg node >>= fun rpc -> init_signal (); lwt_log_notice "The Tezos node is now running!" >>= fun () -> - Utils.termination_thread >>= fun x -> + Lwt_exit.termination_thread >>= fun x -> lwt_log_notice "Shutting down the Tezos node..." >>= fun () -> Node.shutdown node >>= fun () -> lwt_log_notice "Shutting down the RPC server..." >>= fun () -> - Lwt_utils.may RPC.shutdown rpc >>= fun () -> + Lwt_utils.may RPC_server.shutdown rpc >>= fun () -> lwt_log_notice "BYE (%d)" x >>= fun () -> return () diff --git a/src/proto/bootstrap/storage.ml b/src/proto/bootstrap/storage.ml index 2a23756f8..8a0c5e189 100644 --- a/src/proto/bootstrap/storage.ml +++ b/src/proto/bootstrap/storage.ml @@ -16,19 +16,19 @@ let prevalidation_key = [ version ; "prevalidation" ] type t = Storage_functors.context -type error += Invalid_sandbox_parameter of string +type error += Invalid_sandbox_parameter let get_sandboxed c = Context.get c sandboxed_key >>= function | None -> return None - | Some json -> - match Data_encoding.Json.from_string (MBytes.to_string json) with - | Error err -> fail (Invalid_sandbox_parameter err) - | Ok json -> return (Some json) + | Some bytes -> + match Data_encoding.Binary.of_bytes Data_encoding.json bytes with + | None -> fail Invalid_sandbox_parameter + | Some json -> return (Some json) let set_sandboxed c json = Context.set c sandboxed_key - (MBytes.of_string (Data_encoding.Json.to_string json)) + (Data_encoding.Binary.to_bytes Data_encoding.json json) let prepare (c : Context.t) : t tzresult Lwt.t = get_sandboxed c >>=? fun sandbox -> diff --git a/src/proto/environment/data_encoding.mli b/src/proto/environment/data_encoding.mli index b70ef5506..736ff8874 100644 --- a/src/proto/environment/data_encoding.mli +++ b/src/proto/environment/data_encoding.mli @@ -170,13 +170,6 @@ val mu : string -> ('a encoding -> 'a encoding) -> 'a encoding module Json : sig - (** Read a JSON document from a string. *) - val from_string : string -> (json, string) result - - (** Write a JSON document to a string. This goes via an intermediate - buffer and so may be slow on large documents. *) - val to_string : json -> string - val schema : 'a encoding -> json_schema val construct : 't encoding -> 't -> json val destruct : 't encoding -> json -> 't diff --git a/src/utils/data_encoding_ezjsonm.ml b/src/utils/data_encoding_ezjsonm.ml new file mode 100644 index 000000000..0b3c36ebf --- /dev/null +++ b/src/utils/data_encoding_ezjsonm.ml @@ -0,0 +1,56 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +let to_root = function + | `O ctns -> `O ctns + | `A ctns -> `A ctns + | `Null -> `O [] + | oth -> `A [ oth ] + +let to_string j = Ezjsonm.to_string ~minify:false (to_root j) + +let from_string s = + try Ok (Ezjsonm.from_string s :> Data_encoding.json) + with Ezjsonm.Parse_error (_, msg) -> Error msg + +let from_stream (stream: string Lwt_stream.t) = + let buffer = ref "" in + Lwt_stream.filter_map + (fun str -> + buffer := !buffer ^ str ; + try + let json = Ezjsonm.from_string !buffer in + buffer := "" ; + Some (Ok json) + with Ezjsonm.Parse_error (_, msg) -> + if String.length str = 32 * 1024 then None + else Some (Error msg)) + stream + +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) + +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) diff --git a/src/utils/data_encoding_ezjsonm.mli b/src/utils/data_encoding_ezjsonm.mli new file mode 100644 index 000000000..a195f10a0 --- /dev/null +++ b/src/utils/data_encoding_ezjsonm.mli @@ -0,0 +1,26 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +(** Read a JSON document from a string. *) +val from_string : string -> (Data_encoding.json, string) result + +(** Read a stream of JSON documents from a stream of strings. + A single JSON document may be represented in multiple consecutive + strings. But only the first document of a string is considered. *) +val from_stream : string Lwt_stream.t -> (Data_encoding.json, string) result Lwt_stream.t + +(** Write a JSON document to a string. This goes via an intermediate + buffer and so may be slow on large documents. *) +val to_string : Data_encoding.json -> string + +(** Loads a JSON file in memory *) +val read_file : string -> Data_encoding.json option Lwt.t + +(** (Over)write a JSON file from in memory data *) +val write_file : string -> Data_encoding.json -> bool Lwt.t diff --git a/src/utils/error_monad.ml b/src/utils/error_monad.ml index 4aeaf2cea..f689b8410 100644 --- a/src/utils/error_monad.ml +++ b/src/utils/error_monad.ml @@ -18,7 +18,7 @@ type 'err full_error_category = let json_pp encoding ppf x = Format.pp_print_string ppf @@ - Data_encoding.Json.to_string @@ + Data_encoding_ezjsonm.to_string @@ Data_encoding.Json.(construct encoding x) module Make() = struct diff --git a/src/utils/logging.ml b/src/utils/logging.ml index dea4cc404..2cad82973 100644 --- a/src/utils/logging.ml +++ b/src/utils/logging.ml @@ -54,7 +54,7 @@ module Make(S : sig val name: string end) : LOG = struct let log_error fmt = ign_log_f ~section ~level:Lwt_log.Error fmt let fatal_error fmt = Format.kasprintf - (fun s -> Lwt_log.ign_fatal ~section s; Utils.exit 1) + (fun s -> Lwt_log.ign_fatal ~section s; Lwt_exit.exit 1) fmt let lwt_debug fmt = log_f ~section ~level:Lwt_log.Debug fmt diff --git a/src/utils/lwt_exit.ml b/src/utils/lwt_exit.ml new file mode 100644 index 000000000..2e82b1fe8 --- /dev/null +++ b/src/utils/lwt_exit.ml @@ -0,0 +1,23 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + + +exception Exit + +let termination_thread, exit_wakener = Lwt.wait () +let exit x = Lwt.wakeup exit_wakener x; raise Exit + +let () = + Lwt.async_exception_hook := + (function + | Exit -> () + | exn -> + Printf.eprintf "Uncaught (asynchronous) exception: %S\n%s\n%!" + (Printexc.to_string exn) (Printexc.get_backtrace ()); + Lwt.wakeup exit_wakener 1) diff --git a/src/utils/lwt_exit.mli b/src/utils/lwt_exit.mli new file mode 100644 index 000000000..2ba38abb9 --- /dev/null +++ b/src/utils/lwt_exit.mli @@ -0,0 +1,18 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +(** A global thread that resumes the first time {!exit} is called + anywhere in the program. Called by the main to wait for any other + thread in the system to call {!exit}. *) +val termination_thread: int Lwt.t + +(** Awakens the {!termination_thread} with the given return value, and + raises an exception that cannot be caught, except by a + catch-all. Should only be called once. *) +val exit: int -> 'a diff --git a/src/utils/lwt_utils.ml b/src/utils/lwt_utils.ml index 3e4de7572..d3ad37d5b 100644 --- a/src/utils/lwt_utils.ml +++ b/src/utils/lwt_utils.ml @@ -263,3 +263,37 @@ let write_mbytes ?(pos=0) ?len descr buf = | nb_written -> inner (pos + nb_written) (len - nb_written) in inner pos len +let (>>=) = Lwt.bind + +let remove_dir dir = + let rec remove dir = + let files = Lwt_unix.files_of_directory dir in + Lwt_stream.iter_s + (fun file -> + if file = "." || file = ".." then + Lwt.return () + else begin + let file = Filename.concat dir file in + if Sys.is_directory file + then remove file + else Lwt_unix.unlink file + end) + files >>= fun () -> + Lwt_unix.rmdir dir in + if Sys.file_exists dir && Sys.is_directory dir then + remove dir + else + Lwt.return () + +let rec create_dir ?(perm = 0o755) dir = + if Sys.file_exists dir then + Lwt.return () + else begin + create_dir (Filename.dirname dir) >>= fun () -> + Lwt_unix.mkdir dir perm + end + +let create_file ?(perm = 0o644) name content = + Lwt_unix.openfile name Unix.([O_TRUNC; O_CREAT; O_WRONLY]) perm >>= fun fd -> + Lwt_unix.write_string fd content 0 (String.length content) >>= fun _ -> + Lwt_unix.close fd diff --git a/src/utils/lwt_utils.mli b/src/utils/lwt_utils.mli index 2b3df7ac8..0fd73d6cd 100644 --- a/src/utils/lwt_utils.mli +++ b/src/utils/lwt_utils.mli @@ -35,3 +35,7 @@ val read_mbytes: val write_mbytes: ?pos:int -> ?len:int -> Lwt_unix.file_descr -> MBytes.t -> unit Lwt.t + +val remove_dir: string -> unit Lwt.t +val create_dir: ?perm:int -> string -> unit Lwt.t +val create_file: ?perm:int -> string -> string -> unit Lwt.t diff --git a/test/.merlin b/test/.merlin index c283d6621..ce4f056ca 100644 --- a/test/.merlin +++ b/test/.merlin @@ -1,6 +1,8 @@ REC S . B . +S ../src/minutils +B ../src/minutils S ../src/utils B ../src/utils S ../src/node/db diff --git a/test/Makefile b/test/Makefile index a58b5abdd..45cf2e67d 100644 --- a/test/Makefile +++ b/test/Makefile @@ -13,6 +13,7 @@ OCAMLFLAGS = \ SOURCE_DIRECTORIES := \ lib \ $(addprefix ../src/, \ + minutils \ utils \ compiler \ node/db \ @@ -37,7 +38,7 @@ PACKAGES := \ lwt.unix \ ocplib-endian \ ocplib-ocamlres \ - ocplib-json-typed \ + ocplib-json-typed.bson \ ocplib-resto.directory \ sodium \ unix \ @@ -47,7 +48,9 @@ PACKAGES := \ ############################################################################ ## External packages -NODELIB := ../src/utils.cmxa ../src/compiler.cmxa ../src/node.cmxa +NODELIB := \ + ../src/minutils.cmxa ../src/utils.cmxa \ + ../src/compiler.cmxa ../src/node.cmxa CLIENTLIB := ../src/client.cmxa \ $(patsubst ../src/client/embedded/%/, \ ../src/proto/client_embedded_proto_%.cmxa, \ @@ -221,6 +224,7 @@ COVERAGESRCDIR= \ -I ../src/proto \ -I ../src/proto/bootstrap \ -I ../src/proto/demo \ + -I ../src/minutils \ -I ../src/utils bisect: diff --git a/test/test_basic.ml b/test/test_basic.ml index 682f56d88..44434f60f 100644 --- a/test/test_basic.ml +++ b/test/test_basic.ml @@ -13,7 +13,17 @@ open Tezos_context open Error_monad open Hash -let () = Random.self_init () +let () = + Random.self_init () ; + let log channel msg = match channel with + | "stdout" -> + print_endline msg ; + Lwt.return () + | "stderr" -> + prerr_endline msg ; + Lwt.return () + | _ -> Lwt.return () in + Cli_entries.log_hook := Some log let should_fail f t = t >>= function diff --git a/test/test_data_encoding.ml b/test/test_data_encoding.ml index 8a7b187ed..848419be9 100644 --- a/test/test_data_encoding.ml +++ b/test/test_data_encoding.ml @@ -104,15 +104,16 @@ let test_simple_values _ = Lwt.return_unit let test_json testdir = + let open Data_encoding_ezjsonm in let file = testdir // "testing_data_encoding.tezos" in let v = `Float 42. in - let f_str = Json.to_string v in + let f_str = to_string v in Assert.equal_string ~msg:__LOC__ f_str "[\n 42\n]"; - Json.read_file (testdir // "NONEXISTINGFILE") >>= fun rf -> + read_file (testdir // "NONEXISTINGFILE") >>= fun rf -> Assert.is_none ~msg:__LOC__ rf; - Json.write_file file v >>= fun success -> + write_file file v >>= fun success -> Assert.is_true ~msg:__LOC__ success; - Json.read_file file >>= fun opt -> + read_file file >>= fun opt -> Assert.is_some ~msg:__LOC__ opt; Lwt.return () @@ -267,7 +268,7 @@ let test_json_input testdir = } |} in - Json.read_file file >>= function + Data_encoding_ezjsonm.read_file file >>= function None -> Assert.fail_msg "Cannot parse \"good.json\"." | Some json -> let (id, value, popup) = Json.destruct enc json in @@ -293,7 +294,7 @@ let test_json_input testdir = } |} in - Json.read_file file >>= function + Data_encoding_ezjsonm.read_file file >>= function None -> Assert.fail_msg "Cannot parse \"unknown.json\"." | Some json -> Assert.test_fail ~msg:__LOC__