From dc64f9b6fb88adde2957d39b6355f2facc010fb8 Mon Sep 17 00:00:00 2001 From: Benjamin Canou Date: Thu, 1 Dec 2016 23:20:23 +0100 Subject: [PATCH 1/3] Webclient: first draft. --- .gitignore | 10 + src/Makefile | 109 +++++++-- src/client/client_config.ml | 113 +++++---- src/client/embedded/Makefile.shared | 85 +++++-- src/client/embedded/bootstrap/Makefile | 72 +++++- src/client/embedded/bootstrap/mining/Makefile | 4 +- .../embedded/bootstrap/webclient/.merlin | 5 + .../bootstrap/webclient/browser/.merlin | 9 + .../webclient/browser/webclient_main.ml | 53 +++++ .../bootstrap/webclient/shared/.merlin | 5 + .../shared/webclient_proto_services.ml | 30 +++ .../shared/webclient_proto_services.mli | 19 ++ .../bootstrap/webclient/static/index.html | 12 + .../bootstrap/webclient/static/not_found.html | 10 + .../webclient/webclient_proto_main.ml | 15 ++ .../webclient_proto_service_directory.ml | 24 ++ src/client/embedded/demo/Makefile | 4 +- src/client/webclient_version.ml | 28 +++ src/client_main.ml | 25 +- src/tezos-deps.opam | 3 + src/utils/cli_entries.ml | 4 +- src/utils/cli_entries.mli | 9 +- src/utils/logging.ml | 1 + src/utils/logging.mli | 1 + src/webclient_main.ml | 218 ++++++++++++++++++ src/webclient_static/index.html | 33 +++ src/webclient_static/not_found.html | 10 + test/Makefile | 1 - 28 files changed, 799 insertions(+), 113 deletions(-) create mode 100644 src/client/embedded/bootstrap/webclient/.merlin create mode 100644 src/client/embedded/bootstrap/webclient/browser/.merlin create mode 100644 src/client/embedded/bootstrap/webclient/browser/webclient_main.ml create mode 100644 src/client/embedded/bootstrap/webclient/shared/.merlin create mode 100644 src/client/embedded/bootstrap/webclient/shared/webclient_proto_services.ml create mode 100644 src/client/embedded/bootstrap/webclient/shared/webclient_proto_services.mli create mode 100644 src/client/embedded/bootstrap/webclient/static/index.html create mode 100644 src/client/embedded/bootstrap/webclient/static/not_found.html create mode 100644 src/client/embedded/bootstrap/webclient/webclient_proto_main.ml create mode 100644 src/client/embedded/bootstrap/webclient/webclient_proto_service_directory.ml create mode 100644 src/client/webclient_version.ml create mode 100644 src/webclient_main.ml create mode 100644 src/webclient_static/index.html create mode 100644 src/webclient_static/not_found.html diff --git a/.gitignore b/.gitignore index 3346ad50b..5cdc07c18 100644 --- a/.gitignore +++ b/.gitignore @@ -2,7 +2,9 @@ /tezos-node /tezos-protocol-compiler /tezos-client +/tezos-webclient +/src/webclient_static.ml /src/.depend /src/node/updater/environment_gen @@ -19,6 +21,12 @@ /src/client/embedded/bootstrap/concrete_lexer.ml /src/client/embedded/bootstrap/concrete_parser.ml /src/client/embedded/bootstrap/concrete_parser.mli +/src/client/embedded/bootstrap/webclient_proto_static.ml +/src/client/embedded/bootstrap/main.byte +/src/client/embedded/bootstrap/webclient_static/main.js +/src/client/embedded/bootstrap/webclient/browser/main.byte +/src/client/embedded/bootstrap/webclient/static/main.js +/src/client/embedded/bootstrap/webclient/webclient_proto_static.ml /test/.depend /test/reports @@ -44,6 +52,8 @@ *.cmp *.mli.deps *.ml.deps +*.mli.deps.byte +*.ml.deps.byte bisect*.out diff --git a/src/Makefile b/src/Makefile index 9082ce468..c48fc410a 100644 --- a/src/Makefile +++ b/src/Makefile @@ -4,8 +4,9 @@ include Makefile.config TZCOMPILER=../tezos-protocol-compiler TZNODE=../tezos-node TZCLIENT=../tezos-client +TZWEBCLIENT=../tezos-webclient -all: ${TZCOMPILER} ${TZNODE} ${TZCLIENT} +all: ${TZCOMPILER} ${TZNODE} ${TZCLIENT} ${TZWEBCLIENT} ############################################################################ @@ -131,6 +132,17 @@ minutils.cmxa: ${MINUTILS_LIB_IMPLS:.ml=.cmx} @echo LINK $(notdir $@) @${OCAMLOPT} ${OCAMLFLAGS} -a -o $@ $^ +MINUTILS_OBJS_BYTECODE := \ + ${MINUTILS_LIB_IMPLS:.ml=.cmo} ${MINUTILS_LIB_IMPLS:.ml=.ml.deps.byte} +${MINUTILS_OBJS_BYTECODE}: PACKAGES=${MINUTILS_PACKAGES} +${MINUTILS_OBJS_BYTECODE}: SOURCE_DIRECTORIES=minutils +${MINUTILS_OBJS_BYTECODE}: TARGET="(minutils.cma)" +${MINUTILS_OBJS_BYTECODE}: OPENED_MODULES= + +minutils.cma: ${MINUTILS_LIB_IMPLS:.ml=.cmo} + @echo LINK $(notdir $@) + @${OCAMLC} ${OCAMLFLAGS} -a -o $@ $^ + ############################################################################ ## Utils library ############################################################################ @@ -366,7 +378,6 @@ proto/client_embedded_proto_%.cmxa: \ clean:: rm -f ${TZNODE} - ############################################################################ ## Client program ############################################################################ @@ -390,55 +401,108 @@ CLIENT_LIB_IMPLS := \ client/client_keys.ml \ client/client_protocols.ml \ +WEBCLIENT_LIB_INTFS := \ + +WEBCLIENT_LIB_IMPLS := \ + client/webclient_version.ml \ + CLIENT_IMPLS := \ client_main.ml +WEBCLIENT_IMPLS := \ + webclient_static.ml \ + webclient_main.ml + CLIENT_PACKAGES := \ ${NODE_PACKAGES} EMBEDDED_CLIENT_PROTOCOLS := \ $(patsubst client/embedded/%/, \ proto/client_embedded_proto_%.cmxa, \ - $(shell ls -d client/embedded/*/)) \ - $(patsubst client/embedded/%/, \ - client/embedded/client_%.cmx , \ $(shell ls -d client/embedded/*/)) +EMBEDDED_CLIENT_VERSIONS := \ + $(patsubst client/embedded/%/, \ + client/embedded/client_%.cmx, \ + $(shell ls -d client/embedded/*/)) + +EMBEDDED_WEBCLIENT_VERSIONS := \ + $(patsubst client/embedded/%/, \ + client/embedded/webclient_%.cmx, \ + $(shell ls -d client/embedded/*/)) CLIENT_OBJS := \ ${CLIENT_IMPLS:.ml=.cmx} ${CLIENT_IMPLS:.ml=.ml.deps} \ + ${WEBCLIENT_IMPLS:.ml=.cmx} ${WEBCLIENT_IMPLS:.ml=.ml.deps} \ ${CLIENT_LIB_IMPLS:.ml=.cmx} ${CLIENT_LIB_IMPLS:.ml=.ml.deps} \ ${CLIENT_LIB_INTFS:.mli=.cmi} ${CLIENT_LIB_INTFS:.mli=.mli.deps} \ - ${TZCLIENT} + ${WEBCLIENT_LIB_IMPLS:.ml=.cmx} ${WEBCLIENT_LIB_IMPLS:.ml=.ml.deps} \ + ${WEBCLIENT_LIB_INTFS:.mli=.cmi} ${WEBCLIENT_LIB_INTFS:.mli=.mli.deps} \ + ${TZCLIENT} \ + ${TZWEBCLIENT} ${CLIENT_OBJS}: PACKAGES=${CLIENT_PACKAGES} ${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 +${CLIENT_LIB_IMPLS:.ml=.cmx} ${CLIENT_LIB_IMPLS:.ml=.ml.deps}: TARGET="(client.cmxa)" +${CLIENT_LIB_INTFS:.mli=.cmi} ${CLIENT_LIB_INTFS:.mli=.mli.deps}: TARGET="(client.cmxa)" +${WEBCLIENT_LIB_IMPLS:.ml=.cmx} ${WEBCLIENT_LIB_IMPLS:.ml=.ml.deps}: TARGET="(webclient.cmxa)" +${WEBCLIENT_LIB_INTFS:.mli=.cmi} ${WEBCLIENT_LIB_INTFS:.mli=.mli.deps}: TARGET="(webclient.cmxa)" + client.cmxa: ${CLIENT_LIB_IMPLS:.ml=.cmx} @echo LINK $(notdir $@) @${OCAMLOPT} ${OCAMLFLAGS} -a -o $@ $^ -${EMBEDDED_CLIENT_PROTOCOLS}: client.cmxa -${CLIENT_IMPLS:.ml=.cmx}: ${EMBEDDED_CLIENT_PROTOCOLS} +webclient.cmxa: ${WEBCLIENT_LIB_IMPLS:.ml=.cmx} client.cmxa + @echo LINK $(notdir $@) + ${OCAMLOPT} ${OCAMLFLAGS} -a -o $@ ${WEBCLIENT_LIB_IMPLS:.ml=.cmx} + +${EMBEDDED_CLIENT_VERSIONS}: client.cmxa +${CLIENT_IMPLS:.ml=.cmx}: ${EMBEDDED_CLIENT_VERSIONS} + +${EMBEDDED_WEBCLIENT_VERSIONS}: webclient.cmxa +${WEBCLIENT_IMPLS:.ml=.cmx}: ${EMBEDDED_CLIENT_VERSIONS} ${EMBEDDED_WEBCLIENT_VERSIONS} ${TZCLIENT}: minutils.cmxa utils.cmxa compiler.cmxa node.cmxa \ - client.cmxa ${EMBEDDED_CLIENT_PROTOCOLS} \ - ${CLIENT_IMPLS:.ml=.cmx} + client.cmxa \ + ${EMBEDDED_CLIENT_PROTOCOLS} \ + ${EMBEDDED_CLIENT_VERSIONS} \ + ${CLIENT_IMPLS:.ml=.cmx} @echo LINK $(notdir $@) @${OCAMLOPT} -linkpkg ${OCAMLFLAGS} -o $@ $^ +${TZWEBCLIENT}: minutils.cmxa utils.cmxa compiler.cmxa node.cmxa \ + client.cmxa webclient.cmxa \ + ${EMBEDDED_CLIENT_PROTOCOLS} \ + ${EMBEDDED_CLIENT_VERSIONS} \ + ${EMBEDDED_WEBCLIENT_VERSIONS} \ + ${WEBCLIENT_IMPLS:.ml=.cmx} + @echo LINK $(notdir $@) + @${OCAMLOPT} -linkpkg ${OCAMLFLAGS} -o $@ $^ + +webclient_static.ml: $$(shell find webclient_static/) + ocp-ocamlres webclient_static -o $@ + clean:: - -rm -f ${TZCLIENT} + -rm -f ${TZCLIENT} $(TZWEBCLIENT) ## Embedded client protocol modules .SECONDEXPANSION: + client/embedded/client_%.cmx: \ $(patsubst %.ml, %.cmx, $(NODE_LIB_IMPLS) $(CLIENT_LIB_IMPLS)) \ proto/client_embedded_proto_%.cmxa \ $$(shell find client/embedded/% -name \*.ml -or -name \*.mli) @$(MAKE) -C client/embedded/$* ../client_$*.cmx + +client/embedded/webclient_%.cmx: \ + client/embedded/client_%.cmx \ + minutils.cma \ + $$(shell find client/embedded/%/webclient -name \*.ml -or -name \*.mli) \ + $$(shell find client/embedded/%/webclient/static/) + @$(MAKE) -C client/embedded/$* ../webclient_$*.cmx + clean:: -for d in $$(ls -d client/embedded/*/) ; do make clean -C $$d ; done -rm -f client/embedded/*.cm* client/embedded/*.o @@ -450,7 +514,7 @@ clean:: @$(OCAMLOPT) ${OCAMLFLAGS} -c $< %.cmo: %.ml - @echo OCAMLOPT ${TARGET} $(notdir $@) + @echo OCAMLC ${TARGET} $(notdir $@) @$(OCAMLC) ${OCAMLFLAGS} -c $< %.cmi: %.mli @@ -472,9 +536,10 @@ compiler/embedded_cmis.cmx compiler/embedded_cmis.cmi: OPENED_MODULES= ifneq ($(MAKECMDGOALS),clean) ifneq ($(MAKECMDGOALS),build-deps) --include .depend +include .depend endif endif + DEPENDS := $(filter-out $(NO_DEPS), $(MINUTILS_LIB_INTFS) $(MINUTILS_LIB_IMPLS) \ $(UTILS_LIB_INTFS) $(UTILS_LIB_IMPLS) \ $(COMPILER_LIB_INTFS) $(COMPILER_LIB_IMPLS) \ @@ -482,14 +547,18 @@ DEPENDS := $(filter-out $(NO_DEPS), $(MINUTILS_LIB_INTFS) $(MINUTILS_LIB_IMPLS) $(NODE_LIB_INTFS) $(NODE_LIB_IMPLS) \ $(NODE_INTFS) $(NODE_IMPLS) \ $(CLIENT_LIB_INTFS) $(CLIENT_LIB_IMPLS) \ - $(CLIENT_INTFS) $(CLIENT_IMPLS)) + $(WEBCLIENT_LIB_INTFS) $(WEBCLIENT_LIB_IMPLS) \ + $(CLIENT_INTFS) $(CLIENT_IMPLS) \ + $(WEBCLIENT_INTFS) $(WEBCLIENT_IMPLS)) + +DEPENDS_BYTECODE := $(filter-out $(NO_DEPS), $(MINUTILS_LIB_INTFS) $(MINUTILS_LIB_IMPLS)) predepend: node/updater/proto_environment.mli compiler/tezos_compiler.cmo compiler/tezos_compiler.cmx: \ compiler/embedded_cmis.cmi compiler/embedded_cmis.cmx -.SECONDARY: $(patsubst %,%.deps,${DEPENDS}) -.depend: $(patsubst %,%.deps,${DEPENDS}) +.SECONDARY: $(patsubst %,%.deps,${DEPENDS}) $(patsubst %,%.deps.byte,${DEPENDS_BYTECODE}) +.depend: $(patsubst %,%.deps,${DEPENDS}) $(patsubst %,%.deps.byte,${DEPENDS_BYTECODE}) @cat $^ > .depend %.ml.deps: %.ml | predepend @echo OCAMLDEP ${TARGET} $(notdir $^) @@ -497,6 +566,12 @@ compiler/tezos_compiler.cmo compiler/tezos_compiler.cmx: \ %.mli.deps: %.mli | predepend @echo OCAMLDEP ${TARGET} $(notdir $^) @$(OCAMLDEP) -native $(INCLUDES) $^ > $@ +%.ml.deps.byte: %.ml | predepend + @echo OCAMLDEP ${TARGET} $(notdir $^) + @$(OCAMLDEP) $(INCLUDES) $^ > $@ +%.mli.deps.byte: %.mli | predepend + @echo OCAMLDEP ${TARGET} $(notdir $^) + @$(OCAMLDEP) $(INCLUDES) $^ > $@ clean:: -rm -f .depend diff --git a/src/client/client_config.ml b/src/client/client_config.ml index 6dd9b287e..6485825a2 100644 --- a/src/client/client_config.ml +++ b/src/client/client_config.ml @@ -102,53 +102,64 @@ let register_config_option version option = (* Entry point *) -let parse_args ?version usage dispatcher = +let parse_args ?version usage dispatcher argv = let open Lwt in - try begin match version with - | None -> () - | Some version -> - try - !(Protocol_hash_table.find contextual_options version) () - with Not_found -> () end ; - let base_args = cli_group#command_line_args "-" in - let args = ref base_args in - let anon dispatch n = match dispatch (`Arg n) with - | `Nop -> () - | `Args nargs -> args := nargs @ !args - | `Fail exn -> raise exn - | `Res _ -> assert false in - Arg.parse_argv_dynamic - ~current:(ref 0) Sys.argv args (anon (dispatcher ())) (usage base_args) ; - let dispatch = dispatcher () in - (if Sys.file_exists config_file#get then begin - try - file_group#read config_file#get ; - (* parse once again to overwrite file options by cli ones *) - Arg.parse_argv_dynamic - ~current:(ref 0) Sys.argv args (anon dispatch) (usage base_args) ; - Lwt.return () - with Sys_error msg -> - Cli_entries.error - "Error: can't read the configuration file: %s\n%!" msg - end else begin - try - (* parse once again with contextual options *) - Arg.parse_argv_dynamic - ~current:(ref 0) Sys.argv args (anon dispatch) (usage base_args) ; - Lwt_utils.create_dir (Filename.dirname config_file#get) >>= fun () -> - file_group#write config_file#get ; - Lwt.return () - with Sys_error msg -> - Cli_entries.warning - "Warning: can't create the default configuration file: %s\n%!" msg - end) >>= fun () -> - begin match dispatch `End with - | `Res res -> - res - | `Fail exn -> fail exn - | `Nop | `Args _ -> assert false - end - with exn -> Lwt.fail exn + catch + (fun () -> + let args = ref (cli_group#command_line_args "-") in + begin match version with + | None -> () + | Some version -> + try + !(Protocol_hash_table.find contextual_options version) () + with Not_found -> () end ; + let anon dispatch n = match dispatch (`Arg n) with + | `Nop -> () + | `Args nargs -> args := nargs @ !args + | `Fail exn -> raise exn + | `Res _ -> assert false in + Arg.parse_argv_dynamic + ~current:(ref 0) argv args (anon (dispatcher ())) "\000" ; + let dispatch = dispatcher () in + (if Sys.file_exists config_file#get then begin + try + file_group#read config_file#get ; + (* parse once again to overwrite file options by cli ones *) + Arg.parse_argv_dynamic + ~current:(ref 0) argv args (anon dispatch) "\000" ; + Lwt.return () + with Sys_error msg -> + Cli_entries.error + "Error: can't read the configuration file: %s\n%!" msg + end else begin + try + (* parse once again with contextual options *) + Arg.parse_argv_dynamic + ~current:(ref 0) argv args (anon dispatch) "\000" ; + Lwt_utils.create_dir (Filename.dirname config_file#get) >>= fun () -> + file_group#write config_file#get ; + Lwt.return () + with Sys_error msg -> + Cli_entries.warning + "Warning: can't create the default configuration file: %s\n%!" msg + end) >>= fun () -> + begin match dispatch `End with + | `Res res -> Lwt.return res + | `Fail exn -> fail exn + | `Nop | `Args _ -> assert false + end) + (function + | Arg.Bad msg -> + (* FIXME: this is an ugly hack to circumvent [Arg] + spuriously printing options at the end of the error + message. *) + let args = cli_group#command_line_args "-" in + let msg = List.hd (Utils.split '\000' msg) in + Lwt.fail (Arg.Help (msg ^ usage args ^ "\n")) + | Arg.Help _ -> + let args = cli_group#command_line_args "-" in + Lwt.fail (Arg.Help (usage args ^ "\n")) + | exn -> Lwt.fail exn) exception Found of string let preparse name argv = @@ -160,14 +171,14 @@ let preparse name argv = None with Found s -> Some s -let preparse_args () : Node_rpc_services.Blocks.block Lwt.t = +let preparse_args argv : Node_rpc_services.Blocks.block Lwt.t = begin - match preparse "-base-dir" Sys.argv with + match preparse "-base-dir" argv with | None -> () | Some dir -> base_dir#set dir end ; begin - match preparse "-config-file" Sys.argv with + match preparse "-config-file" argv with | None -> config_file#set @@ base_dir#get // "config" | Some file -> config_file#set file end ; @@ -181,12 +192,12 @@ let preparse_args () : Node_rpc_services.Blocks.block Lwt.t = else Lwt.return () end >>= fun () -> begin - match preparse "-addr" Sys.argv with + match preparse "-addr" argv with | None -> () | Some addr -> incoming_addr#set addr end ; begin - match preparse "-port" Sys.argv with + match preparse "-port" argv with | None -> Lwt.return () | Some port -> try diff --git a/src/client/embedded/Makefile.shared b/src/client/embedded/Makefile.shared index 083d8cf4a..2f56137d9 100644 --- a/src/client/embedded/Makefile.shared +++ b/src/client/embedded/Makefile.shared @@ -1,5 +1,7 @@ -all: ../client_$(PROTO_VERSION).cmx +all: \ + ../client_$(PROTO_VERSION).cmx \ + ../webclient_$(PROTO_VERSION).cmx include ../../../Makefile.config @@ -26,25 +28,56 @@ OPENED_MODULES := \ ${OPENED_MODULES} OBJS := \ - ${IMPLS:.ml=.cmx} ${IMPLS:.ml=.ml.deps} \ - ${INTFS:.mli=.cmi} ${INTFS:.mli=.mli.deps} \ - ../client_$(PROTO_VERSION).cmx -${OBJS}: TARGET="(client_$(PROTO_VERSION).cmx)" -${OBJS}: PACKAGES=lwt ocplib-json-typed config-file sodium -${OBJS}: ../../../proto/client_embedded_proto_${PROTO_VERSION}.cmxa + ${CLIENT_IMPLS:.ml=.cmx} ${CLIENT_INTFS:.mli=.cmi} +OBJS_DEPS := \ + ${CLIENT_IMPLS:.ml=.ml.deps} ${CLIENT_INTFS:.mli=.mli.deps} -../client_$(PROTO_VERSION).cmx: $(patsubst %.ml, %.cmx, ${IMPLS}) +${OBJS} ${OBJS_DEPS}: TARGET="(client_$(PROTO_VERSION).cmx)" +${OBJS}: EXTRA_OCAMLFLAGS = -for-pack Client_$(PROTO_VERSION) +../client_$(PROTO_VERSION).cmx: EXTRA_OCAMLFLAGS = +${OBJS} ${OBJS_DEPS} ../client_$(PROTO_VERSION).cmx: \ + PACKAGES=lwt ocplib-json-typed config-file sodium ocplib-ocamlres +${OBJS} ${OBJS_DEPS} ../client_$(PROTO_VERSION).cmx: \ + ../../../proto/client_embedded_proto_${PROTO_VERSION}.cmxa + +WEBOBJS := \ + ${WEBCLIENT_IMPLS:.ml=.cmx} ${WEBCLIENT_INTFS:.mli=.cmi} +WEBOBJS_DEPENDS := \ + ${WEBCLIENT_IMPLS:.ml=.ml.deps} ${WEBCLIENT_INTFS:.mli=.mli.deps} + +${WEBOBJS} ${WEBOBJS_DEPS}: TARGET="(webclient_$(PROTO_VERSION).cmx)" +${WEBOBJS} ${WEBOBJS_DEPS}: SOURCE_DIRECTORIES += .. +${WEBOBJS} ${WEBOBJS_DEPS}: OPENED_MODULES += Client_${PROTO_VERSION} +${WEBOBJS}: EXTRA_OCAMLFLAGS = -for-pack Webclient_$(PROTO_VERSION) +../client_$(PROTO_VERSION).cmx: EXTRA_OCAMLFLAGS = +${WEBOBJS} ${WEBOBJS_DEPS} ../webclient_$(PROTO_VERSION).cmx: \ + PACKAGES=lwt ocplib-json-typed config-file sodium ocplib-ocamlres +${WEBOBJS} ${WEBOBJS_DEPS} ../webclient_$(PROTO_VERSION).cmx: \ + ../../../proto/client_embedded_proto_${PROTO_VERSION}.cmxa +${WEBOBJS} ../webclient_$(PROTO_VERSION).cmx: \ + ../client_${PROTO_VERSION}.cmx + +../client_$(PROTO_VERSION).cmx: $(patsubst %.ml, %.cmx, ${CLIENT_IMPLS}) @echo LINK $(notdir $@) @$(OCAMLOPT) -linkall ${OCAMLFLAGS} -pack -o $@ \ - $(patsubst %.ml, %.cmx, ${IMPLS}) + $(patsubst %.ml, %.cmx, ${CLIENT_IMPLS}) + +../webclient_$(PROTO_VERSION).cmx: $(patsubst %.ml, %.cmx, ${WEBCLIENT_IMPLS}) + @echo LINK $(notdir $@) + @$(OCAMLOPT) -linkall ${OCAMLFLAGS} -pack -o $@ \ + $(patsubst %.ml, %.cmx, ${WEBCLIENT_IMPLS}) %.cmx: %.ml @echo OCAMLOPT ${TARGET} $(notdir $@) - @$(OCAMLOPT) ${OCAMLFLAGS} -for-pack Client_$(PROTO_VERSION) -c $< + @$(OCAMLOPT) ${OCAMLFLAGS} -c $< + +%.cmo: %.ml + @echo OCAMLC ${TARGET} $(notdir $@) + @$(OCAMLC) ${OCAMLFLAGS} -c $< %.cmi: %.mli @echo OCAMLOPT ${TARGET} $(notdir $@) - @$(OCAMLOPT) ${OCAMLFLAGS} -for-pack Client_$(PROTO_VERSION) -c $< + @$(OCAMLOPT) ${OCAMLFLAGS} -c $< %.ml: %.mll @echo OCAMLLEX ${TARGET} $(notdir $@) @@ -57,23 +90,39 @@ ${OBJS}: ../../../proto/client_embedded_proto_${PROTO_VERSION}.cmxa .PHONY: clean clean:: -rm -f ../client_$(PROTO_VERSION).cm* ../client_$(PROTO_VERSION).o - -rm -f *.cm* *~ *.o *.a *.deps + -rm -f ../webclient_$(PROTO_VERSION).cm* ../webclient_$(PROTO_VERSION).o + -rm -f *.cm* *~ *.o *.a *.deps *.deps.byte -rm -rf _tzbuild -rm -f .depend ifneq ($(MAKECMDGOALS),clean) --include .depend +include .depend endif predepend: -DEPENDS := ${INTFS} ${IMPLS} -.SECONDARY: $(patsubst %,%.deps,${DEPENDS}) -.depend: $(patsubst %,%.deps,${DEPENDS}) +DEPENDS += \ + $(patsubst %,%.deps,${CLIENT_INTFS} ${CLIENT_IMPLS}) \ + $(patsubst %,%.deps,${WEBCLIENT_INTFS} ${WEBCLIENT_IMPLS}) +DEPENDS := $(filter-out ${NODEPENDS}, ${DEPENDS}) + +.SECONDARY: ${DEPENDS} + +.depend: ${DEPENDS} @cat $^ > .depend + %.ml.deps: %.ml | predepend @echo OCAMLDEP ${TARGET} $(notdir $<) - @$(OCAMLDEP) -native $(INCLUDES) ${EXTRA_OCAMLFLAGS} $^ > $@ + @$(OCAMLDEP) -native $(INCLUDES) ${EXTRA_OCAMLFLAGS} $< > $@ + %.mli.deps: %.mli | predepend @echo OCAMLDEP ${TARGET} $(notdir $<) - @$(OCAMLDEP) -native $(INCLUDES) ${EXTRA_OCAMLFLAGS} $^ > $@ + @$(OCAMLDEP) -native $(INCLUDES) ${EXTRA_OCAMLFLAGS} $< > $@ + +%.ml.deps.byte: %.ml | predepend + @echo OCAMLDEP ${TARGET} $(notdir $<) + @$(OCAMLDEP) $(INCLUDES) ${EXTRA_OCAMLFLAGS} $< > $@ + +%.mli.deps.byte: %.mli | predepend + @echo OCAMLDEP ${TARGET} $(notdir $<) + @$(OCAMLDEP) $(INCLUDES) ${EXTRA_OCAMLFLAGS} $< > $@ diff --git a/src/client/embedded/bootstrap/Makefile b/src/client/embedded/bootstrap/Makefile index 3da331ee6..90b82815f 100644 --- a/src/client/embedded/bootstrap/Makefile +++ b/src/client/embedded/bootstrap/Makefile @@ -1,7 +1,7 @@ PROTO_VERSION := bootstrap -INTFS := \ +CLIENT_INTFS := \ concrete_parser.mli \ client_proto_rpcs.mli \ client_proto_args.mli \ @@ -11,7 +11,7 @@ INTFS := \ client_proto_nonces.mli \ client_proto_main.mli -IMPLS := \ +CLIENT_IMPLS := \ script_located_ir.ml \ concrete_parser.ml concrete_lexer.ml \ client_proto_rpcs.ml \ @@ -22,10 +22,74 @@ IMPLS := \ client_proto_nonces.ml \ client_proto_main.ml -OPENED_MODULES := Tezos_context +WEBCLIENT_INTFS := \ + webclient/shared/webclient_proto_services.mli -predepend: concrete_parser.ml concrete_lexer.ml +WEBCLIENT_IMPLS := \ + webclient/webclient_proto_static.ml \ + webclient/shared/webclient_proto_services.ml \ + webclient/webclient_proto_service_directory.ml \ + webclient/webclient_proto_main.ml + +SOURCE_DIRECTORIES := webclient/shared webclient/browser webclient -include mining/Makefile +JS_IMPLS := \ + webclient/shared/webclient_proto_services.ml \ + webclient/browser/webclient_main.ml + +JS_INTFS := \ + webclient/shared/webclient_proto_services.mli + +JS_DEPS := $(patsubst %,%.deps.byte,${JS_IMPLS} ${JS_INTFS}) + +DEPENDS += ${JS_DEPS} + +# the generated .ml depends on the result of the bytecode compilation +NODEPENDS := webclient/webclient_proto_static.ml.deps + include ../Makefile.shared + +${WEBOBJS}: OPENED_MODULES += Tezos_context +${OBJS}: OPENED_MODULES += Tezos_context + +predepend: concrete_parser.ml concrete_lexer.ml + +webclient/webclient_proto_static.ml: $(shell find webclient/static/*) webclient/static/main.js + ocp-ocamlres webclient/static -o $@ + +webclient/webclient_proto_main.cmx: webclient/webclient_proto_static.cmx + +.PHONY: clean +clean:: + -rm -f webclient/webclient_proto_static.ml + -rm -f webclient/*/*.cm* webclient/*/*~ webclient/*/*.o webclient/*/*.a + -rm -f webclient/*/*.deps webclient/*/*.deps.byte + -rm -f mining/*.cm* mining/*~ mining/*.o mining/*.a + -rm -f mining/*.deps mining/*.deps.byte + +JS_PACKAGES := \ + lwt \ + cstruct \ + ocplib-json-typed.browser \ + ocplib-json-typed.bson \ + ocplib-resto.directory \ + js_of_ocaml.tyxml \ + js_of_ocaml.ppx +${JS_DEPS} ${JS_IMPLS:.ml=.cmo} ${JS_INTFS:.mli=.cmi} webclient/browser/main.byte: \ + PACKAGES=${JS_PACKAGES} +${JS_DEPS} ${JS_IMPLS:.ml=.cmo} ${JS_INTFS:.mli=.cmi} webclient/browser/main.byte: \ + OPENED_MODULES= +${JS_DEPS} ${JS_IMPLS:.ml=.cmo} ${JS_INTFS:.mli=.cmi} webclient/browser/main.byte: \ + SOURCE_DIRECTORIES=../../../minutils webclient/shared webclient/browser + +webclient/static/main.js: webclient/browser/main.byte + @echo JS_OF_OCAML $(notdir $@) + @js_of_ocaml +weak.js $< -o $@ + +webclient/browser/main.byte: \ + ../../../minutils.cma \ + ${JS_IMPLS:.ml=.cmo} + @echo LINK $(notdir $@) + ${OCAMLC} ${OCAMLFLAGS} -o $@ $^ -linkpkg diff --git a/src/client/embedded/bootstrap/mining/Makefile b/src/client/embedded/bootstrap/mining/Makefile index 33d3a09b0..d595477d1 100644 --- a/src/client/embedded/bootstrap/mining/Makefile +++ b/src/client/embedded/bootstrap/mining/Makefile @@ -1,7 +1,7 @@ SOURCE_DIRECTORIES += mining -INTFS += \ +CLIENT_INTFS += \ mining/client_mining_blocks.mli \ mining/client_mining_operations.mli \ mining/client_mining_endorsement.mli \ @@ -11,7 +11,7 @@ INTFS += \ mining/client_mining_daemon.mli \ mining/client_mining_main.mli \ -IMPLS += \ +CLIENT_IMPLS += \ mining/client_mining_blocks.ml \ mining/client_mining_operations.ml \ mining/client_mining_endorsement.ml \ diff --git a/src/client/embedded/bootstrap/webclient/.merlin b/src/client/embedded/bootstrap/webclient/.merlin new file mode 100644 index 000000000..4906c83c7 --- /dev/null +++ b/src/client/embedded/bootstrap/webclient/.merlin @@ -0,0 +1,5 @@ +REC +B browser/ +S browser/ +B shared/ +S shared/ diff --git a/src/client/embedded/bootstrap/webclient/browser/.merlin b/src/client/embedded/bootstrap/webclient/browser/.merlin new file mode 100644 index 000000000..b19c07692 --- /dev/null +++ b/src/client/embedded/bootstrap/webclient/browser/.merlin @@ -0,0 +1,9 @@ +B ../../../../../minutils +S ../../../../../minutils +B ../shared +S ../shared +PKG lwt +PKG ocplib-json-typed.bson +PKG ocplib-resto.directory \ +PKG js_of_ocaml.ppx +PKG js_of_ocaml.tyxml diff --git a/src/client/embedded/bootstrap/webclient/browser/webclient_main.ml b/src/client/embedded/bootstrap/webclient/browser/webclient_main.ml new file mode 100644 index 000000000..c1bc4e28f --- /dev/null +++ b/src/client/embedded/bootstrap/webclient/browser/webclient_main.ml @@ -0,0 +1,53 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +open Lwt.Infix + +module Services = Webclient_proto_services.Make (struct + type root = unit + end) + +let call_service service params input = + let write_json_body json = + let jsobj = + Json_repr.convert + (module Json_repr.Ezjsonm) + (module Json_repr_browser.Repr) + json in + Js._JSON##stringify jsobj in + let read_json_body body = + Json_repr.convert + (module Json_repr_browser.Repr) + (module Json_repr.Ezjsonm) + (Js._JSON##parse body) in + let path, json = RPC.forge_request service params input in + let url = String.concat "/" path in + let xhr = XmlHttpRequest.create () in + let t, u = Lwt.wait () in + xhr##.onreadystatechange := Js.wrap_callback (fun _ -> + if xhr##.readyState = XmlHttpRequest.DONE then + let response = read_json_body xhr##.responseText in + Lwt.wakeup u response) ; + xhr##_open (Js.string "POST") (Js.string url) Js._true ; + xhr##send (Js.Opt.return (write_json_body json)) ; + t >>= fun json -> + match RPC.read_answer service json with + | Ok res -> Lwt.return res + | Error msg -> Lwt.fail_with msg + +let () = Lwt.async @@ fun () -> + call_service Services.contracts () () >>= fun names -> + call_service Services.hash () () >>= fun hash -> + let list = Tyxml_js.Html.(ul (List.map (fun n -> (li [ pcdata n ])) names)) in + Tyxml_js.Register.id "receptacle" + Tyxml_js.Html. + [ h2 [ pcdata "Block: " ; pcdata hash ] ; + h2 [ pcdata "Contract aliases:" ] ; + list ] ; + Lwt.return () diff --git a/src/client/embedded/bootstrap/webclient/shared/.merlin b/src/client/embedded/bootstrap/webclient/shared/.merlin new file mode 100644 index 000000000..fe28cdf14 --- /dev/null +++ b/src/client/embedded/bootstrap/webclient/shared/.merlin @@ -0,0 +1,5 @@ +B ../../../../../minutils +S ../../../../../minutils +PKG lwt +PKG ocplib-json-typed.bson +PKG ocplib-resto.directory diff --git a/src/client/embedded/bootstrap/webclient/shared/webclient_proto_services.ml b/src/client/embedded/bootstrap/webclient/shared/webclient_proto_services.ml new file mode 100644 index 000000000..d36d785a0 --- /dev/null +++ b/src/client/embedded/bootstrap/webclient/shared/webclient_proto_services.ml @@ -0,0 +1,30 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +module type RPC_CONTEXT = sig + type root +end + +module Make (RPC_context : RPC_CONTEXT) = struct + + let box_result field enc = + let open Data_encoding in + obj1 (req field enc) + + let contracts = + let input = Data_encoding.empty in + let output = box_result "contracts" Data_encoding.(list string) in + RPC.service ~input ~output RPC.Path.(root / "contracts") + + let hash = + let input = Data_encoding.empty in + let output = box_result "hash" Data_encoding.string in + RPC.service ~input ~output RPC.Path.(root / "hash") + +end diff --git a/src/client/embedded/bootstrap/webclient/shared/webclient_proto_services.mli b/src/client/embedded/bootstrap/webclient/shared/webclient_proto_services.mli new file mode 100644 index 000000000..7d19597e7 --- /dev/null +++ b/src/client/embedded/bootstrap/webclient/shared/webclient_proto_services.mli @@ -0,0 +1,19 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +module type RPC_CONTEXT = sig + type root +end + +module Make (RPC_context : RPC_CONTEXT) : sig + val contracts : + (RPC_context.root, RPC_context.root, unit, string list) RPC.service + val hash : + (RPC_context.root, RPC_context.root, unit, string) RPC.service +end diff --git a/src/client/embedded/bootstrap/webclient/static/index.html b/src/client/embedded/bootstrap/webclient/static/index.html new file mode 100644 index 000000000..65f7743f8 --- /dev/null +++ b/src/client/embedded/bootstrap/webclient/static/index.html @@ -0,0 +1,12 @@ + + + + Tezos Web Client :: Bootstrap Version + + + + +

