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

Merge branch 'web-client' into 'master'

Browse Source 
Template for the server part of the webclient

See merge request !119
This commit is contained in:
Grégoire Henry 2016-12-06 11:40:51 +01:00
commit 9ece98167a
77 changed files with 2185 additions and 1284 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
.gitignore vendored
View File

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

107
src/Makefile
View File

@ -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,13 +378,12 @@ proto/client_embedded_proto_%.cmxa: \
clean::
rm -f ${TZNODE}
############################################################################
## Client program
############################################################################
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 \
@ -381,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 \
@ -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/*/)) \
$(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.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

156
src/client/client_aliases.ml
View File

@ -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,70 +161,73 @@ 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 =
let alias_param ?(name = "name") ?(desc = "existing " ^ Entity.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 =
let fresh_alias_param ?(name = "new") ?(desc = "new " ^ Entity.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
if n = s then
cctxt.Client_commands.error
"the %s alias %s already exists, use -force true to update" Entity.name n
else return ())
list >>= fun () ->
return s
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\
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

58
src/client/client_aliases.mli
View File

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

36
src/client/client_version.ml → src/client/client_commands.ml
View File

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

30
src/client/client_commands.mli Normal file
View File

@ -0,0 +1,30 @@
(**************************************************************************)
(* *)
(* Copyright (c) 2014 - 2016. *)
(* Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* All rights reserved. No warranty, explicit or implicit, provided. *)
(* *)
(**************************************************************************)
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
val register: Protocol_hash.t -> command list -> unit
val commands_for_version: Protocol_hash.t -> command list
val get_versions: unit -> (Protocol_hash.t * (command list)) list

53
src/client/client_config.ml
View File

@ -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 cctxt =
let open Lwt in
try begin match version with
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 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) ;
~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) Sys.argv args (anon dispatch) (usage base_args) ;
~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
(* parse once again with contextual options *)
Arg.parse_argv_dynamic
~current:(ref 0) Sys.argv args (anon dispatch) (usage base_args) ;
~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
cctxt.Client_commands.warning
"Warning: can't create the default configuration file: %s\n%!" msg
end) >>= fun () ->
begin match dispatch `End with
| `Res res ->
res
| `Res res -> Lwt.return res
| `Fail exn -> fail exn
| `Nop | `Args _ -> assert false
end
with exn -> Lwt.fail exn
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 cctxt : 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 ;
@ -176,24 +187,24 @@ let preparse_args () : 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 () ->
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
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
@ -201,6 +212,6 @@ let preparse_args () : 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

77
src/client/client_generic_rpcs.ml
View File

@ -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 "@ @[<v 2>Available services:@ @ %a@]@."
cctxt.message "@ @[<v 2>Available services:@ @ %a@]@."
display (args, args, tree) >>= fun () ->
if !collected_args <> [] then
Cli_entries.message "@,@[<v 2>Dynamic parameter description:@ @ %a@]@."
cctxt.message "@,@[<v 2>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"
let commands = [
command ~desc: "list all understood protocol versions"
(fixed [ "list" ; "versions" ])
(fun () ->
(fun cctxt ->
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)"
(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
~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)
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
~tags: [ "low-level" ; "local" ]
~group: "rpc"
~desc: "get the schemas of an RPC"
(prefixes [ "rpc" ; "schema" ] @@ string "url" "the RPC's URL" @@ stop)
command ~group ~desc: "get the schemas of an RPC"
(prefixes [ "rpc" ; "schema" ] @@ string ~name: "url" ~desc: "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)
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
])
]

2
src/client/client_generic_rpcs.mli
View File

@ -7,4 +7,4 @@
(* *)
(**************************************************************************)
val commands: Cli_entries.command list
val commands: Client_commands.command list

14
src/client/client_helpers.ml
View File

@ -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,9 +22,13 @@ 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

2
src/client/client_helpers.mli
View File

@ -7,4 +7,4 @@
(* *)
(**************************************************************************)
val commands: unit -> Cli_entries.command list
val commands: unit -> Client_commands.command list

107
src/client/client_keys.ml
View File

@ -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, \
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 []) ;
]

3
src/client/client_keys.mli
View File

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

159
src/client/client_node_rpcs.ml
View File

@ -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,22 +34,22 @@ 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"
cctxt.message "Request to /%s succeeded in %gs"
(String.concat "/" service) time
else Lwt.return ()) >>= fun () ->
Lwt.return (
@ -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"
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

87
src/client/client_node_rpcs.mli
View File

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

63
src/client/client_protocols.ml
View File

@ -1,51 +1,60 @@
(**************************************************************************)
(* *)
(* Copyright (c) 2014 - 2016. *)
(* Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* 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);
]

10
src/client/client_protocols.mli
View File

@ -1,2 +1,10 @@
(**************************************************************************)
(* *)
(* Copyright (c) 2014 - 2016. *)
(* Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* All rights reserved. No warranty, explicit or implicit, provided. *)
(* *)
(**************************************************************************)
val commands: unit -> Cli_entries.command list
val commands: unit -> Client_commands.command list

85
src/client/embedded/Makefile.shared
View File

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

72
src/client/embedded/bootstrap/Makefile
View File

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

2
src/client/embedded/bootstrap/client_proto_args.ml
View File

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

3
src/client/embedded/bootstrap/client_proto_args.mli
View File

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

222
src/client/embedded/bootstrap/client_proto_context.ml
View File

@ -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
(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
() >>=? fun contract ->
RawContractAlias.add neu contract >>= fun () ->
return ()) ;
command
~group: "context"
~desc: "open a new scripted account"
()) >>= 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" ]
@ -235,22 +223,18 @@ let commands () =
~name:"prg" ~desc: "script of the account\n\
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
(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 ()
>>=? fun contract ->
RawContractAlias.add neu contract >>= fun () ->
return ()) ;
command
~group: "context"
~desc: "transfer tokens"
~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)
]

5
src/client/embedded/bootstrap/client_proto_context.mli
View File

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

106
src/client/embedded/bootstrap/client_proto_contracts.ml
View File

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

25
src/client/embedded/bootstrap/client_proto_contracts.mli
View File

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

2
src/client/embedded/bootstrap/client_proto_main.ml
View File

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

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

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

20
src/client/embedded/bootstrap/client_proto_nonces.mli
View File

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

141
src/client/embedded/bootstrap/client_proto_programs.ml
View File

@ -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 =
"@[<v 2>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 "@[<v 0>@[<v 2>storage@,%a@]@,@[<v 2>output@,%a@]@,@[<v 2>trace@,%a@]@]@."
cctxt.message "@[<v 0>@[<v 2>storage@,%a@]@,@[<v 2>output@,%a@]@,@[<v 2>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 "@[<v 0>@[<v 2>storage@,%a@]@,@[<v 2>output@,%a@]@]@."
cctxt.message "@[<v 0>@[<v 2>storage@,%a@]@,@[<v 2>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@[<v 0> : [ @[<v 0>%a ]@]@,-> [ @[<v 0>%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") ;
]

14
src/client/embedded/bootstrap/client_proto_programs.mli
View File

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

206
src/client/embedded/bootstrap/client_proto_rpcs.ml
View File

@ -10,11 +10,11 @@
let string_of_errors exns =
Format.asprintf " @[<v>%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

122
src/client/embedded/bootstrap/client_proto_rpcs.mli
View File

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

4
src/client/embedded/bootstrap/mining/Makefile
View File

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

36
src/client/embedded/bootstrap/mining/client_mining_blocks.ml
View File

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

6
src/client/embedded/bootstrap/mining/client_mining_blocks.mli
View File

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

16
src/client/embedded/bootstrap/mining/client_mining_daemon.ml
View File

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

1
src/client/embedded/bootstrap/mining/client_mining_daemon.mli
View File

@ -8,6 +8,7 @@
(**************************************************************************)
val run:
Client_commands.context ->
?max_priority: int ->
delay: int ->
?min_date: Time.t ->

4
src/client/embedded/bootstrap/mining/client_mining_denunciation.ml
View File

@ -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 @[<h>%a@])"

1
src/client/embedded/bootstrap/mining/client_mining_denunciation.mli
View File

@ -8,5 +8,6 @@
(**************************************************************************)
val create:
Client_commands.context ->
Client_mining_operations.valid_endorsement Lwt_stream.t ->
unit Lwt.t

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

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

2
src/client/embedded/bootstrap/mining/client_mining_endorsement.mli
View File

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

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

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

11
src/client/embedded/bootstrap/mining/client_mining_forge.mli
View File

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

117
src/client/embedded/bootstrap/mining/client_mining_main.ml
View File

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

3
src/client/embedded/bootstrap/mining/client_mining_main.mli
View File

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

18
src/client/embedded/bootstrap/mining/client_mining_operations.ml
View File

@ -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
"@[<v 2>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) ;

5
src/client/embedded/bootstrap/mining/client_mining_operations.mli
View File

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

25
src/client/embedded/bootstrap/mining/client_mining_revelation.ml
View File

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

2
src/client/embedded/bootstrap/mining/client_mining_revelation.mli
View File

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

5
src/client/embedded/bootstrap/webclient/.merlin Normal file
View File

@ -0,0 +1,5 @@
REC
B browser/
S browser/
B shared/
S shared/

9
src/client/embedded/bootstrap/webclient/browser/.merlin Normal file
View File

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

53
src/client/embedded/bootstrap/webclient/browser/webclient_main.ml Normal file
View File

@ -0,0 +1,53 @@
(**************************************************************************)
(* *)
(* Copyright (c) 2014 - 2016. *)
(* Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* 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 ()

5
src/client/embedded/bootstrap/webclient/shared/.merlin Normal file
View File

@ -0,0 +1,5 @@
B ../../../../../minutils
S ../../../../../minutils
PKG lwt
PKG ocplib-json-typed.bson
PKG ocplib-resto.directory

30
src/client/embedded/bootstrap/webclient/shared/webclient_proto_services.ml Normal file
View File

@ -0,0 +1,30 @@
(**************************************************************************)
(* *)
(* Copyright (c) 2014 - 2016. *)
(* Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* 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

19
src/client/embedded/bootstrap/webclient/shared/webclient_proto_services.mli Normal file
View File

@ -0,0 +1,19 @@
(**************************************************************************)
(* *)
(* Copyright (c) 2014 - 2016. *)
(* Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* 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

12
src/client/embedded/bootstrap/webclient/static/index.html Normal file
View File

@ -0,0 +1,12 @@
<!doctype html>
<html>
<head>
<title>Tezos Web Client :: Bootstrap Version</title>
<meta charset="utf-8" />
<script src="main.js" defer></script>
</head>
<body>
<h1>Tezos Web client :: Bootstrap Version</h1>
<div id="receptacle"></div>
</body>
</html>

10
src/client/embedded/bootstrap/webclient/static/not_found.html Normal file
View File

@ -0,0 +1,10 @@
<!doctype html>
<html>
<head>
<title>Tezos Web Client :: Bootstrap Version</title>
<meta charset="utf-8" />
</head>
<body>
<h1>Not Found</h1>
</body>
</html>

11
src/client/client_version.mli → src/client/embedded/bootstrap/webclient/webclient_proto_main.ml
View File

@ -7,10 +7,9 @@
(* *)
(**************************************************************************)
open Cli_entries
exception Version_not_found
val register: Protocol_hash.t -> command list -> unit
val commands_for_version: Protocol_hash.t -> command list
val get_versions: unit -> (Protocol_hash.t * (command list)) list
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

26
src/client/embedded/bootstrap/webclient/webclient_proto_service_directory.ml Normal file
View File

@ -0,0 +1,26 @@
(**************************************************************************)
(* *)
(* Copyright (c) 2014 - 2016. *)
(* Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* 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 cctxt = Client_commands.ignore_context
let root =
let root =
RPC.register RPC.empty Services.contracts @@ fun block () ->
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 cctxt Node_rpc_services.Blocks.hash block ()) >>= fun res ->
RPC.Answer.return (Hash.Block_hash.to_b48check res) in
root

4
src/client/embedded/demo/Makefile
View File

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

54
src/client/embedded/demo/client_proto_main.ml
View File

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

12
src/client/embedded/demo/client_proto_rpcs.ml
View File

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

8
src/client/embedded/demo/client_proto_rpcs.mli
View File

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

28
src/client/webclient_version.ml Normal file
View File

@ -0,0 +1,28 @@
(**************************************************************************)
(* *)
(* Copyright (c) 2014 - 2016. *)
(* Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* 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

42
src/client_main.ml
View File

@ -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,12 +38,13 @@ let main () =
Sodium.Random.stir () ;
catch
(fun () ->
Client_config.preparse_args () >>= 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\
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)
@ -53,36 +54,39 @@ 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.inline_dispatch commands))
(Cli_entries.usage ~commands)
(Cli_entries.inline_dispatch commands)
Sys.argv cctxt >>= fun command ->
command cctxt >>= 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
| Client_version.Version_not_found ->
Lwt.return 1
| Client_commands.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
Format.eprintf "%s\n%!" message ;
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 ()))

3
src/tezos-deps.opam
View File

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

192
src/utils/cli_entries.ml
View File

@ -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
@ -189,7 +175,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 +184,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
@ -207,15 +193,15 @@ let inline_tree_dispatch tree last =
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
@ -232,13 +218,13 @@ let inline_dispatch commands =
(* Command line help for a set of commands *)
let usage
(type arg) (type ret)
commands options =
~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,35 +279,28 @@ let usage
| Rest _ -> "" in example opt) ;
if desc <> "" then
Format.fprintf ppf "@, @[<hov>%a@]" Format.pp_print_text (trim desc) in
let command_help ppf (Command (p, _, desc, _, _, options)) =
let small = Format.asprintf "@[<h>%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 "@[<h>%a@]" help params in
let desc = trim desc in
if String.length small < 50 then begin
Format.fprintf ppf "@[<v 2>%s@,@[<hov>%a@]"
small Format.pp_print_text desc
end else begin
Format.fprintf ppf "@[<v 2>%a@,@[<hov 0>%a@]@,%a"
help_sum p
help_sum params
Format.pp_print_text desc
help_args p ;
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
let rec group_help ppf (n, commands) =
let title =
match n with
| None -> "Miscellaneous commands"
| Some n -> group_title n in
args in
let rec group_help ppf ({ title }, commands) =
Format.fprintf ppf "@[<v 2>%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
"@[<v>@[<v 2>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 =
let ungrouped = ref [] in
let grouped =
List.fold_left
(fun acc (Command (_, _, _, _, g, _) as c) ->
(fun acc (Command { group } as command) ->
match group with
| None ->
ungrouped := command :: !ungrouped ;
acc
| Some group ->
try
let r = List.assoc g acc in
r := c :: !r ;
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 ->
(g, ref [ c ]) :: acc)
[] commands |> List.sort compare in
(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

81
src/utils/cli_entries.mli
View File

@ -14,61 +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
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 of string | `End ] ->
[> `Args of (Arg.key * Arg.spec * Arg.doc) list
('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 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

2
src/utils/hash.ml
View File

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

4
src/utils/hash.mli
View File

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

1
src/utils/logging.ml
View File

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

1
src/utils/logging.mli
View File

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

199
src/webclient_main.ml Normal file
View File

@ -0,0 +1,199 @@
(**************************************************************************)
(* *)
(* Copyright (c) 2014 - 2016. *)
(* Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* All rights reserved. No warranty, explicit or implicit, provided. *)
(* *)
(**************************************************************************)
(* Tezos Command line interface - Main Program *)
open Lwt.Infix
open Logging.Webclient
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 cctxt block =
Lwt.catch
(fun () ->
Client_node_rpcs.Blocks.protocol cctxt block)
(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 =
let cctxt, result = make_context () in
Lwt.catch
(fun () ->
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_commands.commands_for_version version in
Client_config.parse_args ~version
(Cli_entries.usage ~commands)
(Cli_entries.inline_dispatch commands)
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)
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 "outputs" (assoc 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 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
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 Client_commands.ignore_context 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 ~commands: [])
(fun () -> function
| `Arg arg -> raise (Arg.Bad ("unexpected argument " ^ arg))
| `End -> `Res (fun () -> Lwt.return ()))
Sys.argv Client_commands.ignore_context>>= 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))

38
src/webclient_static/index.html Normal file
View File

@ -0,0 +1,38 @@
<!doctype html>
<html>
<head>
<title>Tezos Web Client</title>
<meta charset="utf-8" />
<script src="//code.jquery.com/jquery-2.1.0.min.js"></script>
</head>
<body>
<h1>Tezos Web client</h1>
<pre id="console"></pre>
<br/>
<form id="form">
./tezos-client <input type="text" name="command" id="command">
<input type="submit" value="RUN">
</form>
<script>
$('#form').on('submit', function(e) {
e.preventDefault();
$.ajax ({
url: '/command',
method: 'POST',
contentType: 'application/json',
dataType: 'json',
data: JSON.stringify({ command : './tezos-client ' + $('#command')[0].value }),
processData: false
}).done (function ({ outputs }) {
let stdout = document.createElement ("span");
stdout.appendChild (document.createTextNode (outputs.stdout));
let stderr = document.createElement ("span");
stderr.appendChild (document.createTextNode (outputs.stderr));
stderr.style.color = "darkred";
$('#console')[0].appendChild (stdout);
$('#console')[0].appendChild (stderr);
})
})
</script>
</body>
</html>

10
src/webclient_static/not_found.html Normal file
View File

@ -0,0 +1,10 @@
<!doctype html>
<html>
<head>
<title>Tezos Web Client</title>
<meta charset="utf-8" />
</head>
<body>
<h1>Not Found</h1>
</body>
</html>

1
test/Makefile
View File

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

16
test/test_basic.ml
View File

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