Tezos Web client :: Bootstrap Version

+
+ + diff --git a/src/client/embedded/bootstrap/webclient/static/not_found.html b/src/client/embedded/bootstrap/webclient/static/not_found.html new file mode 100644 index 000000000..467aceb19 --- /dev/null +++ b/src/client/embedded/bootstrap/webclient/static/not_found.html @@ -0,0 +1,10 @@ + + + + Tezos Web Client :: Bootstrap Version + + + +

Not Found

+ + diff --git a/src/client/embedded/bootstrap/webclient/webclient_proto_main.ml b/src/client/embedded/bootstrap/webclient/webclient_proto_main.ml new file mode 100644 index 000000000..9b6607795 --- /dev/null +++ b/src/client/embedded/bootstrap/webclient/webclient_proto_main.ml @@ -0,0 +1,15 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + + +let () = + Webclient_version.register_services + Client_proto_main.protocol Webclient_proto_service_directory.root ; + Webclient_version.register_static_files + Client_proto_main.protocol Webclient_proto_static.root diff --git a/src/client/embedded/bootstrap/webclient/webclient_proto_service_directory.ml b/src/client/embedded/bootstrap/webclient/webclient_proto_service_directory.ml new file mode 100644 index 000000000..2f94bcada --- /dev/null +++ b/src/client/embedded/bootstrap/webclient/webclient_proto_service_directory.ml @@ -0,0 +1,24 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +module Services = Webclient_proto_services.Make (struct + type root = Node_rpc_services.Blocks.block + end) + +let root = + let root = + RPC.register RPC.empty Services.contracts @@ fun block () -> + Client_proto_contracts.RawContractAlias.load () >>= fun list -> + let (names, _) = List.split list in + RPC.Answer.return names in + let root = + RPC.register root Services.hash @@ fun block () -> + Client_node_rpcs.(call_service1 Node_rpc_services.Blocks.hash block ()) >>= fun res -> + RPC.Answer.return (Hash.Block_hash.to_b48check res) in + root diff --git a/src/client/embedded/demo/Makefile b/src/client/embedded/demo/Makefile index a3eec6135..c696281bd 100644 --- a/src/client/embedded/demo/Makefile +++ b/src/client/embedded/demo/Makefile @@ -1,11 +1,11 @@ PROTO_VERSION = demo -IMPLS = \ +CLIENT_IMPLS = \ client_proto_rpcs.ml \ client_proto_main.ml -INTFS = \ +CLIENT_INTFS = \ client_proto_rpcs.mli \ client_proto_main.mli diff --git a/src/client/webclient_version.ml b/src/client/webclient_version.ml new file mode 100644 index 000000000..91541c628 --- /dev/null +++ b/src/client/webclient_version.ml @@ -0,0 +1,28 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +(* Tezos Web Interface - version dependent services *) + +let contextual_static_files : string OCamlRes.Res.root Protocol_hash_table.t = + Protocol_hash_table.create 7 + +let register_static_files version root = + Protocol_hash_table.add contextual_static_files version root + +let find_contextual_static_files version = + Protocol_hash_table.find contextual_static_files version + +let contextual_services : Node_rpc_services.Blocks.block RPC.directory Protocol_hash_table.t = + Protocol_hash_table.create 7 + +let register_services version root = + Protocol_hash_table.add contextual_services version root + +let find_contextual_services version = + Protocol_hash_table.find contextual_services version diff --git a/src/client_main.ml b/src/client_main.ml index 408f60546..3c5fad188 100644 --- a/src/client_main.ml +++ b/src/client_main.ml @@ -38,7 +38,7 @@ let main () = Sodium.Random.stir () ; catch (fun () -> - Client_config.preparse_args () >>= fun block -> + Client_config.preparse_args Sys.argv >>= fun block -> Lwt.catch (fun () -> Client_node_rpcs.Blocks.protocol block) @@ -56,33 +56,36 @@ let main () = Client_version.commands_for_version version in Client_config.parse_args ~version (Cli_entries.usage commands) - (Cli_entries.inline_dispatch commands)) + (Cli_entries.inline_dispatch commands) + Sys.argv >>= fun command -> + command () >>= fun () -> + Lwt.return 0) (function | Arg.Help help -> Format.printf "%s%!" help ; - Pervasives.exit 0 + Lwt.return 0 | Arg.Bad help -> Format.eprintf "%s%!" help ; - Pervasives.exit 1 + Lwt.return 1 | Cli_entries.Command_not_found -> Format.eprintf "Unkonwn command, try `-help`.\n%!" ; - Pervasives.exit 1 + Lwt.return 1 | Client_version.Version_not_found -> Format.eprintf "Unkonwn protocol version, try `list versions`.\n%!" ; - Pervasives.exit 1 + Lwt.return 1 | Cli_entries.Bad_argument (idx, _n, v) -> Format.eprintf "There's a problem with argument %d, %s.\n%!" idx v ; - Pervasives.exit 1 + Lwt.return 1 | Cli_entries.Command_failed message -> Format.eprintf "Command failed, %s.\n%!" message ; - Pervasives.exit 1 + Lwt.return 1 | Failure message -> Format.eprintf "%s%!" message ; - Pervasives.exit 1 + Lwt.return 1 | exn -> Format.printf "Fatal internal error: %s\n%!" (Printexc.to_string exn) ; - Pervasives.exit 1) + Lwt.return 1) (* Where all the user friendliness starts *) -let () = Lwt_main.run (main ()) +let () = Pervasives.exit (Lwt_main.run (main ())) diff --git a/src/tezos-deps.opam b/src/tezos-deps.opam index ddb5a7262..102b625b3 100644 --- a/src/tezos-deps.opam +++ b/src/tezos-deps.opam @@ -27,6 +27,9 @@ depends: [ "ocplib-endian" "ocplib-json-typed" "ocplib-resto" {>= "dev"} + "reactiveData" + "tyxml" + "js_of_ocaml" "sodium" {>= "0.3.0"} "kaputt" (* only for testing *) "bisect_ppx" (* only for testing *) diff --git a/src/utils/cli_entries.ml b/src/utils/cli_entries.ml index 9cca0bd66..a274a7f7f 100644 --- a/src/utils/cli_entries.ml +++ b/src/utils/cli_entries.ml @@ -189,7 +189,7 @@ let tree_dispatch tree last args = in loop (tree, args) -let inline_tree_dispatch tree last = +let inline_tree_dispatch tree () = let state = ref (tree, []) in fun arg -> match !state, arg with | (( TStop c | @@ -198,7 +198,7 @@ let inline_tree_dispatch tree last = TParam { stop = Some c}), acc), `End -> state := (TEmpty, []) ; - `Res (exec c last (List.rev acc)) + `Res (fun last -> exec c last (List.rev acc)) | (TMore c, acc), `Arg n -> state := (TMore c, n :: acc) ; `Nop diff --git a/src/utils/cli_entries.mli b/src/utils/cli_entries.mli index 1b431e0c8..ffa7eedff 100644 --- a/src/utils/cli_entries.mli +++ b/src/utils/cli_entries.mli @@ -54,13 +54,12 @@ val register_tag: tag -> string -> unit val usage: command list -> (string * Arg.spec * string) list -> string val inline_dispatch: - command list -> - unit -> - [> `Arg of string | `End ] -> - [> `Args of (Arg.key * Arg.spec * Arg.doc) list + command list -> unit -> + [ `Arg of string | `End ] -> + [ `Args of (Arg.key * Arg.spec * Arg.doc) list | `Fail of exn | `Nop - | `Res of unit Lwt.t ] + | `Res of unit -> unit Lwt.t ] val dispatch: command list -> unit -> string list -> unit Lwt.t diff --git a/src/utils/logging.ml b/src/utils/logging.ml index 2cad82973..173fbb3d7 100644 --- a/src/utils/logging.ml +++ b/src/utils/logging.ml @@ -85,6 +85,7 @@ module Client = struct module Revelation = Make(struct let name = "client.revealation" end) module Denunciation = Make(struct let name = "client.denunciation" end) end +module Webclient = Make(struct let name = "webclient" end) let default_logger () = Lwt_log.channel ~close_mode:`Keep ~channel:Lwt_io.stderr () diff --git a/src/utils/logging.mli b/src/utils/logging.mli index 7486a0699..155ffa2ff 100644 --- a/src/utils/logging.mli +++ b/src/utils/logging.mli @@ -44,6 +44,7 @@ module Client : sig module Revelation : LOG module Denunciation : LOG end +module Webclient : LOG module Make(S: sig val name: string end) : LOG diff --git a/src/webclient_main.ml b/src/webclient_main.ml new file mode 100644 index 000000000..daa962253 --- /dev/null +++ b/src/webclient_main.ml @@ -0,0 +1,218 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +(* Tezos Command line interface - Main Program *) + +open Lwt.Infix +open Logging.Webclient + +let with_cli_entries_logging = + let startup = + CalendarLib.Printer.Precise_Calendar.sprint + "%Y-%m-%dT%H:%M:%SZ" + (CalendarLib.Calendar.Precise.now ()) in + let stdout = Buffer.create 1000 in + let stderr = Buffer.create 1000 in + let log channel msg = match channel with + | "stdout" -> + Buffer.add_string stdout msg ; + Lwt.return () + | "stderr" -> + Buffer.add_string stderr msg ; + Lwt.return () + | log -> + Lwt_utils.create_dir Client_config.(base_dir#get // "webclient_logs" // log) >>= fun () -> + Lwt_io.with_file + ~flags: Unix.[ O_APPEND ; O_CREAT ; O_WRONLY ] + ~mode: Lwt_io.Output + Client_config.(base_dir#get // "webclient_logs" // log // startup) + (fun chan -> Lwt_io.write chan msg) in + Cli_entries.log_hook := Some log ; + let global_cli_entries_mutex = Lwt_mutex.create () in + (fun callback -> + Lwt_mutex.with_lock + global_cli_entries_mutex + (fun () -> + Buffer.clear stdout ; + Buffer.clear stderr ; + Lwt.catch + (fun () -> + callback () >>= fun result -> + Lwt.return + (Ok (result, + Buffer.contents stdout, + Buffer.contents stderr))) + (fun exn -> + Lwt.return + (Error (exn, + Buffer.contents stdout, + Buffer.contents stderr))))) + +let block_protocol block = + Lwt.catch + (fun () -> + Client_node_rpcs.Blocks.protocol block) + (fun _ -> + Cli_entries.message "\n\ + The connection to the RPC server failed, \ + using the default protocol version.\n" >>= fun () -> + Lwt.return Client_bootstrap.Client_proto_main.protocol) + +let eval_command argv = + with_cli_entries_logging + (fun () -> + Client_config.preparse_args argv >>= fun block -> + block_protocol block >>= fun version -> + let commands = + Client_generic_rpcs.commands @ + Client_keys.commands () @ + Client_protocols.commands () @ + Client_helpers.commands () @ + Client_version.commands_for_version version in + Client_config.parse_args ~version + (Cli_entries.usage commands) + (Cli_entries.inline_dispatch commands) + argv >>= fun command -> + command ()) >>= function + | Ok ((), stdout, _stderr) -> + Lwt.return (Ok stdout) + | Error (exn, stdout, stderr) -> + let msg = match exn with + | Arg.Help help -> + Format.asprintf "%s%!" help + | Arg.Bad help -> + Format.asprintf "%s%!" help + | Cli_entries.Command_not_found -> + Format.asprintf "Unkonwn command, try `-help`.\n%!" + | Client_version.Version_not_found -> + Format.asprintf "Unkonwn protocol version, try `list versions`.\n%!" + | Cli_entries.Bad_argument (idx, _n, v) -> + Format.asprintf "There's a problem with argument %d, %s.\n%!" idx v + | Cli_entries.Command_failed message -> + Format.asprintf "Command failed, %s.\n%!" message + | Failure msg -> + Format.asprintf "Fatal error: %s\n%!" msg + | exn -> + Format.asprintf "Fatal internal error: %s\n%!" (Printexc.to_string exn) in + let stderr = + if stdout = "" + || String.get stdout (String.length stderr - 1) = '\n' then + stdout ^ stderr + else + stdout ^ "\n" ^ stderr in + let stderr = + if stderr = "" + || String.get stderr (String.length stderr - 1) = '\n' then + msg + else + stderr ^ "\n" ^ msg in + Lwt.return (Error stderr) + +module ConnectionMap = Map.Make(Cohttp.Connection) + +exception Invalid_method +exception Cannot_parse_body of string + +let root = + let input, output = + let open Data_encoding in + (obj1 (req "command" string)), + (obj1 (req "output" string)) in + let root = + RPC.empty in + let root = + RPC.register0 root + (RPC.service ~input ~output RPC.Path.(root / "command")) + (fun command -> + let argv = Array.of_list (Utils.split ' ' command) in + eval_command argv >>= function + | Ok output | Error output -> + RPC.Answer.return output) in + let root = + RPC.register_dynamic_directory1 root + RPC.Path.(root / "block" /: Node_rpc_services.Blocks.blocks_arg) + (fun block -> + Client_node_rpcs.Blocks.protocol block >>= fun version -> + let directory = Webclient_version.find_contextual_services version in + let directory = RPC.map (fun ((), block) -> block) directory in + Lwt.return directory) in + root + +let find_static_file path = + let path = OCamlRes.Path.of_string path in + let index path = match path with + | ([], None) -> ([], Some ("index", Some "html")) + | oth -> oth in + match path with + | ("block" :: block :: path, file) -> + let path = index (path, file) in + (match Node_rpc_services.Blocks.parse_block block with + | Ok block -> + block_protocol block >>= fun version -> + Lwt.return + (try + let root = + Webclient_version.find_contextual_static_files version in + Some (OCamlRes.Res.find path root) + with Not_found -> None) + | Error _ -> Lwt.return None) + | _ -> + Lwt.return + (try + Some (OCamlRes.Res.find (index path) Webclient_static.root) + with Not_found -> None) + +let http_proxy port = + let pre_hook path = + find_static_file path >>= function + | Some body -> + Lwt.return { RPC.Answer.code = 200 ; body = RPC.Answer.Single body } + | None -> + Lwt.return { RPC.Answer.code = 404 ; body = RPC.Answer.Empty } in + let post_hook _ = + (find_static_file "not_found.html" >>= function + | Some body -> + Lwt.return (RPC.Answer.Single body) + | None -> + Lwt.return (RPC.Answer.Empty)) >>= fun body -> + Lwt.return { RPC.Answer.code = 404 ; body } in + RPC_server.launch ~pre_hook ~post_hook port root + +let web_port = Client_config.in_both_groups @@ + new Config_file.int_cp [ "web" ; "port" ] 8080 + "The TCP port to point the web browser to." + +(* Where all the user friendliness starts *) +let () = + Pervasives.exit @@ Lwt_main.run + (Lwt.catch + (fun () -> + Client_config.parse_args + (Cli_entries.usage []) + (fun () -> function + | `Arg arg -> raise (Arg.Bad ("unexpected argument " ^ arg)) + | `End -> `Res (fun () -> Lwt.return ())) + Sys.argv >>= fun _no_command -> + Random.self_init () ; + Sodium.Random.stir () ; + http_proxy web_port#get >>= fun _server -> + fst (Lwt.wait ())) + (function + | Arg.Help help -> + Format.eprintf "%s%!" help ; + Lwt.return 0 + | Arg.Bad help -> + Format.eprintf "%s%!" help ; + Lwt.return 1 + | Failure msg -> + Format.eprintf "Fatal error: %s\n%!" msg ; + Lwt.return 1 + | exn -> + Format.eprintf "Fatal internal error: %s\n%!" (Printexc.to_string exn) ; + Lwt.return 1)) diff --git a/src/webclient_static/index.html b/src/webclient_static/index.html new file mode 100644 index 000000000..7c044cc5e --- /dev/null +++ b/src/webclient_static/index.html @@ -0,0 +1,33 @@ + + + + Tezos Web Client + + + + +

Tezos Web client

+
+ ./tezos-client + +
+ +
+ + + diff --git a/src/webclient_static/not_found.html b/src/webclient_static/not_found.html new file mode 100644 index 000000000..d577c597d --- /dev/null +++ b/src/webclient_static/not_found.html @@ -0,0 +1,10 @@ + + + + Tezos Web Client + + + +

Not Found

+ + diff --git a/test/Makefile b/test/Makefile index 45cf2e67d..ab44dbdb4 100644 --- a/test/Makefile +++ b/test/Makefile @@ -214,7 +214,6 @@ COVERAGESRCDIR= \ -I ../src/client/embedded \ -I ../src/client/embedded/bootstrap \ -I ../src/client/embedded/bootstrap/mining \ - -I ../src/client/embedded/bootstrap/demo \ -I ../src/compiler \ -I ../src/node \ -I ../src/node/db \ From a098d25a550e9634e668301b61ccb8dd8b514b32 Mon Sep 17 00:00:00 2001 From: Benjamin Canou Date: Sat, 3 Dec 2016 13:05:02 +0100 Subject: [PATCH 2/3] Client: add a context to command evaluation. --- src/Makefile | 4 +- src/client/client_aliases.ml | 148 ++++++----- src/client/client_aliases.mli | 58 +++-- .../{client_version.ml => client_commands.ml} | 36 ++- ...client_version.mli => client_commands.mli} | 16 +- src/client/client_config.ml | 14 +- src/client/client_generic_rpcs.ml | 91 +++---- src/client/client_generic_rpcs.mli | 2 +- src/client/client_helpers.ml | 16 +- src/client/client_helpers.mli | 2 +- src/client/client_keys.ml | 109 ++++----- src/client/client_keys.mli | 3 +- src/client/client_node_rpcs.ml | 163 +++++++------ src/client/client_node_rpcs.mli | 87 +++++-- src/client/client_protocols.ml | 63 +++-- src/client/client_protocols.mli | 10 +- .../embedded/bootstrap/client_proto_args.ml | 2 +- .../embedded/bootstrap/client_proto_args.mli | 3 +- .../bootstrap/client_proto_context.ml | 230 ++++++++---------- .../bootstrap/client_proto_context.mli | 5 +- .../bootstrap/client_proto_contracts.ml | 106 ++++---- .../bootstrap/client_proto_contracts.mli | 25 +- .../embedded/bootstrap/client_proto_main.ml | 2 +- .../embedded/bootstrap/client_proto_nonces.ml | 37 +-- .../bootstrap/client_proto_nonces.mli | 20 +- .../bootstrap/client_proto_programs.ml | 141 +++++------ .../bootstrap/client_proto_programs.mli | 14 +- .../embedded/bootstrap/client_proto_rpcs.ml | 206 ++++++++-------- .../embedded/bootstrap/client_proto_rpcs.mli | 122 ++++++++-- .../bootstrap/mining/client_mining_blocks.ml | 36 +-- .../bootstrap/mining/client_mining_blocks.mli | 6 +- .../bootstrap/mining/client_mining_daemon.ml | 16 +- .../bootstrap/mining/client_mining_daemon.mli | 1 + .../mining/client_mining_denunciation.ml | 4 +- .../mining/client_mining_denunciation.mli | 1 + .../mining/client_mining_endorsement.ml | 96 ++++---- .../mining/client_mining_endorsement.mli | 2 + .../bootstrap/mining/client_mining_forge.ml | 90 +++---- .../bootstrap/mining/client_mining_forge.mli | 11 +- .../bootstrap/mining/client_mining_main.ml | 117 +++++---- .../bootstrap/mining/client_mining_main.mli | 3 +- .../mining/client_mining_operations.ml | 18 +- .../mining/client_mining_operations.mli | 5 +- .../mining/client_mining_revelation.ml | 25 +- .../mining/client_mining_revelation.mli | 2 + .../webclient_proto_service_directory.ml | 6 +- src/client/embedded/demo/client_proto_main.ml | 54 ++-- src/client/embedded/demo/client_proto_rpcs.ml | 12 +- .../embedded/demo/client_proto_rpcs.mli | 8 +- src/client_main.ml | 27 +- src/utils/cli_entries.ml | 194 ++++++--------- src/utils/cli_entries.mli | 80 +++--- src/utils/hash.ml | 2 +- src/utils/hash.mli | 4 +- src/webclient_main.ml | 163 ++++++------- src/webclient_static/index.html | 15 +- test/test_basic.ml | 16 +- 57 files changed, 1482 insertions(+), 1267 deletions(-) rename src/client/{client_version.ml => client_commands.ml} (54%) rename src/client/{client_version.mli => client_commands.mli} (63%) diff --git a/src/Makefile b/src/Makefile index c48fc410a..7c34eac0d 100644 --- a/src/Makefile +++ b/src/Makefile @@ -383,7 +383,7 @@ clean:: ############################################################################ CLIENT_LIB_INTFS := \ - client/client_version.mli \ + client/client_commands.mli \ client/client_node_rpcs.mli \ client/client_generic_rpcs.mli \ client/client_helpers.mli \ @@ -392,7 +392,7 @@ CLIENT_LIB_INTFS := \ client/client_protocols.mli \ CLIENT_LIB_IMPLS := \ - client/client_version.ml \ + client/client_commands.ml \ client/client_config.ml \ client/client_node_rpcs.ml \ client/client_generic_rpcs.ml \ diff --git a/src/client/client_aliases.ml b/src/client/client_aliases.ml index 4d30c3dda..4e9d2b8bf 100644 --- a/src/client/client_aliases.ml +++ b/src/client/client_aliases.ml @@ -15,36 +15,62 @@ open Cli_entries module type Entity = sig type t val encoding : t Data_encoding.t - val of_source : string -> t Lwt.t - val to_source : t -> string Lwt.t + val of_source : + Client_commands.context -> + string -> t Lwt.t + val to_source : + Client_commands.context -> + t -> string Lwt.t val name : string end module type Alias = sig type t - val load : unit -> (Lwt_io.file_name * t) list Lwt.t - val find : Lwt_io.file_name -> t Lwt.t - val find_opt : Lwt_io.file_name -> t option Lwt.t - val rev_find : t -> Lwt_io.file_name option Lwt.t - val name : t -> string Lwt.t - val mem : Lwt_io.file_name -> bool Lwt.t - val add : Lwt_io.file_name -> t -> unit Lwt.t - val del : Lwt_io.file_name -> unit Lwt.t - val save : (Lwt_io.file_name * t) list -> unit Lwt.t - val to_source : t -> string Lwt.t + val load : + Client_commands.context -> + (string * t) list Lwt.t + val find : + Client_commands.context -> + string -> t Lwt.t + val find_opt : + Client_commands.context -> + string -> t option Lwt.t + val rev_find : + Client_commands.context -> + t -> string option Lwt.t + val name : + Client_commands.context -> + t -> string Lwt.t + val mem : + Client_commands.context -> + string -> bool Lwt.t + val add : + Client_commands.context -> + string -> t -> unit Lwt.t + val del : + Client_commands.context -> + string -> unit Lwt.t + val save : + Client_commands.context -> + (string * t) list -> unit Lwt.t + val to_source : + Client_commands.context -> + t -> string Lwt.t val alias_param : ?name:string -> ?desc:string -> - 'a Cli_entries.params -> - (Lwt_io.file_name * t -> 'a) Cli_entries.params + ('a, Client_commands.context, 'ret) Cli_entries.params -> + (string * t -> 'a, Client_commands.context, 'ret) Cli_entries.params val fresh_alias_param : ?name:string -> ?desc:string -> - 'a Cli_entries.params -> (string -> 'a) Cli_entries.params + ('a, Client_commands.context, 'ret) Cli_entries.params -> + (string -> 'a, Client_commands.context, 'ret) Cli_entries.params val source_param : ?name:string -> ?desc:string -> - 'a Cli_entries.params -> (t -> 'a) Cli_entries.params + ('a, Client_commands.context, 'ret) Cli_entries.params -> + (t -> 'a, Client_commands.context, 'ret) Cli_entries.params end module Alias = functor (Entity : Entity) -> struct @@ -58,43 +84,46 @@ module Alias = functor (Entity : Entity) -> struct let filename () = Client_config.(base_dir#get // Entity.name ^ "s") - let load () = + let load cctxt = let filename = filename () in if not (Sys.file_exists filename) then return [] else Data_encoding_ezjsonm.read_file filename >>= function | None -> - error "couldn't to read the %s alias file" Entity.name + cctxt.Client_commands.error + "couldn't to read the %s alias file" Entity.name | Some json -> match Data_encoding.Json.destruct encoding json with | exception _ -> (* TODO print_error *) - error "didn't understand the %s alias file" Entity.name + cctxt.Client_commands.error + "didn't understand the %s alias file" Entity.name | list -> return list - let find_opt name = - load () >>= fun list -> + let find_opt cctxt name = + load cctxt >>= fun list -> try return (Some (List.assoc name list)) with Not_found -> return None - let find name = - load () >>= fun list -> + let find cctxt name = + load cctxt >>= fun list -> try return (List.assoc name list) - with Not_found -> error "no %s alias named %s" Entity.name name + with Not_found -> + cctxt.Client_commands.error "no %s alias named %s" Entity.name name - let rev_find v = - load () >>= fun list -> + let rev_find cctxt v = + load cctxt >>= fun list -> try return (Some (List.find (fun (_, v') -> v = v') list |> fst)) with Not_found -> return None - let mem name = - load () >>= fun list -> + let mem cctxt name = + load cctxt >>= fun list -> try ignore (List.assoc name list) ; Lwt.return true with | Not_found -> Lwt.return false - let save list = + let save cctxt list = catch (fun () -> let dirname = Client_config.base_dir#get in @@ -106,21 +135,25 @@ module Alias = functor (Entity : Entity) -> struct | false -> fail (Failure "Json.write_file") | true -> return ()) (fun exn -> - error "could not write the %s alias file: %s." + cctxt.Client_commands.error + "could not write the %s alias file: %s." Entity.name (Printexc.to_string exn)) - let add name value = + let add cctxt name value = let keep = ref false in - load () >>= fun list -> + load cctxt >>= fun list -> (if not Client_config.force#get then Lwt_list.iter_s (fun (n, v) -> if n = name && v = value then (keep := true ; - message "The %s alias %s already exists with the same value." Entity.name n) + cctxt.Client_commands.message + "The %s alias %s already exists with the same value." Entity.name n) else if n = name && v <> value then - error "another %s is already aliased as %s, use -force true to update" Entity.name n + cctxt.Client_commands.error + "another %s is already aliased as %s, use -force true to update" Entity.name n else if n <> name && v = value then - error "this %s is already aliased as %s, use -force true to insert duplicate" Entity.name n + cctxt.Client_commands.error + "this %s is already aliased as %s, use -force true to insert duplicate" Entity.name n else return ()) list else return ()) >>= fun () -> let list = List.filter (fun (n, _) -> n <> name) list in @@ -128,33 +161,36 @@ module Alias = functor (Entity : Entity) -> struct if !keep then return () else - save list >>= fun () -> - message "New %s alias '%s' saved." Entity.name name + save cctxt list >>= fun () -> + cctxt.Client_commands.message + "New %s alias '%s' saved." Entity.name name - let del name = - load () >>= fun list -> + let del cctxt name = + load cctxt >>= fun list -> let list = List.filter (fun (n, _) -> n <> name) list in - save list + save cctxt list - let save list = - save list >>= fun () -> - message "Successful update of the %s alias file." Entity.name + let save cctxt list = + save cctxt list >>= fun () -> + cctxt.Client_commands.message + "Successful update of the %s alias file." Entity.name include Entity let alias_param ?(name = "name") ?(desc = "existing " ^ name ^ " alias") next = param ~name ~desc - (fun s -> find s >>= fun v -> return (s, v)) + (fun cctxt s -> find cctxt s >>= fun v -> return (s, v)) next let fresh_alias_param ?(name = "new") ?(desc = "new " ^ name ^ " alias") next = param ~name ~desc - (fun s -> - load () >>= fun list -> + (fun cctxt s -> + load cctxt >>= fun list -> if not Client_config.force#get then Lwt_list.iter_s (fun (n, _v) -> if n = name then - error "the %s alias %s already exists, use -force true to update" Entity.name n + cctxt.Client_commands.error + "the %s alias %s already exists, use -force true to update" Entity.name n else return ()) list >>= fun () -> return s @@ -167,31 +203,31 @@ module Alias = functor (Entity : Entity) -> struct ^ "can be an alias, file or literal (autodetected in this order)\n\ use 'file:path', 'text:literal' or 'alias:name' to force" in param ~name ~desc - (fun s -> + (fun cctxt s -> let read path = catch (fun () -> Lwt_io.(with_file ~mode:Input path read)) (fun exn -> Lwt.fail_with @@ Format.asprintf "cannot read file (%s)" (Printexc.to_string exn)) - >>= of_source in + >>= of_source cctxt in match Utils.split ~limit:1 ':' s with | [ "alias" ; alias ]-> - find alias + find cctxt alias | [ "text" ; text ] -> - of_source text + of_source cctxt text | [ "file" ; path ] -> read path | _ -> catch - (fun () -> find s) + (fun () -> find cctxt s) (fun _ -> catch (fun () -> read s) - (fun _ -> of_source s))) + (fun _ -> of_source cctxt s))) next - let name d = - rev_find d >>= function - | None -> Entity.to_source d + let name cctxt d = + rev_find cctxt d >>= function + | None -> Entity.to_source cctxt d | Some name -> Lwt.return name end diff --git a/src/client/client_aliases.mli b/src/client/client_aliases.mli index a8f75e8af..502ef10f7 100644 --- a/src/client/client_aliases.mli +++ b/src/client/client_aliases.mli @@ -11,35 +11,61 @@ module type Entity = sig type t val encoding : t Data_encoding.t - val of_source : string -> t Lwt.t - val to_source : t -> string Lwt.t + val of_source : + Client_commands.context -> + string -> t Lwt.t + val to_source : + Client_commands.context -> + t -> string Lwt.t val name : string end module type Alias = sig type t - val load : unit -> (Lwt_io.file_name * t) list Lwt.t - val find : Lwt_io.file_name -> t Lwt.t - val find_opt : Lwt_io.file_name -> t option Lwt.t - val rev_find : t -> Lwt_io.file_name option Lwt.t - val name : t -> string Lwt.t - val mem : Lwt_io.file_name -> bool Lwt.t - val add : Lwt_io.file_name -> t -> unit Lwt.t - val del : Lwt_io.file_name -> unit Lwt.t - val save : (Lwt_io.file_name * t) list -> unit Lwt.t - val to_source : t -> string Lwt.t + val load : + Client_commands.context -> + (string * t) list Lwt.t + val find : + Client_commands.context -> + string -> t Lwt.t + val find_opt : + Client_commands.context -> + string -> t option Lwt.t + val rev_find : + Client_commands.context -> + t -> string option Lwt.t + val name : + Client_commands.context -> + t -> string Lwt.t + val mem : + Client_commands.context -> + string -> bool Lwt.t + val add : + Client_commands.context -> + string -> t -> unit Lwt.t + val del : + Client_commands.context -> + string -> unit Lwt.t + val save : + Client_commands.context -> + (string * t) list -> unit Lwt.t + val to_source : + Client_commands.context -> + t -> string Lwt.t val alias_param : ?name:string -> ?desc:string -> - 'a Cli_entries.params -> - (Lwt_io.file_name * t -> 'a) Cli_entries.params + ('a, Client_commands.context, 'ret) Cli_entries.params -> + (string * t -> 'a, Client_commands.context, 'ret) Cli_entries.params val fresh_alias_param : ?name:string -> ?desc:string -> - 'a Cli_entries.params -> (string -> 'a) Cli_entries.params + ('a, Client_commands.context, 'ret) Cli_entries.params -> + (string -> 'a, Client_commands.context, 'ret) Cli_entries.params val source_param : ?name:string -> ?desc:string -> - 'a Cli_entries.params -> (t -> 'a) Cli_entries.params + ('a, Client_commands.context, 'ret) Cli_entries.params -> + (t -> 'a, Client_commands.context, 'ret) Cli_entries.params end module Alias (Entity : Entity) : Alias with type t = Entity.t diff --git a/src/client/client_version.ml b/src/client/client_commands.ml similarity index 54% rename from src/client/client_version.ml rename to src/client/client_commands.ml index bbc4fdfa5..e09e4c258 100644 --- a/src/client/client_version.ml +++ b/src/client/client_commands.ml @@ -7,8 +7,42 @@ (* *) (**************************************************************************) +type ('a, 'b) lwt_format = + ('a, Format.formatter, unit, 'b Lwt.t) format4 -(* A global store for version indexed commands. *) +type context = + { error : 'a 'b. ('a, 'b) lwt_format -> 'a ; + warning : 'a. ('a, unit) lwt_format -> 'a ; + message : 'a. ('a, unit) lwt_format -> 'a ; + answer : 'a. ('a, unit) lwt_format -> 'a ; + log : 'a. string -> ('a, unit) lwt_format -> 'a } + +type command = (context, unit) Cli_entries.command + +let make_context log = + let error fmt = + Format.kasprintf + (fun msg -> + Lwt.fail (Failure msg)) + fmt in + let warning fmt = + Format.kasprintf + (fun msg -> log "stderr" msg) + fmt in + let message fmt = + Format.kasprintf + (fun msg -> log "stdout" msg) + fmt in + let answer = + message in + let log name fmt = + Format.kasprintf + (fun msg -> log name msg) + fmt in + { error ; warning ; message ; answer ; log } + +let ignore_context = + make_context (fun _ _ -> Lwt.return ()) exception Version_not_found diff --git a/src/client/client_version.mli b/src/client/client_commands.mli similarity index 63% rename from src/client/client_version.mli rename to src/client/client_commands.mli index eefd4cbdf..4140e7f5f 100644 --- a/src/client/client_version.mli +++ b/src/client/client_commands.mli @@ -7,7 +7,21 @@ (* *) (**************************************************************************) -open Cli_entries +type ('a, 'b) lwt_format = + ('a, Format.formatter, unit, 'b Lwt.t) format4 + +type context = + { error : 'a 'b. ('a, 'b) lwt_format -> 'a ; + warning : 'a. ('a, unit) lwt_format -> 'a ; + message : 'a. ('a, unit) lwt_format -> 'a ; + answer : 'a. ('a, unit) lwt_format -> 'a ; + log : 'a. string -> ('a, unit) lwt_format -> 'a } + +val make_context : (string -> string -> unit Lwt.t) -> context + +val ignore_context : context + +type command = (context, unit) Cli_entries.command exception Version_not_found diff --git a/src/client/client_config.ml b/src/client/client_config.ml index 6485825a2..5e4ef8504 100644 --- a/src/client/client_config.ml +++ b/src/client/client_config.ml @@ -102,7 +102,7 @@ let register_config_option version option = (* Entry point *) -let parse_args ?version usage dispatcher argv = +let parse_args ?version usage dispatcher argv cctxt = let open Lwt in catch (fun () -> @@ -129,7 +129,7 @@ let parse_args ?version usage dispatcher argv = ~current:(ref 0) argv args (anon dispatch) "\000" ; Lwt.return () with Sys_error msg -> - Cli_entries.error + cctxt.Client_commands.error "Error: can't read the configuration file: %s\n%!" msg end else begin try @@ -140,7 +140,7 @@ let parse_args ?version usage dispatcher argv = file_group#write config_file#get ; Lwt.return () with Sys_error msg -> - Cli_entries.warning + cctxt.Client_commands.warning "Warning: can't create the default configuration file: %s\n%!" msg end) >>= fun () -> begin match dispatch `End with @@ -171,7 +171,7 @@ let preparse name argv = None with Found s -> Some s -let preparse_args argv : Node_rpc_services.Blocks.block Lwt.t = +let preparse_args argv cctxt : Node_rpc_services.Blocks.block Lwt.t = begin match preparse "-base-dir" argv with | None -> () @@ -187,7 +187,7 @@ let preparse_args argv : Node_rpc_services.Blocks.block Lwt.t = (file_group#read config_file#get ; Lwt.return ()) with Sys_error msg -> - Cli_entries.error + cctxt.Client_commands.error "Error: can't read the configuration file: %s\n%!" msg else Lwt.return () end >>= fun () -> @@ -204,7 +204,7 @@ let preparse_args argv : Node_rpc_services.Blocks.block Lwt.t = incoming_port#set (int_of_string port) ; Lwt.return () with _ -> - Cli_entries.error + cctxt.Client_commands.error "Error: can't parse the -port option: %S.\n%!" port end >>= fun () -> match preparse "-block" Sys.argv with @@ -212,6 +212,6 @@ let preparse_args argv : Node_rpc_services.Blocks.block Lwt.t = | Some x -> match Node_rpc_services.Blocks.parse_block x with | Error _ -> - Cli_entries.error + cctxt.Client_commands.error "Error: can't parse the -block option: %S.\n%!" x | Ok b -> Lwt.return b diff --git a/src/client/client_generic_rpcs.ml b/src/client/client_generic_rpcs.ml index 19d5fa803..0dab9ab56 100644 --- a/src/client/client_generic_rpcs.ml +++ b/src/client/client_generic_rpcs.ml @@ -192,9 +192,9 @@ let rec count = (*-- Commands ---------------------------------------------------------------*) -let list url () = +let list url cctxt = let args = Utils.split '/' url in - Client_node_rpcs.describe ~recurse:true args >>= fun tree -> + Client_node_rpcs.describe cctxt ~recurse:true args >>= fun tree -> let open RPC.Description in let collected_args = ref [] in let collect arg = @@ -272,24 +272,24 @@ let list url () = Format.pp_print_list (fun ppf (n,t) -> display ppf ([ n ], tpath @ [ n ], t)) in - Cli_entries.message "@ @[Available services:@ @ %a@]@." + cctxt.message "@ @[Available services:@ @ %a@]@." display (args, args, tree) >>= fun () -> if !collected_args <> [] then - Cli_entries.message "@,@[Dynamic parameter description:@ @ %a@]@." + cctxt.message "@,@[Dynamic parameter description:@ @ %a@]@." (Format.pp_print_list display_arg) !collected_args else Lwt.return () -let schema url () = +let schema url cctxt = let args = Utils.split '/' url in let open RPC.Description in - Client_node_rpcs.describe ~recurse:false args >>= function + Client_node_rpcs.describe cctxt ~recurse:false args >>= function | Static { service = Some { input ; output } } -> - Cli_entries.message "Input schema:\n%s\nOutput schema:\n%s\n%!" + cctxt.message "Input schema:\n%s\nOutput schema:\n%s\n%!" (Data_encoding_ezjsonm.to_string (Json_schema.to_json input)) (Data_encoding_ezjsonm.to_string (Json_schema.to_json output)) | _ -> - Cli_entries.message + cctxt.message "No service found at this URL (but this is a valid prefix)\n%!" let fill_in schema = @@ -299,60 +299,43 @@ let fill_in schema = | Any | Object { properties = [] } -> Lwt.return (Ok (`O [])) | _ -> editor_fill_in schema -let call url () = +let call url cctxt = let args = Utils.split '/' url in let open RPC.Description in - Client_node_rpcs.describe ~recurse:false args >>= function + Client_node_rpcs.describe cctxt ~recurse:false args >>= function | Static { service = Some { input } } -> begin fill_in input >>= function | Error msg -> - error "%s" msg + cctxt.error "%s" msg | Ok json -> - Client_node_rpcs.get_json args json >>= fun json -> - Cli_entries.message "Output:\n%s\n%!" (Data_encoding_ezjsonm.to_string json) + Client_node_rpcs.get_json cctxt args json >>= fun json -> + cctxt.message "Output:\n%s\n%!" (Data_encoding_ezjsonm.to_string json) end | _ -> - Cli_entries.message + cctxt.message "No service found at this URL (but this is a valid prefix)\n%!" -let () = - let open Cli_entries in - register_tag "low-level" "low level commands for advanced users" ; - register_tag "local" "commands that do not require a running node" ; - register_tag "debug" "commands mostly useful for debugging" ; - register_group "rpc" "Commands for the low level RPC layer" +let group = + { Cli_entries.name = "rpc" ; + title = "Commands for the low level RPC layer" } -let commands = Cli_entries.([ - command - ~tags: [ "local" ] - ~desc: "list all understood protocol versions" - (fixed [ "list" ; "versions" ]) - (fun () -> - Lwt_list.iter_s - (fun (ver, _) -> message "%a" Protocol_hash.pp_short ver) - (Client_version.get_versions ())) ; - command - ~tags: [ "low-level" ; "local" ] - ~group: "rpc" - ~desc: "list available RPCs (low level command for advanced users)" - (prefixes [ "rpc" ; "list" ] @@ stop) - (list "/"); - command - ~tags: [ "low-level" ; "local" ] - ~group: "rpc" - ~desc: "list available RPCs (low level command for advanced users)" - (prefixes [ "rpc" ; "list" ] @@ string "url" "the RPC's prefix to be described" @@ stop) - list ; - command - ~tags: [ "low-level" ; "local" ] - ~group: "rpc" - ~desc: "get the schemas of an RPC" - (prefixes [ "rpc" ; "schema" ] @@ string "url" "the RPC's URL" @@ stop) - schema ; - command - ~tags: [ "low-level" ; "local" ] - ~group: "rpc" - ~desc: "call an RPC (low level command for advanced users)" - (prefixes [ "rpc" ; "call" ] @@ string "url" "the RPC's URL" @@ stop) - call - ]) +let commands = [ + command ~desc: "list all understood protocol versions" + (fixed [ "list" ; "versions" ]) + (fun cctxt -> + Lwt_list.iter_s + (fun (ver, _) -> cctxt.Client_commands.message "%a" Protocol_hash.pp_short ver) + (Client_commands.get_versions ())) ; + command ~group ~desc: "list available RPCs (low level command for advanced users)" + (prefixes [ "rpc" ; "list" ] @@ stop) + (list "/"); + command ~group ~desc: "list available RPCs (low level command for advanced users)" + (prefixes [ "rpc" ; "list" ] @@ string ~name:"url" ~desc: "the RPC's prefix to be described" @@ stop) + list ; + command ~group ~desc: "get the schemas of an RPC" + (prefixes [ "rpc" ; "schema" ] @@ string ~name: "url" ~desc: "the RPC's URL" @@ stop) + schema ; + command ~group ~desc: "call an RPC (low level command for advanced users)" + (prefixes [ "rpc" ; "call" ] @@ string ~name: "url" ~desc: "the RPC's URL" @@ stop) + call +] diff --git a/src/client/client_generic_rpcs.mli b/src/client/client_generic_rpcs.mli index 7c819c892..863c977cc 100644 --- a/src/client/client_generic_rpcs.mli +++ b/src/client/client_generic_rpcs.mli @@ -7,4 +7,4 @@ (* *) (**************************************************************************) -val commands: Cli_entries.command list +val commands: Client_commands.command list diff --git a/src/client/client_helpers.ml b/src/client/client_helpers.ml index 4555be6ee..20b4db683 100644 --- a/src/client/client_helpers.ml +++ b/src/client/client_helpers.ml @@ -9,10 +9,6 @@ open Client_config -let () = - let open Cli_entries in - register_group "helpers" "Various helpers" - let unique = ref false let unique_arg = "-unique", @@ -26,13 +22,17 @@ let commands () = Cli_entries.[ works only for blocks, operations, public key and contract \ identifiers." ~args: [unique_arg] - (prefixes [ "complete" ] @@ string "prefix" "the prefix of the Base48Check-encoded hash to be completed" @@ stop) - (fun prefix () -> - Client_node_rpcs.complete ~block:(block ()) prefix >>= fun completions -> + (prefixes [ "complete" ] @@ + string + ~name: "prefix" + ~desc: "the prefix of the Base48Check-encoded hash to be completed" @@ + stop) + (fun prefix cctxt -> + Client_node_rpcs.complete cctxt ~block:(block ()) prefix >>= fun completions -> match completions with | [] -> Pervasives.exit 3 | _ :: _ :: _ when !unique -> Pervasives.exit 3 | completions -> List.iter print_endline completions ; Lwt.return_unit) -] + ] diff --git a/src/client/client_helpers.mli b/src/client/client_helpers.mli index 2ae45c301..8e0608798 100644 --- a/src/client/client_helpers.mli +++ b/src/client/client_helpers.mli @@ -7,4 +7,4 @@ (* *) (**************************************************************************) -val commands: unit -> Cli_entries.command list +val commands: unit -> Client_commands.command list diff --git a/src/client/client_keys.ml b/src/client/client_keys.ml index 2b9d77969..dcd013a9a 100644 --- a/src/client/client_keys.ml +++ b/src/client/client_keys.ml @@ -12,18 +12,18 @@ module Ed25519 = Environment.Ed25519 module Public_key_hash = Client_aliases.Alias (struct type t = Ed25519.Public_key_hash.t let encoding = Ed25519.Public_key_hash.encoding - let of_source s = Lwt.return (Ed25519.Public_key_hash.of_b48check s) - let to_source p = Lwt.return (Ed25519.Public_key_hash.to_b48check p) + let of_source _ s = Lwt.return (Ed25519.Public_key_hash.of_b48check s) + let to_source _ p = Lwt.return (Ed25519.Public_key_hash.to_b48check p) let name = "public key hash" end) module Public_key = Client_aliases.Alias (struct type t = Ed25519.public_key let encoding = Ed25519.public_key_encoding - let of_source s = + let of_source _ s = Lwt.return (Sodium.Sign.Bytes.to_public_key (Bytes.of_string B64.(decode ~alphabet:uri_safe_alphabet s))) - let to_source p = + let to_source _ p = Lwt.return B64.(encode ~alphabet:uri_safe_alphabet (Bytes.to_string (Sodium.Sign.Bytes.of_public_key p))) let name = "public key" @@ -32,106 +32,99 @@ module Public_key = Client_aliases.Alias (struct module Secret_key = Client_aliases.Alias (struct type t = Ed25519.secret_key let encoding = Ed25519.secret_key_encoding - let of_source s = + let of_source _ s = Lwt.return (Sodium.Sign.Bytes.to_secret_key (Bytes.of_string B64.(decode ~alphabet:uri_safe_alphabet s))) - let to_source p = + let to_source _ p = Lwt.return B64.(encode ~alphabet:uri_safe_alphabet (Bytes.to_string (Sodium.Sign.Bytes.of_secret_key p))) let name = "secret key" end) -let gen_keys name = +let gen_keys cctxt name = let secret_key, public_key = Sodium.Sign.random_keypair () in - Secret_key.add name secret_key >>= fun () -> - Public_key.add name public_key >>= fun () -> - Public_key_hash.add name (Ed25519.hash public_key) >>= fun () -> - Cli_entries.message "I generated a brand new pair of keys under the name '%s'." name + Secret_key.add cctxt name secret_key >>= fun () -> + Public_key.add cctxt name public_key >>= fun () -> + Public_key_hash.add cctxt name (Ed25519.hash public_key) >>= fun () -> + cctxt.message "I generated a brand new pair of keys under the name '%s'." name let check_keys_consistency pk sk = let message = MBytes.of_string "Voulez-vous coucher avec moi, ce soir ?" in let signature = Ed25519.sign sk message in Ed25519.check_signature pk signature message -let get_key pkh = - Public_key_hash.rev_find pkh >>= function - | None -> Cli_entries.error "no keys for the source contract manager" +let get_key cctxt pkh = + Public_key_hash.rev_find cctxt pkh >>= function + | None -> cctxt.error "no keys for the source contract manager" | Some n -> - Public_key.find n >>= fun pk -> - Secret_key.find n >>= fun sk -> + Public_key.find cctxt n >>= fun pk -> + Secret_key.find cctxt n >>= fun sk -> return (n, pk, sk) +let group = + { Cli_entries.name = "keys" ; + title = "Commands for managing cryptographic keys" } + let commands () = let open Cli_entries in - register_group "keys" "Commands for managing cryptographic keys" ; - [ command - ~group: "keys" - ~desc: "generate a pair of keys" + [ command ~group ~desc: "generate a pair of keys" (prefixes [ "gen" ; "keys" ] @@ Secret_key.fresh_alias_param @@ stop) - (fun name () -> gen_keys name) ; - command - ~group: "keys" - ~desc: "add a secret key to the wallet" + (fun name cctxt -> gen_keys cctxt name) ; + command ~group ~desc: "add a secret key to the wallet" (prefixes [ "add" ; "secret" ; "key" ] @@ Secret_key.fresh_alias_param @@ Secret_key.source_param @@ stop) - (fun name sk () -> + (fun name sk cctxt -> Lwt.catch (fun () -> - Public_key.find name >>= fun pk -> + Public_key.find cctxt name >>= fun pk -> if check_keys_consistency pk sk || Client_config.force#get then - Secret_key.add name sk + Secret_key.add cctxt name sk else - error "public and secret keys '%s' don't correspond, \ - please don't use -force true" name) + cctxt.error + "public and secret keys '%s' don't correspond, \ + please don't use -force true" name) (function | Not_found -> - error "no public key named '%s', add it before adding the secret key" name + cctxt.error + "no public key named '%s', add it before adding the secret key" name | exn -> Lwt.fail exn)) ; - command - ~group: "keys" - ~desc: "add a public key to the wallet" + command ~group ~desc: "add a public key to the wallet" (prefixes [ "add" ; "public" ; "key" ] @@ Public_key.fresh_alias_param @@ Public_key.source_param @@ stop) - (fun name key () -> - Public_key_hash.add name (Ed25519.hash key) >>= fun () -> - Public_key.add name key) ; - command - ~group: "keys" - ~desc: "add an ID a public key hash to the wallet" + (fun name key cctxt -> + Public_key_hash.add cctxt name (Ed25519.hash key) >>= fun () -> + Public_key.add cctxt name key) ; + command ~group ~desc: "add an ID a public key hash to the wallet" (prefixes [ "add" ; "identity" ] @@ Public_key_hash.fresh_alias_param @@ Public_key_hash.source_param @@ stop) - (fun name hash () -> - Public_key_hash.add name hash) ; - command - ~group: "keys" - ~desc: "list all public key hashes and associated keys" + (fun name hash cctxt -> + Public_key_hash.add cctxt name hash) ; + command ~group ~desc: "list all public key hashes and associated keys" (fixed [ "list" ; "known" ; "identities" ]) - (fun () -> - Public_key_hash.load () >>= fun l -> + (fun cctxt -> + Public_key_hash.load cctxt >>= fun l -> Lwt_list.iter_s (fun (name, pkh) -> - Public_key.mem name >>= fun pkm -> - Secret_key.mem name >>= fun pks -> - Public_key_hash.to_source pkh >>= fun v -> - message "%s: %s%s%s" name v + Public_key.mem cctxt name >>= fun pkm -> + Secret_key.mem cctxt name >>= fun pks -> + Public_key_hash.to_source cctxt pkh >>= fun v -> + cctxt.message "%s: %s%s%s" name v (if pkm then " (public key known)" else "") (if pks then " (secret key known)" else "")) l) ; - command - ~group: "keys" - ~desc: "forget all keys" + command ~group ~desc: "forget all keys" (fixed [ "forget" ; "all" ; "keys" ]) - (fun () -> + (fun cctxt -> if not Client_config.force#get then - error "this can only used with option -force true" + cctxt.Client_commands.error "this can only used with option -force true" else - Public_key.save [] >>= fun () -> - Secret_key.save [] >>= fun () -> - Public_key_hash.save []) ; + Public_key.save cctxt [] >>= fun () -> + Secret_key.save cctxt [] >>= fun () -> + Public_key_hash.save cctxt []) ; ] diff --git a/src/client/client_keys.mli b/src/client/client_keys.mli index 757df170c..a45fef0ab 100644 --- a/src/client/client_keys.mli +++ b/src/client/client_keys.mli @@ -15,8 +15,9 @@ module Public_key : Client_aliases.Alias with type t = Ed25519.public_key module Secret_key : Client_aliases.Alias with type t = Ed25519.secret_key val get_key: + Client_commands.context -> Public_key_hash.t -> ( string * Public_key.t * Secret_key.t ) tzresult Lwt.t -val commands: unit -> Cli_entries.command list +val commands: unit -> Client_commands.command list diff --git a/src/client/client_node_rpcs.ml b/src/client/client_node_rpcs.ml index b3092747a..ddeeeccab 100644 --- a/src/client/client_node_rpcs.ml +++ b/src/client/client_node_rpcs.ml @@ -11,18 +11,17 @@ open Lwt open Cli_entries +open Client_commands open Logging.RPC -let log_request cpt url req = - Cli_entries.log "requests" - ">>>>%d: %s\n%s\n" cpt url req +let log_request { log } cpt url req = + log "requests" ">>>>%d: %s\n%s\n" cpt url req -let log_response cpt code ans = - Cli_entries.log "requests" - "<<<<%d: %s\n%s\n" cpt (Cohttp.Code.string_of_status code) ans +let log_response { log } cpt code ans = + log "requests" "<<<<%d: %s\n%s\n" cpt (Cohttp.Code.string_of_status code) ans let cpt = ref 0 -let make_request service json = +let make_request cctxt service json = incr cpt ; let cpt = !cpt in let serv = "http://" ^ Client_config.incoming_addr#get @@ -35,23 +34,23 @@ let make_request service json = (fun () -> let body = Cohttp_lwt_body.of_string reqbody in Cohttp_lwt_unix.Client.post ~body uri >>= fun (code, ansbody) -> - log_request cpt string_uri reqbody >>= fun () -> + log_request cctxt cpt string_uri reqbody >>= fun () -> return (cpt, Unix.gettimeofday () -. tzero, code.Cohttp.Response.status, ansbody)) (fun e -> let msg = match e with | Unix.Unix_error (e, _, _) -> Unix.error_message e | e -> Printexc.to_string e in - error "cannot connect to the RPC server (%s)" msg) + cctxt.error "cannot connect to the RPC server (%s)" msg) -let get_streamed_json service json = - make_request service json >>= fun (_cpt, time, code, ansbody) -> +let get_streamed_json cctxt service json = + make_request cctxt service json >>= fun (_cpt, time, code, ansbody) -> let ansbody = Cohttp_lwt_body.to_stream ansbody in match code, ansbody with | #Cohttp.Code.success_status, ansbody -> (if Client_config.print_timings#get then - message "Request to /%s succeeded in %gs" - (String.concat "/" service) time + cctxt.message "Request to /%s succeeded in %gs" + (String.concat "/" service) time else Lwt.return ()) >>= fun () -> Lwt.return ( Lwt_stream.filter_map_s @@ -64,88 +63,92 @@ let get_streamed_json service json = (Data_encoding_ezjsonm.from_stream ansbody)) | err, _ansbody -> (if Client_config.print_timings#get then - message "Request to /%s failed in %gs" - (String.concat "/" service) time + cctxt.message "Request to /%s failed in %gs" + (String.concat "/" service) time else Lwt.return ()) >>= fun () -> - message "Request to /%s failed, server returned %s" + cctxt.message "Request to /%s failed, server returned %s" (String.concat "/" service) (Cohttp.Code.string_of_status err) >>= fun () -> - error "the RPC server returned a non-success status (%s)" + cctxt.error "the RPC server returned a non-success status (%s)" (Cohttp.Code.string_of_status err) -let get_json service json = - make_request service json >>= fun (cpt, time, code, ansbody) -> +let get_json cctxt service json = + make_request cctxt service json >>= fun (cpt, time, code, ansbody) -> Cohttp_lwt_body.to_string ansbody >>= fun ansbody -> match code, ansbody with | #Cohttp.Code.success_status, ansbody -> begin (if Client_config.print_timings#get then - message "Request to /%s succeeded in %gs" + cctxt.message "Request to /%s succeeded in %gs" (String.concat "/" service) time else Lwt.return ()) >>= fun () -> - log_response cpt code ansbody >>= fun () -> + log_response cctxt cpt code ansbody >>= fun () -> if ansbody = "" then Lwt.return `Null else match Data_encoding_ezjsonm.from_string ansbody with - | Error _ -> error "the RPC server returned malformed JSON" + | Error _ -> cctxt.error "the RPC server returned malformed JSON" | Ok res -> Lwt.return res end | err, _ansbody -> (if Client_config.print_timings#get then - message "Request to /%s failed in %gs" + cctxt.message "Request to /%s failed in %gs" (String.concat "/" service) time else Lwt.return ()) >>= fun () -> - message "Request to /%s failed, server returned %s" + cctxt.message "Request to /%s failed, server returned %s" (String.concat "/" service) (Cohttp.Code.string_of_status err) >>= fun () -> - error "the RPC server returned a non-success status (%s)" + cctxt.error "the RPC server returned a non-success status (%s)" (Cohttp.Code.string_of_status err) exception Unknown_error of Data_encoding.json -let parse_answer service path json = +let parse_answer cctxt 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" + cctxt.error "request to /%s returned wrong JSON (%s)\n%s" (String.concat "/" path) msg (Data_encoding_ezjsonm.to_string json) | Ok v -> return v -let call_service0 service arg = +let call_service0 cctxt service arg = let path, arg = RPC.forge_request service () arg in - get_json path arg >>= parse_answer service path + get_json cctxt path arg >>= fun json -> + parse_answer cctxt service path json -let call_service1 service a1 arg = +let call_service1 cctxt service a1 arg = let path, arg = RPC.forge_request service ((), a1) arg in - get_json path arg >>= parse_answer service path + get_json cctxt path arg >>= fun json -> + parse_answer cctxt service path json -let call_service2 service a1 a2 arg = +let call_service2 cctxt service a1 a2 arg = let path, arg = RPC.forge_request service (((), a1), a2) arg in - get_json path arg >>= parse_answer service path + get_json cctxt path arg >>= fun json -> + parse_answer cctxt service path json -let call_streamed_service0 service arg = +let call_streamed_service0 cctxt service arg = let path, arg = RPC.forge_request service () arg in - get_streamed_json path arg >|= fun st -> - Lwt_stream.map_s (parse_answer service path) st + get_streamed_json cctxt path arg >|= fun st -> + Lwt_stream.map_s (parse_answer cctxt service path) st module Services = Node_rpc_services -let errors = call_service0 Services.Error.service -let forge_block ?net ?predecessor ?timestamp fitness ops header = - call_service0 Services.forge_block +let errors cctxt = + call_service0 cctxt Services.Error.service () +let forge_block cctxt ?net ?predecessor ?timestamp fitness ops header = + call_service0 cctxt Services.forge_block (net, predecessor, timestamp, fitness, ops, header) -let validate_block net block = - call_service0 Services.validate_block (net, block) -let inject_block ?(wait = true) ?force block = - call_service0 Services.inject_block (block, wait, force) -let inject_operation ?(wait = true) ?force operation = - call_service0 Services.inject_operation (operation, wait, force) -let inject_protocol ?(wait = true) ?force protocol = - call_service0 Services.inject_protocol (protocol, wait, force) -let complete ?block prefix = +let validate_block cctxt net block = + call_service0 cctxt Services.validate_block (net, block) +let inject_block cctxt ?(wait = true) ?force block = + call_service0 cctxt Services.inject_block (block, wait, force) +let inject_operation cctxt ?(wait = true) ?force operation = + call_service0 cctxt Services.inject_operation (operation, wait, force) +let inject_protocol cctxt ?(wait = true) ?force protocol = + call_service0 cctxt Services.inject_protocol (protocol, wait, force) +let complete cctxt ?block prefix = match block with | None -> - call_service1 Services.complete prefix () + call_service1 cctxt Services.complete prefix () | Some block -> - call_service2 Services.Blocks.complete block prefix () -let describe ?recurse path = + call_service2 cctxt Services.Blocks.complete block prefix () +let describe cctxt ?recurse path = let prefix, arg = RPC.forge_request Services.describe () recurse in - get_json (prefix @ path) arg >>= - parse_answer Services.describe prefix + get_json cctxt (prefix @ path) arg >>= + parse_answer cctxt Services.describe prefix type net = Services.Blocks.net = Net of Block_hash.t @@ -173,42 +176,42 @@ module Blocks = struct fitness: MBytes.t list ; timestamp: Time.t ; } - let net h = call_service1 Services.Blocks.net h () - let predecessor h = call_service1 Services.Blocks.predecessor h () - let hash h = call_service1 Services.Blocks.hash h () - let timestamp h = call_service1 Services.Blocks.timestamp h () - let fitness h = call_service1 Services.Blocks.fitness h () - let operations h = call_service1 Services.Blocks.operations h () - let protocol h = call_service1 Services.Blocks.protocol h () - let test_protocol h = call_service1 Services.Blocks.test_protocol h () - let test_network h = call_service1 Services.Blocks.test_network h () - let preapply h ?timestamp ?(sort = false) operations = - call_service1 Services.Blocks.preapply h { operations ; sort ; timestamp } - let pending_operations block = - call_service1 Services.Blocks.pending_operations block () - let info ?(operations = false) h = - call_service1 Services.Blocks.info h operations - let complete block prefix = - call_service2 Services.Blocks.complete block prefix () - let list ?operations ?length ?heads ?delay ?min_date ?min_heads () = - call_service0 Services.Blocks.list + let net cctxt h = call_service1 cctxt Services.Blocks.net h () + let predecessor cctxt h = call_service1 cctxt Services.Blocks.predecessor h () + let hash cctxt h = call_service1 cctxt Services.Blocks.hash h () + let timestamp cctxt h = call_service1 cctxt Services.Blocks.timestamp h () + let fitness cctxt h = call_service1 cctxt Services.Blocks.fitness h () + let operations cctxt h = call_service1 cctxt Services.Blocks.operations h () + let protocol cctxt h = call_service1 cctxt Services.Blocks.protocol h () + let test_protocol cctxt h = call_service1 cctxt Services.Blocks.test_protocol h () + let test_network cctxt h = call_service1 cctxt Services.Blocks.test_network h () + let preapply cctxt h ?timestamp ?(sort = false) operations = + call_service1 cctxt Services.Blocks.preapply h { operations ; sort ; timestamp } + let pending_operations cctxt block = + call_service1 cctxt Services.Blocks.pending_operations block () + let info cctxt ?(operations = false) h = + call_service1 cctxt Services.Blocks.info h operations + let complete cctxt block prefix = + call_service2 cctxt Services.Blocks.complete block prefix () + let list cctxt ?operations ?length ?heads ?delay ?min_date ?min_heads () = + call_service0 cctxt Services.Blocks.list { operations; length ; heads ; monitor = Some false ; delay ; min_date ; min_heads } - let monitor ?operations ?length ?heads ?delay ?min_date ?min_heads () = - call_streamed_service0 Services.Blocks.list + let monitor cctxt ?operations ?length ?heads ?delay ?min_date ?min_heads () = + call_streamed_service0 cctxt Services.Blocks.list { operations; length ; heads ; monitor = Some true ; delay ; min_date ; min_heads } end module Operations = struct - let monitor ?contents () = - call_streamed_service0 Services.Operations.list + let monitor cctxt ?contents () = + call_streamed_service0 cctxt Services.Operations.list { monitor = Some true ; contents } end module Protocols = struct - let bytes hash = - call_service1 Services.Protocols.bytes hash () - let list ?contents () = - call_service0 Services.Protocols.list { contents; monitor = Some false } + let bytes cctxt hash = + call_service1 cctxt Services.Protocols.bytes hash () + let list cctxt ?contents () = + call_service0 cctxt Services.Protocols.list { contents; monitor = Some false } end diff --git a/src/client/client_node_rpcs.mli b/src/client/client_node_rpcs.mli index 8944348fe..9084dc85b 100644 --- a/src/client/client_node_rpcs.mli +++ b/src/client/client_node_rpcs.mli @@ -9,8 +9,12 @@ type net = State.net_id = Net of Block_hash.t -val errors: unit -> Json_schema.schema Lwt.t +val errors: + Client_commands.context -> + Json_schema.schema Lwt.t + val forge_block: + Client_commands.context -> ?net:Updater.net_id -> ?predecessor:Block_hash.t -> ?timestamp:Time.t -> @@ -19,14 +23,28 @@ val forge_block: MBytes.t -> MBytes.t Lwt.t -val validate_block: net -> Block_hash.t -> unit tzresult Lwt.t +val validate_block: + Client_commands.context -> + net -> Block_hash.t -> + unit tzresult Lwt.t + val inject_block: - ?wait:bool -> ?force:bool -> MBytes.t -> + Client_commands.context -> + ?wait:bool -> ?force:bool -> + MBytes.t -> Block_hash.t tzresult Lwt.t + val inject_operation: - ?wait:bool -> ?force:bool -> MBytes.t -> Operation_hash.t tzresult Lwt.t + Client_commands.context -> + ?wait:bool -> ?force:bool -> + MBytes.t -> + Operation_hash.t tzresult Lwt.t + val inject_protocol: - ?wait:bool -> ?force:bool -> Tezos_compiler.Protocol.t -> Protocol_hash.t tzresult Lwt.t + Client_commands.context -> + ?wait:bool -> ?force:bool -> + Tezos_compiler.Protocol.t -> + Protocol_hash.t tzresult Lwt.t module Blocks : sig @@ -37,17 +55,36 @@ module Blocks : sig | `Hash of Block_hash.t ] - val net: block -> net Lwt.t - val predecessor: block -> Block_hash.t Lwt.t - val hash: block -> Block_hash.t Lwt.t - val timestamp: block -> Time.t Lwt.t - val fitness: block -> MBytes.t list Lwt.t - val operations: block -> Operation_hash.t list Lwt.t - val protocol: block -> Protocol_hash.t Lwt.t - val test_protocol: block -> Protocol_hash.t option Lwt.t - val test_network: block -> (net * Time.t) option Lwt.t + val net: + Client_commands.context -> + block -> net Lwt.t + val predecessor: + Client_commands.context -> + block -> Block_hash.t Lwt.t + val hash: + Client_commands.context -> + block -> Block_hash.t Lwt.t + val timestamp: + Client_commands.context -> + block -> Time.t Lwt.t + val fitness: + Client_commands.context -> + block -> MBytes.t list Lwt.t + val operations: + Client_commands.context -> + block -> Operation_hash.t list Lwt.t + val protocol: + Client_commands.context -> + block -> Protocol_hash.t Lwt.t + val test_protocol: + Client_commands.context -> + block -> Protocol_hash.t option Lwt.t + val test_network: + Client_commands.context -> + block -> (net * Time.t) option Lwt.t val pending_operations: + Client_commands.context -> block -> (error Updater.preapply_result * Operation_hash_set.t) Lwt.t type block_info = { @@ -63,14 +100,17 @@ module Blocks : sig } val info: + Client_commands.context -> ?operations:bool -> block -> block_info Lwt.t val list: + Client_commands.context -> ?operations:bool -> ?length:int -> ?heads:Block_hash.t list -> ?delay:int -> ?min_date:Time.t -> ?min_heads:int -> unit -> block_info list list Lwt.t val monitor: + Client_commands.context -> ?operations:bool -> ?length:int -> ?heads:Block_hash.t list -> ?delay:int -> ?min_date:Time.t -> ?min_heads:int -> unit -> block_info list list Lwt_stream.t Lwt.t @@ -82,6 +122,7 @@ module Blocks : sig } val preapply: + Client_commands.context -> block -> ?timestamp:Time.t -> ?sort:bool -> @@ -91,30 +132,42 @@ end module Operations : sig val monitor: + Client_commands.context -> ?contents:bool -> unit -> (Operation_hash.t * Store.operation option) list Lwt_stream.t Lwt.t end module Protocols : sig val bytes: + Client_commands.context -> Protocol_hash.t -> Store.protocol tzresult Time.timed_data Lwt.t val list: + Client_commands.context -> ?contents:bool -> unit -> (Protocol_hash.t * Store.protocol option) list Lwt.t end -val complete: ?block:Blocks.block -> string -> string list Lwt.t +val complete: + Client_commands.context -> + ?block:Blocks.block -> string -> string list Lwt.t -val describe: ?recurse:bool -> string list -> RPC.Description.directory_descr Lwt.t +val describe: + Client_commands.context -> + ?recurse:bool -> string list -> RPC.Description.directory_descr Lwt.t (** Low-level *) -val get_json: string list -> Data_encoding.json -> Data_encoding.json Lwt.t +val get_json: + Client_commands.context -> + string list -> Data_encoding.json -> Data_encoding.json Lwt.t val call_service0: + Client_commands.context -> (unit, unit, 'i, 'o) RPC.service -> 'i -> 'o Lwt.t val call_service1: + Client_commands.context -> (unit, unit * 'a, 'i, 'o) RPC.service -> 'a -> 'i -> 'o Lwt.t val call_service2: + Client_commands.context -> (unit, (unit * 'a) * 'b, 'i, 'o) RPC.service -> 'a -> 'b -> 'i -> 'o Lwt.t diff --git a/src/client/client_protocols.ml b/src/client/client_protocols.ml index d6d3e0afc..574b48670 100644 --- a/src/client/client_protocols.ml +++ b/src/client/client_protocols.ml @@ -1,51 +1,60 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +let group = + { Cli_entries.name = "protocols" ; + title = "Commands for managing protocols" } + let commands () = let open Cli_entries in - let check_dir dn = - if Sys.is_directory dn then Lwt.return dn else Lwt.fail_invalid_arg "not a directory" - in - let check_hash ph = Lwt.wrap1 Protocol_hash.of_b48check ph in - register_group "protocols" "Commands for managing protocols" ; + let check_dir _ dn = + if Sys.is_directory dn then + Lwt.return dn + else + Lwt.fail_with (dn ^ " is not a directory") in + let check_hash _ ph = + Lwt.wrap1 Protocol_hash.of_b48check ph in [ - command - ~group: "protocols" - ~desc: "list known protocols" + command ~group ~desc: "list known protocols" (prefixes [ "list" ; "protocols" ] stop) - (fun () -> - Client_node_rpcs.Protocols.list ~contents:false () >>= fun protos -> - Lwt_list.iter_s (fun (ph, _p) -> message "%a" Protocol_hash.pp ph) protos + (fun cctxt -> + Client_node_rpcs.Protocols.list cctxt ~contents:false () >>= fun protos -> + Lwt_list.iter_s (fun (ph, _p) -> cctxt.message "%a" Protocol_hash.pp ph) protos ); - command - ~group: "protocols" - ~desc: "inject a new protocol to the shell database" + command ~group ~desc: "inject a new protocol to the shell database" (prefixes [ "inject" ; "protocol" ] - @@ param ~name:"directory containing a protocol" ~desc:"" check_dir + @@ param ~name:"dir" ~desc:"directory containing a protocol" check_dir @@ stop) - (fun dirname () -> + (fun dirname cctxt -> Lwt.catch (fun () -> let proto = Tezos_compiler.Protocol.of_dir dirname in - Client_node_rpcs.inject_protocol proto >>= function + Client_node_rpcs.inject_protocol cctxt proto >>= function | Ok hash -> - message "Injected protocol %a successfully" Protocol_hash.pp_short hash + cctxt.message "Injected protocol %a successfully" Protocol_hash.pp_short hash | Error err -> - error "Error while injecting protocol from %s: %a" + cctxt.error "Error while injecting protocol from %s: %a" dirname Error_monad.pp_print_error err) (fun exn -> - error "Error while injecting protocol from %s: %a" + cctxt.error "Error while injecting protocol from %s: %a" dirname Error_monad.pp_print_error [Error_monad.Exn exn]) ); - command - ~group: "protocols" - ~desc: "dump a protocol from the shell database" + command ~group ~desc: "dump a protocol from the shell database" (prefixes [ "dump" ; "protocol" ] @@ param ~name:"protocol hash" ~desc:"" check_hash @@ stop) - (fun ph () -> - Client_node_rpcs.Protocols.bytes ph >>= fun { data } -> match data with + (fun ph cctxt -> + Client_node_rpcs.Protocols.bytes cctxt ph >>= fun { data } -> match data with | Ok proto -> Updater.extract "" ph proto >>= fun () -> - message "Extracted protocol %a" Protocol_hash.pp_short ph + cctxt.message "Extracted protocol %a" Protocol_hash.pp_short ph | Error err -> - error "Error while dumping protocol %a: %a" + cctxt.error "Error while dumping protocol %a: %a" Protocol_hash.pp_short ph Error_monad.pp_print_error err); ] diff --git a/src/client/client_protocols.mli b/src/client/client_protocols.mli index 1b6371300..8e0608798 100644 --- a/src/client/client_protocols.mli +++ b/src/client/client_protocols.mli @@ -1,2 +1,10 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) -val commands: unit -> Cli_entries.command list +val commands: unit -> Client_commands.command list diff --git a/src/client/embedded/bootstrap/client_proto_args.ml b/src/client/embedded/bootstrap/client_proto_args.ml index ac2f66c36..f09a7d3c7 100644 --- a/src/client/embedded/bootstrap/client_proto_args.ml +++ b/src/client/embedded/bootstrap/client_proto_args.ml @@ -86,7 +86,7 @@ let tez_param ~name ~desc next = name (desc ^ " in \xEA\x9C\xA9\n\ text format: D,DDD,DDD.DD (centiles and comas are optional)") - (fun s -> + (fun _ s -> try Lwt.return (tez_of_string s) with _ -> Lwt.fail_with "invalid \xEA\x9C\xA9 notation") next diff --git a/src/client/embedded/bootstrap/client_proto_args.mli b/src/client/embedded/bootstrap/client_proto_args.mli index ab04ad0be..22f8abf2d 100644 --- a/src/client/embedded/bootstrap/client_proto_args.mli +++ b/src/client/embedded/bootstrap/client_proto_args.mli @@ -25,7 +25,8 @@ val endorsement_delay_arg: string * Arg.spec * string val tez_param : name:string -> desc:string -> - 'a Cli_entries.params -> (Tez.t -> 'a) Cli_entries.params + ('a, Client_commands.context, unit) Cli_entries.params -> + (Tez.t -> 'a, Client_commands.context, unit) Cli_entries.params val delegate: string option ref val source: string option ref diff --git a/src/client/embedded/bootstrap/client_proto_context.ml b/src/client/embedded/bootstrap/client_proto_context.ml index fc48aab3b..d9fab7bff 100644 --- a/src/client/embedded/bootstrap/client_proto_context.ml +++ b/src/client/embedded/bootstrap/client_proto_context.ml @@ -13,43 +13,40 @@ open Client_proto_programs open Client_keys module Ed25519 = Environment.Ed25519 -let handle_error f () = - f () >>= Client_proto_rpcs.handle_error - -let check_contract neu = - RawContractAlias.mem neu >>= function +let check_contract cctxt neu = + RawContractAlias.mem cctxt neu >>= function | true -> - Cli_entries.error "contract '%s' already exists" neu + cctxt.error "contract '%s' already exists" neu | false -> Lwt.return () -let get_delegate_pkh = function +let get_delegate_pkh cctxt = function | None -> Lwt.return None | Some delegate -> Lwt.catch (fun () -> - Public_key_hash.find delegate >>= fun r -> + Public_key_hash.find cctxt delegate >>= fun r -> Lwt.return (Some r)) (fun _ -> Lwt.return None) -let get_timestamp block () = - Client_node_rpcs.Blocks.timestamp block >>= fun v -> - Cli_entries.message "%s" (Time.to_notation v) +let get_timestamp cctxt block = + Client_node_rpcs.Blocks.timestamp cctxt block >>= fun v -> + cctxt.message "%s" (Time.to_notation v) -let list_contracts block () = - Client_proto_rpcs.Context.Contract.list block >>=? fun contracts -> +let list_contracts cctxt block = + Client_proto_rpcs.Context.Contract.list cctxt block >>=? fun contracts -> iter_s (fun h -> begin match Contract.is_default h with | Some m -> begin - Public_key_hash.rev_find m >>= function + Public_key_hash.rev_find cctxt m >>= function | None -> Lwt.return "" | Some nm -> - RawContractAlias.find_opt nm >|= function + RawContractAlias.find_opt cctxt nm >|= function | None -> " (known as " ^ nm ^ ")" | Some _ -> " (known as key:" ^ nm ^ ")" end | None -> begin - RawContractAlias.rev_find h >|= function + RawContractAlias.rev_find cctxt h >|= function | None -> "" | Some nm -> " (known as " ^ nm ^ ")" end @@ -57,134 +54,129 @@ let list_contracts block () = let kind = match Contract.is_default h with | Some _ -> " (default)" | None -> "" in - Cli_entries.message "%s%s%s" (Contract.to_b48check h) kind nm >>= fun () -> + cctxt.message "%s%s%s" (Contract.to_b48check h) kind nm >>= fun () -> return ()) contracts -let transfer block ?force +let transfer cctxt + block ?force ~source ~src_pk ~src_sk ~destination ?arg ~amount ~fee () = let open Cli_entries in - Client_node_rpcs.Blocks.net block >>= fun net -> + Client_node_rpcs.Blocks.net cctxt block >>= fun net -> begin match arg with | Some arg -> - Client_proto_programs.parse_data arg >>= fun arg -> + Client_proto_programs.parse_data cctxt arg >>= fun arg -> Lwt.return (Some arg) | None -> Lwt.return None end >>= fun parameters -> - Client_proto_rpcs.Context.Contract.counter block source >>=? fun pcounter -> + Client_proto_rpcs.Context.Contract.counter cctxt block source >>=? fun pcounter -> let counter = Int32.succ pcounter in - message "Acquired the source's sequence counter (%ld -> %ld)." + cctxt.message "Acquired the source's sequence counter (%ld -> %ld)." pcounter counter >>= fun () -> - Client_proto_rpcs.Helpers.Forge.Manager.transaction block + Client_proto_rpcs.Helpers.Forge.Manager.transaction cctxt block ~net ~source ~sourcePubKey:src_pk ~counter ~amount ~destination ?parameters ~fee () >>=? fun bytes -> - message "Forged the raw transaction frame." >>= fun () -> + cctxt.message "Forged the raw transaction frame." >>= fun () -> let signed_bytes = Ed25519.append_signature src_sk bytes in - Client_node_rpcs.inject_operation ?force ~wait:true signed_bytes >>=? fun oph -> - answer "Operation successfully injected in the node." >>= fun () -> - answer "Operation hash is '%a'." Operation_hash.pp oph >>= fun () -> + Client_node_rpcs.inject_operation cctxt ?force ~wait:true signed_bytes >>=? fun oph -> + cctxt.answer "Operation successfully injected in the node." >>= fun () -> + cctxt.answer "Operation hash is '%a'." Operation_hash.pp oph >>= fun () -> return () -let originate_account block ?force +let originate_account cctxt + block ?force ~source ~src_pk ~src_sk ~manager_pkh ?delegatable ?spendable ?delegate ~balance ~fee () = let open Cli_entries in - Client_node_rpcs.Blocks.net block >>= fun net -> - Client_proto_rpcs.Context.Contract.counter block source >>=? fun pcounter -> + Client_node_rpcs.Blocks.net cctxt block >>= fun net -> + Client_proto_rpcs.Context.Contract.counter cctxt block source >>=? fun pcounter -> let counter = Int32.succ pcounter in - message "Acquired the source's sequence counter (%ld -> %ld)." + cctxt.message "Acquired the source's sequence counter (%ld -> %ld)." pcounter counter >>= fun () -> - Client_proto_rpcs.Helpers.Forge.Manager.origination block + Client_proto_rpcs.Helpers.Forge.Manager.origination cctxt block ~net ~source ~sourcePubKey:src_pk ~managerPubKey:manager_pkh ~counter ~balance ?spendable ?delegatable ?delegatePubKey:delegate ~fee () >>=? fun (contract, bytes) -> - message "Forged the raw origination frame." >>= fun () -> + cctxt.message "Forged the raw origination frame." >>= fun () -> let signed_bytes = Ed25519.append_signature src_sk bytes in - Client_node_rpcs.inject_operation ?force ~wait:true signed_bytes >>=? fun oph -> - message "Operation successfully injected in the node." >>= fun () -> - message "Operation hash is '%a'." Operation_hash.pp oph >>= fun () -> + Client_node_rpcs.inject_operation cctxt ?force ~wait:true signed_bytes >>=? fun oph -> + cctxt.message "Operation successfully injected in the node." >>= fun () -> + cctxt.message "Operation hash is '%a'." Operation_hash.pp oph >>= fun () -> return contract -let originate_contract +let originate_contract cctxt block ?force ~source ~src_pk ~src_sk ~manager_pkh ~balance ?delegatable ?delegatePubKey ~(code:Script.code) ~init ~fee () = let open Cli_entries in - Client_proto_programs.parse_data init >>= fun storage -> + Client_proto_programs.parse_data cctxt init >>= fun storage -> let init = Script.{ storage ; storage_type = code.storage_type } in - Client_proto_rpcs.Context.Contract.counter block source >>=? fun pcounter -> + Client_proto_rpcs.Context.Contract.counter cctxt block source >>=? fun pcounter -> let counter = Int32.succ pcounter in - message "Acquired the source's sequence counter (%ld -> %ld)." + cctxt.message "Acquired the source's sequence counter (%ld -> %ld)." pcounter counter >>= fun () -> - Client_node_rpcs.Blocks.net block >>= fun net -> - Client_proto_rpcs.Helpers.Forge.Manager.origination block + Client_node_rpcs.Blocks.net cctxt block >>= fun net -> + Client_proto_rpcs.Helpers.Forge.Manager.origination cctxt block ~net ~source ~sourcePubKey:src_pk ~managerPubKey:manager_pkh ~counter ~balance ~spendable:!spendable ?delegatable ?delegatePubKey ~script:(code, init) ~fee () >>=? fun (contract, bytes) -> - message "Forged the raw origination frame." >>= fun () -> + cctxt.message "Forged the raw origination frame." >>= fun () -> let signed_bytes = Ed25519.append_signature src_sk bytes in - Client_node_rpcs.inject_operation ?force ~wait:true signed_bytes >>=? fun oph -> - message "Operation successfully injected in the node." >>= fun () -> - message "Operation hash is '%a'." Operation_hash.pp oph >>= fun () -> + Client_node_rpcs.inject_operation cctxt ?force ~wait:true signed_bytes >>=? fun oph -> + cctxt.message "Operation successfully injected in the node." >>= fun () -> + cctxt.message "Operation hash is '%a'." Operation_hash.pp oph >>= fun () -> return contract +let group = + { Cli_entries.name = "context" ; + title = "Block contextual commands (see option -block)" } + let commands () = let open Cli_entries in - register_group "context" "Block contextual commands (see option -block)" ; - [ command - ~group: "context" - ~desc: "access the timestamp of the block" + [ command ~group ~desc: "access the timestamp of the block" (fixed [ "get" ; "timestamp" ]) - (get_timestamp (block ())) ; - command - ~group: "context" - ~desc: "lists all non empty contracts of the block" + (fun cctxt -> get_timestamp cctxt (block ())) ; + command ~group ~desc: "lists all non empty contracts of the block" (fixed [ "list" ; "contracts" ]) - (handle_error (list_contracts (block ()))) ; - command - ~group: "context" - ~desc: "get the bootstrap keys and bootstrap contract handle" + (fun cctxt -> + list_contracts cctxt (block ()) >>= fun res -> + Client_proto_rpcs.handle_error cctxt res) ; + command ~group ~desc: "get the bootstrap keys and bootstrap contract handle" (fixed [ "bootstrap" ]) - (fun () -> - Client_proto_rpcs.Constants.bootstrap `Genesis >>= fun accounts -> + (fun cctxt -> + Client_proto_rpcs.Constants.bootstrap cctxt `Genesis >>= fun accounts -> let cpt = ref 0 in Lwt_list.iter_s (fun { Bootstrap.public_key_hash = pkh ; public_key = pk ; secret_key = sk } -> incr cpt ; let name = Printf.sprintf "bootstrap%d" !cpt in - Public_key_hash.add name pkh >>= fun () -> - Public_key.add name pk >>= fun () -> - Secret_key.add name sk >>= fun () -> - message "Bootstrap keys added under the name '%s'." name) + Public_key_hash.add cctxt name pkh >>= fun () -> + Public_key.add cctxt name pk >>= fun () -> + Secret_key.add cctxt name sk >>= fun () -> + cctxt.message "Bootstrap keys added under the name '%s'." name) accounts >>= fun () -> Lwt.return_unit) ; - command - ~group: "context" - ~desc: "get the balance of a contract" + command ~group ~desc: "get the balance of a contract" (prefixes [ "get" ; "balance" ] @@ ContractAlias.destination_param ~name:"src" ~desc:"source contract" @@ stop) - (fun (_, contract) () -> - Client_proto_rpcs.Context.Contract.balance (block ()) contract - >>= Client_proto_rpcs.handle_error >>= fun amount -> - answer "%a %s" Tez.pp amount tez_sym); - command - ~group: "context" - ~desc: "get the manager of a block" + (fun (_, contract) cctxt -> + Client_proto_rpcs.Context.Contract.balance cctxt (block ()) contract + >>= Client_proto_rpcs.handle_error cctxt >>= fun amount -> + cctxt.answer "%a %s" Tez.pp amount tez_sym); + command ~group ~desc: "get the manager of a block" (prefixes [ "get" ; "manager" ] @@ ContractAlias.destination_param ~name:"src" ~desc:"source contract" @@ stop) - (fun (_, contract) () -> - Client_proto_rpcs.Context.Contract.manager (block ()) contract - >>= Client_proto_rpcs.handle_error >>= fun manager -> - Public_key_hash.rev_find manager >>= fun mn -> - Public_key_hash.to_source manager >>= fun m -> - message "%s (%s)" m + (fun (_, contract) cctxt -> + Client_proto_rpcs.Context.Contract.manager cctxt (block ()) contract + >>= Client_proto_rpcs.handle_error cctxt >>= fun manager -> + Public_key_hash.rev_find cctxt manager >>= fun mn -> + Public_key_hash.to_source cctxt manager >>= fun m -> + cctxt.message "%s (%s)" m (match mn with None -> "unknown" | Some n -> "known as " ^ n)); - command - ~group: "context" - ~desc: "open a new account" + command ~group ~desc: "open a new account" ~args: ([ fee_arg ; delegate_arg ; force_arg ] @ delegatable_args @ spendable_args) (prefixes [ "originate" ; "account" ] @@ -200,22 +192,18 @@ let commands () = @@ ContractAlias.alias_param ~name:"src" ~desc: "name of the source contract" @@ stop) - (fun neu (_, manager) balance (_, source) -> - handle_error @@ fun () -> - check_contract neu >>= fun () -> - get_delegate_pkh !delegate >>= fun delegate -> - Client_proto_contracts.get_manager (block ()) source >>=? fun src_pkh -> - Client_keys.get_key src_pkh >>=? fun (src_name, src_pk, src_sk) -> - message "Got the source's manager keys (%s)." src_name >>= fun () -> - originate_account (block ()) ~force:!force - ~source ~src_pk ~src_sk ~manager_pkh:manager ~balance ~fee:!fee - ~delegatable:!delegatable ~spendable:!spendable ?delegate:delegate - () >>=? fun contract -> - RawContractAlias.add neu contract >>= fun () -> - return ()) ; - command - ~group: "context" - ~desc: "open a new scripted account" + (fun neu (_, manager) balance (_, source) cctxt -> + check_contract cctxt neu >>= fun () -> + get_delegate_pkh cctxt !delegate >>= fun delegate -> + (Client_proto_contracts.get_manager cctxt (block ()) source >>=? fun src_pkh -> + Client_keys.get_key cctxt src_pkh >>=? fun (src_name, src_pk, src_sk) -> + cctxt.message "Got the source's manager keys (%s)." src_name >>= fun () -> + originate_account cctxt (block ()) ~force:!force + ~source ~src_pk ~src_sk ~manager_pkh:manager ~balance ~fee:!fee + ~delegatable:!delegatable ~spendable:!spendable ?delegate:delegate + ()) >>= Client_proto_rpcs.handle_error cctxt >>= fun contract -> + RawContractAlias.add cctxt neu contract) ; + command ~group ~desc: "open a new scripted account" ~args: ([ fee_arg ; delegate_arg ; force_arg ] @ delegatable_args @ spendable_args @ [ init_arg ]) (prefixes [ "originate" ; "contract" ] @@ -233,24 +221,20 @@ let commands () = @@ prefix "running" @@ Program.source_param ~name:"prg" ~desc: "script of the account\n\ - combine with -init if the storage type is non void" + combine with -init if the storage type is non void" @@ stop) - (fun neu (_, manager) balance (_, source) code -> - handle_error @@ fun () -> - check_contract neu >>= fun () -> - get_delegate_pkh !delegate >>= fun delegate -> - Client_proto_contracts.get_manager (block ()) source >>=? fun src_pkh -> - Client_keys.get_key src_pkh >>=? fun (src_name, src_pk, src_sk) -> - message "Got the source's manager keys (%s)." src_name >>= fun () -> - originate_contract (block ()) ~force:!force - ~source ~src_pk ~src_sk ~manager_pkh:manager ~balance ~fee:!fee - ~delegatable:!delegatable ?delegatePubKey:delegate ~code ~init:!init () - >>=? fun contract -> - RawContractAlias.add neu contract >>= fun () -> - return ()) ; - command - ~group: "context" - ~desc: "transfer tokens" + (fun neu (_, manager) balance (_, source) code cctxt -> + check_contract cctxt neu >>= fun () -> + get_delegate_pkh cctxt !delegate >>= fun delegate -> + (Client_proto_contracts.get_manager cctxt (block ()) source >>=? fun src_pkh -> + Client_keys.get_key cctxt src_pkh >>=? fun (src_name, src_pk, src_sk) -> + cctxt.message "Got the source's manager keys (%s)." src_name >>= fun () -> + originate_contract cctxt (block ()) ~force:!force + ~source ~src_pk ~src_sk ~manager_pkh:manager ~balance ~fee:!fee + ~delegatable:!delegatable ?delegatePubKey:delegate ~code ~init:!init + ()) >>= Client_proto_rpcs.handle_error cctxt >>= fun contract -> + RawContractAlias.add cctxt neu contract) ; + command ~group ~desc: "transfer tokens" ~args: [ fee_arg ; arg_arg ; force_arg ] (prefixes [ "transfer" ] @@ tez_param @@ -262,11 +246,11 @@ let commands () = @@ ContractAlias.destination_param ~name: "dst" ~desc: "name/literal of the destination contract" @@ stop) - (fun amount (_, source) (_, destination) -> - handle_error @@ fun () -> - Client_proto_contracts.get_manager (block ()) source >>=? fun src_pkh -> - Client_keys.get_key src_pkh >>=? fun (src_name, src_pk, src_sk) -> - message "Got the source's manager keys (%s)." src_name >>= fun () -> - transfer (block ()) ~force:!force - ~source ~src_pk ~src_sk ~destination ?arg:!arg ~amount ~fee:!fee ()) + (fun amount (_, source) (_, destination) cctxt -> + (Client_proto_contracts.get_manager cctxt (block ()) source >>=? fun src_pkh -> + Client_keys.get_key cctxt src_pkh >>=? fun (src_name, src_pk, src_sk) -> + cctxt.message "Got the source's manager keys (%s)." src_name >>= fun () -> + transfer cctxt (block ()) ~force:!force + ~source ~src_pk ~src_sk ~destination ?arg:!arg ~amount ~fee:!fee ()) >>= + Client_proto_rpcs.handle_error cctxt) ] diff --git a/src/client/embedded/bootstrap/client_proto_context.mli b/src/client/embedded/bootstrap/client_proto_context.mli index e000c2d7f..03859e72b 100644 --- a/src/client/embedded/bootstrap/client_proto_context.mli +++ b/src/client/embedded/bootstrap/client_proto_context.mli @@ -8,6 +8,7 @@ (**************************************************************************) val transfer: + Client_commands.context -> Client_proto_rpcs.block -> ?force:bool -> source:Contract.t -> @@ -20,6 +21,7 @@ val transfer: unit -> unit tzresult Lwt.t val originate_account: + Client_commands.context -> Client_proto_rpcs.block -> ?force:bool -> source:Contract.t -> @@ -34,6 +36,7 @@ val originate_account: unit -> Contract.t tzresult Lwt.t val originate_contract: + Client_commands.context -> Client_proto_rpcs.block -> ?force:bool -> source:Contract.t -> @@ -48,4 +51,4 @@ val originate_contract: fee:Tez.t -> unit -> Contract.t tzresult Lwt.t -val commands: unit -> Cli_entries.command list +val commands: unit -> Client_commands.command list diff --git a/src/client/embedded/bootstrap/client_proto_contracts.ml b/src/client/embedded/bootstrap/client_proto_contracts.ml index a9270b5cb..cb2bf27e2 100644 --- a/src/client/embedded/bootstrap/client_proto_contracts.ml +++ b/src/client/embedded/bootstrap/client_proto_contracts.ml @@ -12,44 +12,44 @@ module Ed25519 = Environment.Ed25519 module RawContractAlias = Client_aliases.Alias (struct type t = Contract.t let encoding = Contract.encoding - let of_source s = + let of_source _ s = match Contract.of_b48check s with | Error _ -> Lwt.fail (Failure "bad contract notation") | Ok s -> Lwt.return s - let to_source s = + let to_source _ s = Lwt.return (Contract.to_b48check s) let name = "contract" end) module ContractAlias = struct - let find s = - RawContractAlias.find_opt s >>= function + let find cctxt s = + RawContractAlias.find_opt cctxt s >>= function | Some v -> Lwt.return (s, v) | None -> - Client_keys.Public_key_hash.find_opt s >>= function + Client_keys.Public_key_hash.find_opt cctxt s >>= function | Some v -> Lwt.return (s, Contract.default_contract v) | None -> - Cli_entries.error + cctxt.error "no contract alias nor key alias names %s" s - let find_key name = - Client_keys.Public_key_hash.find name >>= fun v -> + let find_key cctxt name = + Client_keys.Public_key_hash.find cctxt name >>= fun v -> Lwt.return (name, Contract.default_contract v) - let rev_find c = + let rev_find cctxt c = match Contract.is_default c with | Some hash -> begin - Client_keys.Public_key_hash.rev_find hash >>= function + Client_keys.Public_key_hash.rev_find cctxt hash >>= function | Some name -> Lwt.return (Some ("key:" ^ name)) | None -> Lwt.return_none end - | None -> RawContractAlias.rev_find c + | None -> RawContractAlias.rev_find cctxt c - let get_contract s = + let get_contract cctxt s = match Utils.split ~limit:1 ':' s with | [ "key" ; key ]-> - find_key key - | _ -> find s + find_key cctxt key + | _ -> find cctxt s let alias_param ?(name = "name") ?(desc = "existing contract alias") next = let desc = @@ -64,42 +64,42 @@ module ContractAlias = struct ^ "can be an alias, a key alias, or a literal (autodetected in this order)\n\ use 'text:literal', 'alias:name', 'key:name' to force" in Cli_entries.param ~name ~desc - (fun s -> + (fun cctxt s -> match Utils.split ~limit:1 ':' s with | [ "alias" ; alias ]-> - find alias + find cctxt alias | [ "key" ; text ] -> - Client_keys.Public_key_hash.find text >>= fun v -> + Client_keys.Public_key_hash.find cctxt text >>= fun v -> Lwt.return (s, Contract.default_contract v) | _ -> Lwt.catch - (fun () -> find s) + (fun () -> find cctxt s) (fun _ -> match Contract.of_b48check s with | Error _ -> Lwt.fail (Failure "bad contract notation") | Ok v -> Lwt.return (s, v))) next - let name contract = - rev_find contract >|= function + let name cctxt contract = + rev_find cctxt contract >|= function | None -> Contract.to_b48check contract | Some name -> name end -let get_manager block source = +let get_manager cctxt block source = match Contract.is_default source with | Some hash -> return hash - | None -> Client_proto_rpcs.Context.Contract.manager block source + | None -> Client_proto_rpcs.Context.Contract.manager cctxt block source -let get_delegate block source = +let get_delegate cctxt block source = let open Client_keys in match Contract.is_default source with | Some hash -> return hash | None -> - Client_proto_rpcs.Context.Contract.delegate block source >>=? function + Client_proto_rpcs.Context.Contract.delegate cctxt block source >>=? function | Some delegate -> return delegate - | None -> Client_proto_rpcs.Context.Contract.manager block source + | None -> Client_proto_rpcs.Context.Contract.manager cctxt block source let may_check_key sourcePubKey sourcePubKeyHash = match sourcePubKey with @@ -111,8 +111,8 @@ let may_check_key sourcePubKey sourcePubKeyHash = return () | None -> return () -let check_public_key block ?src_pk src_pk_hash = - Client_proto_rpcs.Context.Key.get block src_pk_hash >>= function +let check_public_key cctxt block ?src_pk src_pk_hash = + Client_proto_rpcs.Context.Key.get cctxt block src_pk_hash >>= function | Error errors -> begin match src_pk with @@ -125,59 +125,51 @@ let check_public_key block ?src_pk src_pk_hash = end | Ok _ -> return None +let group = + { Cli_entries.name = "contracts" ; + title = "Commands for managing the record of known contracts" } + let commands () = let open Cli_entries in - register_group "contracts" - "Commands for managing the record of known contracts" ; [ - command - ~group: "contracts" - ~desc: "add a contract to the wallet" + command ~group ~desc: "add a contract to the wallet" (prefixes [ "remember" ; "contract" ] @@ RawContractAlias.fresh_alias_param @@ RawContractAlias.source_param @@ stop) - (fun name hash () -> RawContractAlias.add name hash) ; - command - ~group: "contracts" - ~desc: "remove a contract from the wallet" + (fun name hash cctxt -> RawContractAlias.add cctxt name hash) ; + command ~group ~desc: "remove a contract from the wallet" (prefixes [ "forget" ; "contract" ] @@ RawContractAlias.alias_param @@ stop) - (fun (name, _) () -> RawContractAlias.del name) ; - command - ~group: "contracts" - ~desc: "lists all known contracts" + (fun (name, _) cctxt -> RawContractAlias.del cctxt name) ; + command ~group ~desc: "lists all known contracts" (fixed [ "list" ; "known" ; "contracts" ]) - (fun () -> - RawContractAlias.load () >>= fun list -> + (fun cctxt -> + RawContractAlias.load cctxt >>= fun list -> Lwt_list.iter_s (fun (n, v) -> let v = Contract.to_b48check v in - message "%s: %s" n v) + cctxt.message "%s: %s" n v) list >>= fun () -> - Client_keys.Public_key_hash.load () >>= fun list -> + Client_keys.Public_key_hash.load cctxt >>= fun list -> Lwt_list.iter_s (fun (n, v) -> - RawContractAlias.mem n >>= fun mem -> + RawContractAlias.mem cctxt n >>= fun mem -> let p = if mem then "key:" else "" in let v = Contract.to_b48check (Contract.default_contract v) in - message "%s%s: %s" p n v) + cctxt.message "%s%s: %s" p n v) list >>= fun () -> Lwt.return ()) ; - command - ~group: "contracts" - ~desc: "forget all known contracts" + command ~group ~desc: "forget all known contracts" (fixed [ "forget" ; "all" ; "contracts" ]) - (fun () -> + (fun cctxt -> if not Client_config.force#get then - error "this can only used with option -force true" + cctxt.Client_commands.error "this can only used with option -force true" else - RawContractAlias.save []) ; - command - ~group: "contracts" - ~desc: "display a contract from the wallet" + RawContractAlias.save cctxt []) ; + command ~group ~desc: "display a contract from the wallet" (prefixes [ "show" ; "known" ; "contract" ] @@ RawContractAlias.alias_param @@ stop) - (fun (_, contract) () -> - Cli_entries.message "%a\n%!" Contract.pp contract) ; + (fun (_, contract) cctxt -> + cctxt.message "%a\n%!" Contract.pp contract) ; ] diff --git a/src/client/embedded/bootstrap/client_proto_contracts.mli b/src/client/embedded/bootstrap/client_proto_contracts.mli index 54257e48f..9d4b511ec 100644 --- a/src/client/embedded/bootstrap/client_proto_contracts.mli +++ b/src/client/embedded/bootstrap/client_proto_contracts.mli @@ -11,35 +11,44 @@ module RawContractAlias : Client_aliases.Alias with type t = Contract.t module ContractAlias : sig - val get_contract: string -> (string * Contract.t) Lwt.t + val get_contract: + Client_commands.context -> + string -> (string * Contract.t) Lwt.t val alias_param: ?name:string -> ?desc:string -> - 'a Cli_entries.params -> - (Lwt_io.file_name * Contract.t -> 'a) Cli_entries.params + ('a, Client_commands.context, unit) Cli_entries.params -> + (Lwt_io.file_name * Contract.t -> 'a, Client_commands.context, unit) Cli_entries.params val destination_param: ?name:string -> ?desc:string -> - 'a Cli_entries.params -> - (Lwt_io.file_name * Contract.t -> 'a) Cli_entries.params - val rev_find: Contract.t -> string option Lwt.t - val name: Contract.t -> string Lwt.t + ('a, Client_commands.context, unit) Cli_entries.params -> + (Lwt_io.file_name * Contract.t -> 'a, Client_commands.context, unit) Cli_entries.params + val rev_find: + Client_commands.context -> + Contract.t -> string option Lwt.t + val name: + Client_commands.context -> + Contract.t -> string Lwt.t end val get_manager: + Client_commands.context -> Client_proto_rpcs.block -> Contract.t -> public_key_hash tzresult Lwt.t val get_delegate: + Client_commands.context -> Client_proto_rpcs.block -> Contract.t -> public_key_hash tzresult Lwt.t val check_public_key : + Client_commands.context -> Client_proto_rpcs.block -> ?src_pk:public_key -> public_key_hash -> public_key option tzresult Lwt.t -val commands: unit -> Cli_entries.command list +val commands: unit -> Client_commands.command list diff --git a/src/client/embedded/bootstrap/client_proto_main.ml b/src/client/embedded/bootstrap/client_proto_main.ml index da62e7a10..dbbc47bd3 100644 --- a/src/client/embedded/bootstrap/client_proto_main.ml +++ b/src/client/embedded/bootstrap/client_proto_main.ml @@ -12,7 +12,7 @@ let protocol = "4p64VagsbXchSF88eaPy5XrkqMLEjBCaSnaGv2vQkhv8e37Nnqmrd" let () = - Client_version.register protocol @@ + Client_commands.register protocol @@ Client_proto_programs.commands () @ Client_proto_contracts.commands () @ Client_proto_context.commands () diff --git a/src/client/embedded/bootstrap/client_proto_nonces.ml b/src/client/embedded/bootstrap/client_proto_nonces.ml index 526f51fce..a9acf47f3 100644 --- a/src/client/embedded/bootstrap/client_proto_nonces.ml +++ b/src/client/embedded/bootstrap/client_proto_nonces.ml @@ -23,17 +23,17 @@ let encoding : t Data_encoding.t = let filename () = Client_config.(base_dir#get // "nonces") -let load () = +let load cctxt = let filename = filename () in if not (Sys.file_exists filename) then Lwt.return [] else Data_encoding_ezjsonm.read_file filename >>= function - | None -> error "couldn't to read the nonces file" + | None -> cctxt.Client_commands.error "couldn't to read the nonces file" | Some json -> match Data_encoding.Json.destruct encoding json with | exception _ -> (* TODO print_error *) - error "didn't understand the nonces file" + cctxt.Client_commands.error "didn't understand the nonces file" | list -> Lwt.return list @@ -43,7 +43,7 @@ let check_dir dirname = else Lwt.return () -let save list = +let save cctxt list = Lwt.catch (fun () -> let dirname = Client_config.base_dir#get in @@ -54,29 +54,30 @@ let save list = | false -> failwith "Json.write_file" | true -> return ()) (fun exn -> - error "could not write the nonces file: %s." (Printexc.to_string exn)) + cctxt.Client_commands.error + "could not write the nonces file: %s." (Printexc.to_string exn)) -let mem block_hash = - load () >|= fun data -> +let mem cctxt block_hash = + load cctxt >|= fun data -> List.mem_assoc block_hash data -let find block_hash = - load () >|= fun data -> +let find cctxt block_hash = + load cctxt >|= fun data -> try Some (List.assoc block_hash data) with Not_found -> None -let add block_hash nonce = - load () >>= fun data -> - save ((block_hash, nonce) :: +let add cctxt block_hash nonce = + load cctxt >>= fun data -> + save cctxt ((block_hash, nonce) :: List.remove_assoc block_hash data) -let del block_hash = - load () >>= fun data -> - save (List.remove_assoc block_hash data) +let del cctxt block_hash = + load cctxt >>= fun data -> + save cctxt (List.remove_assoc block_hash data) -let dels hashes = - load () >>= fun data -> - save @@ +let dels cctxt hashes = + load cctxt >>= fun data -> + save cctxt @@ List.fold_left (fun data hash -> List.remove_assoc hash data) data hashes diff --git a/src/client/embedded/bootstrap/client_proto_nonces.mli b/src/client/embedded/bootstrap/client_proto_nonces.mli index d99f7caed..224734cf4 100644 --- a/src/client/embedded/bootstrap/client_proto_nonces.mli +++ b/src/client/embedded/bootstrap/client_proto_nonces.mli @@ -7,8 +7,18 @@ (* *) (**************************************************************************) -val mem: Block_hash.t -> bool Lwt.t -val find: Block_hash.t -> Nonce.t option Lwt.t -val add: Block_hash.t -> Nonce.t -> unit tzresult Lwt.t -val del: Block_hash.t -> unit tzresult Lwt.t -val dels: Block_hash.t list -> unit tzresult Lwt.t +val mem: + Client_commands.context -> + Block_hash.t -> bool Lwt.t +val find: + Client_commands.context -> + Block_hash.t -> Nonce.t option Lwt.t +val add: + Client_commands.context -> + Block_hash.t -> Nonce.t -> unit tzresult Lwt.t +val del: + Client_commands.context -> + Block_hash.t -> unit tzresult Lwt.t +val dels: + Client_commands.context -> + Block_hash.t list -> unit tzresult Lwt.t diff --git a/src/client/embedded/bootstrap/client_proto_programs.ml b/src/client/embedded/bootstrap/client_proto_programs.ml index 6edacffa2..1146f10b5 100644 --- a/src/client/embedded/bootstrap/client_proto_programs.ml +++ b/src/client/embedded/bootstrap/client_proto_programs.ml @@ -10,7 +10,7 @@ module Ed25519 = Environment.Ed25519 open Client_proto_args -let report_parse_error _prefix exn _lexbuf = +let report_parse_error cctxt _prefix exn _lexbuf = let open Lexing in let open Script_located_ir in let print_loc ppf ((sl, sc), (el, ec)) = @@ -29,17 +29,17 @@ let report_parse_error _prefix exn _lexbuf = sl sc el ec in match exn with | Missing_program_field n -> - Cli_entries.error "missing script %s" n + cctxt.Client_commands.error "missing script %s" n | Illegal_character (loc, c) -> - Cli_entries.error "%a, illegal character %C" print_loc loc c + cctxt.Client_commands.error "%a, illegal character %C" print_loc loc c | Illegal_escape (loc, c) -> - Cli_entries.error "%a, illegal escape sequence %S" print_loc loc c + cctxt.Client_commands.error "%a, illegal escape sequence %S" print_loc loc c | Failure s -> - Cli_entries.error "%s" s + cctxt.Client_commands.error "%s" s | exn -> - Cli_entries.error "%s" @@ Printexc.to_string exn + cctxt.Client_commands.error "%s" @@ Printexc.to_string exn -let parse_program s = +let parse_program cctxt s = let lexbuf = Lexing.from_string s in try Lwt.return @@ -55,7 +55,7 @@ let parse_program s = storage_type = get_field "storage" fields } ) with - | exn -> report_parse_error "program: " exn lexbuf + | exn -> report_parse_error cctxt "program: " exn lexbuf let rec print_ir locations ppf node = let open Script in @@ -99,23 +99,23 @@ let print_program locations ppf c = "@[code@,%a@]" (print_ir locations) (c : Script.code).Script.code -let parse_data s = +let parse_data cctxt s = let lexbuf = Lexing.from_string s in try match Concrete_parser.tree Concrete_lexer.(token (init_state ())) lexbuf with | [node] -> Lwt.return (Script_located_ir.strip_locations node) - | _ -> Cli_entries.error "single data expression expected" + | _ -> cctxt.Client_commands.error "single data expression expected" with - | exn -> report_parse_error "data: " exn lexbuf + | exn -> report_parse_error cctxt "data: " exn lexbuf -let parse_data_type s = +let parse_data_type cctxt s = let lexbuf = Lexing.from_string s in try match Concrete_parser.tree Concrete_lexer.(token (init_state ())) lexbuf with | [node] -> Lwt.return (Script_located_ir.strip_locations node) - | _ -> Cli_entries.error "single type expression expected" + | _ -> cctxt.Client_commands.error "single type expression expected" with - | exn -> report_parse_error "data_type: " exn lexbuf + | exn -> report_parse_error cctxt "data_type: " exn lexbuf let unexpand_macros type_map program = let open Script in @@ -159,11 +159,15 @@ let unexpand_macros type_map program = module Program = Client_aliases.Alias (struct type t = Script.code let encoding = Script.code_encoding - let of_source s = parse_program s - let to_source p = Lwt.return (Format.asprintf "%a" (print_program (fun _ -> false)) p) + let of_source cctxt s = parse_program cctxt s + let to_source _ p = Lwt.return (Format.asprintf "%a" (print_program (fun _ -> false)) p) let name = "program" end) +let group = + { Cli_entries.name = "programs" ; + title = "Commands for managing the record of known programs" } + let commands () = let open Cli_entries in let show_types = ref false in @@ -176,41 +180,32 @@ let commands () = "-trace-stack", Arg.Set trace_stack, "Show the stack after each step" in - register_group "programs" "Commands for managing the record of known programs" ; [ - command - ~group: "programs" - ~desc: "lists all known programs" + command ~group ~desc: "lists all known programs" (fixed [ "list" ; "known" ; "programs" ]) - (fun () -> Program.load () >>= fun list -> - Lwt_list.iter_s (fun (n, _) -> message "%s" n) list) ; - command - ~group: "programs" - ~desc: "remember a program under some name" + (fun cctxt -> Program.load cctxt >>= fun list -> + Lwt_list.iter_s (fun (n, _) -> cctxt.message "%s" n) list) ; + command ~group ~desc: "remember a program under some name" (prefixes [ "remember" ; "program" ] @@ Program.fresh_alias_param @@ Program.source_param @@ stop) - (fun name hash () -> Program.add name hash) ; - command - ~group: "programs" - ~desc: "forget a remembered program" + (fun name hash cctxt -> + Program.add cctxt name hash) ; + command ~group ~desc: "forget a remembered program" (prefixes [ "forget" ; "program" ] @@ Program.alias_param @@ stop) - (fun (name, _) () -> Program.del name) ; - command - ~group: "programs" - ~desc: "display a program" + (fun (name, _) cctxt -> + Program.del cctxt name) ; + command ~group ~desc: "display a program" (prefixes [ "show" ; "known" ; "program" ] @@ Program.alias_param @@ stop) - (fun (_, program) () -> - Program.to_source program >>= fun source -> - Cli_entries.message "%s\n" source) ; - command - ~group: "programs" - ~desc: "ask the node to run a program" + (fun (_, program) cctxt -> + Program.to_source cctxt program >>= fun source -> + cctxt.message "%s\n" source) ; + command ~group ~desc: "ask the node to run a program" ~args: [ trace_stack_arg ] (prefixes [ "run" ; "program" ] @@ Program.source_param @@ -219,12 +214,13 @@ let commands () = @@ prefixes [ "and" ; "input" ] @@ Cli_entries.param ~name:"storage" ~desc:"the untagged input data" parse_data @@ stop) - (fun program storage input () -> + (fun program storage input cctxt -> let open Data_encoding in if !trace_stack then - Client_proto_rpcs.Helpers.trace_code (block ()) program (storage, input) >>= function + Client_proto_rpcs.Helpers.trace_code cctxt + (block ()) program (storage, input) >>= function | Ok (storage, output, trace) -> - Cli_entries.message "@[@[storage@,%a@]@,@[output@,%a@]@,@[trace@,%a@]@]@." + cctxt.message "@[@[storage@,%a@]@,@[output@,%a@]@,@[trace@,%a@]@]@." (print_ir (fun _ -> false)) storage (print_ir (fun _ -> false)) output (Format.pp_print_list @@ -237,37 +233,36 @@ let commands () = trace | Error errs -> pp_print_error Format.err_formatter errs ; - error "error running program" + cctxt.error "error running program" else - Client_proto_rpcs.Helpers.run_code (block ()) program (storage, input) >>= function + Client_proto_rpcs.Helpers.run_code cctxt + (block ()) program (storage, input) >>= function | Ok (storage, output) -> - Cli_entries.message "@[@[storage@,%a@]@,@[output@,%a@]@]@." + cctxt.message "@[@[storage@,%a@]@,@[output@,%a@]@]@." (print_ir (fun _ -> false)) storage (print_ir (fun _ -> false)) output | Error errs -> pp_print_error Format.err_formatter errs ; - error "error running program") ; - command - ~group: "programs" - ~desc: "ask the node to typecheck a program" + cctxt.error "error running program") ; + command ~group ~desc: "ask the node to typecheck a program" ~args: [ show_types_arg ] (prefixes [ "typecheck" ; "program" ] @@ Program.source_param @@ stop) - (fun program () -> + (fun program cctxt -> let open Data_encoding in - Client_proto_rpcs.Helpers.typecheck_code (block ()) program >>= function + Client_proto_rpcs.Helpers.typecheck_code cctxt (block ()) program >>= function | Ok type_map -> let type_map, program = unexpand_macros type_map program in - message "Well typed" >>= fun () -> + cctxt.message "Well typed" >>= fun () -> if !show_types then begin print_program (fun l -> List.mem_assoc l type_map) Format.std_formatter program ; - Cli_entries.message "@." >>= fun () -> + cctxt.message "@." >>= fun () -> Lwt_list.iter_s (fun (loc, (before, after)) -> - Cli_entries.message + cctxt.message "%3d@[ : [ @[%a ]@]@,-> [ @[%a ]@]@]@." loc (Format.pp_print_list (print_ir (fun _ -> false))) @@ -279,41 +274,38 @@ let commands () = else Lwt.return () | Error errs -> pp_print_error Format.err_formatter errs ; - error "ill-typed program") ; - command - ~group: "programs" - ~desc: "ask the node to typecheck a tagged data expression" + cctxt.error "ill-typed program") ; + command ~group ~desc: "ask the node to typecheck a tagged data expression" (prefixes [ "typecheck" ; "data" ] @@ Cli_entries.param ~name:"data" ~desc:"the data to typecheck" parse_data @@ prefixes [ "against" ; "type" ] @@ Cli_entries.param ~name:"type" ~desc:"the expected type" parse_data @@ stop) - (fun data exp_ty () -> + (fun data exp_ty cctxt -> let open Data_encoding in - Client_proto_rpcs.Helpers.typecheck_untagged_data + Client_proto_rpcs.Helpers.typecheck_untagged_data cctxt (block ()) (data, exp_ty) >>= function | Ok () -> - message "Well typed" + cctxt.message "Well typed" | Error errs -> pp_print_error Format.err_formatter errs ; - error "ill-typed data") ; - command - ~group: "programs" + cctxt.error "ill-typed data") ; + command ~group ~desc: "ask the node to compute the hash of an untagged data expression \ using the same algorithm as script instruction H" (prefixes [ "hash" ; "data" ] @@ Cli_entries.param ~name:"data" ~desc:"the data to hash" parse_data @@ stop) - (fun data () -> + (fun data cctxt -> let open Data_encoding in - Client_proto_rpcs.Helpers.hash_data (block ()) data >>= function + Client_proto_rpcs.Helpers.hash_data cctxt + (block ()) data >>= function | Ok hash -> - message "%S" hash + cctxt.message "%S" hash | Error errs -> pp_print_error Format.err_formatter errs ; - error "ill-formed data") ; - command - ~group: "programs" + cctxt.error "ill-formed data") ; + command ~group ~desc: "ask the node to compute the hash of an untagged data expression \ using the same algorithm as script instruction H, sign it using \ a given secret key, and display it using the format expected by \ @@ -323,17 +315,18 @@ let commands () = @@ prefixes [ "for" ] @@ Client_keys.Secret_key.alias_param @@ stop) - (fun data (_, key) () -> + (fun data (_, key) cctxt -> let open Data_encoding in - Client_proto_rpcs.Helpers.hash_data (block ()) data >>= function + Client_proto_rpcs.Helpers.hash_data cctxt + (block ()) data >>= function | Ok hash -> let signature = Ed25519.sign key (MBytes.of_string hash) in - message "Hash: %S@.Signature: %S" + cctxt.message "Hash: %S@.Signature: %S" hash (signature |> Data_encoding.Binary.to_bytes Ed25519.signature_encoding |> Hex_encode.hex_of_bytes) | Error errs -> pp_print_error Format.err_formatter errs ; - error "ill-formed data") ; + cctxt.error "ill-formed data") ; ] diff --git a/src/client/embedded/bootstrap/client_proto_programs.mli b/src/client/embedded/bootstrap/client_proto_programs.mli index 23e4b8664..760f07473 100644 --- a/src/client/embedded/bootstrap/client_proto_programs.mli +++ b/src/client/embedded/bootstrap/client_proto_programs.mli @@ -7,10 +7,16 @@ (* *) (**************************************************************************) -val parse_program: string -> Script.code Lwt.t -val parse_data: string -> Script.expr Lwt.t -val parse_data_type: string -> Script.expr Lwt.t +val parse_program: + Client_commands.context -> + string -> Script.code Lwt.t +val parse_data: + Client_commands.context -> + string -> Script.expr Lwt.t +val parse_data_type: + Client_commands.context -> + string -> Script.expr Lwt.t module Program : Client_aliases.Alias with type t = Script.code -val commands: unit -> Cli_entries.command list +val commands: unit -> Client_commands.command list diff --git a/src/client/embedded/bootstrap/client_proto_rpcs.ml b/src/client/embedded/bootstrap/client_proto_rpcs.ml index ee474b1fc..50d55ae45 100644 --- a/src/client/embedded/bootstrap/client_proto_rpcs.ml +++ b/src/client/embedded/bootstrap/client_proto_rpcs.ml @@ -10,11 +10,11 @@ let string_of_errors exns = Format.asprintf " @[%a@]" pp_print_error exns -let handle_error = function +let handle_error cctxt = function | Ok res -> Lwt.return res | Error exns -> pp_print_error Format.err_formatter exns ; - Cli_entries.error "cannot continue" + cctxt.Client_commands.error "%s" "cannot continue" type net = State.net_id = Net of Block_hash.t type block = [ @@ -24,42 +24,46 @@ type block = [ | `Hash of Block_hash.t ] -let call_service1 s block a1 = - Client_node_rpcs.call_service1 +let call_service1 cctxt s block a1 = + Client_node_rpcs.call_service1 cctxt (s Node_rpc_services.Blocks.proto_path) block a1 -let call_error_service1 s block a1 = - call_service1 s block a1 >|= wrap_error -let call_service2 s block a1 a2 = - Client_node_rpcs.call_service2 +let call_error_service1 cctxt s block a1 = + call_service1 cctxt s block a1 >|= wrap_error +let call_service2 cctxt s block a1 a2 = + Client_node_rpcs.call_service2 cctxt (s Node_rpc_services.Blocks.proto_path) block a1 a2 -let call_error_service2 s block a1 a2 = - call_service2 s block a1 a2 >|= wrap_error +let call_error_service2 cctxt s block a1 a2 = + call_service2 cctxt s block a1 a2 >|= wrap_error module Constants = struct - let bootstrap block = call_service1 Services.Constants.bootstrap block () - let errors block = call_service1 Services.Constants.errors block () - let cycle_length block = - call_error_service1 Services.Constants.cycle_length block () - let voting_period_length block = - call_error_service1 Services.Constants.voting_period_length block () - let time_before_reward block = - call_error_service1 Services.Constants.time_before_reward block () - let time_between_slots block = - call_error_service1 Services.Constants.time_between_slots block () - let first_free_mining_slot block = - call_error_service1 Services.Constants.first_free_mining_slot block () - let max_signing_slot block = - call_error_service1 Services.Constants.max_signing_slot block () - let instructions_per_transaction block = - call_error_service1 Services.Constants.instructions_per_transaction block () - let stamp_threshold block = - call_error_service1 Services.Constants.proof_of_work_threshold block () + let bootstrap cctxt block = + call_service1 cctxt Services.Constants.bootstrap block () + let errors cctxt block = + call_service1 cctxt Services.Constants.errors block () + let cycle_length cctxt block = + call_error_service1 cctxt Services.Constants.cycle_length block () + let voting_period_length cctxt block = + call_error_service1 cctxt Services.Constants.voting_period_length block () + let time_before_reward cctxt block = + call_error_service1 cctxt Services.Constants.time_before_reward block () + let time_between_slots cctxt block = + call_error_service1 cctxt Services.Constants.time_between_slots block () + let first_free_mining_slot cctxt block = + call_error_service1 cctxt Services.Constants.first_free_mining_slot block () + let max_signing_slot cctxt block = + call_error_service1 cctxt Services.Constants.max_signing_slot block () + let instructions_per_transaction cctxt block = + call_error_service1 cctxt Services.Constants.instructions_per_transaction block () + let stamp_threshold cctxt block = + call_error_service1 cctxt Services.Constants.proof_of_work_threshold block () end module Context = struct - let level block = call_error_service1 Services.Context.level block () - let next_level block = call_error_service1 Services.Context.next_level block () + let level cctxt block = + call_error_service1 cctxt Services.Context.level block () + let next_level cctxt block = + call_error_service1 cctxt Services.Context.next_level block () module Nonce = struct @@ -68,27 +72,27 @@ module Context = struct | Missing of Nonce_hash.t | Forgotten - let get block level = - call_error_service2 Services.Context.Nonce.get block level () + let get cctxt block level = + call_error_service2 cctxt Services.Context.Nonce.get block level () - let hash block = - call_error_service1 Services.Context.Nonce.hash block () + let hash cctxt block = + call_error_service1 cctxt Services.Context.Nonce.hash block () end module Key = struct - let get block pk_h = - call_error_service2 Services.Context.Key.get block pk_h () + let get cctxt block pk_h = + call_error_service2 cctxt Services.Context.Key.get block pk_h () - let list block = - call_error_service1 Services.Context.Key.list block () + let list cctxt block = + call_error_service1 cctxt Services.Context.Key.list block () end module Contract = struct - let list b = - call_error_service1 Services.Context.Contract.list b () + let list cctxt b = + call_error_service1 cctxt Services.Context.Contract.list b () type info = Services.Context.Contract.info = { manager: public_key_hash ; balance: Tez.t ; @@ -98,64 +102,68 @@ module Context = struct assets: Asset.Map.t ; counter: int32 ; } - let get b c = - call_error_service2 Services.Context.Contract.get b c () - let balance b c = - call_error_service2 Services.Context.Contract.balance b c () - let manager b c = - call_error_service2 Services.Context.Contract.manager b c () - let delegate b c = - call_error_service2 Services.Context.Contract.delegate b c () - let counter b c = - call_error_service2 Services.Context.Contract.counter b c () - let spendable b c = - call_error_service2 Services.Context.Contract.spendable b c () - let delegatable b c = - call_error_service2 Services.Context.Contract.delegatable b c () - let script b c = - call_error_service2 Services.Context.Contract.script b c () - let assets b c = - call_error_service2 Services.Context.Contract.assets b c () + let get cctxt b c = + call_error_service2 cctxt Services.Context.Contract.get b c () + let balance cctxt b c = + call_error_service2 cctxt Services.Context.Contract.balance b c () + let manager cctxt b c = + call_error_service2 cctxt Services.Context.Contract.manager b c () + let delegate cctxt b c = + call_error_service2 cctxt Services.Context.Contract.delegate b c () + let counter cctxt b c = + call_error_service2 cctxt Services.Context.Contract.counter b c () + let spendable cctxt b c = + call_error_service2 cctxt Services.Context.Contract.spendable b c () + let delegatable cctxt b c = + call_error_service2 cctxt Services.Context.Contract.delegatable b c () + let script cctxt b c = + call_error_service2 cctxt Services.Context.Contract.script b c () + let assets cctxt b c = + call_error_service2 cctxt Services.Context.Contract.assets b c () end end module Helpers = struct - let minimal_time block ?prio () = - call_error_service1 Services.Helpers.minimal_timestamp block prio + let minimal_time cctxt block ?prio () = + call_error_service1 cctxt Services.Helpers.minimal_timestamp block prio - let typecheck_code = call_error_service1 Services.Helpers.typecheck_code + let typecheck_code cctxt = + call_error_service1 cctxt Services.Helpers.typecheck_code - let run_code block code (storage, input) = - call_error_service1 Services.Helpers.run_code + let run_code cctxt block code (storage, input) = + call_error_service1 cctxt Services.Helpers.run_code block (code, storage, input, None, None) - let trace_code block code (storage, input) = - call_error_service1 Services.Helpers.trace_code + let trace_code cctxt block code (storage, input) = + call_error_service1 cctxt Services.Helpers.trace_code block (code, storage, input, None, None) - let typecheck_tagged_data = call_error_service1 Services.Helpers.typecheck_tagged_data + let typecheck_tagged_data cctxt = + call_error_service1 cctxt Services.Helpers.typecheck_tagged_data - let typecheck_untagged_data = call_error_service1 Services.Helpers.typecheck_untagged_data + let typecheck_untagged_data cctxt = + call_error_service1 cctxt Services.Helpers.typecheck_untagged_data - let hash_data = call_error_service1 Services.Helpers.hash_data + let hash_data cctxt = + call_error_service1 cctxt Services.Helpers.hash_data - let level block ?offset lvl = - call_error_service2 Services.Helpers.level block lvl offset + let level cctxt block ?offset lvl = + call_error_service2 cctxt Services.Helpers.level block lvl offset - let levels block cycle = - call_error_service2 Services.Helpers.levels block cycle () + let levels cctxt block cycle = + call_error_service2 cctxt Services.Helpers.levels block cycle () module Rights = struct type slot = Raw_level.t * int * Time.t option - let mining_rights_for_delegate + let mining_rights_for_delegate cctxt b c ?max_priority ?first_level ?last_level () = - call_error_service2 Services.Helpers.Rights.mining_rights_for_delegate + call_error_service2 cctxt Services.Helpers.Rights.mining_rights_for_delegate b c (max_priority, first_level, last_level) - let endorsement_rights_for_delegate + let endorsement_rights_for_delegate cctxt b c ?max_priority ?first_level ?last_level () = - call_error_service2 Services.Helpers.Rights.endorsement_rights_for_delegate + call_error_service2 cctxt Services.Helpers.Rights.endorsement_rights_for_delegate b c (max_priority, first_level, last_level) end @@ -168,24 +176,24 @@ module Helpers = struct open Operation module Manager = struct - let operations + let operations cctxt block ~net ~source ?sourcePubKey ~counter ~fee operations = let ops = Manager_operations { source ; public_key = sourcePubKey ; counter ; operations ; fee } in - (call_error_service1 Services.Helpers.Forge.operations block + (call_error_service1 cctxt Services.Helpers.Forge.operations block ({net_id=net}, Sourced_operations ops)) >>=? fun (bytes, contracts) -> return (bytes, match contracts with None -> [] | Some l -> l) - let transaction + let transaction cctxt block ~net ~source ?sourcePubKey ~counter ~amount ~destination ?parameters ~fee ()= - operations block ~net ~source ?sourcePubKey ~counter ~fee + operations cctxt block ~net ~source ?sourcePubKey ~counter ~fee Tezos_context.[Transaction { amount ; parameters ; destination }] >>=? fun (bytes, contracts) -> assert (contracts = []) ; return bytes - let origination + let origination cctxt block ~net ~source ?sourcePubKey ~counter ~managerPubKey ~balance @@ -193,7 +201,7 @@ module Helpers = struct ?(delegatable = true) ?delegatePubKey ?script ~fee () = let script = script_of_option script in - operations block ~net ~source ?sourcePubKey ~counter ~fee + operations cctxt block ~net ~source ?sourcePubKey ~counter ~fee Tezos_context.[ Origination { manager = managerPubKey ; delegate = delegatePubKey ; @@ -206,54 +214,56 @@ module Helpers = struct match contracts with | [contract] -> return (contract, bytes) | _ -> assert false - let issuance + let issuance cctxt block ~net ~source ?sourcePubKey ~counter ~assetType ~quantity ~fee ()= - operations block ~net ~source ?sourcePubKey ~counter ~fee + operations cctxt block ~net ~source ?sourcePubKey ~counter ~fee Tezos_context.[Issuance { asset = assetType ; amount = quantity }] >>=? fun (bytes, contracts) -> assert (contracts = []) ; return bytes - let delegation + let delegation cctxt block ~net ~source ?sourcePubKey ~counter ~fee delegate = - operations block ~net ~source ?sourcePubKey ~counter ~fee + operations cctxt block ~net ~source ?sourcePubKey ~counter ~fee Tezos_context.[Delegation delegate] >>=? fun (bytes, contracts) -> assert (contracts = []) ; return bytes end module Delegate = struct - let operations + let operations cctxt block ~net ~source operations = let ops = Delegate_operations { source ; operations } in - (call_error_service1 Services.Helpers.Forge.operations block + (call_error_service1 cctxt Services.Helpers.Forge.operations block ({net_id=net}, Sourced_operations ops)) >>=? fun (hash, _contracts) -> return hash - let endorsement b ~net ~source ~block ~slot () = - operations b ~net ~source + let endorsement cctxt + b ~net ~source ~block ~slot () = + operations cctxt b ~net ~source Tezos_context.[Endorsement { block ; slot }] end module Anonymous = struct - let operations block ~net operations = - (call_error_service1 Services.Helpers.Forge.operations block + let operations cctxt block ~net operations = + (call_error_service1 cctxt Services.Helpers.Forge.operations block ({net_id=net}, Anonymous_operations operations)) >>=? fun (hash, _contracts) -> return hash - let seed_nonce_revelation + let seed_nonce_revelation cctxt block ~net ~level ~nonce () = - operations block ~net [Seed_nonce_revelation { level ; nonce }] + operations cctxt block ~net [Seed_nonce_revelation { level ; nonce }] end - let block + let block cctxt block ~net ~predecessor ~timestamp ~fitness ~operations ~level ~priority ~seed_nonce_hash ~proof_of_work_nonce () = - call_error_service1 Services.Helpers.Forge.block block + call_error_service1 cctxt Services.Helpers.Forge.block block (net, predecessor, timestamp, fitness, operations, level, priority, seed_nonce_hash, proof_of_work_nonce) end module Parse = struct - let operations block ?check shell bytes = - call_error_service1 Services.Helpers.Parse.operations block (shell, bytes, check) + let operations cctxt + block ?check shell bytes = + call_error_service1 cctxt Services.Helpers.Parse.operations block (shell, bytes, check) end end diff --git a/src/client/embedded/bootstrap/client_proto_rpcs.mli b/src/client/embedded/bootstrap/client_proto_rpcs.mli index 1580065e3..373919206 100644 --- a/src/client/embedded/bootstrap/client_proto_rpcs.mli +++ b/src/client/embedded/bootstrap/client_proto_rpcs.mli @@ -8,7 +8,7 @@ (**************************************************************************) val string_of_errors: error list -> string -val handle_error: 'a tzresult -> 'a Lwt.t +val handle_error: Client_commands.context -> 'a tzresult -> 'a Lwt.t type net = State.net_id = Net of Block_hash.t @@ -20,39 +20,71 @@ type block = [ ] module Constants : sig - val errors: block -> Json_schema.schema Lwt.t - val bootstrap: block -> Bootstrap.account list Lwt.t - val cycle_length: block -> int32 tzresult Lwt.t - val voting_period_length: block -> int32 tzresult Lwt.t - val time_before_reward: block -> Period.t tzresult Lwt.t - val time_between_slots: block -> Period.t tzresult Lwt.t - val first_free_mining_slot: block -> int32 tzresult Lwt.t - val max_signing_slot: block -> int tzresult Lwt.t - val instructions_per_transaction: block -> int tzresult Lwt.t - val stamp_threshold: block -> int64 tzresult Lwt.t + val errors: + Client_commands.context -> + block -> Json_schema.schema Lwt.t + val bootstrap: + Client_commands.context -> + block -> Bootstrap.account list Lwt.t + val cycle_length: + Client_commands.context -> + block -> int32 tzresult Lwt.t + val voting_period_length: + Client_commands.context -> + block -> int32 tzresult Lwt.t + val time_before_reward: + Client_commands.context -> + block -> Period.t tzresult Lwt.t + val time_between_slots: + Client_commands.context -> + block -> Period.t tzresult Lwt.t + val first_free_mining_slot: + Client_commands.context -> + block -> int32 tzresult Lwt.t + val max_signing_slot: + Client_commands.context -> + block -> int tzresult Lwt.t + val instructions_per_transaction: + Client_commands.context -> + block -> int tzresult Lwt.t + val stamp_threshold: + Client_commands.context -> + block -> int64 tzresult Lwt.t end module Context : sig - val level: block -> Level.t tzresult Lwt.t - val next_level: block -> Level.t tzresult Lwt.t + val level: + Client_commands.context -> + block -> Level.t tzresult Lwt.t + val next_level: + Client_commands.context -> + block -> Level.t tzresult Lwt.t module Nonce : sig - val hash: block -> Nonce_hash.t tzresult Lwt.t + val hash: + Client_commands.context -> + block -> Nonce_hash.t tzresult Lwt.t type nonce_info = | Revealed of Nonce.t | Missing of Nonce_hash.t | Forgotten - val get: block -> Raw_level.t -> nonce_info tzresult Lwt.t + val get: + Client_commands.context -> + block -> Raw_level.t -> nonce_info tzresult Lwt.t end module Key : sig val get : + Client_commands.context -> block -> public_key_hash -> (public_key_hash * public_key) tzresult Lwt.t val list : + Client_commands.context -> block -> ((public_key_hash * public_key) list) tzresult Lwt.t end module Contract : sig - val list: block -> Contract.t list tzresult Lwt.t + val list: + Client_commands.context -> + block -> Contract.t list tzresult Lwt.t type info = { manager: public_key_hash ; balance: Tez.t ; @@ -62,28 +94,38 @@ module Context : sig assets: Asset.Map.t ; counter: int32 ; } - val get: block -> Contract.t -> info tzresult Lwt.t + val get: + Client_commands.context -> + block -> Contract.t -> info tzresult Lwt.t val balance: + Client_commands.context -> block -> Contract.t -> Tez.t tzresult Lwt.t val manager: + Client_commands.context -> block -> Contract.t -> public_key_hash tzresult Lwt.t val delegate: + Client_commands.context -> block -> Contract.t -> public_key_hash option tzresult Lwt.t val counter: + Client_commands.context -> block -> Contract.t -> int32 tzresult Lwt.t val spendable: + Client_commands.context -> block -> Contract.t -> bool tzresult Lwt.t val delegatable: + Client_commands.context -> block -> Contract.t -> bool tzresult Lwt.t val script: + Client_commands.context -> block -> Contract.t -> Script.t tzresult Lwt.t val assets: + Client_commands.context -> block -> Contract.t -> Asset.Map.t tzresult Lwt.t end @@ -91,29 +133,48 @@ end module Helpers : sig val minimal_time: + Client_commands.context -> block -> ?prio:int -> unit -> Time.t tzresult Lwt.t - val run_code: block -> Script.code -> + val run_code: + Client_commands.context -> + block -> Script.code -> (Script.expr * Script.expr) -> (Script.expr * Script.expr) tzresult Lwt.t - val trace_code: block -> Script.code -> + val trace_code: + Client_commands.context -> + block -> Script.code -> (Script.expr * Script.expr) -> (Script.expr * Script.expr * (Script.location * int * Script.expr list) list) tzresult Lwt.t - val typecheck_code: block -> Script.code -> Script_ir_translator.type_map tzresult Lwt.t - val typecheck_tagged_data: block -> Script.expr -> unit tzresult Lwt.t - val typecheck_untagged_data: block -> Script.expr * Script.expr -> unit tzresult Lwt.t - val hash_data: block -> Script.expr -> string tzresult Lwt.t - val level: block -> ?offset:int32 -> Raw_level.t -> Level.t tzresult Lwt.t - val levels: block -> Cycle.t -> Level.t list tzresult Lwt.t + val typecheck_code: + Client_commands.context -> + block -> Script.code -> Script_ir_translator.type_map tzresult Lwt.t + val typecheck_tagged_data: + Client_commands.context -> + block -> Script.expr -> unit tzresult Lwt.t + val typecheck_untagged_data: + Client_commands.context -> + block -> Script.expr * Script.expr -> unit tzresult Lwt.t + val hash_data: + Client_commands.context -> + block -> Script.expr -> string tzresult Lwt.t + val level: + Client_commands.context -> + block -> ?offset:int32 -> Raw_level.t -> Level.t tzresult Lwt.t + val levels: + Client_commands.context -> + block -> Cycle.t -> Level.t list tzresult Lwt.t module Rights : sig type slot = Raw_level.t * int * Time.t option val mining_rights_for_delegate: + Client_commands.context -> block -> public_key_hash -> ?max_priority:int -> ?first_level:Raw_level.t -> ?last_level:Raw_level.t -> unit -> (slot list) tzresult Lwt.t val endorsement_rights_for_delegate: + Client_commands.context -> block -> public_key_hash -> ?max_priority:int -> ?first_level:Raw_level.t -> ?last_level:Raw_level.t -> unit -> (slot list) tzresult Lwt.t @@ -122,6 +183,7 @@ module Helpers : sig module Forge : sig module Manager : sig val operations: + Client_commands.context -> block -> net:net -> source:Contract.t -> @@ -131,6 +193,7 @@ module Helpers : sig manager_operation list -> (MBytes.t * Contract.t list) tzresult Lwt.t val transaction: + Client_commands.context -> block -> net:net -> source:Contract.t -> @@ -142,6 +205,7 @@ module Helpers : sig fee:Tez.t -> unit -> MBytes.t tzresult Lwt.t val origination: + Client_commands.context -> block -> net:net -> source:Contract.t -> @@ -157,6 +221,7 @@ module Helpers : sig unit -> (Contract.t * MBytes.t) tzresult Lwt.t val issuance: + Client_commands.context -> block -> net:net -> source:Contract.t -> @@ -167,6 +232,7 @@ module Helpers : sig fee:Tez.t -> unit -> MBytes.t tzresult Lwt.t val delegation: + Client_commands.context -> block -> net:net -> source:Contract.t -> @@ -178,12 +244,14 @@ module Helpers : sig end module Delegate : sig val operations: + Client_commands.context -> block -> net:net -> source:public_key -> delegate_operation list -> MBytes.t tzresult Lwt.t val endorsement: + Client_commands.context -> block -> net:net -> source:public_key -> @@ -193,11 +261,13 @@ module Helpers : sig end module Anonymous : sig val operations: + Client_commands.context -> block -> net:net -> anonymous_operation list -> MBytes.t tzresult Lwt.t val seed_nonce_revelation: + Client_commands.context -> block -> net:net -> level:Raw_level.t -> @@ -205,6 +275,7 @@ module Helpers : sig unit -> MBytes.t tzresult Lwt.t end val block: + Client_commands.context -> block -> net:net -> predecessor:Block_hash.t -> @@ -220,6 +291,7 @@ module Helpers : sig module Parse : sig val operations: + Client_commands.context -> block -> ?check:bool -> Updater.shell_operation -> MBytes.t -> proto_operation tzresult Lwt.t end diff --git a/src/client/embedded/bootstrap/mining/client_mining_blocks.ml b/src/client/embedded/bootstrap/mining/client_mining_blocks.ml index 3abd01af6..9375f6d03 100644 --- a/src/client/embedded/bootstrap/mining/client_mining_blocks.ml +++ b/src/client/embedded/bootstrap/mining/client_mining_blocks.ml @@ -16,25 +16,25 @@ type block_info = { level: Level.t ; } -let convert_block_info +let convert_block_info cctxt ( { hash ; predecessor ; fitness ; timestamp ; protocol } : Client_node_rpcs.Blocks.block_info ) = - Client_proto_rpcs.Context.level (`Hash hash) >>= function + Client_proto_rpcs.Context.level cctxt (`Hash hash) >>= function | Ok level -> Lwt.return (Some { hash ; predecessor ; fitness ; timestamp ; protocol ; level }) | Error _ -> (* TODO log error *) Lwt.return_none -let convert_block_info_err +let convert_block_info_err cctxt ( { hash ; predecessor ; fitness ; timestamp ; protocol } : Client_node_rpcs.Blocks.block_info ) = - Client_proto_rpcs.Context.level (`Hash hash) >>=? fun level -> + Client_proto_rpcs.Context.level cctxt (`Hash hash) >>=? fun level -> return { hash ; predecessor ; fitness ; timestamp ; protocol ; level } -let info ?operations block = - Client_node_rpcs.Blocks.info ?operations block >>= fun block -> - convert_block_info_err block +let info cctxt ?operations block = + Client_node_rpcs.Blocks.info cctxt ?operations block >>= fun block -> + convert_block_info_err cctxt block let compare (bi1 : block_info) (bi2 : block_info) = match Fitness.compare bi1.fitness bi2.fitness with @@ -49,29 +49,29 @@ let compare (bi1 : block_info) (bi2 : block_info) = end | x -> x -let sort_blocks ?(compare = compare) blocks = - Lwt_list.map_p convert_block_info blocks >|= fun blocks -> +let sort_blocks cctxt ?(compare = compare) blocks = + Lwt_list.map_p (convert_block_info cctxt) blocks >|= fun blocks -> let blocks = Utils.unopt_list blocks in List.sort compare blocks -let monitor +let monitor cctxt ?operations ?length ?heads ?delay ?min_date ?min_heads ?compare () = - Client_node_rpcs.Blocks.monitor + Client_node_rpcs.Blocks.monitor cctxt ?operations ?length ?heads ?delay ?min_date ?min_heads () >>= fun block_stream -> - let convert blocks = sort_blocks ?compare (List.flatten blocks) in + let convert blocks = sort_blocks cctxt ?compare (List.flatten blocks) in Lwt.return (Lwt_stream.map_s convert block_stream) -let blocks_from_cycle block cycle = +let blocks_from_cycle cctxt block cycle = let block = match block with | `Prevalidation -> `Head 0 | `Test_prevalidation -> `Test_head 0 | _ -> block in - Client_node_rpcs.Blocks.hash block >>= fun block_hash -> - Client_proto_rpcs.Context.level block >>=? fun level -> - Client_proto_rpcs.Helpers.levels block cycle >>=? fun block_levels -> + Client_node_rpcs.Blocks.hash cctxt block >>= fun block_hash -> + Client_proto_rpcs.Context.level cctxt block >>=? fun level -> + Client_proto_rpcs.Helpers.levels cctxt block cycle >>=? fun block_levels -> begin match List.sort Level.compare block_levels with | [] -> failwith "Internal error" @@ -79,11 +79,11 @@ let blocks_from_cycle block cycle = end >>=? fun min_level -> let length = 1 + Int32.to_int (Level.diff level min_level) in begin - Client_node_rpcs.Blocks.list ~length ~heads:[block_hash] () >>= function + Client_node_rpcs.Blocks.list cctxt ~length ~heads:[block_hash] () >>= function | [] | _::_::_ -> failwith "Unexpected RPC result" | [blocks] -> return blocks end >>=? fun block_infos -> let block_infos = Utils.remove_elem_from_list (length - List.length block_levels) block_infos in - map_s convert_block_info_err block_infos >>=? fun block_res -> + map_s (convert_block_info_err cctxt) block_infos >>=? fun block_res -> return block_res diff --git a/src/client/embedded/bootstrap/mining/client_mining_blocks.mli b/src/client/embedded/bootstrap/mining/client_mining_blocks.mli index 16ab379f6..f6ff288ce 100644 --- a/src/client/embedded/bootstrap/mining/client_mining_blocks.mli +++ b/src/client/embedded/bootstrap/mining/client_mining_blocks.mli @@ -17,17 +17,21 @@ type block_info = { } val info: + Client_commands.context -> ?operations:bool -> Client_node_rpcs.Blocks.block -> block_info tzresult Lwt.t -val compare: block_info -> block_info -> int +val compare: + block_info -> block_info -> int val monitor: + Client_commands.context -> ?operations:bool -> ?length:int -> ?heads:Block_hash.t list -> ?delay:int -> ?min_date:Time.t -> ?min_heads:int -> ?compare:(block_info -> block_info -> int) -> unit -> block_info list Lwt_stream.t Lwt.t val blocks_from_cycle: + Client_commands.context -> Client_node_rpcs.Blocks.block -> Cycle.t -> block_info list tzresult Lwt.t diff --git a/src/client/embedded/bootstrap/mining/client_mining_daemon.ml b/src/client/embedded/bootstrap/mining/client_mining_daemon.ml index 868cb8318..e352bb003 100644 --- a/src/client/embedded/bootstrap/mining/client_mining_daemon.ml +++ b/src/client/embedded/bootstrap/mining/client_mining_daemon.ml @@ -9,27 +9,27 @@ open Logging.Client.Mining -let run ?max_priority ~delay ?min_date delegates = +let run cctxt ?max_priority ~delay ?min_date delegates = (* TODO really detach... *) let endorsement = if Client_proto_args.Daemon.(!all || !endorsement) then - Client_mining_blocks.monitor ?min_date () >>= fun block_stream -> - Client_mining_endorsement.create ~delay delegates block_stream + Client_mining_blocks.monitor cctxt ?min_date () >>= fun block_stream -> + Client_mining_endorsement.create cctxt ~delay delegates block_stream else Lwt.return_unit in let denunciation = if Client_proto_args.Daemon.(!all || !denunciation) then - Client_mining_operations.monitor_endorsement () >>= fun endorsement_stream -> - Client_mining_denunciation.create endorsement_stream + Client_mining_operations.monitor_endorsement cctxt >>= fun endorsement_stream -> + Client_mining_denunciation.create cctxt endorsement_stream else Lwt.return_unit in let forge = - Client_mining_blocks.monitor ?min_date () >>= fun block_stream -> - Client_mining_operations.monitor_endorsement () >>= fun endorsement_stream -> + Client_mining_blocks.monitor cctxt ?min_date () >>= fun block_stream -> + Client_mining_operations.monitor_endorsement cctxt >>= fun endorsement_stream -> if Client_proto_args.Daemon.(!all || !mining) then - Client_mining_forge.create + Client_mining_forge.create cctxt ?max_priority delegates block_stream endorsement_stream else Lwt.return_unit diff --git a/src/client/embedded/bootstrap/mining/client_mining_daemon.mli b/src/client/embedded/bootstrap/mining/client_mining_daemon.mli index a13d9465c..360bfd41b 100644 --- a/src/client/embedded/bootstrap/mining/client_mining_daemon.mli +++ b/src/client/embedded/bootstrap/mining/client_mining_daemon.mli @@ -8,6 +8,7 @@ (**************************************************************************) val run: + Client_commands.context -> ?max_priority: int -> delay: int -> ?min_date: Time.t -> diff --git a/src/client/embedded/bootstrap/mining/client_mining_denunciation.ml b/src/client/embedded/bootstrap/mining/client_mining_denunciation.ml index c2fbb8f38..2d1aa6a2b 100644 --- a/src/client/embedded/bootstrap/mining/client_mining_denunciation.ml +++ b/src/client/embedded/bootstrap/mining/client_mining_denunciation.ml @@ -9,7 +9,7 @@ open Logging.Client.Denunciation -let create endorsement_stream = +let create cctxt endorsement_stream = let last_get_endorsement = ref None in let get_endorsement () = match !last_get_endorsement with @@ -28,7 +28,7 @@ let create endorsement_stream = Lwt.return_unit | `Endorsement (Some e) -> last_get_endorsement := None ; - Client_keys.Public_key_hash.name + Client_keys.Public_key_hash.name cctxt e.Client_mining_operations.source >>= fun source -> lwt_debug "Discovered endorsement for block %a by %s (slot @[%a@])" diff --git a/src/client/embedded/bootstrap/mining/client_mining_denunciation.mli b/src/client/embedded/bootstrap/mining/client_mining_denunciation.mli index bd7ee8932..20cd8eec1 100644 --- a/src/client/embedded/bootstrap/mining/client_mining_denunciation.mli +++ b/src/client/embedded/bootstrap/mining/client_mining_denunciation.mli @@ -8,5 +8,6 @@ (**************************************************************************) val create: + Client_commands.context -> Client_mining_operations.valid_endorsement Lwt_stream.t -> unit Lwt.t diff --git a/src/client/embedded/bootstrap/mining/client_mining_endorsement.ml b/src/client/embedded/bootstrap/mining/client_mining_endorsement.ml index 425967e60..0d268a2c4 100644 --- a/src/client/embedded/bootstrap/mining/client_mining_endorsement.ml +++ b/src/client/embedded/bootstrap/mining/client_mining_endorsement.ml @@ -15,11 +15,13 @@ module Ed25519 = Environment.Ed25519 module State : sig val get_endorsement: + Client_commands.context -> Raw_level.t -> int -> (Block_hash.t * Operation_hash.t) option tzresult Lwt.t val record_endorsement: + Client_commands.context -> Raw_level.t -> Block_hash.t -> int -> Operation_hash.t -> unit tzresult Lwt.t @@ -45,20 +47,20 @@ end = struct let filename () = Client_config.(base_dir#get // "endorsements") - let load () = + let load cctxt = let filename = filename () in if not (Sys.file_exists filename) then return LevelMap.empty else Data_encoding_ezjsonm.read_file filename >>= function | None -> - error "couldn't to read the endorsement file" + cctxt.Client_commands.error "couldn't to read the endorsement file" | Some json -> match Data_encoding.Json.destruct encoding json with | exception _ -> (* TODO print_error *) - error "didn't understand the endorsement file" + cctxt.Client_commands.error "didn't understand the endorsement file" | map -> return map - let save map = + let save cctxt map = Lwt.catch (fun () -> let dirname = Client_config.base_dir#get in @@ -70,15 +72,15 @@ end = struct | false -> failwith "Json.write_file" | true -> return ()) (fun exn -> - error "could not write the endorsement file: %s." + cctxt.Client_commands.error "could not write the endorsement file: %s." (Printexc.to_string exn)) let lock = Lwt_mutex.create () - let get_endorsement level slot = + let get_endorsement cctxt level slot = Lwt_mutex.with_lock lock (fun () -> - load () >>=? fun map -> + load cctxt >>=? fun map -> try let _, block, op = LevelMap.find level map @@ -86,27 +88,27 @@ end = struct return (Some (block, op)) with Not_found -> return None) - let record_endorsement level hash slot oph = + let record_endorsement cctxt level hash slot oph = Lwt_mutex.with_lock lock (fun () -> - load () >>=? fun map -> + load cctxt >>=? fun map -> let previous = try LevelMap.find level map with Not_found -> [] in - save + save cctxt (LevelMap.add level ((slot, hash, oph) :: previous) map)) end -let get_block_hash = function +let get_block_hash cctxt = function | `Hash hash -> Lwt.return hash | `Genesis | `Head _ | `Test_head _ as block -> - Client_node_rpcs.Blocks.hash block - | `Prevalidation -> Client_node_rpcs.Blocks.hash (`Head 0) - | `Test_prevalidation -> Client_node_rpcs.Blocks.hash (`Test_head 0) + Client_node_rpcs.Blocks.hash cctxt block + | `Prevalidation -> Client_node_rpcs.Blocks.hash cctxt (`Head 0) + | `Test_prevalidation -> Client_node_rpcs.Blocks.hash cctxt (`Test_head 0) -let get_signing_slots ?max_priority block delegate level = - Client_proto_rpcs.Helpers.Rights.endorsement_rights_for_delegate +let get_signing_slots cctxt ?max_priority block delegate level = + Client_proto_rpcs.Helpers.Rights.endorsement_rights_for_delegate cctxt ?max_priority ~first_level:level ~last_level:level block delegate () >>=? fun possibilities -> let slots = @@ -114,12 +116,12 @@ let get_signing_slots ?max_priority block delegate level = @@ List.filter (fun (l, _, _) -> l = level) possibilities in return slots -let inject_endorsement +let inject_endorsement cctxt block level ?wait ?force src_sk source slot = - get_block_hash block >>= fun block_hash -> - Client_node_rpcs.Blocks.net block >>= fun net -> - Client_proto_rpcs.Helpers.Forge.Delegate.endorsement + get_block_hash cctxt block >>= fun block_hash -> + Client_node_rpcs.Blocks.net cctxt block >>= fun net -> + Client_proto_rpcs.Helpers.Forge.Delegate.endorsement cctxt block ~net ~source @@ -127,41 +129,41 @@ let inject_endorsement ~slot:slot () >>=? fun bytes -> let signed_bytes = Ed25519.append_signature src_sk bytes in - Client_node_rpcs.inject_operation ?force ?wait signed_bytes >>=? fun oph -> - State.record_endorsement level block_hash slot oph >>=? fun () -> + Client_node_rpcs.inject_operation cctxt ?force ?wait signed_bytes >>=? fun oph -> + State.record_endorsement cctxt level block_hash slot oph >>=? fun () -> return oph -let previously_endorsed_slot level slot = - State.get_endorsement level slot >>=? function +let previously_endorsed_slot cctxt level slot = + State.get_endorsement cctxt level slot >>=? function | None -> return false | Some _ -> return true -let check_endorsement level slot = - State.get_endorsement level slot >>=? function +let check_endorsement cctxt level slot = + State.get_endorsement cctxt level slot >>=? function | None -> return () | Some (block, _) -> - failwith + Error_monad.failwith "Already signed block %a at level %a, slot %d" Block_hash.pp_short block Raw_level.pp level slot -let forge_endorsement +let forge_endorsement cctxt block ?(force = false) ~src_sk ?slot ?max_priority src_pk = let src_pkh = Ed25519.hash src_pk in - Client_proto_rpcs.Context.next_level block >>=? fun level -> + Client_proto_rpcs.Context.next_level cctxt block >>=? fun level -> let level = Raw_level.succ @@ level.level in begin match slot with | Some slot -> return slot | None -> - get_signing_slots ?max_priority block src_pkh level >>=? function + get_signing_slots cctxt ?max_priority block src_pkh level >>=? function | slot::_ -> return slot - | [] -> error "No slot found at level %a" Raw_level.pp level + | [] -> cctxt.error "No slot found at level %a" Raw_level.pp level end >>=? fun slot -> - (if force then return () else check_endorsement level slot) >>=? fun () -> - inject_endorsement + (if force then return () else check_endorsement cctxt level slot) >>=? fun () -> + inject_endorsement cctxt block level ~wait:true ~force src_sk src_pk slot @@ -194,19 +196,19 @@ let rec insert ({time} as e) = function e :: l | e' :: l -> e' :: insert e l -let schedule_endorsements state bis = +let schedule_endorsements cctxt state bis = let may_endorse (block: Client_mining_blocks.block_info) delegate time = - Client_keys.Public_key_hash.name delegate >>= fun name -> + Client_keys.Public_key_hash.name cctxt delegate >>= fun name -> lwt_log_info "May endorse block %a for %s" Block_hash.pp_short block.hash name >>= fun () -> let b = `Hash block.hash in let level = Raw_level.succ block.level.level in - get_signing_slots b delegate level >>=? fun slots -> + get_signing_slots cctxt b delegate level >>=? fun slots -> lwt_debug "Found slots for %a/%s (%d)" Block_hash.pp_short block.hash name (List.length slots) >>= fun () -> iter_p (fun slot -> - previously_endorsed_slot level slot >>=? function + previously_endorsed_slot cctxt level slot >>=? function | true -> lwt_debug "slot %d: previously endorsed." slot >>= fun () -> return () @@ -270,23 +272,23 @@ let pop_endorsements state = state.to_endorse <- future_endorsement ; to_endorse -let endorse state = +let endorse cctxt state = let to_endorse = pop_endorsements state in iter_p (fun {delegate;block;slot} -> let hash = block.hash in let b = `Hash hash in let level = Raw_level.succ block.level.level in - previously_endorsed_slot level slot >>=? function + previously_endorsed_slot cctxt level slot >>=? function | true -> return () | false -> - Client_keys.get_key delegate >>=? fun (name, pk, sk) -> + Client_keys.get_key cctxt delegate >>=? fun (name, pk, sk) -> lwt_debug "Endorsing %a for %s (slot %d)!" Block_hash.pp_short hash name slot >>= fun () -> - inject_endorsement + inject_endorsement cctxt b level ~wait:false ~force:true sk pk slot >>=? fun oph -> - message + cctxt.message "Injected endorsement for block '%a' \ \ (level %a, slot %d, contract %s) '%a'" Block_hash.pp_short hash @@ -306,11 +308,11 @@ let compute_timeout state = else Lwt_unix.sleep (Int64.to_float delay) -let create ~delay contracts block_stream = +let create cctxt ~delay contracts block_stream = lwt_log_info "Starting endorsement daemon" >>= fun () -> Lwt_stream.get block_stream >>= function | None | Some [] -> - error "Can't fetch the current block head." + cctxt.Client_commands.error "Can't fetch the current block head." | Some ({ Client_mining_blocks.fitness } :: _ as initial_heads) -> let last_get_block = ref None in let get_block () = @@ -330,11 +332,11 @@ let create ~delay contracts block_stream = | `Hash (Some bis) -> Lwt.cancel timeout ; last_get_block := None ; - schedule_endorsements state bis >>= fun () -> + schedule_endorsements cctxt state bis >>= fun () -> worker_loop () | `Timeout -> begin - endorse state >>= function + endorse cctxt state >>= function | Ok () -> Lwt.return_unit | Error errs -> lwt_log_error "Error while endorsing:\n%a" @@ -343,5 +345,5 @@ let create ~delay contracts block_stream = Lwt.return_unit end >>= fun () -> worker_loop () in - schedule_endorsements state initial_heads >>= fun () -> + schedule_endorsements cctxt state initial_heads >>= fun () -> worker_loop () diff --git a/src/client/embedded/bootstrap/mining/client_mining_endorsement.mli b/src/client/embedded/bootstrap/mining/client_mining_endorsement.mli index afb6a33df..2ddc1fcc3 100644 --- a/src/client/embedded/bootstrap/mining/client_mining_endorsement.mli +++ b/src/client/embedded/bootstrap/mining/client_mining_endorsement.mli @@ -8,6 +8,7 @@ (**************************************************************************) val forge_endorsement: + Client_commands.context -> Client_proto_rpcs.block -> ?force:bool -> src_sk:secret_key -> @@ -17,6 +18,7 @@ val forge_endorsement: Operation_hash.t tzresult Lwt.t val create: + Client_commands.context -> delay: int -> public_key_hash list -> Client_mining_blocks.block_info list Lwt_stream.t -> diff --git a/src/client/embedded/bootstrap/mining/client_mining_forge.ml b/src/client/embedded/bootstrap/mining/client_mining_forge.ml index 7d023ec61..68a621970 100644 --- a/src/client/embedded/bootstrap/mining/client_mining_forge.ml +++ b/src/client/embedded/bootstrap/mining/client_mining_forge.ml @@ -19,8 +19,8 @@ let generate_seed_nonce () = | Error _ -> assert false | Ok nonce -> nonce -let rec compute_stamp block delegate_sk shell mining_slot seed_nonce_hash = - Client_proto_rpcs.Constants.stamp_threshold block >>=? fun stamp_threshold -> +let rec compute_stamp cctxt block delegate_sk shell mining_slot seed_nonce_hash = + Client_proto_rpcs.Constants.stamp_threshold cctxt block >>=? fun stamp_threshold -> let rec loop () = let proof_of_work_nonce = generate_proof_of_work_nonce () in let unsigned_header = @@ -35,21 +35,21 @@ let rec compute_stamp block delegate_sk shell mining_slot seed_nonce_hash = loop () in return (loop ()) -let inject_block block +let inject_block cctxt block ?force ~priority ~timestamp ~fitness ~seed_nonce ~src_sk operations = let block = match block with `Prevalidation -> `Head 0 | block -> block in - Client_node_rpcs.Blocks.info block >>= fun bi -> + Client_node_rpcs.Blocks.info cctxt block >>= fun bi -> let seed_nonce_hash = Nonce.hash seed_nonce in - Client_proto_rpcs.Context.next_level block >>=? fun level -> + Client_proto_rpcs.Context.next_level cctxt block >>=? fun level -> let shell = { Store.net_id = bi.net ; predecessor = bi.hash ; timestamp ; fitness ; operations } in let slot = level.level, Int32.of_int priority in - compute_stamp block + compute_stamp cctxt block src_sk shell slot seed_nonce_hash >>=? fun proof_of_work_nonce -> - Client_proto_rpcs.Helpers.Forge.block + Client_proto_rpcs.Helpers.Forge.block cctxt block ~net:bi.net ~predecessor:bi.hash @@ -62,11 +62,11 @@ let inject_block block ~proof_of_work_nonce () >>=? fun unsigned_header -> let signed_header = Ed25519.append_signature src_sk unsigned_header in - Client_node_rpcs.inject_block + Client_node_rpcs.inject_block cctxt ~wait:true ?force signed_header >>=? fun block_hash -> return block_hash -let forge_block block +let forge_block cctxt block ?force ?operations ?(best_effort = operations = None) ?(sort = best_effort) ?timestamp ?max_priority ?priority @@ -76,12 +76,12 @@ let forge_block block | `Prevalidation -> `Head 0 | `Test_prevalidation -> `Test_head 0 | block -> block in - Client_proto_rpcs.Context.level block >>=? fun level -> + Client_proto_rpcs.Context.level cctxt block >>=? fun level -> let level = Raw_level.succ level.level in begin match operations with | None -> - Client_node_rpcs.Blocks.pending_operations block >|= fun (ops, pendings) -> + Client_node_rpcs.Blocks.pending_operations cctxt block >|= fun (ops, pendings) -> Operation_hash_set.elements @@ Operation_hash_set.union (Updater.operations ops) pendings | Some operations -> Lwt.return operations @@ -89,11 +89,11 @@ let forge_block block begin match priority with | Some prio -> begin - Client_proto_rpcs.Helpers.minimal_time block ~prio () >>=? fun time -> + Client_proto_rpcs.Helpers.minimal_time cctxt block ~prio () >>=? fun time -> return (prio, Some time) end | None -> - Client_proto_rpcs.Helpers.Rights.mining_rights_for_delegate + Client_proto_rpcs.Helpers.Rights.mining_rights_for_delegate cctxt ?max_priority ~first_level:level ~last_level:level @@ -103,7 +103,7 @@ let forge_block block List.find (fun (l,_,_) -> l = level) possibilities in return (prio, time) with Not_found -> - failwith "No slot found at level %a" Raw_level.pp level + Error_monad.failwith "No slot found at level %a" Raw_level.pp level end >>=? fun (priority, minimal_timestamp) -> lwt_log_info "Mining block at level %a prio %d" Raw_level.pp level priority >>= fun () -> @@ -113,7 +113,7 @@ let forge_block block | None, timestamp | timestamp, None -> return timestamp | Some timestamp, Some minimal_timestamp -> if timestamp < minimal_timestamp then - failwith + Error_monad.failwith "Proposed timestamp %a is earlier than minimal timestamp %a" Time.pp_hum timestamp Time.pp_hum minimal_timestamp @@ -121,7 +121,7 @@ let forge_block block return (Some timestamp) end >>=? fun timestamp -> let request = List.length operations in - Client_node_rpcs.Blocks.preapply block ?timestamp ~sort operations >>=? + Client_node_rpcs.Blocks.preapply cctxt block ?timestamp ~sort operations >>=? fun { operations ; fitness ; timestamp } -> let valid = List.length operations.applied in lwt_log_info "Found %d valid operations (%d refused) for timestamp %a" @@ -132,7 +132,7 @@ let forge_block block || ( Operation_hash_map.is_empty operations.refused && Operation_hash_map.is_empty operations.branch_refused && Operation_hash_map.is_empty operations.branch_delayed ) then - inject_block ?force ~src_sk + inject_block cctxt ?force ~src_sk ~priority ~timestamp ~fitness ~seed_nonce block operations.applied else failwith "Cannot (fully) validate the given operations." @@ -143,9 +143,11 @@ let forge_block block module State : sig val get_block: + Client_commands.context -> Raw_level.t -> Block_hash.t list tzresult Lwt.t val record_block: + Client_commands.context -> Raw_level.t -> Block_hash.t -> Nonce.t -> unit tzresult Lwt.t end = struct @@ -190,13 +192,13 @@ end = struct | false -> failwith "Json.write_file" | true -> return ()) (fun exn -> - failwith + Error_monad.failwith "could not write the block file: %s." (Printexc.to_string exn)) let lock = Lwt_mutex.create () - let get_block level = + let get_block cctxt level = Lwt_mutex.with_lock lock (fun () -> load () >>=? fun map -> @@ -205,7 +207,7 @@ end = struct return blocks with Not_found -> return []) - let record_block level hash nonce = + let record_block cctxt level hash nonce = Lwt_mutex.with_lock lock (fun () -> load () >>=? fun map -> @@ -214,17 +216,17 @@ end = struct with Not_found -> [] in save (LevelMap.add level (hash :: previous) map)) >>=? fun () -> - Client_proto_nonces.add hash nonce + Client_proto_nonces.add cctxt hash nonce end -let get_mining_slot +let get_mining_slot cctxt ?max_priority (bi: Client_mining_blocks.block_info) delegates = let block = `Hash bi.hash in let level = Raw_level.succ bi.level.level in Lwt_list.filter_map_p (fun delegate -> - Client_proto_rpcs.Helpers.Rights.mining_rights_for_delegate + Client_proto_rpcs.Helpers.Rights.mining_rights_for_delegate cctxt ?max_priority ~first_level:level ~last_level:level @@ -278,16 +280,16 @@ let compute_timeout { future_slots } = else Lwt_unix.sleep (Int64.to_float delay) -let insert_block ?max_priority state (bi: Client_mining_blocks.block_info) = +let insert_block cctxt ?max_priority state (bi: Client_mining_blocks.block_info) = if Fitness.compare state.best_fitness bi.fitness < 0 then state.best_fitness <- bi.fitness ; - get_mining_slot ?max_priority bi state.delegates >>= function + get_mining_slot cctxt ?max_priority bi state.delegates >>= function | None -> lwt_debug "Can't compute slot for %a" Block_hash.pp_short bi.hash >>= fun () -> Lwt.return_unit | Some ((timestamp, (_,_,delegate)) as slot) -> - Client_keys.Public_key_hash.name delegate >>= fun name -> + Client_keys.Public_key_hash.name cctxt delegate >>= fun name -> lwt_log_info "New mining slot at %a for %s after %a" Time.pp_hum timestamp name @@ -306,10 +308,10 @@ let pop_mining_slots state = state.future_slots <- future_slots ; slots -let insert_blocks ?max_priority state bis = - Lwt_list.iter_s (insert_block ?max_priority state) bis +let insert_blocks cctxt ?max_priority state bis = + Lwt_list.iter_s (insert_block cctxt ?max_priority state) bis -let mine state = +let mine cctxt state = let slots = pop_mining_slots state in Lwt_list.map_p (fun (timestamp, (bi, prio, delegate)) -> @@ -319,17 +321,17 @@ let mine state = Time.now () else timestamp in - Client_keys.Public_key_hash.name delegate >>= fun name -> + Client_keys.Public_key_hash.name cctxt delegate >>= fun name -> lwt_debug "Try mining after %a (slot %d) for %s (%a)" Block_hash.pp_short bi.hash prio name Time.pp_hum timestamp >>= fun () -> - Client_node_rpcs.Blocks.pending_operations + Client_node_rpcs.Blocks.pending_operations cctxt block >>= fun (res, ops) -> let operations = let open Operation_hash_set in elements (union ops (Updater.operations res)) in let request = List.length operations in - Client_node_rpcs.Blocks.preapply block + Client_node_rpcs.Blocks.preapply cctxt block ~timestamp ~sort:true operations >>= function | Error errs -> lwt_log_error "Error while prevalidating operations:\n%a" @@ -359,14 +361,14 @@ let mine state = Block_hash.pp_short bi.hash priority Fitness.pp fitness >>= fun () -> let seed_nonce = generate_seed_nonce () in - Client_keys.get_key delegate >>=? fun (_,_,src_sk) -> - inject_block ~force:true ~src_sk ~priority ~timestamp ~fitness ~seed_nonce + Client_keys.get_key cctxt delegate >>=? fun (_,_,src_sk) -> + inject_block cctxt ~force:true ~src_sk ~priority ~timestamp ~fitness ~seed_nonce (`Hash bi.hash) operations.applied |> trace_exn (Failure "Error while injecting block") >>=? fun block_hash -> - State.record_block level block_hash seed_nonce + State.record_block cctxt level block_hash seed_nonce |> trace_exn (Failure "Error while recording block") >>=? fun () -> - Client_keys.Public_key_hash.name delegate >>= fun name -> - Cli_entries.message + Client_keys.Public_key_hash.name cctxt delegate >>= fun name -> + cctxt.message "Injected block %a for %s after %a \ \ (level %a, slot %d, fitness %a, operations %d)" Block_hash.pp_short block_hash @@ -381,14 +383,14 @@ let mine state = lwt_debug "No valid candidates." >>= fun () -> return () -let create ?max_priority delegates +let create cctxt ?max_priority delegates (block_stream: Client_mining_blocks.block_info list Lwt_stream.t) (endorsement_stream: Client_mining_operations.valid_endorsement Lwt_stream.t) = Lwt_stream.get block_stream >>= function | None | Some [] -> - Cli_entries.error "Can't fetch the current block head." + cctxt.Client_commands.error "Can't fetch the current block head." | Some ({ Client_mining_blocks.fitness } :: _ as initial_heads) -> - Client_node_rpcs.Blocks.hash `Genesis >>= fun genesis_hash -> + Client_node_rpcs.Blocks.hash cctxt `Genesis >>= fun genesis_hash -> let last_get_block = ref None in let get_block () = match !last_get_block with @@ -406,7 +408,7 @@ let create ?max_priority delegates t | Some t -> t in let state = create_state genesis_hash delegates fitness in - insert_blocks ?max_priority state initial_heads >>= fun () -> + insert_blocks cctxt ?max_priority state initial_heads >>= fun () -> let rec worker_loop () = let timeout = compute_timeout state in Lwt.choose [ (timeout >|= fun () -> `Timeout) ; @@ -426,20 +428,20 @@ let create ?max_priority delegates Block_hash.pp_short ppf bi.Client_mining_blocks.hash)) bis >>= fun () -> - insert_blocks ?max_priority state bis >>= fun () -> + insert_blocks cctxt ?max_priority state bis >>= fun () -> worker_loop () end | `Endorsement (Some e) -> Lwt.cancel timeout ; last_get_endorsement := None ; - Client_keys.Public_key_hash.name + Client_keys.Public_key_hash.name cctxt e.Client_mining_operations.source >>= fun _source -> (* TODO *) worker_loop () | `Timeout -> lwt_debug "Waking up for mining..." >>= fun () -> begin - mine state >>= function + mine cctxt state >>= function | Ok () -> Lwt.return_unit | Error errs -> lwt_log_error "Error while mining:\n%a" diff --git a/src/client/embedded/bootstrap/mining/client_mining_forge.mli b/src/client/embedded/bootstrap/mining/client_mining_forge.mli index 2eb38ec07..2683f6094 100644 --- a/src/client/embedded/bootstrap/mining/client_mining_forge.mli +++ b/src/client/embedded/bootstrap/mining/client_mining_forge.mli @@ -10,6 +10,7 @@ val generate_seed_nonce: unit -> Nonce.t val inject_block: + Client_commands.context -> Client_proto_rpcs.block -> ?force:bool -> priority:int -> @@ -21,6 +22,7 @@ val inject_block: Block_hash.t tzresult Lwt.t val forge_block: + Client_commands.context -> Client_proto_rpcs.block -> ?force:bool -> ?operations:Operation_hash.t list -> @@ -35,11 +37,16 @@ val forge_block: Block_hash.t tzresult Lwt.t module State : sig - val get_block: Raw_level.t -> Block_hash.t list tzresult Lwt.t - val record_block: Raw_level.t -> Block_hash.t -> Nonce.t -> unit tzresult Lwt.t + val get_block: + Client_commands.context -> + Raw_level.t -> Block_hash.t list tzresult Lwt.t + val record_block: + Client_commands.context -> + Raw_level.t -> Block_hash.t -> Nonce.t -> unit tzresult Lwt.t end val create: + Client_commands.context -> ?max_priority: int -> public_key_hash list -> Client_mining_blocks.block_info list Lwt_stream.t -> diff --git a/src/client/embedded/bootstrap/mining/client_mining_main.ml b/src/client/embedded/bootstrap/mining/client_mining_main.ml index 253b0abd6..e416659f8 100644 --- a/src/client/embedded/bootstrap/mining/client_mining_main.ml +++ b/src/client/embedded/bootstrap/mining/client_mining_main.ml @@ -10,159 +10,156 @@ open Cli_entries open Client_proto_contracts -let mine_block block ?force ?max_priority ?src_sk delegate = +let mine_block cctxt block ?force ?max_priority ?src_sk delegate = begin match src_sk with | None -> - Client_keys.get_key delegate >>=? fun (_, _, src_sk) -> + Client_keys.get_key cctxt delegate >>=? fun (_, _, src_sk) -> return src_sk | Some sk -> return sk end >>=? fun src_sk -> - Client_proto_rpcs.Context.level block >>=? fun level -> + Client_proto_rpcs.Context.level cctxt block >>=? fun level -> let level = Raw_level.succ level.level in let seed_nonce = Client_mining_forge.generate_seed_nonce () in - Client_mining_forge.forge_block + Client_mining_forge.forge_block cctxt ~timestamp:(Time.now ()) ?force ?max_priority ~seed_nonce ~src_sk block delegate >>=? fun block_hash -> - Client_mining_forge.State.record_block level block_hash seed_nonce + Client_mining_forge.State.record_block cctxt level block_hash seed_nonce |> trace_exn (Failure "Error while recording block") >>=? fun () -> - message "Injected block %a" Block_hash.pp_short block_hash >>= fun () -> + cctxt.message "Injected block %a" Block_hash.pp_short block_hash >>= fun () -> return () -let endorse_block ?force ?max_priority delegate = +let endorse_block cctxt ?force ?max_priority delegate = let block = Client_proto_args.block () in - Client_keys.get_key delegate >>=? fun (_src_name, src_pk, src_sk) -> - Client_mining_endorsement.forge_endorsement + Client_keys.get_key cctxt delegate >>=? fun (_src_name, src_pk, src_sk) -> + Client_mining_endorsement.forge_endorsement cctxt block ?force ?max_priority ~src_sk src_pk >>=? fun oph -> - answer "Operation successfully injected in the node." >>= fun () -> - answer "Operation hash is '%a'." Operation_hash.pp oph >>= fun () -> + cctxt.answer "Operation successfully injected in the node." >>= fun () -> + cctxt.answer "Operation hash is '%a'." Operation_hash.pp oph >>= fun () -> return () -let get_predecessor_cycle cycle = +let get_predecessor_cycle cctxt cycle = match Cycle.pred cycle with | None -> if Cycle.(cycle = root) then - error "No predecessor for the first cycle" + cctxt.Client_commands.error "No predecessor for the first cycle" else - error + cctxt.error "Cannot compute the predecessor of cycle %a" Cycle.pp cycle | Some cycle -> Lwt.return cycle -let do_reveal ?force block blocks = +let do_reveal cctxt ?force block blocks = let nonces = List.map snd blocks in - Client_mining_revelation.forge_seed_nonce_revelation + Client_mining_revelation.forge_seed_nonce_revelation cctxt block ?force nonces >>=? fun () -> - Client_proto_nonces.dels (List.map fst blocks) >>=? fun () -> + Client_proto_nonces.dels cctxt (List.map fst blocks) >>=? fun () -> return () -let reveal_block_nonces ?force block_hashes = +let reveal_block_nonces cctxt ?force block_hashes = let block = Client_proto_args.block () in Lwt_list.filter_map_p (fun hash -> Lwt.catch (fun () -> - Client_mining_blocks.info (`Hash hash) >>= function + Client_mining_blocks.info cctxt (`Hash hash) >>= function | Ok bi -> Lwt.return (Some bi) | Error _ -> Lwt.fail Not_found) (fun _ -> - Cli_entries.warning + cctxt.warning "Cannot find block %a in the chain. (ignoring)@." Block_hash.pp_short hash >>= fun () -> Lwt.return_none)) block_hashes >>= fun block_infos -> map_filter_s (fun (bi : Client_mining_blocks.block_info) -> - Client_proto_nonces.find bi.hash >>= function + Client_proto_nonces.find cctxt bi.hash >>= function | None -> - Cli_entries.warning "Cannot find nonces for block %a (ignoring)@." + cctxt.warning "Cannot find nonces for block %a (ignoring)@." Block_hash.pp_short bi.hash >>= fun () -> return None | Some nonce -> return (Some (bi.hash, (bi.level.level, nonce)))) block_infos >>=? fun blocks -> - do_reveal ?force block blocks + do_reveal cctxt ?force block blocks -let reveal_nonces ?force () = +let reveal_nonces cctxt ?force () = let block = Client_proto_args.block () in - Client_proto_rpcs.Context.next_level block >>=? fun level -> + Client_proto_rpcs.Context.next_level cctxt block >>=? fun level -> let cur_cycle = level.cycle in - get_predecessor_cycle cur_cycle >>= fun cycle -> - Client_mining_blocks.blocks_from_cycle block cycle >>=? fun block_infos -> + get_predecessor_cycle cctxt cur_cycle >>= fun cycle -> + Client_mining_blocks.blocks_from_cycle cctxt block cycle >>=? fun block_infos -> map_filter_s (fun (bi : Client_mining_blocks.block_info) -> - Client_proto_nonces.find bi.hash >>= function + Client_proto_nonces.find cctxt bi.hash >>= function | None -> return None | Some nonce -> - Cli_entries.warning "Found nonce for %a (level: %a)@." + cctxt.warning "Found nonce for %a (level: %a)@." Block_hash.pp_short bi.hash Level.pp bi.level >>= fun () -> return (Some (bi.hash, (bi.level.level, nonce)))) block_infos >>=? fun blocks -> - do_reveal ?force block blocks + do_reveal cctxt ?force block blocks open Client_proto_args -let run_daemon delegates () = - Client_mining_daemon.run +let run_daemon cctxt delegates = + Client_mining_daemon.run cctxt ?max_priority:!max_priority ~delay:!endorsement_delay ~min_date:((Time.add (Time.now ()) (Int64.neg 1800L))) (List.map snd delegates) +let group = + { Cli_entries.name = "delegate" ; + title = "Commands related to delegate operations." } + let commands () = let open Cli_entries in - register_group "delegate" "Commands related to delegate operations." ; [ - command - ~group: "delegate" - ~desc: "Launch a daemon that handles delegate operations." + command ~group ~desc: "Launch a daemon that handles delegate operations." ~args: [endorsement_delay_arg; max_priority_arg; Daemon.mining_arg ; Daemon.endorsement_arg ; Daemon.denunciation_arg] (prefixes [ "launch" ; "daemon" ] @@ seq_of_param Client_keys.Public_key_hash.alias_param ) - run_daemon ; - command - ~group: "delegate" - ~desc: "Forge and inject an endorsement operation" + (fun delegates cctxt -> + run_daemon cctxt delegates) ; + command ~group ~desc: "Forge and inject an endorsement operation" ~args: [ force_arg ] (prefixes [ "endorse"; "for" ] @@ Client_keys.Public_key_hash.alias_param ~name:"miner" ~desc: "name of the delegate owning the endorsement right" @@ stop) - (fun (_, delegate) () -> - endorse_block + (fun (_, delegate) cctxt -> + endorse_block cctxt ~force:!force ?max_priority:!max_priority delegate >>= - Client_proto_rpcs.handle_error) ; - command - ~group: "delegate" - ~desc: "Forge and inject block using the delegate rights" + Client_proto_rpcs.handle_error cctxt) ; + command ~group ~desc: "Forge and inject block using the delegate rights" ~args: [ max_priority_arg ; force_arg ] (prefixes [ "mine"; "for" ] @@ Client_keys.Public_key_hash.alias_param ~name:"miner" ~desc: "name of the delegate owning the mining right" @@ stop) - (fun (_, delegate) () -> - mine_block (block ()) + (fun (_, delegate) cctxt -> + mine_block cctxt (block ()) ~force:!force ?max_priority:!max_priority delegate >>= - Client_proto_rpcs.handle_error) ; - command - ~group: "delegate" - ~desc: "Forge and inject a seed-nonce revelation operation" + Client_proto_rpcs.handle_error cctxt) ; + command ~group ~desc: "Forge and inject a seed-nonce revelation operation" ~args: [ force_arg ] (prefixes [ "reveal"; "nonce"; "for" ] @@ Cli_entries.seq_of_param Block_hash.param) - (fun block_hashes () -> - reveal_block_nonces ~force:!force block_hashes >>= Client_proto_rpcs.handle_error) ; - command - ~group: "delegate" - ~desc: "Forge and inject redemption operations" + (fun block_hashes cctxt -> + reveal_block_nonces cctxt + ~force:!force block_hashes >>= + Client_proto_rpcs.handle_error cctxt) ; + command ~group ~desc: "Forge and inject redemption operations" ~args: [ force_arg ] (prefixes [ "reveal"; "nonces" ] @@ stop) - (fun () -> - reveal_nonces ~force:!force () >>= Client_proto_rpcs.handle_error) ; + (fun cctxt -> + reveal_nonces cctxt ~force:!force () >>= + Client_proto_rpcs.handle_error cctxt) ; ] let () = - Client_version.register Client_proto_main.protocol @@ + Client_commands.register Client_proto_main.protocol @@ commands () diff --git a/src/client/embedded/bootstrap/mining/client_mining_main.mli b/src/client/embedded/bootstrap/mining/client_mining_main.mli index 85f38966e..1b0c233e2 100644 --- a/src/client/embedded/bootstrap/mining/client_mining_main.mli +++ b/src/client/embedded/bootstrap/mining/client_mining_main.mli @@ -8,6 +8,7 @@ (**************************************************************************) val mine_block: + Client_commands.context -> Client_proto_rpcs.block -> ?force:bool -> ?max_priority: int -> @@ -15,4 +16,4 @@ val mine_block: public_key_hash -> unit tzresult Lwt.t -val commands: unit -> Cli_entries.command list +val commands: unit -> Client_commands.command list diff --git a/src/client/embedded/bootstrap/mining/client_mining_operations.ml b/src/client/embedded/bootstrap/mining/client_mining_operations.ml index bd95edab5..e6841e7db 100644 --- a/src/client/embedded/bootstrap/mining/client_mining_operations.ml +++ b/src/client/embedded/bootstrap/mining/client_mining_operations.ml @@ -18,15 +18,15 @@ type operation = { content: (Updater.shell_operation * proto_operation) option } -let monitor ?contents ?check () = - Client_node_rpcs.Operations.monitor ?contents () >>= fun ops_stream -> +let monitor cctxt ?contents ?check () = + Client_node_rpcs.Operations.monitor cctxt ?contents () >>= fun ops_stream -> let convert ops = Lwt_list.filter_map_p (fun (hash, bytes) -> match bytes with | None -> Lwt.return (Some { hash; content = None }) | Some ({ Store.shell ; proto } : Updater.raw_operation) -> - Client_proto_rpcs.Helpers.Parse.operations + Client_proto_rpcs.Helpers.Parse.operations cctxt `Prevalidation ?check shell proto >>= function | Ok proto -> Lwt.return (Some { hash ; content = Some (shell, proto) }) | Error err -> @@ -46,7 +46,7 @@ type valid_endorsement = { slots: int list ; } -let filter_valid_endorsement { hash; content } = +let filter_valid_endorsement cctxt { hash; content } = let open Tezos_context in match content with | None @@ -73,14 +73,14 @@ let filter_valid_endorsement { hash; content } = slots in (* Ensure thath the block has been previously validated by the node. This might took some times... *) - Client_node_rpcs.validate_block net_id block >>= function + Client_node_rpcs.validate_block cctxt net_id block >>= function | Error error -> lwt_log_info "@[Found endorsement for an invalid block@,%a@[" pp_print_error error >>= fun () -> Lwt.return_none | Ok () -> - Client_node_rpcs.Blocks.preapply (`Hash block) [hash] >>= function + Client_node_rpcs.Blocks.preapply cctxt (`Hash block) [hash] >>= function | Ok _ -> Lwt.return (Some { hash ; source ; block ; slots }) | Error error -> @@ -90,14 +90,14 @@ let filter_valid_endorsement { hash; content } = Lwt.return_none with Not_found -> Lwt.return_none -let monitor_endorsement () = - monitor ~contents:true ~check:true () >>= fun ops_stream -> +let monitor_endorsement cctxt = + monitor cctxt ~contents:true ~check:true () >>= fun ops_stream -> let endorsement_stream, push = Lwt_stream.create () in Lwt_stream.on_termination ops_stream (fun () -> push None) ; Lwt.async (fun () -> Lwt_stream.iter_p (Lwt_list.iter_p (fun e -> - filter_valid_endorsement e >>= function + filter_valid_endorsement cctxt e >>= function | None -> Lwt.return_unit | Some e -> push (Some e) ; Lwt.return_unit)) ops_stream) ; diff --git a/src/client/embedded/bootstrap/mining/client_mining_operations.mli b/src/client/embedded/bootstrap/mining/client_mining_operations.mli index daca93419..a75943339 100644 --- a/src/client/embedded/bootstrap/mining/client_mining_operations.mli +++ b/src/client/embedded/bootstrap/mining/client_mining_operations.mli @@ -13,6 +13,7 @@ type operation = { } val monitor: + Client_commands.context -> ?contents:bool -> ?check:bool -> unit -> operation list Lwt_stream.t Lwt.t @@ -24,7 +25,9 @@ type valid_endorsement = { } val filter_valid_endorsement: + Client_commands.context -> operation -> valid_endorsement option Lwt.t val monitor_endorsement: - unit -> valid_endorsement Lwt_stream.t Lwt.t + Client_commands.context -> + valid_endorsement Lwt_stream.t Lwt.t diff --git a/src/client/embedded/bootstrap/mining/client_mining_revelation.ml b/src/client/embedded/bootstrap/mining/client_mining_revelation.ml index 72f020fd2..c448e22f4 100644 --- a/src/client/embedded/bootstrap/mining/client_mining_revelation.ml +++ b/src/client/embedded/bootstrap/mining/client_mining_revelation.ml @@ -11,30 +11,31 @@ open Cli_entries open Tezos_context open Logging.Client.Revelation -let inject_seed_nonce_revelation block ?force ?wait nonces = +let inject_seed_nonce_revelation cctxt block ?force ?wait nonces = let operations = List.map (fun (level, nonce) -> Seed_nonce_revelation { level ; nonce }) nonces in - Client_node_rpcs.Blocks.net block >>= fun net -> - Client_proto_rpcs.Helpers.Forge.Anonymous.operations + Client_node_rpcs.Blocks.net cctxt block >>= fun net -> + Client_proto_rpcs.Helpers.Forge.Anonymous.operations cctxt block ~net operations >>=? fun bytes -> - Client_node_rpcs.inject_operation ?force ?wait bytes >>=? fun oph -> + Client_node_rpcs.inject_operation cctxt ?force ?wait bytes >>=? fun oph -> return oph type Error_monad.error += Bad_revelation -let forge_seed_nonce_revelation block ?(force = false) redempted_nonces = +let forge_seed_nonce_revelation cctxt + block ?(force = false) redempted_nonces = begin if force then return redempted_nonces else map_filter_s (fun (level, nonce) -> - Client_proto_rpcs.Context.Nonce.get block level >>=? function + Client_proto_rpcs.Context.Nonce.get cctxt block level >>=? function | Forgotten -> - message "Too late revelation for level %a" + cctxt.message "Too late revelation for level %a" Raw_level.pp level >>= fun () -> return None | Revealed _ -> - message "Ignoring previously-revealed nonce for level %a" + cctxt.message "Ignoring previously-revealed nonce for level %a" Raw_level.pp level >>= fun () -> return None | Missing nonce_hash -> @@ -48,11 +49,11 @@ let forge_seed_nonce_revelation block ?(force = false) redempted_nonces = end >>=? fun nonces -> match nonces with | [] -> - message "No nonce to reveal"; + cctxt.message "No nonce to reveal" >>= fun () -> return () | _ -> - inject_seed_nonce_revelation + inject_seed_nonce_revelation cctxt block ~force ~wait:true nonces >>=? fun oph -> - answer "Operation successfully injected in the node." >>= fun () -> - answer "Operation hash is '%a'." Operation_hash.pp_short oph >>= fun () -> + cctxt.answer "Operation successfully injected in the node." >>= fun () -> + cctxt.answer "Operation hash is '%a'." Operation_hash.pp_short oph >>= fun () -> return () diff --git a/src/client/embedded/bootstrap/mining/client_mining_revelation.mli b/src/client/embedded/bootstrap/mining/client_mining_revelation.mli index f426f473b..06b52b91a 100644 --- a/src/client/embedded/bootstrap/mining/client_mining_revelation.mli +++ b/src/client/embedded/bootstrap/mining/client_mining_revelation.mli @@ -8,6 +8,7 @@ (**************************************************************************) val inject_seed_nonce_revelation: + Client_commands.context -> Client_proto_rpcs.block -> ?force:bool -> ?wait:bool -> @@ -15,6 +16,7 @@ val inject_seed_nonce_revelation: Operation_hash.t tzresult Lwt.t val forge_seed_nonce_revelation: + Client_commands.context -> Client_proto_rpcs.block -> ?force:bool -> (Raw_level.t * Nonce.t) list -> diff --git a/src/client/embedded/bootstrap/webclient/webclient_proto_service_directory.ml b/src/client/embedded/bootstrap/webclient/webclient_proto_service_directory.ml index 2f94bcada..71023c1ec 100644 --- a/src/client/embedded/bootstrap/webclient/webclient_proto_service_directory.ml +++ b/src/client/embedded/bootstrap/webclient/webclient_proto_service_directory.ml @@ -11,14 +11,16 @@ module Services = Webclient_proto_services.Make (struct type root = Node_rpc_services.Blocks.block end) +let cctxt = Client_commands.ignore_context + let root = let root = RPC.register RPC.empty Services.contracts @@ fun block () -> - Client_proto_contracts.RawContractAlias.load () >>= fun list -> + Client_proto_contracts.RawContractAlias.load cctxt >>= fun list -> let (names, _) = List.split list in RPC.Answer.return names in let root = RPC.register root Services.hash @@ fun block () -> - Client_node_rpcs.(call_service1 Node_rpc_services.Blocks.hash block ()) >>= fun res -> + Client_node_rpcs.(call_service1 cctxt Node_rpc_services.Blocks.hash block ()) >>= fun res -> RPC.Answer.return (Hash.Block_hash.to_b48check res) in root diff --git a/src/client/embedded/demo/client_proto_main.ml b/src/client/embedded/demo/client_proto_main.ml index 2fe562f5e..628b191ef 100644 --- a/src/client/embedded/demo/client_proto_main.ml +++ b/src/client/embedded/demo/client_proto_main.ml @@ -11,35 +11,35 @@ let protocol = Protocol_hash.of_b48check "2gagsSEvTKAHRjxAamgSdBNkv39VtNCqpaDXrrH4K8R4KQAAHrhe3" -let demo () = +let demo cctxt = let block = Client_config.block () in - Cli_entries.message "Calling the 'echo' RPC." >>= fun () -> + cctxt.Client_commands.message "Calling the 'echo' RPC." >>= fun () -> let msg = "test" in - Client_proto_rpcs.echo block msg >>= fun reply -> + Client_proto_rpcs.echo cctxt block msg >>= fun reply -> fail_unless (reply = msg) (Unclassified "...") >>=? fun () -> begin - Cli_entries.message "Calling the 'failing' RPC." >>= fun () -> - Client_proto_rpcs.failing block 3 >>= function + cctxt.message "Calling the 'failing' RPC." >>= fun () -> + Client_proto_rpcs.failing cctxt block 3 >>= function | Error [Ecoproto_error [Error.Demo_error 3]] -> return () | _ -> failwith "..." end >>=? fun () -> - Cli_entries.message "Direct call to `demo_error`." >>= fun () -> + cctxt.message "Direct call to `demo_error`." >>= fun () -> begin Error.demo_error 101010 >|= wrap_error >>= function | Error [Ecoproto_error [Error.Demo_error 101010]] -> return () | _ -> failwith "...." end >>=? fun () -> - Cli_entries.answer "All good!" >>= fun () -> + cctxt.answer "All good!" >>= fun () -> return () -let mine () = +let mine cctxt = let block = match Client_config.block () with | `Prevalidation -> `Head 0 | `Test_prevalidation -> `Test_head 0 | b -> b in - Client_node_rpcs.Blocks.info block >>= fun bi -> + Client_node_rpcs.Blocks.info cctxt block >>= fun bi -> let fitness = match bi.fitness with | [ v ; b ] -> @@ -48,46 +48,40 @@ let mine () = [ v ; b ] | _ -> Lwt.ignore_result - (Cli_entries.message "Cannot parse fitness: %a" Fitness.pp bi.fitness); + (cctxt.message "Cannot parse fitness: %a" Fitness.pp bi.fitness); exit 2 in - Client_node_rpcs.forge_block + Client_node_rpcs.forge_block cctxt ~net:bi.net ~predecessor:bi.hash fitness [] (MBytes.create 0) >>= fun bytes -> - Client_node_rpcs.inject_block ~wait:true bytes >>=? fun hash -> - Cli_entries.answer "Injected %a" Block_hash.pp_short hash >>= fun () -> + Client_node_rpcs.inject_block cctxt ~wait:true bytes >>=? fun hash -> + cctxt.answer "Injected %a" Block_hash.pp_short hash >>= fun () -> return () -let handle_error = function +let handle_error cctxt = function | Ok res -> Lwt.return res | Error exns -> pp_print_error Format.err_formatter exns ; - Cli_entries.error "cannot continue" + cctxt.Client_commands.error "%s" "cannot continue" let commands () = let open Cli_entries in - register_group "demo" "Some demo command" ; + let group = {name = "demo" ; title = "Some demo command" } in [ - command - ~group: "demo" - ~desc: "A demo command" + command ~group ~desc: "A demo command" (fixed [ "demo" ]) - (fun () -> demo () >>= handle_error) ; - command - ~group: "demo" - ~desc: "An failing command" + (fun cctxt -> demo cctxt >>= handle_error cctxt) ; + command ~group ~desc: "A failing command" (fixed [ "fail" ]) - (fun () -> + (fun cctxt -> Error.demo_error 101010 >|= wrap_error - >>= handle_error ) ; - command - ~group: "demo" - ~desc: "Mine an empty block" + >>= handle_error cctxt) ; + command ~group ~desc: "Mine an empty block" (fixed [ "mine" ]) - (fun () -> mine () >>= handle_error) ; + (fun cctxt -> mine cctxt >>= handle_error cctxt) ; ] let () = - Client_version.register protocol @@ + Client_commands.register protocol @@ commands () diff --git a/src/client/embedded/demo/client_proto_rpcs.ml b/src/client/embedded/demo/client_proto_rpcs.ml index f43445e2c..49fbc1d8c 100644 --- a/src/client/embedded/demo/client_proto_rpcs.ml +++ b/src/client/embedded/demo/client_proto_rpcs.ml @@ -7,11 +7,11 @@ (* *) (**************************************************************************) -let call_service1 s block a1 = - Client_node_rpcs.call_service1 +let call_service1 cctxt s block a1 = + Client_node_rpcs.call_service1 cctxt (s Node_rpc_services.Blocks.proto_path) block a1 -let call_error_service1 s block a1 = - call_service1 s block a1 >|= wrap_error +let call_error_service1 cctxt s block a1 = + call_service1 cctxt s block a1 >|= wrap_error -let echo = call_service1 Services.echo_service -let failing = call_error_service1 Services.failing_service +let echo cctxt = call_service1 cctxt Services.echo_service +let failing cctxt = call_error_service1 cctxt Services.failing_service diff --git a/src/client/embedded/demo/client_proto_rpcs.mli b/src/client/embedded/demo/client_proto_rpcs.mli index bfb965889..45fa2de27 100644 --- a/src/client/embedded/demo/client_proto_rpcs.mli +++ b/src/client/embedded/demo/client_proto_rpcs.mli @@ -9,5 +9,9 @@ open Node_rpc_services -val echo: Blocks.block -> string -> string Lwt.t -val failing: Blocks.block -> int -> unit tzresult Lwt.t +val echo: + Client_commands.context -> + Blocks.block -> string -> string Lwt.t +val failing: + Client_commands.context -> + Blocks.block -> int -> unit tzresult Lwt.t diff --git a/src/client_main.ml b/src/client_main.ml index 3c5fad188..47aaf319e 100644 --- a/src/client_main.ml +++ b/src/client_main.ml @@ -11,7 +11,7 @@ open Lwt -let () = +let cctxt = let startup = CalendarLib.Printer.Precise_Calendar.sprint "%Y-%m-%dT%H:%M:%SZ" @@ -30,7 +30,7 @@ let () = ~mode: Lwt_io.Output Client_config.(base_dir#get // "logs" // log // startup) (fun chan -> Lwt_io.write chan msg) in - Cli_entries.log_hook := Some log + Client_commands.make_context log (* Main (lwt) entry *) let main () = @@ -38,14 +38,15 @@ let main () = Sodium.Random.stir () ; catch (fun () -> - Client_config.preparse_args Sys.argv >>= fun block -> + Client_config.preparse_args Sys.argv cctxt >>= fun block -> Lwt.catch (fun () -> - Client_node_rpcs.Blocks.protocol block) + Client_node_rpcs.Blocks.protocol cctxt block) (fun _ -> - Cli_entries.message "\n\ - The connection to the RPC server failed, \ - using the default protocol version.\n" >>= fun () -> + cctxt.message + "\n\ + The connection to the RPC server failed, \ + using the default protocol version.\n" >>= fun () -> Lwt.return Client_bootstrap.Client_proto_main.protocol) >>= fun version -> let commands = @@ -53,12 +54,12 @@ let main () = Client_keys.commands () @ Client_protocols.commands () @ Client_helpers.commands () @ - Client_version.commands_for_version version in + Client_commands.commands_for_version version in Client_config.parse_args ~version - (Cli_entries.usage commands) + (Cli_entries.usage ~commands) (Cli_entries.inline_dispatch commands) - Sys.argv >>= fun command -> - command () >>= fun () -> + Sys.argv cctxt >>= fun command -> + command cctxt >>= fun () -> Lwt.return 0) (function | Arg.Help help -> @@ -70,7 +71,7 @@ let main () = | Cli_entries.Command_not_found -> Format.eprintf "Unkonwn command, try `-help`.\n%!" ; Lwt.return 1 - | Client_version.Version_not_found -> + | Client_commands.Version_not_found -> Format.eprintf "Unkonwn protocol version, try `list versions`.\n%!" ; Lwt.return 1 | Cli_entries.Bad_argument (idx, _n, v) -> @@ -80,7 +81,7 @@ let main () = Format.eprintf "Command failed, %s.\n%!" message ; Lwt.return 1 | Failure message -> - Format.eprintf "%s%!" message ; + Format.eprintf "%s\n%!" message ; Lwt.return 1 | exn -> Format.printf "Fatal internal error: %s\n%!" diff --git a/src/utils/cli_entries.ml b/src/utils/cli_entries.ml index a274a7f7f..b9381f15c 100644 --- a/src/utils/cli_entries.ml +++ b/src/utils/cli_entries.ml @@ -18,50 +18,35 @@ exception Command_failed of string (* A simple structure for command interpreters. This is more generic than the exported one, see end of file. *) -type ('a, 'arg, 'ret) tparams = - | Prefix : string * ('a, 'arg, 'ret) tparams -> - ('a, 'arg, 'ret) tparams +type ('a, 'arg, 'ret) params = + | Prefix : string * ('a, 'arg, 'ret) params -> + ('a, 'arg, 'ret) params | Param : string * string * - (string -> 'p Lwt.t) * - ('a, 'arg, 'ret) tparams -> - ('p -> 'a, 'arg, 'ret) tparams + ('arg -> string -> 'p Lwt.t) * + ('a, 'arg, 'ret) params -> + ('p -> 'a, 'arg, 'ret) params | Stop : - ('arg -> 'ret Lwt.t, 'arg, 'ret) tparams + ('arg -> 'ret Lwt.t, 'arg, 'ret) params | More : - (string list -> 'arg -> 'ret Lwt.t, 'arg, 'ret) tparams + (string list -> 'arg -> 'ret Lwt.t, 'arg, 'ret) params | Seq : string * string * - (string -> 'p Lwt.t) -> - ('p list -> 'arg -> 'ret Lwt.t, 'arg, 'ret) tparams + ('arg -> string -> 'p Lwt.t) -> + ('p list -> 'arg -> 'ret Lwt.t, 'arg, 'ret) params + +(* A command group *) +type group = + { name : string ; + title : string } (* A command wraps a callback with its type and info *) -and ('arg, 'ret) tcommand = +type ('arg, 'ret) command = | Command - : ('a, 'arg, 'ret) tparams * 'a * - desc option * tag list * group option * - (Arg.key * Arg.spec * Arg.doc) list - -> ('arg, 'ret) tcommand - -and desc = string -and group = string -and tag = string - -(* Associates group names with group titles *) -let groups : (group * string) list ref = ref [] -let register_group group title = - try ignore @@ List.assoc group !groups with - | Not_found -> groups := (group, title) :: !groups -let group_title group = - try List.assoc group !groups with - | Not_found -> group - -(* Associates tag names with tag descriptions *) -let tags : (tag * string) list ref = ref [] -let register_tag tag title = - try ignore @@ List.assoc tag !tags with - | Not_found -> tags := (tag, title) :: !tags -let tag_description tag = - try List.assoc tag !tags with - | Not_found -> "undocumented tag" + : { params: ('a, 'arg, 'ret) params ; + handler : 'a ; + desc : string ; + group : group option ; + args : (Arg.key * Arg.spec * Arg.doc) list } + -> ('arg, 'ret) command (* Some combinators for writing commands concisely. *) let param ~name ~desc kind next = Param (name, desc, kind, next) @@ -80,18 +65,19 @@ let stop = Stop let more = More let void = Stop let any = More -let command ?desc ?(tags = []) ?group ?(args = []) params cb = - Command (params, cb, desc,tags, group, args) +let command ?group ?(args = []) ~desc params handler = + Command { params ; handler ; desc ; group ; args } (* Param combinators *) -let string n desc next = param n desc (fun s -> return s) next +let string ~name ~desc next = + param name desc (fun _ s -> return s) next (* Command execution *) let exec (type arg) (type ret) - (Command (params, cb, _, _, _, _)) (last : arg) args = + (Command { params ; handler }) (last : arg) args = let rec exec - : type a. int -> (a, arg, ret) tparams -> a -> string list -> ret Lwt.t + : type a. int -> (a, arg, ret) params -> a -> string list -> ret Lwt.t = fun i params cb args -> match params, args with | Stop, [] -> cb last @@ -101,7 +87,7 @@ let exec | [] -> Lwt.return (List.rev acc) | p :: rest -> catch - (fun () -> f p) + (fun () -> f last p) (function | Failure msg -> Lwt.fail (Bad_argument (i, p, msg)) | exn -> Lwt.fail exn) >>= fun v -> @@ -113,33 +99,33 @@ let exec exec (succ i) next cb rest | Param (_, _, f, next), p :: rest -> catch - (fun () -> f p) + (fun () -> f last p) (function | Failure msg -> Lwt.fail (Bad_argument (i, p, msg)) | exn -> Lwt.fail exn) >>= fun v -> exec (succ i) next (cb v) rest | _ -> Lwt.fail Command_not_found - in exec 1 params cb args + in exec 1 params handler args (* Command dispatch tree *) type ('arg, 'ret) level = - { stop : ('arg, 'ret) tcommand option ; + { stop : ('arg, 'ret) command option ; prefix : (string * ('arg, 'ret) tree) list } and ('arg, 'ret) param_level = - { stop : ('arg, 'ret) tcommand option ; + { stop : ('arg, 'ret) command option ; tree : ('arg, 'ret) tree } and ('arg, 'ret) tree = | TPrefix of ('arg, 'ret) level | TParam of ('arg, 'ret) param_level - | TStop of ('arg, 'ret) tcommand - | TMore of ('arg, 'ret) tcommand + | TStop of ('arg, 'ret) command + | TMore of ('arg, 'ret) command | TEmpty let insert_in_dispatch_tree (type arg) (type ret) - root (Command (params, _, _, _, _, _) as command) = + root (Command { params } as command) = let rec insert_tree - : type a. (arg, ret) tree -> (a, arg, ret) tparams -> (arg, ret) tree + : type a. (arg, ret) tree -> (a, arg, ret) params -> (arg, ret) tree = fun t c -> match t, c with | TEmpty, Stop -> TStop command | TEmpty, More -> TMore command @@ -207,15 +193,15 @@ let inline_tree_dispatch tree () = let t = List.assoc n prefix in state := (t, n :: acc) ; begin match t with - | TStop (Command (_, _, _, _, _, args)) - | TMore (Command (_, _, _, _, _, args)) -> `Args args + | TStop (Command { args }) + | TMore (Command { args }) -> `Args args | _ -> `Nop end with Not_found -> `Fail Command_not_found end | (TParam { tree }, acc), `Arg n -> state := (tree, n :: acc) ; begin match tree with - | TStop (Command (_, _, _, _, _, args)) - | TMore (Command (_, _, _, _, _, args)) -> `Args args + | TStop (Command { args }) + | TMore (Command { args }) -> `Args args | _ -> `Nop end | _, _ -> `Fail Command_not_found @@ -231,14 +217,14 @@ let inline_dispatch commands = (* Command line help for a set of commands *) let usage - (type arg) (type ret) - commands options = + (type arg) (type ret) + ~commands options = let trim s = (* config-file wokaround *) Utils.split '\n' s |> List.map String.trim |> String.concat "\n" in let rec help - : type a. Format.formatter -> (a, arg, ret) tparams -> unit + : type a. Format.formatter -> (a, arg, ret) params -> unit = fun ppf -> function | Stop -> () | More -> Format.fprintf ppf "..." @@ -251,7 +237,7 @@ let usage | Param (n, "", _, next) -> Format.fprintf ppf "(%s) %a" n help next | Param (_, desc, _, next) -> Format.fprintf ppf "(%s) %a" desc help next in let rec help_sum - : type a. Format.formatter -> (a, arg, ret) tparams -> unit + : type a. Format.formatter -> (a, arg, ret) params -> unit = fun ppf -> function | Stop -> () | More -> Format.fprintf ppf "..." @@ -261,7 +247,7 @@ let usage | Prefix (n, next) -> Format.fprintf ppf "%s %a" n help_sum next | Param (n, _, _, next) -> Format.fprintf ppf "(%s) %a" n help_sum next in let rec help_args - : type a. Format.formatter -> (a, arg, ret) tparams -> unit + : type a. Format.formatter -> (a, arg, ret) params -> unit = fun ppf -> function | Stop -> () | More -> Format.fprintf ppf "..." @@ -293,20 +279,17 @@ let usage | Rest _ -> "" in example opt) ; if desc <> "" then Format.fprintf ppf "@, @[%a@]" Format.pp_print_text (trim desc) in - let command_help ppf (Command (p, _, desc, _, _, options)) = - let small = Format.asprintf "@[%a@]" help p in - let desc = - match desc with - | None -> "undocumented command" - | Some desc -> trim desc in + let command_help ppf (Command { params ; desc ; args }) = + let small = Format.asprintf "@[%a@]" help params in + let desc = trim desc in if String.length small < 50 then begin Format.fprintf ppf "@[%s@,@[%a@]" small Format.pp_print_text desc end else begin Format.fprintf ppf "@[%a@,@[%a@]@,%a" - help_sum p + help_sum params Format.pp_print_text desc - help_args p ; + help_args params ; end ; if options = [] then Format.fprintf ppf "@]" @@ -314,14 +297,10 @@ let usage Format.fprintf ppf "@,%a@]" (Format.pp_print_list option_help) options in - let rec group_help ppf (n, commands) = - let title = - match n with - | None -> "Miscellaneous commands" - | Some n -> group_title n in + let rec group_help ppf ({ title }, commands) = Format.fprintf ppf "@[%s:@,%a@]" title - (Format.pp_print_list command_help) !commands in + (Format.pp_print_list command_help) commands in let usage ppf (by_group, options) = Format.fprintf ppf "@[@[Usage:@,%s [ options ] command [ command options ]@]@,\ @@ -331,49 +310,26 @@ let usage (Format.pp_print_list option_help) options (Format.pp_print_list group_help) by_group in let by_group = - List.fold_left - (fun acc (Command (_, _, _, _, g, _) as c) -> - try - let r = List.assoc g acc in - r := c :: !r ; - acc - with Not_found -> - (g, ref [ c ]) :: acc) - [] commands |> List.sort compare in + let ungrouped = ref [] in + let grouped = + List.fold_left + (fun acc (Command { group } as command) -> + match group with + | None -> + ungrouped := command :: !ungrouped ; + acc + | Some group -> + try + let ({ title }, r) = + List.find (fun ({ name }, _) -> group.name = name) acc in + if title <> group.title then + invalid_arg "Cli_entries.usage: duplicate group name" ; + r := command :: !r ; + acc + with Not_found -> + (group, ref [ command ]) :: acc) + [] commands in + List.map (fun (g, c) -> (g, List.rev !c)) grouped @ + [ { name = "untitled" ; title = "Miscellaneous commands" }, + List.rev !ungrouped ] in Format.asprintf "%a" usage (by_group, options) - -(* Pre-instanciated types *) -type 'a params = ('a, unit, unit) tparams -type command = (unit, unit) tcommand - -let log_hook - : (string -> string -> unit Lwt.t) option ref - = ref None - -let log channel msg = - match !log_hook with - | None -> Lwt.fail (Invalid_argument "Cli_entries.log: uninitialized hook") - | Some hook -> hook channel msg - -let error fmt= - Format.kasprintf - (fun msg -> - Lwt.fail (Failure msg)) - fmt - -let warning fmt = - Format.kasprintf - (fun msg -> log "stderr" msg) - fmt - -let message fmt = - Format.kasprintf - (fun msg -> log "stdout" msg) - fmt - -let answer = message - -let log name fmt = - Format.kasprintf - (fun msg -> log name msg) - fmt diff --git a/src/utils/cli_entries.mli b/src/utils/cli_entries.mli index ffa7eedff..05d367069 100644 --- a/src/utils/cli_entries.mli +++ b/src/utils/cli_entries.mli @@ -14,60 +14,66 @@ exception Command_not_found exception Bad_argument of int * string * string exception Command_failed of string -type 'a params -type command - -and desc = string -and group = string -and tag = string +type ('a, 'arg, 'ret) params +type ('arg, 'ret) command val param: name: string -> desc: string -> - (string -> 'a Lwt.t) -> 'b params -> ('a -> 'b) params -val prefix: string -> 'a params -> 'a params -val prefixes: string list -> 'a params -> 'a params -val string: string -> string -> 'a params -> (string -> 'a) params -val fixed: string list -> (unit -> unit Lwt.t) params -val stop: (unit -> unit Lwt.t) params + ('arg -> string -> 'a Lwt.t) -> + ('b, 'arg, 'ret) params -> + ('a -> 'b, 'arg, 'ret) params +val prefix: + string -> + ('a, 'arg, 'ret) params -> + ('a, 'arg, 'ret) params +val prefixes: + string list -> + ('a, 'arg, 'ret) params -> + ('a, 'arg, 'ret) params +val fixed: + string list -> + ('arg -> 'ret Lwt.t, 'arg, 'ret) params +val stop: + ('arg -> 'ret Lwt.t, 'arg, 'ret) params val seq: name: string -> desc: string -> - (string -> 'p Lwt.t) -> - ('p list -> unit -> unit Lwt.t) params + ('arg -> string -> 'p Lwt.t) -> + ('p list -> 'arg -> 'ret Lwt.t, 'arg, 'ret) params + +val string: + name: string -> + desc: string -> + ('a, 'arg, 'ret) params -> + (string -> 'a, 'arg, 'ret) params val seq_of_param: - ((unit -> unit Lwt.t) params -> - ('a -> unit -> unit Lwt.t) params) -> - ('a list -> unit -> unit Lwt.t) params + (('arg -> 'ret Lwt.t, 'arg, 'ret) params -> + ('a -> 'arg -> 'ret Lwt.t, 'arg, 'ret) params) -> + ('a list -> 'arg -> 'ret Lwt.t, 'arg, 'ret) params + +type group = + { name : string ; + title : string } val command: - ?desc:desc -> - ?tags:tag list -> - ?group:group -> - ?args:(Arg.key * Arg.spec * Arg.doc) list -> - 'a params -> 'a -> command - -val register_group: group -> group -> unit -val register_tag: tag -> string -> unit + ?group: group -> + ?args: (Arg.key * Arg.spec * Arg.doc) list -> + desc: string -> + ('a, 'arg, 'ret) params -> 'a -> ('arg, 'ret) command val usage: - command list -> (string * Arg.spec * string) list -> string + commands: ('arg, 'ret) command list -> + (string * Arg.spec * string) list -> string + val inline_dispatch: - command list -> unit -> + ('arg, 'ret) command list -> unit -> [ `Arg of string | `End ] -> [ `Args of (Arg.key * Arg.spec * Arg.doc) list | `Fail of exn | `Nop - | `Res of unit -> unit Lwt.t ] + | `Res of 'arg -> 'ret Lwt.t ] val dispatch: - command list -> unit -> string list -> unit Lwt.t - -val log_hook : (string -> string -> unit Lwt.t) option ref - -val error : ('a, Format.formatter, unit, 'b Lwt.t) format4 -> 'a -val warning : ('a, Format.formatter, unit, unit Lwt.t) format4 -> 'a -val message : ('a, Format.formatter, unit, unit Lwt.t) format4 -> 'a -val answer : ('a, Format.formatter, unit, unit Lwt.t) format4 -> 'a -val log : string -> ('a, Format.formatter, unit, unit Lwt.t) format4 -> 'a + ('arg, 'ret) command list -> 'arg -> string list -> 'ret Lwt.t diff --git a/src/utils/hash.ml b/src/utils/hash.ml index f327afb28..b088cfdf3 100644 --- a/src/utils/hash.ml +++ b/src/utils/hash.ml @@ -224,7 +224,7 @@ module Make_Blake2B (R : sig conv to_b48check (Data_encoding.Json.wrap_error of_b48check) string) let param ?(name=K.name) ?(desc=K.title) t = - Cli_entries.param ~name ~desc (fun str -> Lwt.return (of_b48check str)) t + Cli_entries.param ~name ~desc (fun _ str -> Lwt.return (of_b48check str)) t let pp ppf t = Format.pp_print_string ppf (to_b48check t) diff --git a/src/utils/hash.mli b/src/utils/hash.mli index 28a4b9e82..57f8d25b1 100644 --- a/src/utils/hash.mli +++ b/src/utils/hash.mli @@ -113,8 +113,8 @@ module Block_hash : sig val param : ?name:string -> ?desc:string -> - 'a Cli_entries.params -> - (t -> 'a) Cli_entries.params + ('a, 'arg, 'ret) Cli_entries.params -> + (t -> 'a, 'arg, 'ret) Cli_entries.params end module Block_hash_set : module type of Hash_set (Block_hash) diff --git a/src/webclient_main.ml b/src/webclient_main.ml index daa962253..1f79b809e 100644 --- a/src/webclient_main.ml +++ b/src/webclient_main.ml @@ -12,107 +12,88 @@ open Lwt.Infix open Logging.Webclient -let with_cli_entries_logging = - let startup = - CalendarLib.Printer.Precise_Calendar.sprint - "%Y-%m-%dT%H:%M:%SZ" - (CalendarLib.Calendar.Precise.now ()) in - let stdout = Buffer.create 1000 in - let stderr = Buffer.create 1000 in - let log channel msg = match channel with - | "stdout" -> - Buffer.add_string stdout msg ; - Lwt.return () - | "stderr" -> - Buffer.add_string stderr msg ; - Lwt.return () - | log -> - Lwt_utils.create_dir Client_config.(base_dir#get // "webclient_logs" // log) >>= fun () -> - Lwt_io.with_file - ~flags: Unix.[ O_APPEND ; O_CREAT ; O_WRONLY ] - ~mode: Lwt_io.Output - Client_config.(base_dir#get // "webclient_logs" // log // startup) - (fun chan -> Lwt_io.write chan msg) in - Cli_entries.log_hook := Some log ; - let global_cli_entries_mutex = Lwt_mutex.create () in - (fun callback -> - Lwt_mutex.with_lock - global_cli_entries_mutex - (fun () -> - Buffer.clear stdout ; - Buffer.clear stderr ; - Lwt.catch - (fun () -> - callback () >>= fun result -> - Lwt.return - (Ok (result, - Buffer.contents stdout, - Buffer.contents stderr))) - (fun exn -> - Lwt.return - (Error (exn, - Buffer.contents stdout, - Buffer.contents stderr))))) +let make_context () = + let buffers = Hashtbl.create 50 in + Hashtbl.add buffers "stdout" (Buffer.create 1000) ; + Hashtbl.add buffers "stderr" (Buffer.create 1000) ; + let log channel msg = + let buffer = + try Hashtbl.find buffers channel with + Not_found -> + let buffer = Buffer.create 1000 in + Hashtbl.add buffers channel buffer ; + buffer in + Buffer.add_string buffer msg ; + Buffer.add_char buffer '\n' ; + Lwt.return () in + Client_commands.make_context log, + (fun () -> + Hashtbl.fold + (fun channel buffer acc -> + (channel, Buffer.contents buffer) :: acc) + buffers []) -let block_protocol block = +let block_protocol cctxt block = Lwt.catch (fun () -> - Client_node_rpcs.Blocks.protocol block) + Client_node_rpcs.Blocks.protocol cctxt block) (fun _ -> - Cli_entries.message "\n\ - The connection to the RPC server failed, \ - using the default protocol version.\n" >>= fun () -> + cctxt.Client_commands.message + "\n\ + The connection to the RPC server failed, \ + using the default protocol version.\n" >>= fun () -> Lwt.return Client_bootstrap.Client_proto_main.protocol) let eval_command argv = - with_cli_entries_logging + let cctxt, result = make_context () in + Lwt.catch (fun () -> - Client_config.preparse_args argv >>= fun block -> - block_protocol block >>= fun version -> + Client_config.preparse_args argv cctxt >>= fun block -> + block_protocol cctxt block >>= fun version -> let commands = Client_generic_rpcs.commands @ Client_keys.commands () @ Client_protocols.commands () @ Client_helpers.commands () @ - Client_version.commands_for_version version in + Client_commands.commands_for_version version in Client_config.parse_args ~version - (Cli_entries.usage commands) + (Cli_entries.usage ~commands) (Cli_entries.inline_dispatch commands) - argv >>= fun command -> - command ()) >>= function - | Ok ((), stdout, _stderr) -> - Lwt.return (Ok stdout) - | Error (exn, stdout, stderr) -> - let msg = match exn with - | Arg.Help help -> - Format.asprintf "%s%!" help - | Arg.Bad help -> - Format.asprintf "%s%!" help - | Cli_entries.Command_not_found -> - Format.asprintf "Unkonwn command, try `-help`.\n%!" - | Client_version.Version_not_found -> - Format.asprintf "Unkonwn protocol version, try `list versions`.\n%!" - | Cli_entries.Bad_argument (idx, _n, v) -> - Format.asprintf "There's a problem with argument %d, %s.\n%!" idx v - | Cli_entries.Command_failed message -> - Format.asprintf "Command failed, %s.\n%!" message - | Failure msg -> - Format.asprintf "Fatal error: %s\n%!" msg - | exn -> - Format.asprintf "Fatal internal error: %s\n%!" (Printexc.to_string exn) in - let stderr = - if stdout = "" - || String.get stdout (String.length stderr - 1) = '\n' then - stdout ^ stderr - else - stdout ^ "\n" ^ stderr in - let stderr = - if stderr = "" - || String.get stderr (String.length stderr - 1) = '\n' then - msg - else - stderr ^ "\n" ^ msg in - Lwt.return (Error stderr) + argv cctxt >>= fun command -> + command cctxt >>= fun () -> + Lwt.return (Ok (result ()))) + (fun exn -> + let msg = match exn with + | Arg.Help help -> + Format.asprintf "%s%!" help + | Arg.Bad help -> + Format.asprintf "%s%!" help + | Cli_entries.Command_not_found -> + Format.asprintf "Unkonwn command, try `-help`.\n%!" + | Client_commands.Version_not_found -> + Format.asprintf "Unkonwn protocol version, try `list versions`.\n%!" + | Cli_entries.Bad_argument (idx, _n, v) -> + Format.asprintf "There's a problem with argument %d, %s.\n%!" idx v + | Cli_entries.Command_failed message -> + Format.asprintf "Command failed, %s.\n%!" message + | Failure msg -> + Format.asprintf "Fatal error: %s\n%!" msg + | exn -> + Format.asprintf "Fatal internal error: %s\n%!" (Printexc.to_string exn) in + let result = + result () in + let stderr = + List.assoc "stderr" result in + let stderr = + if stderr = "" + || String.get stderr (String.length stderr - 1) = '\n' then + msg + else + stderr ^ "\n" ^ msg in + let result = + ("stderr", stderr):: + List.filter (fun (n, _) -> n <> "stderr") result in + Lwt.return (Error result)) module ConnectionMap = Map.Make(Cohttp.Connection) @@ -123,7 +104,7 @@ let root = let input, output = let open Data_encoding in (obj1 (req "command" string)), - (obj1 (req "output" string)) in + (obj1 (req "outputs" (assoc string))) in let root = RPC.empty in let root = @@ -138,7 +119,7 @@ let root = RPC.register_dynamic_directory1 root RPC.Path.(root / "block" /: Node_rpc_services.Blocks.blocks_arg) (fun block -> - Client_node_rpcs.Blocks.protocol block >>= fun version -> + Client_node_rpcs.Blocks.protocol Client_commands.ignore_context block >>= fun version -> let directory = Webclient_version.find_contextual_services version in let directory = RPC.map (fun ((), block) -> block) directory in Lwt.return directory) in @@ -154,7 +135,7 @@ let find_static_file path = let path = index (path, file) in (match Node_rpc_services.Blocks.parse_block block with | Ok block -> - block_protocol block >>= fun version -> + block_protocol Client_commands.ignore_context block >>= fun version -> Lwt.return (try let root = @@ -194,11 +175,11 @@ let () = (Lwt.catch (fun () -> Client_config.parse_args - (Cli_entries.usage []) + (Cli_entries.usage ~commands: []) (fun () -> function | `Arg arg -> raise (Arg.Bad ("unexpected argument " ^ arg)) | `End -> `Res (fun () -> Lwt.return ())) - Sys.argv >>= fun _no_command -> + Sys.argv Client_commands.ignore_context>>= fun _no_command -> Random.self_init () ; Sodium.Random.stir () ; http_proxy web_port#get >>= fun _server -> diff --git a/src/webclient_static/index.html b/src/webclient_static/index.html index 7c044cc5e..2a9b178f2 100644 --- a/src/webclient_static/index.html +++ b/src/webclient_static/index.html @@ -7,11 +7,11 @@

Tezos Web client

+ 

+    

     

       ./tezos-client 
       
-      

-      
     

     
diff --git a/test/test_basic.ml b/test/test_basic.ml
index 44434f60f..2337ce546 100644
--- a/test/test_basic.ml
+++ b/test/test_basic.ml
@@ -14,7 +14,9 @@ open Error_monad
 open Hash
 
 let () =
-  Random.self_init () ;
+  Random.self_init ()
+
+let cctxt =
   let log channel msg = match channel with
     | "stdout" ->
         print_endline msg ;
@@ -23,7 +25,7 @@ let () =
         prerr_endline msg ;
         Lwt.return ()
     | _ -> Lwt.return () in
-  Cli_entries.log_hook := Some log
+  Client_commands.make_context log
 
 let should_fail f t =
   t >>= function
@@ -74,7 +76,7 @@ type account = {
 }
 
 let bootstrap_accounts () =
-  Client_proto_rpcs.Constants.bootstrap `Genesis
+  Client_proto_rpcs.Constants.bootstrap cctxt `Genesis
   >>= fun accounts ->
   let cpt = ref 0 in
   Lwt.return
@@ -105,7 +107,7 @@ let transfer ?(block = `Prevalidation) ?(fee = 5L) ~src ~target amount =
     match amount with
     | Some x -> x
     | None -> assert false in (* will be captured by the previous assert *)
-  Client_proto_context.transfer
+  Client_proto_context.transfer cctxt
     block
     ~source:src.contract
     ~src_pk:src.public_key
@@ -114,7 +116,7 @@ let transfer ?(block = `Prevalidation) ?(fee = 5L) ~src ~target amount =
     ~amount ~fee ()
 
 let check_balance ?(block = `Prevalidation) account expected =
-  Client_proto_rpcs.Context.Contract.balance
+  Client_proto_rpcs.Context.Contract.balance cctxt
     block account.contract >>=? fun balance ->
   let balance = Tez.to_cents balance in
   Assert.equal_int64 ~msg:__LOC__ expected balance ;
@@ -122,9 +124,9 @@ let check_balance ?(block = `Prevalidation) account expected =
 
 let mine contract =
   let block = `Head 0 in
-  Client_proto_rpcs.Context.level block >>=? fun level ->
+  Client_proto_rpcs.Context.level cctxt block >>=? fun level ->
   let seed_nonce = Client_mining_forge.generate_seed_nonce () in
-  Client_mining_forge.forge_block
+  Client_mining_forge.forge_block cctxt
     ~timestamp:(Time.now ()) ~seed_nonce ~src_sk:contract.secret_key
     block contract.public_key_hash >>=? fun block_hash ->
   return ()

From 923d061d7253c90d653bad1d886acbce0501385a Mon Sep 17 00:00:00 2001
From: Benjamin Canou 
Date: Mon, 5 Dec 2016 13:18:12 +0100
Subject: [PATCH 3/3] Client: help generation fixes.

---
 src/client/client_aliases.ml | 8 ++++----
 src/utils/cli_entries.ml     | 4 ++--
 2 files changed, 6 insertions(+), 6 deletions(-)

diff --git a/src/client/client_aliases.ml b/src/client/client_aliases.ml
index 4e9d2b8bf..1a80cc78c 100644
--- a/src/client/client_aliases.ml
+++ b/src/client/client_aliases.ml
@@ -177,18 +177,18 @@ module Alias = functor (Entity : Entity) -> struct
 
   include Entity
 
-  let alias_param ?(name = "name") ?(desc = "existing " ^ name ^ " alias") next =
+  let alias_param ?(name = "name") ?(desc = "existing " ^ Entity.name ^ " alias") next =
     param ~name ~desc
       (fun cctxt s -> find cctxt s >>= fun v -> return (s, v))
       next
 
-  let fresh_alias_param ?(name = "new") ?(desc = "new " ^ name ^ " alias") next =
+  let fresh_alias_param ?(name = "new") ?(desc = "new " ^ Entity.name ^ " alias") next =
     param ~name ~desc
       (fun cctxt s ->
          load cctxt >>= fun list ->
          if not Client_config.force#get then
            Lwt_list.iter_s (fun (n, _v) ->
-               if n = name then
+               if n = s then
                  cctxt.Client_commands.error
                    "the %s alias %s already exists, use -force true to update" Entity.name n
                else return ())
@@ -197,7 +197,7 @@ module Alias = functor (Entity : Entity) -> struct
          else return s)
       next
 
-  let source_param ?(name = "src") ?(desc = "source " ^ name) next =
+  let source_param ?(name = "src") ?(desc = "source " ^ Entity.name) next =
     let desc =
       desc ^ "\n"
       ^ "can be an alias, file or literal (autodetected in this order)\n\
diff --git a/src/utils/cli_entries.ml b/src/utils/cli_entries.ml
index b9381f15c..a83a6f3e1 100644
--- a/src/utils/cli_entries.ml
+++ b/src/utils/cli_entries.ml
@@ -291,12 +291,12 @@ let usage
         Format.pp_print_text desc
         help_args params ;
     end ;
-    if options = [] then
+    if args = [] then
       Format.fprintf ppf "@]"
     else
       Format.fprintf ppf "@,%a@]"
         (Format.pp_print_list option_help)
-        options in
+        args in
   let rec group_help ppf ({ title }, commands) =
     Format.fprintf ppf "@[%s:@,%a@]"
       title