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

Merge branch 'minutils' into 'master'

Browse Source 
Minutils

Split the utils library into two parts, to prepare for the jsoo web client.

See merge request !124
This commit is contained in:
Benjamin Canou 2016-12-01 19:18:50 +01:00
commit 8da7bddc36
63 changed files with 1090 additions and 874 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
src/.merlin
View File

@ -6,6 +6,8 @@ S node/shell
B node/shell
S node/db
B node/db
S minutils
B minutils
S utils
B utils
S proto/environment

82
src/Makefile
View File

@ -92,23 +92,58 @@ clean::
rm -f compiler/embedded_cmis.ml
rm -rf tmp
############################################################################
## Minimal utils library compatible with js_of_ocaml
############################################################################
MINUTILS_LIB_INTFS := \
minutils/mBytes.mli \
minutils/hex_encode.mli \
minutils/utils.mli \
minutils/compare.mli \
minutils/data_encoding.mli \
minutils/RPC.mli \
MINUTILS_LIB_IMPLS := \
minutils/mBytes.ml \
minutils/hex_encode.ml \
minutils/utils.ml \
minutils/compare.ml \
minutils/data_encoding.ml \
minutils/RPC.ml \
MINUTILS_PACKAGES := \
cstruct \
lwt \
ocplib-json-typed.bson \
ocplib-resto.directory \
$(COVERAGEPKG) \
MINUTILS_OBJS := \
${MINUTILS_LIB_IMPLS:.ml=.cmx} ${MINUTILS_LIB_IMPLS:.ml=.ml.deps} \
${MINUTILS_LIB_INTFS:.mli=.cmi} ${MINUTILS_LIB_INTFS:.mli=.mli.deps}
${MINUTILS_OBJS}: PACKAGES=${MINUTILS_PACKAGES}
${MINUTILS_OBJS}: SOURCE_DIRECTORIES=minutils
${MINUTILS_OBJS}: TARGET="(minutils.cmxa)"
${MINUTILS_OBJS}: OPENED_MODULES=
minutils.cmxa: ${MINUTILS_LIB_IMPLS:.ml=.cmx}
@echo LINK $(notdir $@)
@${OCAMLOPT} ${OCAMLFLAGS} -a -o $@ $^
############################################################################
## Node protocol compiler (also embedded in the main program)
## Utils library
############################################################################
UTILS_LIB_INTFS := \
utils/mBytes.mli \
utils/utils.mli \
utils/base48.mli \
utils/hex_encode.mli \
utils/cli_entries.mli \
utils/compare.mli \
utils/data_encoding.mli \
utils/data_encoding_ezjsonm.mli \
utils/crypto_box.mli \
utils/time.mli \
utils/hash.mli \
utils/error_monad.mli \
utils/lwt_exit.mli \
utils/logging.mli \
utils/lwt_utils.mli \
utils/lwt_pipe.mli \
@ -116,18 +151,15 @@ UTILS_LIB_INTFS := \
utils/moving_average.mli \
UTILS_LIB_IMPLS := \
utils/mBytes.ml \
utils/utils.ml \
utils/hex_encode.ml \
utils/base48.ml \
utils/cli_entries.ml \
utils/compare.ml \
utils/data_encoding.ml \
utils/data_encoding_ezjsonm.ml \
utils/time.ml \
utils/hash.ml \
utils/crypto_box.ml \
utils/error_monad_sig.ml \
utils/error_monad.ml \
utils/lwt_exit.ml \
utils/logging.ml \
utils/lwt_utils.ml \
utils/lwt_pipe.ml \
@ -135,12 +167,10 @@ UTILS_LIB_IMPLS := \
utils/moving_average.ml \
UTILS_PACKAGES := \
${MINUTILS_PACKAGES} \
base64 \
calendar \
cstruct \
ezjsonm \
lwt \
ocplib-json-typed \
sodium \
zarith \
$(COVERAGEPKG) \
@ -149,7 +179,7 @@ UTILS_OBJS := \
${UTILS_LIB_IMPLS:.ml=.cmx} ${UTILS_LIB_IMPLS:.ml=.ml.deps} \
${UTILS_LIB_INTFS:.mli=.cmi} ${UTILS_LIB_INTFS:.mli=.mli.deps}
${UTILS_OBJS}: PACKAGES=${UTILS_PACKAGES}
${UTILS_OBJS}: SOURCE_DIRECTORIES=utils
${UTILS_OBJS}: SOURCE_DIRECTORIES=minutils utils
${UTILS_OBJS}: TARGET="(utils.cmxa)"
${UTILS_OBJS}: OPENED_MODULES=
@ -157,7 +187,6 @@ utils.cmxa: ${UTILS_LIB_IMPLS:.ml=.cmx}
@echo LINK $(notdir $@)
@${OCAMLOPT} ${OCAMLFLAGS} -a -o $@ $^
############################################################################
## Node protocol compiler (also embedded in the main program)
############################################################################
@ -188,7 +217,7 @@ COMPILER_OBJS := \
${COMPILER_LIB_INTFS:.mli=.cmi} ${COMPILER_LIB_INTFS:.mli=.mli.deps} \
${TZCOMPILER}
${COMPILER_OBJS}: PACKAGES=${COMPILER_PACKAGES}
${COMPILER_OBJS}: SOURCE_DIRECTORIES=utils compiler
${COMPILER_OBJS}: SOURCE_DIRECTORIES=utils minutils compiler
${COMPILER_OBJS}: TARGET="(compiler.cmxa)"
${COMPILER_OBJS}: \
OPENED_MODULES=Error_monad Hash Utils
@ -197,7 +226,7 @@ compiler.cmxa: ${COMPILER_LIB_IMPLS:.ml=.cmx}
@echo LINK $(notdir $@)
@${OCAMLOPT} ${OCAMLFLAGS} -a -o $@ $^
${TZCOMPILER}: utils.cmxa compiler.cmxa ${COMPILER_IMPLS:.ml=.cmx}
${TZCOMPILER}: minutils.cmxa utils.cmxa compiler.cmxa ${COMPILER_IMPLS:.ml=.cmx}
@echo LINK $(notdir $@)
@$(OCAMLOPT) -linkpkg $(patsubst %, -package %, $(COMPILER_PACKAGES)) -o $@ $^
@ -212,7 +241,7 @@ clean::
NODE_LIB_INTFS := \
\
node/net/p2p.mli \
node/net/RPC.mli \
node/net/RPC_server.mli \
\
node/updater/fitness.mli \
\
@ -242,7 +271,7 @@ NODE_LIB_IMPLS := \
compiler/node_compiler_main.ml \
\
node/net/p2p.ml \
node/net/RPC.ml \
node/net/RPC_server.ml \
\
node/updater/fitness.ml \
\
@ -291,7 +320,7 @@ NODE_OBJS := \
${NODE_LIB_INTFS:.mli=.cmi} ${NODE_LIB_INTFS:.mli=.mli.deps} \
${TZNODE}
${NODE_OBJS}: PACKAGES=${NODE_PACKAGES}
${NODE_OBJS}: SOURCE_DIRECTORIES=utils compiler node/db node/net node/updater node/shell
${NODE_OBJS}: SOURCE_DIRECTORIES=minutils utils compiler node/db node/net node/updater node/shell
${NODE_OBJS}: TARGET="(node.cmxa)"
${NODE_OBJS}: OPENED_MODULES=Error_monad Hash Utils
@ -300,7 +329,7 @@ node.cmxa: ${NODE_LIB_IMPLS:.ml=.cmx}
@${OCAMLOPT} ${OCAMLFLAGS} -a -o $@ $^
${NODE_IMPLS:.ml=.cmx}: ${EMBEDDED_CLIENT_PROTOCOLS}
${TZNODE}: utils.cmxa compiler.cmxa node.cmxa ${EMBEDDED_NODE_PROTOCOLS} ${NODE_IMPLS:.ml=.cmx}
${TZNODE}: minutils.cmxa utils.cmxa compiler.cmxa node.cmxa ${EMBEDDED_NODE_PROTOCOLS} ${NODE_IMPLS:.ml=.cmx}
@echo LINK $(notdir $@)
@${OCAMLOPT} -linkall -linkpkg ${OCAMLFLAGS} -o $@ $^
@ -318,7 +347,7 @@ proto/embedded_proto_%.cmxa: \
@${TZCOMPILER} -static -build-dir proto/$*/_tzbuild $@ proto/$*/
CLIENT_PROTO_INCLUDES := \
utils node/updater node/db node/net node/shell client \
minutils utils node/updater node/db node/net node/shell client \
$(shell ocamlfind query lwt ocplib-json-typed sodium)
proto/client_embedded_proto_%.cmxa: \
@ -382,7 +411,7 @@ CLIENT_OBJS := \
${CLIENT_LIB_INTFS:.mli=.cmi} ${CLIENT_LIB_INTFS:.mli=.mli.deps} \
${TZCLIENT}
${CLIENT_OBJS}: PACKAGES=${CLIENT_PACKAGES}
${CLIENT_OBJS}: SOURCE_DIRECTORIES=client client/embedded utils node/net node/shell node/updater node/db compiler
${CLIENT_OBJS}: SOURCE_DIRECTORIES=client client/embedded minutils utils node/net node/shell node/updater node/db compiler
${CLIENT_OBJS}: TARGET="(client.cmxa)"
${CLIENT_OBJS}: OPENED_MODULES=Error_monad Hash Utils
@ -393,7 +422,7 @@ client.cmxa: ${CLIENT_LIB_IMPLS:.ml=.cmx}
${EMBEDDED_CLIENT_PROTOCOLS}: client.cmxa
${CLIENT_IMPLS:.ml=.cmx}: ${EMBEDDED_CLIENT_PROTOCOLS}
${TZCLIENT}: utils.cmxa compiler.cmxa node.cmxa \
${TZCLIENT}: minutils.cmxa utils.cmxa compiler.cmxa node.cmxa \
client.cmxa ${EMBEDDED_CLIENT_PROTOCOLS} \
${CLIENT_IMPLS:.ml=.cmx}
@echo LINK $(notdir $@)
@ -446,7 +475,8 @@ ifneq ($(MAKECMDGOALS),build-deps)
-include .depend
endif
endif
DEPENDS := $(filter-out $(NO_DEPS), $(UTILS_LIB_INTFS) $(UTILS_LIB_IMPLS) \
DEPENDS := $(filter-out $(NO_DEPS), $(MINUTILS_LIB_INTFS) $(MINUTILS_LIB_IMPLS) \
$(UTILS_LIB_INTFS) $(UTILS_LIB_IMPLS) \
$(COMPILER_LIB_INTFS) $(COMPILER_LIB_IMPLS) \
$(COMPILER_INTFS) $(COMPILER_IMPLS) \
$(NODE_LIB_INTFS) $(NODE_LIB_IMPLS) \

107
src/client/client_aliases.ml
View File

@ -33,16 +33,16 @@ module type Alias = sig
val save : (Lwt_io.file_name * t) list -> unit Lwt.t
val to_source : t -> string Lwt.t
val alias_param :
?n:string ->
?name:string ->
?desc:string ->
'a Cli_entries.params ->
(Lwt_io.file_name * t -> 'a) Cli_entries.params
val fresh_alias_param :
?n:string ->
?name:string ->
?desc:string ->
'a Cli_entries.params -> (string -> 'a) Cli_entries.params
val source_param :
?n:string ->
?name:string ->
?desc:string ->
'a Cli_entries.params -> (t -> 'a) Cli_entries.params
end
@ -61,7 +61,7 @@ module Alias = functor (Entity : Entity) -> struct
let load () =
let filename = filename () in
if not (Sys.file_exists filename) then return [] else
Data_encoding.Json.read_file filename >>= function
Data_encoding_ezjsonm.read_file filename >>= function
| None ->
error "couldn't to read the %s alias file" Entity.name
| Some json ->
@ -98,11 +98,11 @@ module Alias = functor (Entity : Entity) -> struct
catch
(fun () ->
let dirname = Client_config.base_dir#get in
(if not (Sys.file_exists dirname) then Utils.create_dir dirname
(if not (Sys.file_exists dirname) then Lwt_utils.create_dir dirname
else return ()) >>= fun () ->
let filename = filename () in
let json = Data_encoding.Json.construct encoding list in
Data_encoding.Json.write_file filename json >>= function
Data_encoding_ezjsonm.write_file filename json >>= function
| false -> fail (Failure "Json.write_file")
| true -> return ())
(fun exn ->
@ -115,9 +115,8 @@ module Alias = functor (Entity : Entity) -> struct
(if not Client_config.force#get then
Lwt_list.iter_s (fun (n, v) ->
if n = name && v = value then
(message "The %s alias %s already exists with the same value." Entity.name n ;
keep := true ;
return ())
(keep := true ;
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
else if n <> name && v = value then
@ -130,8 +129,7 @@ module Alias = functor (Entity : Entity) -> struct
return ()
else
save list >>= fun () ->
message "New %s alias '%s' saved." Entity.name name ;
return ()
message "New %s alias '%s' saved." Entity.name name
let del name =
load () >>= fun list ->
@ -140,55 +138,56 @@ module Alias = functor (Entity : Entity) -> struct
let save list =
save list >>= fun () ->
message "Successful update of the %s alias file." Entity.name ;
return ()
message "Successful update of the %s alias file." Entity.name
include Entity
let alias_param ?(n = "name") ?(desc = "existing " ^ name ^ " alias") next =
Param (n, desc, (fun s -> find s >>= fun v -> return (s, v)), next)
let alias_param ?(name = "name") ?(desc = "existing " ^ name ^ " alias") next =
param ~name ~desc
(fun s -> find s >>= fun v -> return (s, v))
next
let fresh_alias_param ?(n = "new") ?(desc = "new " ^ name ^ " alias") next =
Param (n,
desc,
(fun s ->
load () >>= 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
else return ())
list >>= fun () ->
return s
else return s),
next)
let fresh_alias_param ?(name = "new") ?(desc = "new " ^ name ^ " alias") next =
param ~name ~desc
(fun s ->
load () >>= 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
else return ())
list >>= fun () ->
return s
else return s)
next
let source_param ?(n = "src") ?(desc = "source " ^ name) next =
Param (n,
desc ^ "\n"
^ "can be an alias, file or litteral (autodetected in this order)\n\
use 'file:path', 'text:litteral' or 'alias:name' to force",
(fun s ->
let read path =
catch
(fun () -> Lwt_io.(with_file ~mode:Input path read))
(fun exn -> param_error "cannot read file (%s)" (Printexc.to_string exn))
>>= of_source in
match Utils.split ~limit:1 ':' s with
| [ "alias" ; alias ]->
find alias
| [ "text" ; text ] ->
of_source text
| [ "file" ; path ] ->
read path
| _ ->
let source_param ?(name = "src") ?(desc = "source " ^ 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 ->
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
match Utils.split ~limit:1 ':' s with
| [ "alias" ; alias ]->
find alias
| [ "text" ; text ] ->
of_source text
| [ "file" ; path ] ->
read path
| _ ->
catch
(fun () -> find s)
(fun _ ->
catch
(fun () -> find s)
(fun _ ->
catch
(fun () -> read s)
(fun _ -> of_source s))),
next)
(fun () -> read s)
(fun _ -> of_source s)))
next
let name d =
rev_find d >>= function

6
src/client/client_aliases.mli
View File

@ -29,16 +29,16 @@ module type Alias = sig
val save : (Lwt_io.file_name * t) list -> unit Lwt.t
val to_source : t -> string Lwt.t
val alias_param :
?n:string ->
?name:string ->
?desc:string ->
'a Cli_entries.params ->
(Lwt_io.file_name * t -> 'a) Cli_entries.params
val fresh_alias_param :
?n:string ->
?name:string ->
?desc:string ->
'a Cli_entries.params -> (string -> 'a) Cli_entries.params
val source_param :
?n:string ->
?name:string ->
?desc:string ->
'a Cli_entries.params -> (t -> 'a) Cli_entries.params
end

42
src/client/client_config.ml
View File

@ -128,20 +128,19 @@ let parse_args ?version usage dispatcher =
~current:(ref 0) Sys.argv args (anon dispatch) (usage base_args) ;
Lwt.return ()
with Sys_error msg ->
Printf.eprintf "Error: can't read the configuration file: %s\n%!" msg;
exit 1
Cli_entries.error
"Error: can't read the configuration file: %s\n%!" msg
end else begin
try
(* parse once again with contextual options *)
Arg.parse_argv_dynamic
~current:(ref 0) Sys.argv args (anon dispatch) (usage base_args) ;
Utils.create_dir (Filename.dirname config_file#get) >>= fun () ->
Lwt_utils.create_dir (Filename.dirname config_file#get) >>= fun () ->
file_group#write config_file#get ;
Lwt.return ()
with Sys_error msg ->
Printf.eprintf
"Warning: can't create the default configuration file: %s\n%!" msg ;
Lwt.return ()
Cli_entries.warning
"Warning: can't create the default configuration file: %s\n%!" msg
end) >>= fun () ->
begin match dispatch `End with
| `Res res ->
@ -161,7 +160,7 @@ let preparse name argv =
None
with Found s -> Some s
let preparse_args () : Node_rpc_services.Blocks.block =
let preparse_args () : Node_rpc_services.Blocks.block Lwt.t =
begin
match preparse "-base-dir" Sys.argv with
| None -> ()
@ -174,11 +173,13 @@ let preparse_args () : Node_rpc_services.Blocks.block =
end ;
begin
if Sys.file_exists config_file#get then try
file_group#read config_file#get ;
(file_group#read config_file#get ;
Lwt.return ())
with Sys_error msg ->
Printf.eprintf "Error: can't read the configuration file: %s\n%!" msg;
exit 1
end ;
Cli_entries.error
"Error: can't read the configuration file: %s\n%!" msg
else Lwt.return ()
end >>= fun () ->
begin
match preparse "-addr" Sys.argv with
| None -> ()
@ -186,17 +187,20 @@ let preparse_args () : Node_rpc_services.Blocks.block =
end ;
begin
match preparse "-port" Sys.argv with
| None -> ()
| None -> Lwt.return ()
| Some port ->
try incoming_port#set (int_of_string port)
try
incoming_port#set (int_of_string port) ;
Lwt.return ()
with _ ->
Printf.eprintf "Error: can't parse the -port option: %S.\n%!" port ;
exit 1 end ;
Cli_entries.error
"Error: can't parse the -port option: %S.\n%!" port
end >>= fun () ->
match preparse "-block" Sys.argv with
| None -> `Prevalidation
| None -> Lwt.return `Prevalidation
| Some x ->
match Node_rpc_services.Blocks.parse_block x with
| Error _ ->
Printf.eprintf "Error: can't parse the -block option: %S.\n%!" x ;
exit 1
| Ok b -> b
Cli_entries.error
"Error: can't parse the -block option: %S.\n%!" x
| Ok b -> Lwt.return b

38
src/client/client_generic_rpcs.ml
View File

@ -132,7 +132,7 @@ let editor_fill_in schema =
| Error msg -> return (Error msg)
| Ok json ->
Lwt_io.(with_file Output tmp (fun fp ->
write_line fp (Data_encoding.Json.to_string json))) >>= fun () ->
write_line fp (Data_encoding_ezjsonm.to_string json))) >>= fun () ->
edit ()
and edit () =
(* launch the user's editor on it *)
@ -160,7 +160,7 @@ let editor_fill_in schema =
and reread () =
(* finally reread the file *)
Lwt_io.(with_file Input tmp (fun fp -> read fp)) >>= fun text ->
match Data_encoding.Json.from_string text with
match Data_encoding_ezjsonm.from_string text with
| Ok r -> return (Ok r)
| Error msg -> return (Error (Printf.sprintf "bad input: %s" msg))
and delete () =
@ -272,12 +272,12 @@ let list url () =
Format.pp_print_list
(fun ppf (n,t) -> display ppf ([ n ], tpath @ [ n ], t))
in
Format.printf "@ @[<v 2>Available services:@ @ %a@]@."
display (args, args, tree) ;
Cli_entries.message "@ @[<v 2>Available services:@ @ %a@]@."
display (args, args, tree) >>= fun () ->
if !collected_args <> [] then
Format.printf "@,@[<v 2>Dynamic parameter description:@ @ %a@]@."
(Format.pp_print_list display_arg) !collected_args ;
return ()
Cli_entries.message "@,@[<v 2>Dynamic parameter description:@ @ %a@]@."
(Format.pp_print_list display_arg) !collected_args
else Lwt.return ()
let schema url () =
@ -285,14 +285,12 @@ let schema url () =
let open RPC.Description in
Client_node_rpcs.describe ~recurse:false args >>= function
| Static { service = Some { input ; output } } ->
Printf.printf "Input schema:\n%s\nOutput schema:\n%s\n%!"
(Data_encoding.Json.to_string (Json_schema.to_json input))
(Data_encoding.Json.to_string (Json_schema.to_json output));
return ()
Cli_entries.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))
| _ ->
Printf.printf
"No service found at this URL (but this is a valid prefix)\n%!" ;
return ()
Cli_entries.message
"No service found at this URL (but this is a valid prefix)\n%!"
let fill_in schema =
let open Json_schema in
@ -311,13 +309,11 @@ let call url () =
error "%s" msg
| Ok json ->
Client_node_rpcs.get_json args json >>= fun json ->
Printf.printf "Output:\n%s\n%!" (Data_encoding.Json.to_string json) ;
return ()
Cli_entries.message "Output:\n%s\n%!" (Data_encoding_ezjsonm.to_string json)
end
| _ ->
Printf.printf
"No service found at this URL (but this is a valid prefix)\n%!" ;
return ()
Cli_entries.message
"No service found at this URL (but this is a valid prefix)\n%!"
let () =
let open Cli_entries in
@ -332,9 +328,9 @@ let commands = Cli_entries.([
~desc: "list all understood protocol versions"
(fixed [ "list" ; "versions" ])
(fun () ->
List.iter
Lwt_list.iter_s
(fun (ver, _) -> message "%a" Protocol_hash.pp_short ver)
(Client_version.get_versions ()) ; return ()) ;
(Client_version.get_versions ())) ;
command
~tags: [ "low-level" ; "local" ]
~group: "rpc"

6
src/client/client_keys.ml
View File

@ -46,8 +46,7 @@ let gen_keys name =
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 ;
Lwt.return ()
Cli_entries.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
@ -122,8 +121,7 @@ let commands () =
Public_key_hash.to_source pkh >>= fun v ->
message "%s: %s%s%s" name v
(if pkm then " (public key known)" else "")
(if pks then " (secret key known)" else "") ;
Lwt.return ())
(if pks then " (secret key known)" else ""))
l) ;
command
~group: "keys"

64
src/client/client_node_rpcs.ml
View File

@ -13,31 +13,13 @@ open Lwt
open Cli_entries
open Logging.RPC
let log_file =
let open CalendarLib in
Printer.Precise_Calendar.sprint
"%Y-%m-%dT%H:%M:%SZ.log"
(Calendar.Precise.now ())
let with_log_file f =
Utils.create_dir Client_config.(base_dir#get // "logs") >>= fun () ->
Lwt_io.with_file
~flags: Unix.[ O_APPEND ; O_CREAT ; O_WRONLY ]
~mode: Lwt_io.Output
Client_config.(base_dir#get // "logs" // log_file)
f
let log_request cpt url req =
with_log_file
(fun fp ->
Lwt_io.fprintf fp">>>>%d: %s\n%s\n" cpt url req >>= fun () ->
Lwt_io.flush fp)
Cli_entries.log "requests"
">>>>%d: %s\n%s\n" cpt url req
let log_response cpt code ans =
with_log_file
(fun fp ->
Lwt_io.fprintf fp"<<<<%d: %s\n%s\n" cpt (Cohttp.Code.string_of_status code) ans >>= fun () ->
Lwt_io.flush fp)
Cli_entries.log "requests"
"<<<<%d: %s\n%s\n" cpt (Cohttp.Code.string_of_status code) ans
let cpt = ref 0
let make_request service json =
@ -47,7 +29,7 @@ let make_request service json =
^ ":" ^ string_of_int Client_config.incoming_port#get in
let string_uri = String.concat "/" (serv :: service) in
let uri = Uri.of_string string_uri in
let reqbody = Data_encoding.Json.to_string json in
let reqbody = Data_encoding_ezjsonm.to_string json in
let tzero = Unix.gettimeofday () in
catch
(fun () ->
@ -67,9 +49,10 @@ let get_streamed_json service json =
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
(if Client_config.print_timings#get then
message "Request to /%s succeeded in %gs"
(String.concat "/" service) time ;
(String.concat "/" service) time
else Lwt.return ()) >>= fun () ->
Lwt.return (
Lwt_stream.filter_map_s
(function
@ -78,13 +61,14 @@ let get_streamed_json service json =
lwt_log_error
"Failed to parse json: %s" msg >>= fun () ->
Lwt.return None)
(Data_encoding.Json.from_stream ansbody))
(Data_encoding_ezjsonm.from_stream ansbody))
| err, _ansbody ->
if Client_config.print_timings#get then
(if Client_config.print_timings#get then
message "Request to /%s failed in %gs"
(String.concat "/" service) time ;
(String.concat "/" service) time
else Lwt.return ()) >>= fun () ->
message "Request to /%s failed, server returned %s"
(String.concat "/" service) (Cohttp.Code.string_of_status err) ;
(String.concat "/" service) (Cohttp.Code.string_of_status err) >>= fun () ->
error "the RPC server returned a non-success status (%s)"
(Cohttp.Code.string_of_status err)
@ -93,21 +77,23 @@ let get_json service json =
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"
(String.concat "/" service) time ;
(if Client_config.print_timings#get then
message "Request to /%s succeeded in %gs"
(String.concat "/" service) time
else Lwt.return ()) >>= fun () ->
log_response cpt code ansbody >>= fun () ->
if ansbody = "" then Lwt.return `Null
else match Data_encoding.Json.from_string ansbody with
else match Data_encoding_ezjsonm.from_string ansbody with
| Error _ -> error "the RPC server returned malformed JSON"
| Ok res -> Lwt.return res
end
| err, _ansbody ->
if Client_config.print_timings#get then
message "Request to /%s failed in %gs"
(String.concat "/" service) time ;
(if Client_config.print_timings#get then
message "Request to /%s failed in %gs"
(String.concat "/" service) time
else Lwt.return ()) >>= fun () ->
message "Request to /%s failed, server returned %s"
(String.concat "/" service) (Cohttp.Code.string_of_status err) ;
(String.concat "/" service) (Cohttp.Code.string_of_status err) >>= fun () ->
error "the RPC server returned a non-success status (%s)"
(Cohttp.Code.string_of_status err)
@ -117,7 +103,7 @@ let parse_answer service path json =
match RPC.read_answer service json with
| Error msg -> (* TODO print_error *)
error "request to /%s returned wrong JSON (%s)\n%s"
(String.concat "/" path) msg (Data_encoding.Json.to_string json)
(String.concat "/" path) msg (Data_encoding_ezjsonm.to_string json)
| Ok v -> return v
let call_service0 service arg =
@ -138,7 +124,7 @@ let call_streamed_service0 service arg =
Lwt_stream.map_s (parse_answer service path) st
module Services = Node_rpc_services
let errors = call_service0 RPC.Error.service
let errors = call_service0 Services.Error.service
let forge_block ?net ?predecessor ?timestamp fitness ops header =
call_service0 Services.forge_block
(net, predecessor, timestamp, fitness, ops, header)

9
src/client/client_protocols.ml
View File

@ -11,8 +11,8 @@ let commands () =
~desc: "list known protocols"
(prefixes [ "list" ; "protocols" ] stop)
(fun () ->
Client_node_rpcs.Protocols.list ~contents:false () >|= fun protos ->
List.iter (fun (ph, _p) -> message "%a" Protocol_hash.pp ph) protos
Client_node_rpcs.Protocols.list ~contents:false () >>= fun protos ->
Lwt_list.iter_s (fun (ph, _p) -> message "%a" Protocol_hash.pp ph) protos
);
command
~group: "protocols"
@ -26,8 +26,7 @@ let commands () =
let proto = Tezos_compiler.Protocol.of_dir dirname in
Client_node_rpcs.inject_protocol proto >>= function
| Ok hash ->
message "Injected protocol %a successfully" Protocol_hash.pp_short hash;
Lwt.return ();
message "Injected protocol %a successfully" Protocol_hash.pp_short hash
| Error err ->
error "Error while injecting protocol from %s: %a"
dirname Error_monad.pp_print_error err)
@ -44,7 +43,7 @@ let commands () =
(fun ph () ->
Client_node_rpcs.Protocols.bytes ph >>= fun { data } -> match data with
| Ok proto ->
Updater.extract "" ph proto >|= fun () ->
Updater.extract "" ph proto >>= fun () ->
message "Extracted protocol %a" Protocol_hash.pp_short ph
| Error err ->
error "Error while dumping protocol %a: %a"

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

@ -5,6 +5,7 @@ include ../../../Makefile.config
NODE_DIRECTORIES = \
$(addprefix ../../../, \
minutils \
utils \
node/updater \
node/db \

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

@ -81,14 +81,14 @@ let delegatable_args =
Arg.Clear delegatable,
"Set the created contract to be non delegatable (default)" ]
let tez_param ~n ~desc next =
let tez_param ~name ~desc next =
Cli_entries.param
n
name
(desc ^ " in \xEA\x9C\xA9\n\
text format: D,DDD,DDD.DD (centiles and comas are optional)")
(fun s ->
try Lwt.return (tez_of_string s)
with _ -> Cli_entries.param_error "invalid \xEA\x9C\xA9 notation")
with _ -> Lwt.fail_with "invalid \xEA\x9C\xA9 notation")
next
let max_priority = ref None

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

@ -23,7 +23,7 @@ val force_arg: string * Arg.spec * string
val endorsement_delay_arg: string * Arg.spec * string
val tez_param :
n:string ->
name:string ->
desc:string ->
'a Cli_entries.params -> (Tez.t -> 'a) Cli_entries.params

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

@ -34,8 +34,7 @@ let get_delegate_pkh = function
let get_timestamp block () =
Client_node_rpcs.Blocks.timestamp block >>= fun v ->
Cli_entries.message "%s" (Time.to_notation v) ;
Lwt.return ()
Cli_entries.message "%s" (Time.to_notation v)
let list_contracts block () =
Client_proto_rpcs.Context.Contract.list block >>=? fun contracts ->
@ -58,7 +57,7 @@ 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;
Cli_entries.message "%s%s%s" (Contract.to_b48check h) kind nm >>= fun () ->
return ())
contracts
@ -75,15 +74,15 @@ let transfer block ?force
Client_proto_rpcs.Context.Contract.counter block source >>=? fun pcounter ->
let counter = Int32.succ pcounter in
message "Acquired the source's sequence counter (%ld -> %ld)."
pcounter counter ;
pcounter counter >>= fun () ->
Client_proto_rpcs.Helpers.Forge.Manager.transaction block
~net ~source ~sourcePubKey:src_pk ~counter ~amount
~destination ?parameters ~fee () >>=? fun bytes ->
message "Forged the raw transaction frame." ;
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." ;
answer "Operation hash is '%a'." Operation_hash.pp oph ;
answer "Operation successfully injected in the node." >>= fun () ->
answer "Operation hash is '%a'." Operation_hash.pp oph >>= fun () ->
return ()
let originate_account block ?force
@ -93,16 +92,16 @@ let originate_account block ?force
Client_proto_rpcs.Context.Contract.counter block source >>=? fun pcounter ->
let counter = Int32.succ pcounter in
message "Acquired the source's sequence counter (%ld -> %ld)."
pcounter counter ;
pcounter counter >>= fun () ->
Client_proto_rpcs.Helpers.Forge.Manager.origination 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." ;
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." ;
message "Operation hash is '%a'." Operation_hash.pp oph ;
message "Operation successfully injected in the node." >>= fun () ->
message "Operation hash is '%a'." Operation_hash.pp oph >>= fun () ->
return contract
let originate_contract
@ -115,18 +114,18 @@ let originate_contract
Client_proto_rpcs.Context.Contract.counter block source >>=? fun pcounter ->
let counter = Int32.succ pcounter in
message "Acquired the source's sequence counter (%ld -> %ld)."
pcounter counter ;
pcounter counter >>= fun () ->
Client_node_rpcs.Blocks.net block >>= fun net ->
Client_proto_rpcs.Helpers.Forge.Manager.origination 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." ;
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." ;
message "Operation hash is '%a'." Operation_hash.pp oph ;
message "Operation successfully injected in the node." >>= fun () ->
message "Operation hash is '%a'." Operation_hash.pp oph >>= fun () ->
return contract
let commands () =
@ -157,26 +156,24 @@ let commands () =
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;
Lwt.return_unit)
message "Bootstrap keys added under the name '%s'." name)
accounts >>= fun () ->
Lwt.return_unit) ;
command
~group: "context"
~desc: "get the balance of a contract"
(prefixes [ "get" ; "balance" ]
@@ ContractAlias.destination_param ~n:"src" ~desc:"source contract"
@@ 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;
Lwt.return ());
answer "%a %s" Tez.pp amount tez_sym);
command
~group: "context"
~desc: "get the manager of a block"
(prefixes [ "get" ; "manager" ]
@@ ContractAlias.destination_param ~n:"src" ~desc:"source contract"
@@ ContractAlias.destination_param ~name:"src" ~desc:"source contract"
@@ stop)
(fun (_, contract) () ->
Client_proto_rpcs.Context.Contract.manager (block ()) contract
@ -184,8 +181,7 @@ let commands () =
Public_key_hash.rev_find manager >>= fun mn ->
Public_key_hash.to_source manager >>= fun m ->
message "%s (%s)" m
(match mn with None -> "unknown" | Some n -> "known as " ^ n) ;
Lwt.return ());
(match mn with None -> "unknown" | Some n -> "known as " ^ n));
command
~group: "context"
~desc: "open a new account"
@ -193,16 +189,16 @@ let commands () =
@ delegatable_args @ spendable_args)
(prefixes [ "originate" ; "account" ]
@@ RawContractAlias.fresh_alias_param
~n: "new" ~desc: "name of the new contract"
~name: "new" ~desc: "name of the new contract"
@@ prefix "for"
@@ Public_key_hash.alias_param
~n: "mgr" ~desc: "manager of the new contract"
~name: "mgr" ~desc: "manager of the new contract"
@@ prefix "transfering"
@@ tez_param
~n: "qty" ~desc: "amount taken from source"
~name: "qty" ~desc: "amount taken from source"
@@ prefix "from"
@@ ContractAlias.alias_param
~n:"src" ~desc: "name of the source contract"
~name:"src" ~desc: "name of the source contract"
@@ stop)
(fun neu (_, manager) balance (_, source) ->
handle_error @@ fun () ->
@ -210,7 +206,7 @@ let commands () =
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 ;
message "Got the source's manager keys (%s)." src_name >>= fun () ->
originate_account (block ()) ~force:!force
~source ~src_pk ~src_sk ~manager_pkh:manager ~balance ~fee:!fee
~delegatable:!delegatable ~spendable:!spendable ?delegate:delegate
@ -224,19 +220,19 @@ let commands () =
delegatable_args @ spendable_args @ [ init_arg ])
(prefixes [ "originate" ; "contract" ]
@@ RawContractAlias.fresh_alias_param
~n: "new" ~desc: "name of the new contract"
~name: "new" ~desc: "name of the new contract"
@@ prefix "for"
@@ Public_key_hash.alias_param
~n: "mgr" ~desc: "manager of the new contract"
~name: "mgr" ~desc: "manager of the new contract"
@@ prefix "transfering"
@@ tez_param
~n: "qty" ~desc: "amount taken from source"
~name: "qty" ~desc: "amount taken from source"
@@ prefix "from"
@@ ContractAlias.alias_param
~n:"src" ~desc: "name of the source contract"
~name:"src" ~desc: "name of the source contract"
@@ prefix "running"
@@ Program.source_param
~n:"prg" ~desc: "script of the account\n\
~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 ->
@ -245,7 +241,7 @@ let commands () =
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 ;
message "Got the source's manager keys (%s)." src_name >>= fun () ->
originate_contract (block ()) ~force:!force
~source ~src_pk ~src_sk ~manager_pkh:manager ~balance ~fee:!fee
~delegatable:!delegatable ?delegatePubKey:delegate ~code ~init:!init ()
@ -258,19 +254,19 @@ let commands () =
~args: [ fee_arg ; arg_arg ; force_arg ]
(prefixes [ "transfer" ]
@@ tez_param
~n: "qty" ~desc: "amount taken from source"
~name: "qty" ~desc: "amount taken from source"
@@ prefix "from"
@@ ContractAlias.alias_param
~n: "src" ~desc: "name of the source contract"
~name: "src" ~desc: "name of the source contract"
@@ prefix "to"
@@ ContractAlias.destination_param
~n: "dst" ~desc: "name/literal of the destination contract"
~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 ;
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 ())
]

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

@ -51,33 +51,34 @@ module ContractAlias = struct
find_key key
| _ -> find s
let alias_param ?(n = "name") ?(desc = "existing contract alias") next =
Cli_entries.Param
(n, desc ^ "\n"
^ "can be an contract alias or a key alias (autodetected in this order)\n\
use 'key:name' to force the later", get_contract, next)
let alias_param ?(name = "name") ?(desc = "existing contract alias") next =
let desc =
desc ^ "\n"
^ "can be an contract alias or a key alias (autodetected in this order)\n\
use 'key:name' to force the later" in
Cli_entries.param ~name ~desc get_contract next
let destination_param ?(n = "dst") ?(desc = "destination contract") next =
Cli_entries.Param
(n,
desc ^ "\n"
^ "can be an alias, a key alias, or a litteral (autodetected in this order)\n\
use 'text:litteral', 'alias:name', 'key:name' to force",
(fun s ->
match Utils.split ~limit:1 ':' s with
| [ "alias" ; alias ]->
find alias
| [ "key" ; text ] ->
Client_keys.Public_key_hash.find text >>= fun v ->
Lwt.return (s, Contract.default_contract v)
| _ ->
Lwt.catch
(fun () -> find s)
(fun _ ->
match Contract.of_b48check s with
| Error _ -> Lwt.fail (Failure "bad contract notation")
| Ok v -> Lwt.return (s, v))),
next)
let destination_param ?(name = "dst") ?(desc = "destination contract") next =
let desc =
desc ^ "\n"
^ "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 ->
match Utils.split ~limit:1 ':' s with
| [ "alias" ; alias ]->
find alias
| [ "key" ; text ] ->
Client_keys.Public_key_hash.find text >>= fun v ->
Lwt.return (s, Contract.default_contract v)
| _ ->
Lwt.catch
(fun () -> find 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
@ -150,17 +151,16 @@ let commands () =
(fixed [ "list" ; "known" ; "contracts" ])
(fun () ->
RawContractAlias.load () >>= fun list ->
List.iter (fun (n, v) ->
Lwt_list.iter_s (fun (n, v) ->
let v = Contract.to_b48check v in
message "%s: %s" n v)
list ;
list >>= fun () ->
Client_keys.Public_key_hash.load () >>= fun list ->
Lwt_list.iter_s (fun (n, v) ->
RawContractAlias.mem 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 ;
Lwt.return_unit)
message "%s%s: %s" p n v)
list >>= fun () ->
Lwt.return ()) ;
command
@ -179,6 +179,5 @@ let commands () =
@@ RawContractAlias.alias_param
@@ stop)
(fun (_, contract) () ->
Format.printf "%a\n%!" Contract.pp contract ;
Lwt.return ()) ;
Cli_entries.message "%a\n%!" Contract.pp contract) ;
]

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

@ -13,12 +13,12 @@ module RawContractAlias :
module ContractAlias : sig
val get_contract: string -> (string * Contract.t) Lwt.t
val alias_param:
?n:string ->
?name:string ->
?desc:string ->
'a Cli_entries.params ->
(Lwt_io.file_name * Contract.t -> 'a) Cli_entries.params
val destination_param:
?n:string ->
?name:string ->
?desc:string ->
'a Cli_entries.params ->
(Lwt_io.file_name * Contract.t -> 'a) Cli_entries.params

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

@ -28,7 +28,7 @@ let load () =
if not (Sys.file_exists filename) then
Lwt.return []
else
Data_encoding.Json.read_file filename >>= function
Data_encoding_ezjsonm.read_file filename >>= function
| None -> error "couldn't to read the nonces file"
| Some json ->
match Data_encoding.Json.destruct encoding json with
@ -39,7 +39,7 @@ let load () =
let check_dir dirname =
if not (Sys.file_exists dirname) then
Utils.create_dir dirname
Lwt_utils.create_dir dirname
else
Lwt.return ()
@ -50,7 +50,7 @@ let save list =
check_dir dirname >>= fun () ->
let filename = filename () in
let json = Data_encoding.Json.construct encoding list in
Data_encoding.Json.write_file filename json >>= function
Data_encoding_ezjsonm.write_file filename json >>= function
| false -> failwith "Json.write_file"
| true -> return ())
(fun exn ->

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

@ -183,7 +183,7 @@ let commands () =
~desc: "lists all known programs"
(fixed [ "list" ; "known" ; "programs" ])
(fun () -> Program.load () >>= fun list ->
List.iter (fun (n, _) -> message "%s" n) list ; Lwt.return ()) ;
Lwt_list.iter_s (fun (n, _) -> message "%s" n) list) ;
command
~group: "programs"
~desc: "remember a program under some name"
@ -207,8 +207,7 @@ let commands () =
@@ stop)
(fun (_, program) () ->
Program.to_source program >>= fun source ->
Format.printf "%s\n" source ;
Lwt.return ()) ;
Cli_entries.message "%s\n" source) ;
command
~group: "programs"
~desc: "ask the node to run a program"
@ -225,7 +224,7 @@ let commands () =
if !trace_stack then
Client_proto_rpcs.Helpers.trace_code (block ()) program (storage, input) >>= function
| Ok (storage, output, trace) ->
Format.printf "@[<v 0>@[<v 2>storage@,%a@]@,@[<v 2>output@,%a@]@,@[<v 2>trace@,%a@]@]@."
Cli_entries.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
@ -235,18 +234,16 @@ let commands () =
loc gas
(Format.pp_print_list (print_ir (fun _ -> false)))
stack))
trace ;
Lwt.return ()
trace
| Error errs ->
pp_print_error Format.err_formatter errs ;
error "error running program"
else
Client_proto_rpcs.Helpers.run_code (block ()) program (storage, input) >>= function
| Ok (storage, output) ->
Format.printf "@[<v 0>@[<v 2>storage@,%a@]@,@[<v 2>output@,%a@]@]@."
Cli_entries.message "@[<v 0>@[<v 2>storage@,%a@]@,@[<v 2>output@,%a@]@]@."
(print_ir (fun _ -> false)) storage
(print_ir (fun _ -> false)) output ;
Lwt.return ()
(print_ir (fun _ -> false)) output
| Error errs ->
pp_print_error Format.err_formatter errs ;
error "error running program") ;
@ -262,15 +259,15 @@ let commands () =
Client_proto_rpcs.Helpers.typecheck_code (block ()) program >>= function
| Ok type_map ->
let type_map, program = unexpand_macros type_map program in
message "Well typed" ;
message "Well typed" >>= fun () ->
if !show_types then begin
print_program
(fun l -> List.mem_assoc l type_map)
Format.std_formatter program ;
Format.printf "@." ;
List.iter
Cli_entries.message "@." >>= fun () ->
Lwt_list.iter_s
(fun (loc, (before, after)) ->
Format.printf
Cli_entries.message
"%3d@[<v 0> : [ @[<v 0>%a ]@]@,-> [ @[<v 0>%a ]@]@]@."
loc
(Format.pp_print_list (print_ir (fun _ -> false)))
@ -278,8 +275,8 @@ let commands () =
(Format.pp_print_list (print_ir (fun _ -> false)))
after)
(List.sort compare type_map)
end ;
Lwt.return ()
end
else Lwt.return ()
| Error errs ->
pp_print_error Format.err_formatter errs ;
error "ill-typed program") ;
@ -296,8 +293,7 @@ let commands () =
Client_proto_rpcs.Helpers.typecheck_untagged_data
(block ()) (data, exp_ty) >>= function
| Ok () ->
message "Well typed" ;
Lwt.return ()
message "Well typed"
| Error errs ->
pp_print_error Format.err_formatter errs ;
error "ill-typed data") ;
@ -312,8 +308,7 @@ let commands () =
let open Data_encoding in
Client_proto_rpcs.Helpers.hash_data (block ()) data >>= function
| Ok hash ->
message "%S" hash;
Lwt.return ()
message "%S" hash
| Error errs ->
pp_print_error Format.err_formatter errs ;
error "ill-formed data") ;
@ -337,8 +332,7 @@ let commands () =
hash
(signature |>
Data_encoding.Binary.to_bytes Ed25519.signature_encoding |>
Hex_encode.hex_of_bytes) ;
Lwt.return ()
Hex_encode.hex_of_bytes)
| Error errs ->
pp_print_error Format.err_formatter errs ;
error "ill-formed data") ;

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

@ -48,7 +48,7 @@ end = struct
let load () =
let filename = filename () in
if not (Sys.file_exists filename) then return LevelMap.empty else
Data_encoding.Json.read_file filename >>= function
Data_encoding_ezjsonm.read_file filename >>= function
| None ->
error "couldn't to read the endorsement file"
| Some json ->
@ -62,11 +62,11 @@ end = struct
Lwt.catch
(fun () ->
let dirname = Client_config.base_dir#get in
(if not (Sys.file_exists dirname) then Utils.create_dir dirname
(if not (Sys.file_exists dirname) then Lwt_utils.create_dir dirname
else Lwt.return ()) >>= fun () ->
let filename = filename () in
let json = Data_encoding.Json.construct encoding map in
Data_encoding.Json.write_file filename json >>= function
Data_encoding_ezjsonm.write_file filename json >>= function
| false -> failwith "Json.write_file"
| true -> return ())
(fun exn ->
@ -292,7 +292,7 @@ let endorse state =
Block_hash.pp_short hash
Raw_level.pp level
slot name
Operation_hash.pp_short oph ;
Operation_hash.pp_short oph >>= fun () ->
return ())
to_endorse

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

@ -168,7 +168,7 @@ end = struct
let load () =
let filename = filename () in
if not (Sys.file_exists filename) then return LevelMap.empty else
Data_encoding.Json.read_file filename >>= function
Data_encoding_ezjsonm.read_file filename >>= function
| None ->
failwith "couldn't to read the block file"
| Some json ->
@ -182,11 +182,11 @@ end = struct
Lwt.catch
(fun () ->
let dirname = Client_config.base_dir#get in
(if not (Sys.file_exists dirname) then Utils.create_dir dirname
(if not (Sys.file_exists dirname) then Lwt_utils.create_dir dirname
else Lwt.return ()) >>= fun () ->
let filename = filename () in
let json = Data_encoding.Json.construct encoding map in
Data_encoding.Json.write_file filename json >>= function
Data_encoding_ezjsonm.write_file filename json >>= function
| false -> failwith "Json.write_file"
| true -> return ())
(fun exn ->
@ -374,7 +374,7 @@ let mine state =
Block_hash.pp_short bi.hash
Raw_level.pp level priority
Fitness.pp fitness
(List.length operations.applied) ;
(List.length operations.applied) >>= fun () ->
return ()
end
| _ ->

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

@ -27,7 +27,7 @@ let mine_block block ?force ?max_priority ?src_sk delegate =
~seed_nonce ~src_sk block delegate >>=? fun block_hash ->
Client_mining_forge.State.record_block level block_hash seed_nonce
|> trace_exn (Failure "Error while recording block") >>=? fun () ->
message "Injected block %a" Block_hash.pp_short block_hash ;
message "Injected block %a" Block_hash.pp_short block_hash >>= fun () ->
return ()
let endorse_block ?force ?max_priority delegate =
@ -35,8 +35,8 @@ let endorse_block ?force ?max_priority delegate =
Client_keys.get_key delegate >>=? fun (_src_name, src_pk, src_sk) ->
Client_mining_endorsement.forge_endorsement
block ?force ?max_priority ~src_sk src_pk >>=? fun oph ->
answer "Operation successfully injected in the node." ;
answer "Operation hash is '%a'." Operation_hash.pp oph ;
answer "Operation successfully injected in the node." >>= fun () ->
answer "Operation hash is '%a'." Operation_hash.pp oph >>= fun () ->
return ()
let get_predecessor_cycle cycle =
@ -68,15 +68,16 @@ let reveal_block_nonces ?force block_hashes =
| Error _ ->
Lwt.fail Not_found)
(fun _ ->
Format.eprintf "Cannot find block %a in the chain. (ignoring)@."
Block_hash.pp_short hash ;
Cli_entries.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
| None ->
Format.eprintf "Cannot find nonces for block %a (ignoring)@."
Block_hash.pp_short bi.hash ;
Cli_entries.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))))
@ -93,15 +94,15 @@ let reveal_nonces ?force () =
Client_proto_nonces.find bi.hash >>= function
| None -> return None
| Some nonce ->
Format.eprintf "Found nonce for %a (level: %a)@."
Block_hash.pp_short bi.hash Level.pp bi.level ;
Cli_entries.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
open Client_proto_args
let run_daemon delegates =
let run_daemon delegates () =
Client_mining_daemon.run
?max_priority:!max_priority
~delay:!endorsement_delay
@ -126,7 +127,7 @@ let commands () =
~args: [ force_arg ]
(prefixes [ "endorse"; "for" ]
@@ Client_keys.Public_key_hash.alias_param
~n:"miner" ~desc: "name of the delegate owning the endorsement right"
~name:"miner" ~desc: "name of the delegate owning the endorsement right"
@@ stop)
(fun (_, delegate) () ->
endorse_block
@ -138,7 +139,7 @@ let commands () =
~args: [ max_priority_arg ; force_arg ]
(prefixes [ "mine"; "for" ]
@@ Client_keys.Public_key_hash.alias_param
~n:"miner" ~desc: "name of the delegate owning the mining right"
~name:"miner" ~desc: "name of the delegate owning the mining right"
@@ stop)
(fun (_, delegate) () ->
mine_block (block ())
@ -150,7 +151,7 @@ let commands () =
~args: [ force_arg ]
(prefixes [ "reveal"; "nonce"; "for" ]
@@ Cli_entries.seq_of_param Block_hash.param)
(fun block_hashes ->
(fun block_hashes () ->
reveal_block_nonces ~force:!force block_hashes >>= Client_proto_rpcs.handle_error) ;
command
~group: "delegate"

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

@ -31,11 +31,11 @@ let forge_seed_nonce_revelation block ?(force = false) redempted_nonces =
Client_proto_rpcs.Context.Nonce.get block level >>=? function
| Forgotten ->
message "Too late revelation for level %a"
Raw_level.pp level ;
Raw_level.pp level >>= fun () ->
return None
| Revealed _ ->
message "Ignoring previously-revealed nonce for level %a"
Raw_level.pp level ;
Raw_level.pp level >>= fun () ->
return None
| Missing nonce_hash ->
if Nonce.check_hash nonce nonce_hash then
@ -53,6 +53,6 @@ let forge_seed_nonce_revelation block ?(force = false) redempted_nonces =
| _ ->
inject_seed_nonce_revelation
block ~force ~wait:true nonces >>=? fun oph ->
answer "Operation successfully injected in the node." ;
answer "Operation hash is '%a'." Operation_hash.pp_short oph ;
answer "Operation successfully injected in the node." >>= fun () ->
answer "Operation hash is '%a'." Operation_hash.pp_short oph >>= fun () ->
return ()

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

@ -13,24 +13,24 @@ let protocol =
let demo () =
let block = Client_config.block () in
Cli_entries.message "Calling the 'echo' RPC." ;
Cli_entries.message "Calling the 'echo' RPC." >>= fun () ->
let msg = "test" in
Client_proto_rpcs.echo block msg >>= fun reply ->
fail_unless (reply = msg) (Unclassified "...") >>=? fun () ->
begin
Cli_entries.message "Calling the 'failing' RPC." ;
Cli_entries.message "Calling the 'failing' RPC." >>= fun () ->
Client_proto_rpcs.failing block 3 >>= function
| Error [Ecoproto_error [Error.Demo_error 3]] ->
return ()
| _ -> failwith "..."
end >>=? fun () ->
Cli_entries.message "Direct call to `demo_error`." ;
Cli_entries.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!" ;
Cli_entries.answer "All good!" >>= fun () ->
return ()
let mine () =
@ -47,13 +47,14 @@ let mine () =
MBytes.set_int64 b 0 (Int64.succ f) ;
[ v ; b ]
| _ ->
Cli_entries.message "Cannot parse fitness: %a" Fitness.pp bi.fitness ;
Lwt.ignore_result
(Cli_entries.message "Cannot parse fitness: %a" Fitness.pp bi.fitness);
exit 2 in
Client_node_rpcs.forge_block
~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 ;
Cli_entries.answer "Injected %a" Block_hash.pp_short hash >>= fun () ->
return ()
let handle_error = function

30
src/client_main.ml
View File

@ -11,20 +11,41 @@
open Lwt
let () =
let startup =
CalendarLib.Printer.Precise_Calendar.sprint
"%Y-%m-%dT%H:%M:%SZ"
(CalendarLib.Calendar.Precise.now ()) in
let log channel msg = match channel with
| "stdout" ->
print_endline msg ;
Lwt.return ()
| "stderr" ->
prerr_endline msg ;
Lwt.return ()
| log ->
Lwt_utils.create_dir Client_config.(base_dir#get // "logs" // log) >>= fun () ->
Lwt_io.with_file
~flags: Unix.[ O_APPEND ; O_CREAT ; O_WRONLY ]
~mode: Lwt_io.Output
Client_config.(base_dir#get // "logs" // log // startup)
(fun chan -> Lwt_io.write chan msg) in
Cli_entries.log_hook := Some log
(* Main (lwt) entry *)
let main () =
Random.self_init () ;
Sodium.Random.stir () ;
catch
(fun () ->
let block = Client_config.preparse_args () in
Client_config.preparse_args () >>= fun block ->
Lwt.catch
(fun () ->
Client_node_rpcs.Blocks.protocol block)
(fun _ ->
Cli_entries.message "\n\
The connection to the RPC server failed, \
using the default protocol version.\n" ;
using the default protocol version.\n" >>= fun () ->
Lwt.return Client_bootstrap.Client_proto_main.protocol)
>>= fun version ->
let commands =
@ -35,7 +56,7 @@ let main () =
Client_version.commands_for_version version in
Client_config.parse_args ~version
(Cli_entries.usage commands)
(Cli_entries.inline_dispatcher commands))
(Cli_entries.inline_dispatch commands))
(function
| Arg.Help help ->
Format.printf "%s%!" help ;
@ -55,6 +76,9 @@ let main () =
| Cli_entries.Command_failed message ->
Format.eprintf "Command failed, %s.\n%!" message ;
Pervasives.exit 1
| Failure message ->
Format.eprintf "%s%!" message ;
Pervasives.exit 1
| exn ->
Format.printf "Fatal internal error: %s\n%!"
(Printexc.to_string exn) ;

13
src/compiler/tezos_compiler.ml
View File

@ -113,15 +113,16 @@ module Meta = struct
(req "modules" ~description:"Modules comprising the protocol" (list string))
let to_file dirname ?hash modules =
let open Data_encoding.Json in
let config_file = construct config_file_encoding (hash, modules) in
Utils.write_file ~bin:false (dirname // name) @@ to_string config_file
let config_file =
Data_encoding.Json.construct config_file_encoding (hash, modules) in
Utils.write_file ~bin:false (dirname // name) @@
Data_encoding_ezjsonm.to_string config_file
let of_file dirname =
let open Data_encoding.Json in
Utils.read_file ~bin:false (dirname // name) |> from_string |> function
Utils.read_file ~bin:false (dirname // name) |>
Data_encoding_ezjsonm.from_string |> function
| Error err -> Pervasives.failwith err
| Ok json -> destruct config_file_encoding json
| Ok json -> Data_encoding.Json.destruct config_file_encoding json
end
module Protocol = struct

24
src/minutils/RPC.ml Normal file
View File

@ -0,0 +1,24 @@
(**************************************************************************)
(* *)
(* Copyright (c) 2014 - 2016. *)
(* Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* All rights reserved. No warranty, explicit or implicit, provided. *)
(* *)
(**************************************************************************)
module Arg = Resto.Arg
module Path = Resto.Path
module Description = Resto.Description
let read_answer = Resto.read_answer
let forge_request = Resto.forge_request
let service ?description ~input ~output path =
Resto.service
?description
~input:(Data_encoding.Json.convert input)
~output:(Data_encoding.Json.convert output)
path
type ('prefix, 'params, 'input, 'output) service =
('prefix, 'params, 'input, 'output) Resto.service
include RestoDirectory

39
src/node/net/RPC.mli → src/minutils/RPC.mli
View File

@ -7,11 +7,7 @@
(* *)
(**************************************************************************)
(** View over the RPC service, restricted to types. A protocol
implementation can define a set of remote procedures which are
registered when the protocol is activated via its [rpcs]
function. However, it cannot register new or update existing
procedures afterwards, neither can it see other procedures. *)
(** Typed RPC services: definition, binding and dispatch. *)
(** Typed path argument. *)
module Arg : sig
@ -272,38 +268,15 @@ val register_custom_lookup3:
('a -> 'b -> 'c -> string list -> custom_lookup Lwt.t) ->
'prefix directory
(** Registring a description service. *)
val register_describe_directory_service:
'prefix directory ->
('prefix, 'prefix, bool option, Description.directory_descr) service ->
'prefix directory
(** A handle on the server worker. *)
type server
exception Cannot_parse of Arg.descr * string * string list
(** Promise a running RPC serve ; takes the port. To call
an RPX at /p/a/t/h/ in the provided service, one must call the URI
/call/p/a/t/h/. Calling /list/p/a/t/h/ will list the services
prefixed by /p/a/t/h/, if any. Calling /schema/p/a/t/h/ will
describe the input and output of the service, if it is
callable. Calling /pipe will read a sequence of services to call in
sequence from the request body, see {!pipe_encoding}. *)
val launch : int -> unit directory -> server Lwt.t
(** Kill an RPC server. *)
val shutdown : server -> unit Lwt.t
(** Retrieve the root service of the server *)
val root_service : server -> unit directory
(** Change the root service of the server *)
val set_root_service : server -> unit directory -> unit
module Error : sig
val service: (unit, unit, unit, Json_schema.schema) service
val encoding: error list Data_encoding.t
val wrap:
'a Data_encoding.t -> 'a tzresult Data_encoding.encoding
end
(** Resolve a service. *)
val lookup:
'prefix directory -> 'prefix -> string list ->
(Data_encoding.json option -> Data_encoding.json Answer.answer Lwt.t) Lwt.t

0
src/utils/compare.ml → src/minutils/compare.ml
View File

0
src/utils/compare.mli → src/minutils/compare.mli
View File

80
src/utils/data_encoding.ml → src/minutils/data_encoding.ml
View File

@ -213,54 +213,6 @@ module Json = struct
type nonrec json = json
let to_root = function
| `O ctns -> `O ctns
| `A ctns -> `A ctns
| `Null -> `O []
| oth -> `A [ oth ]
let to_string j = Ezjsonm.to_string ~minify:false (to_root j)
let from_string s =
try Ok (Ezjsonm.from_string s :> json)
with Ezjsonm.Parse_error (_, msg) -> Error msg
let from_stream (stream: string Lwt_stream.t) =
let buffer = ref "" in
Lwt_stream.filter_map
(fun str ->
buffer := !buffer ^ str ;
try
let json = Ezjsonm.from_string !buffer in
buffer := "" ;
Some (Ok json)
with Ezjsonm.Parse_error (_, msg) ->
if String.length str = 32 * 1024 then None
else Some (Error msg))
stream
let write_file file json =
let json = to_root json in
let open Lwt in
catch
(fun () ->
Lwt_io.(with_file ~mode:Output file (fun chan ->
let str = to_string json in
write chan str >>= fun _ ->
return true)))
(fun _ -> return false)
let read_file file =
let open Lwt in
catch
(fun () ->
Lwt_io.(with_file ~mode:Input file (fun chan ->
read chan >>= fun str ->
return (Some (Ezjsonm.from_string str :> json)))))
(fun _ ->
(* TODO log error or use Error_monad. *)
return None)
let wrap_error f =
fun str ->
try f str
@ -523,19 +475,35 @@ module Encoding = struct
let json = Json.convert json in
raw_splitted ~binary ~json
let raw_json json =
let json =
let binary =
conv
(fun v -> Json_encoding.construct json v |> Json.to_string)
(fun s ->
match Json.from_string s with
| Error msg -> raise (Json.Parse_error msg)
| Ok v -> Json_encoding.destruct json v)
(fun json ->
Json_repr.convert
(module Json_repr.Ezjsonm)
(module Json_repr_bson.Repr)
json |>
Json_repr_bson.bson_to_bytes |>
Bytes.to_string)
(fun s -> try
Bytes.of_string s |>
Json_repr_bson.bytes_to_bson ~copy:false |>
Json_repr.convert
(module Json_repr_bson.Repr)
(module Json_repr.Ezjsonm)
with
| Json_repr_bson.Bson_decoding_error (msg, _, _) ->
raise (Json.Parse_error msg))
string in
let json =
Json_encoding.any_ezjson_value in
raw_splitted ~binary ~json
let json = raw_json Json_encoding.any_ezjson_value
let json_schema = raw_json Json_encoding.any_schema
let json_schema =
conv
Json_schema.to_json
Json_schema.of_json
json
let raw_merge_objs e1 e2 =
let kind = Kind.combine "objects" (classify e1) (classify e2) in

18
src/utils/data_encoding.mli → src/minutils/data_encoding.mli
View File

@ -180,24 +180,6 @@ val mu : string -> ('a encoding -> 'a encoding) -> 'a encoding
module Json : sig
(** Read a JSON document from a string. *)
val from_string : string -> (json, string) result
(** Read a stream of JSON documents from a stream of strings.
A single JSON document may be represented in multiple consecutive
strings. But only the first document of a string is considered. *)
val from_stream : string Lwt_stream.t -> (json, string) result Lwt_stream.t
(** Write a JSON document to a string. This goes via an intermediate
buffer and so may be slow on large documents. *)
val to_string : json -> string
(** Loads a JSON file in memory *)
val read_file : string -> json option Lwt.t
(** (Over)write a JSON file from in memory data *)
val write_file : string -> json -> bool Lwt.t
val convert : 'a encoding -> 'a Json_encoding.encoding
val schema : 'a encoding -> json_schema

0
src/utils/hex_encode.ml → src/minutils/hex_encode.ml
View File

0
src/utils/hex_encode.mli → src/minutils/hex_encode.mli
View File

0
src/utils/mBytes.ml → src/minutils/mBytes.ml
View File

0
src/utils/mBytes.mli → src/minutils/mBytes.mli
View File

49
src/utils/utils.ml → src/minutils/utils.ml
View File

@ -7,55 +7,6 @@
(* *)
(**************************************************************************)
let (>>=) = Lwt.bind
let remove_dir dir =
let rec remove dir =
let files = Lwt_unix.files_of_directory dir in
Lwt_stream.iter_s
(fun file ->
if file = "." || file = ".." then
Lwt.return ()
else begin
let file = Filename.concat dir file in
if Sys.is_directory file
then remove file
else Lwt_unix.unlink file
end)
files >>= fun () ->
Lwt_unix.rmdir dir in
if Sys.file_exists dir && Sys.is_directory dir then
remove dir
else
Lwt.return ()
let rec create_dir ?(perm = 0o755) dir =
if Sys.file_exists dir then
Lwt.return ()
else begin
create_dir (Filename.dirname dir) >>= fun () ->
Lwt_unix.mkdir dir perm
end
let create_file ?(perm = 0o644) name content =
Lwt_unix.openfile name Unix.([O_TRUNC; O_CREAT; O_WRONLY]) perm >>= fun fd ->
Lwt_unix.write_string fd content 0 (String.length content) >>= fun _ ->
Lwt_unix.close fd
exception Exit
let termination_thread, exit_wakener = Lwt.wait ()
let exit x = Lwt.wakeup exit_wakener x; raise Exit
let () =
Lwt.async_exception_hook :=
(function
| Exit -> ()
| exn ->
Printf.eprintf "Uncaught (asynchronous) exception: %S\n%s\n%!"
(Printexc.to_string exn) (Printexc.get_backtrace ());
Lwt.wakeup exit_wakener 1)
module StringMap = Map.Make (String)
let split delim ?(limit = max_int) path =

8
src/utils/utils.mli → src/minutils/utils.mli
View File

@ -7,14 +7,6 @@
(* *)
(**************************************************************************)
val remove_dir: string -> unit Lwt.t
val create_dir: ?perm:int -> string -> unit Lwt.t
val create_file: ?perm:int -> string -> string -> unit Lwt.t
val termination_thread: int Lwt.t
val exit: int -> 'a
module StringMap : Map.S with type key = string
(** Splits a string on slashes, grouping multiple slashes, and

4
src/node/db/context.ml
View File

@ -112,7 +112,7 @@ let checkout ((module GitStore : STORE) as index) key =
GitStore.patch_context (pack (module GitStore) store v) >>= fun ctxt ->
Lwt.return (Some (Ok ctxt))
| Some bytes ->
match Data_encoding.Json.from_string (MBytes.to_string bytes) with
match Data_encoding_ezjsonm.from_string (MBytes.to_string bytes) with
| Ok (`A errors) ->
Lwt.return (Some (Error (List.map error_of_json errors)))
| Error _ | Ok _->
@ -166,7 +166,7 @@ let commit_invalid (module GitStore : STORE) block key exns =
GitStore.clone Irmin.Task.none store (Block_hash.to_b48check key) >>= function
| `Empty_head ->
GitStore.update store invalid_context_key
(MBytes.of_string @@ Data_encoding.Json.to_string @@
(MBytes.of_string @@ Data_encoding_ezjsonm.to_string @@
`A (List.map json_of_error exns))
| `Duplicated_branch | `Ok _ ->
Lwt.fail (Preexistent_context (GitStore.path, key))

4
src/node/db/store.ml
View File

@ -631,7 +631,7 @@ let read_genesis, store_genesis =
get t key >>= function
| None -> Lwt.return None
| Some v ->
match Data_encoding.Json.from_string (MBytes.to_string v) with
match Data_encoding_ezjsonm.from_string (MBytes.to_string v) with
| Error _ ->
fatal_error
"Store.read_genesis: invalid json object."
@ -643,7 +643,7 @@ let read_genesis, store_genesis =
"Store.read_genesis: cannot parse json object." in
let store t h =
set t key ( MBytes.of_string @@
Data_encoding.Json.to_string @@
Data_encoding_ezjsonm.to_string @@
Data_encoding.Json.construct genesis_encoding h ) in
(read, store)

179
src/node/net/RPC.ml
View File

@ -1,179 +0,0 @@
(**************************************************************************)
(* *)
(* Copyright (c) 2014 - 2016. *)
(* Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* All rights reserved. No warranty, explicit or implicit, provided. *)
(* *)
(**************************************************************************)
open Logging.RPC
module Arg = Resto.Arg
module Path = Resto.Path
module Description = Resto.Description
let read_answer = Resto.read_answer
let forge_request = Resto.forge_request
let service ?description ~input ~output path =
Resto.service
?description
~input:(Data_encoding.Json.convert input)
~output:(Data_encoding.Json.convert output)
path
type ('prefix, 'params, 'input, 'output) service =
('prefix, 'params, 'input, 'output) Resto.service
include RestoDirectory
(* public types *)
type server = (* hidden *)
{ shutdown : unit -> unit Lwt.t ;
mutable root : unit directory }
module ConnectionMap = Map.Make(Cohttp.Connection)
exception Invalid_method
exception Cannot_parse_body of string
(* Promise a running RPC server. Takes the port. *)
let launch port root =
(* launch the worker *)
let cancelation, canceler, _ = Lwt_utils.canceler () in
let open Cohttp_lwt_unix in
let create_stream, shutdown_stream =
let streams = ref ConnectionMap.empty in
let create _io con (s: _ Answer.stream) =
let running = ref true in
let stream =
Lwt_stream.from
(fun () ->
if not !running then Lwt.return None else
s.next () >|= function
| None -> None
| Some x -> Some (Data_encoding.Json.to_string x)) in
let shutdown () = running := false ; s.shutdown () in
streams := ConnectionMap.add con shutdown !streams ;
stream
in
let shutdown con =
try ConnectionMap.find con !streams ()
with Not_found -> () in
create, shutdown
in
let callback (io, con) req body =
(* FIXME: check inbound adress *)
let path = Utils.split_path (Uri.path (Cohttp.Request.uri req)) in
lwt_log_info "(%s) receive request to %s"
(Cohttp.Connection.to_string con) (Uri.path (Cohttp.Request.uri req)) >>= fun () ->
Lwt.catch
(fun () ->
lookup root () path >>= fun handler ->
begin
match req.meth with
| `POST -> begin
Cohttp_lwt_body.to_string body >>= fun body ->
match Data_encoding.Json.from_string body with
| Error msg -> Lwt.fail (Cannot_parse_body msg)
| Ok body -> Lwt.return (Some body)
end
| `GET -> Lwt.return None
| _ -> Lwt.fail Invalid_method
end >>= fun body ->
handler body >>= fun { Answer.code ; body } ->
let body = match body with
| Empty ->
Cohttp_lwt_body.empty
| Single json ->
Cohttp_lwt_body.of_string (Data_encoding.Json.to_string json)
| Stream s ->
let stream = create_stream io con s in
Cohttp_lwt_body.of_stream stream in
lwt_log_info "(%s) RPC %s"
(Cohttp.Connection.to_string con)
(if Cohttp.Code.is_error code
then "failed"
else "success") >>= fun () ->
Lwt.return (Response.make ~flush:true ~status:(`Code code) (), body))
(function
| Not_found | Cannot_parse _ ->
lwt_log_info "(%s) not found"
(Cohttp.Connection.to_string con) >>= fun () ->
Lwt.return (Response.make ~flush:true ~status:`Not_found (),
Cohttp_lwt_body.empty)
| Invalid_method ->
lwt_log_info "(%s) bad method"
(Cohttp.Connection.to_string con) >>= fun () ->
let headers =
Cohttp.Header.add_multi (Cohttp.Header.init ())
"Allow" ["POST"] in
Lwt.return (Response.make
~flush:true ~status:`Method_not_allowed
~headers (),
Cohttp_lwt_body.empty)
| Cannot_parse_body msg ->
lwt_log_info "(%s) can't parse RPC body"
(Cohttp.Connection.to_string con) >>= fun () ->
Lwt.return (Response.make ~flush:true ~status:`Bad_request (),
Cohttp_lwt_body.of_string msg)
| e -> Lwt.fail e)
and conn_closed (_, con) =
log_info "connection close %s" (Cohttp.Connection.to_string con) ;
shutdown_stream con in
lwt_log_info "create server listening on port %d" port >>= fun () ->
let ctx = Cohttp_lwt_unix_net.init () in
let mode = `TCP (`Port port) in
let stop = cancelation () in
let _server =
Server.create
~stop ~ctx ~mode
(Server.make ~callback ~conn_closed ()) in
let shutdown () =
canceler () >>= fun () ->
lwt_log_info "server not really stopped (cohttp bug)" >>= fun () ->
Lwt.return () (* server *) (* FIXME: bug in cohttp *) in
Lwt.return { shutdown ; root }
let root_service { root } = root
let set_root_service server root = server.root <- root
let shutdown server =
server.shutdown ()
module Error = struct
let service =
service
~description: "Schema for all the RPC errors from the shell"
~input: Data_encoding.empty
~output: Data_encoding.json_schema
Path.(root / "errors")
let encoding =
let open Data_encoding in
let path, _ = forge_request service () () in
describe
~description:
(Printf.sprintf
"The full list of error is available with \
the global RPC `/%s`" (String.concat "/" path))
(conv
~schema:Json_schema.any
(fun exn -> `A (List.map json_of_error exn))
(function `A exns -> List.map error_of_json exns | _ -> [])
json)
let wrap param_encoding =
let open Data_encoding in
union [
case
(obj1 (req "ok" param_encoding))
(function Ok x -> Some x | _ -> None)
(fun x -> Ok x) ;
case
(obj1 (req "error" encoding))
(function Error x -> Some x | _ -> None)
(fun x -> Error x) ;
]
end

158
src/node/net/RPC_server.ml Normal file
View File

@ -0,0 +1,158 @@
(**************************************************************************)
(* *)
(* Copyright (c) 2014 - 2016. *)
(* Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* All rights reserved. No warranty, explicit or implicit, provided. *)
(* *)
(**************************************************************************)
open RPC
open Logging.RPC
(* public types *)
type server = (* hidden *)
{ shutdown : unit -> unit Lwt.t ;
mutable root : unit directory }
module ConnectionMap = Map.Make(Cohttp.Connection)
exception Invalid_method
exception Cannot_parse_body of string
(* Promise a running RPC server. Takes the port. *)
let launch port ?pre_hook ?post_hook root =
(* launch the worker *)
let cancelation, canceler, _ = Lwt_utils.canceler () in
let open Cohttp_lwt_unix in
let streams = ref ConnectionMap.empty in
let create_stream _io con to_string (s: _ Answer.stream) =
let running = ref true in
let stream =
Lwt_stream.from
(fun () ->
if not !running then Lwt.return None else
s.next () >|= function
| None -> None
| Some x -> Some (to_string x)) in
let shutdown () = running := false ; s.shutdown () in
streams := ConnectionMap.add con shutdown !streams ;
stream
in
let shutdown_stream con =
try ConnectionMap.find con !streams ()
with Not_found -> () in
let call_hook (io, con) req ?(answer_404 = false) hook =
match hook with
| None -> Lwt.return None
| Some hook ->
Lwt.catch
(fun () ->
hook (Uri.path (Cohttp.Request.uri req))
>>= fun { Answer.code ; body } ->
if code = 404 && not answer_404 then
Lwt.return None
else
let body = match body with
| Answer.Empty ->
Cohttp_lwt_body.empty
| Single body ->
Cohttp_lwt_body.of_string body
| Stream s ->
let stream =
create_stream io con (fun s -> s) s in
Cohttp_lwt_body.of_stream stream in
Lwt.return_some
(Response.make ~flush:true ~status:(`Code code) (),
body))
(function
| Not_found -> Lwt.return None
| exn -> Lwt.fail exn) in
let callback (io, con) req body =
(* FIXME: check inbound adress *)
let path = Utils.split_path (Uri.path (Cohttp.Request.uri req)) in
lwt_log_info "(%s) receive request to %s"
(Cohttp.Connection.to_string con) (Uri.path (Cohttp.Request.uri req)) >>= fun () ->
Lwt.catch
(fun () ->
call_hook (io, con) req pre_hook >>= function
| Some res ->
Lwt.return res
| None ->
lookup root () path >>= fun handler ->
begin
match req.meth with
| `POST -> begin
Cohttp_lwt_body.to_string body >>= fun body ->
match Data_encoding_ezjsonm.from_string body with
| Error msg -> Lwt.fail (Cannot_parse_body msg)
| Ok body -> Lwt.return (Some body)
end
| `GET -> Lwt.return None
| _ -> Lwt.fail Invalid_method
end >>= fun body ->
handler body >>= fun { Answer.code ; body } ->
let body = match body with
| Empty ->
Cohttp_lwt_body.empty
| Single json ->
Cohttp_lwt_body.of_string (Data_encoding_ezjsonm.to_string json)
| Stream s ->
let stream =
create_stream io con Data_encoding_ezjsonm.to_string s in
Cohttp_lwt_body.of_stream stream in
lwt_log_info "(%s) RPC %s"
(Cohttp.Connection.to_string con)
(if Cohttp.Code.is_error code
then "failed"
else "success") >>= fun () ->
Lwt.return (Response.make ~flush:true ~status:(`Code code) (),
body))
(function
| Not_found | Cannot_parse _ ->
lwt_log_info "(%s) not found"
(Cohttp.Connection.to_string con) >>= fun () ->
(call_hook (io, con) req ~answer_404: true post_hook >>= function
| Some res -> Lwt.return res
| None ->
Lwt.return (Response.make ~flush:true ~status:`Not_found (),
Cohttp_lwt_body.empty))
| Invalid_method ->
lwt_log_info "(%s) bad method"
(Cohttp.Connection.to_string con) >>= fun () ->
let headers =
Cohttp.Header.add_multi (Cohttp.Header.init ())
"Allow" ["POST"] in
Lwt.return (Response.make
~flush:true ~status:`Method_not_allowed
~headers (),
Cohttp_lwt_body.empty)
| Cannot_parse_body msg ->
lwt_log_info "(%s) can't parse RPC body"
(Cohttp.Connection.to_string con) >>= fun () ->
Lwt.return (Response.make ~flush:true ~status:`Bad_request (),
Cohttp_lwt_body.of_string msg)
| e -> Lwt.fail e)
and conn_closed (_, con) =
log_info "connection close %s" (Cohttp.Connection.to_string con) ;
shutdown_stream con in
lwt_log_info "create server listening on port %d" port >>= fun () ->
let ctx = Cohttp_lwt_unix_net.init () in
let mode = `TCP (`Port port) in
let stop = cancelation () in
let _server =
Server.create
~stop ~ctx ~mode
(Server.make ~callback ~conn_closed ()) in
let shutdown () =
canceler () >>= fun () ->
lwt_log_info "server not really stopped (cohttp bug)" >>= fun () ->
Lwt.return () (* server *) (* FIXME: bug in cohttp *) in
Lwt.return { shutdown ; root }
let root_service { root } = root
let set_root_service server root = server.root <- root
let shutdown server =
server.shutdown ()

40
src/node/net/RPC_server.mli Normal file
View File

@ -0,0 +1,40 @@
(**************************************************************************)
(* *)
(* Copyright (c) 2014 - 2016. *)
(* Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* All rights reserved. No warranty, explicit or implicit, provided. *)
(* *)
(**************************************************************************)
(** Typed RPC services: server implementation. *)
(** A handle on the server worker. *)
type server
(** Promise a running RPC serve ; takes the port. To call
an RPC at /p/a/t/h/ in the provided service, one must call the URI
/call/p/a/t/h/. Calling /list/p/a/t/h/ will list the services
prefixed by /p/a/t/h/, if any. Calling /schema/p/a/t/h/ will
describe the input and output of the service, if it is
callable. Calling /pipe will read a sequence of services to call in
sequence from the request body, see {!pipe_encoding}.
The optional [pre_hook] is called with the path part of the URL
before resolving each request, to delegate the answering to
another resolution mechanism. Its result is ignored if the return
code is [404]. The optional [post_hook] is called if both the
[pre_hook] and the serviced answered with a [404] code. *)
val launch : int ->
?pre_hook: (string -> string RPC.Answer.answer Lwt.t) ->
?post_hook: (string -> string RPC.Answer.answer Lwt.t) ->
unit RPC.directory -> server Lwt.t
(** Kill an RPC server. *)
val shutdown : server -> unit Lwt.t
(** Retrieve the root service of the server *)
val root_service : server -> unit RPC.directory
(** Change the root service of the server *)
val set_root_service : server -> unit RPC.directory -> unit

4
src/node/net/p2p.ml
View File

@ -773,7 +773,7 @@ module Make (P: PARAMS) = struct
(* create the external message pipe *)
let messages = Lwt_pipe.create 100 in
(* fill the known peers pools from last time *)
Data_encoding.Json.read_file config.peers_file >>= fun res ->
Data_encoding_ezjsonm.read_file config.peers_file >>= fun res ->
let known_peers, black_list, my_gid,
my_public_key, my_secret_key, my_proof_of_work =
let init_peers () =
@ -872,7 +872,7 @@ module Make (P: PARAMS) = struct
if source.white_listed then (addr, port) :: w else w))
!known_peers ([], BlackList.bindings !black_list, []))
in
Data_encoding.Json.write_file config.peers_file json >>= fun _ ->
Data_encoding_ezjsonm.write_file config.peers_file json >>= fun _ ->
debug "(%a) peer cache saved" pp_gid my_gid ;
Lwt.return_unit) ;
(* storage of active and not yet active peers *)

2
src/node/shell/node_rpc.ml
View File

@ -433,7 +433,7 @@ let build_rpc_directory node =
let dir =
let implementation () =
RPC.Answer.return Data_encoding.Json.(schema (Error_monad.error_encoding ())) in
RPC.register0 dir RPC.Error.service implementation in
RPC.register0 dir Services.Error.service implementation in
let dir =
RPC.register1 dir Services.complete
(fun s () ->

56
src/node/shell/node_rpc_services.ml
View File

@ -9,6 +9,42 @@
open Data_encoding
module Error = struct
let service =
RPC.service
~description: "Schema for all the RPC errors from the shell"
~input: Data_encoding.empty
~output: Data_encoding.json_schema
RPC.Path.(root / "errors")
let encoding =
let path, _ = RPC.forge_request service () () in
describe
~description:
(Printf.sprintf
"The full list of error is available with \
the global RPC `/%s`" (String.concat "/" path))
(conv
~schema:Json_schema.any
(fun exn -> `A (List.map json_of_error exn))
(function `A exns -> List.map error_of_json exns | _ -> [])
json)
let wrap param_encoding =
union [
case
(obj1 (req "ok" param_encoding))
(function Ok x -> Some x | _ -> None)
(fun x -> Ok x) ;
case
(obj1 (req "error" encoding))
(function Error x -> Some x | _ -> None)
(fun x -> Error x) ;
]
end
module Blocks = struct
type block = [
@ -128,7 +164,7 @@ module Blocks = struct
(obj3
(req "timestamp" Time.encoding)
(req "fitness" Fitness.encoding)
(req "operations" (Updater.preapply_result_encoding RPC.Error.encoding))))
(req "operations" (Updater.preapply_result_encoding Error.encoding))))
let block_path : (unit, unit * block) RPC.Path.path =
RPC.Path.(root / "blocks" /: blocks_arg )
@ -237,9 +273,9 @@ module Blocks = struct
(obj4
(req "applied" (list Operation_hash.encoding))
(req "branch_delayed"
(list (tup2 Operation_hash.encoding RPC.Error.encoding)))
(list (tup2 Operation_hash.encoding Error.encoding)))
(req "branch_refused"
(list (tup2 Operation_hash.encoding RPC.Error.encoding)))
(list (tup2 Operation_hash.encoding Error.encoding)))
(req "unprocessed" (list Operation_hash.encoding))))
RPC.Path.(block_path / "pending_operations")
@ -252,7 +288,7 @@ module Blocks = struct
"Simulate the validation of a block that would contain \
the given operations and return the resulting fitness."
~input: preapply_param_encoding
~output: (RPC.Error.wrap preapply_result_encoding)
~output: (Error.wrap preapply_result_encoding)
RPC.Path.(block_path / "preapply")
let complete =
@ -365,7 +401,7 @@ module Operations = struct
(obj1 (req "data"
(describe ~title: "Tezos signed operation (hex encoded)"
(Time.timed_encoding @@
RPC.Error.wrap @@
Error.wrap @@
Updater.raw_operation_encoding))))
RPC.Path.(root / "operations" /: operations_arg)
@ -416,7 +452,7 @@ module Protocols = struct
(obj1 (req "data"
(describe ~title: "Tezos protocol"
(Time.timed_encoding @@
RPC.Error.wrap @@
Error.wrap @@
Store.protocol_encoding))))
RPC.Path.(root / "protocols" /: protocols_arg)
@ -471,7 +507,7 @@ let validate_block =
(req "net" Blocks.net_encoding)
(req "hash" Block_hash.encoding))
~output:
(RPC.Error.wrap @@ empty)
(Error.wrap @@ empty)
RPC.Path.(root / "validate_block")
let inject_block =
@ -504,7 +540,7 @@ let inject_block =
the current head. (default: false)"
bool))))
~output:
(RPC.Error.wrap @@
(Error.wrap @@
(obj1 (req "block_hash" Block_hash.encoding)))
RPC.Path.(root / "inject_block")
@ -539,7 +575,7 @@ let inject_operation =
or \"branch_delayed\". (default: false)"
bool))))
~output:
(RPC.Error.wrap @@
(Error.wrap @@
describe
~title: "Hash of the injected operation" @@
(obj1 (req "injectedOperation" Operation_hash.encoding)))
@ -592,7 +628,7 @@ let inject_protocol =
"Should we inject protocol that is invalid. (default: false)"
bool))))
~output:
(RPC.Error.wrap @@
(Error.wrap @@
describe
~title: "Hash of the injected protocol" @@
(obj1 (req "injectedProtocol" Protocol_hash.encoding)))

7
src/node/shell/node_rpc_services.mli
View File

@ -7,6 +7,12 @@
(* *)
(**************************************************************************)
module Error : sig
val service: (unit, unit, unit, Json_schema.schema) RPC.service
val encoding: error list Data_encoding.t
val wrap: 'a Data_encoding.t -> 'a tzresult Data_encoding.encoding
end
module Blocks : sig
type block = [
@ -15,6 +21,7 @@ module Blocks : sig
| `Test_head of int | `Test_prevalidation
| `Hash of Block_hash.t
]
val blocks_arg : block RPC.Arg.arg
val parse_block: string -> (block, string) result
type net = Store.net_id = Net of Block_hash.t

8
src/node/updater/updater.ml
View File

@ -140,18 +140,18 @@ type component = Tezos_compiler.Protocol.component = {
}
let create_files dir units =
Utils.remove_dir dir >>= fun () ->
Utils.create_dir dir >>= fun () ->
Lwt_utils.remove_dir dir >>= fun () ->
Lwt_utils.create_dir dir >>= fun () ->
Lwt_list.map_s
(fun { name; interface; implementation } ->
let name = String.lowercase_ascii name in
let ml = dir // (name ^ ".ml") in
let mli = dir // (name ^ ".mli") in
Utils.create_file ml implementation >>= fun () ->
Lwt_utils.create_file ml implementation >>= fun () ->
match interface with
| None -> Lwt.return [ml]
| Some content ->
Utils.create_file mli content >>= fun () ->
Lwt_utils.create_file mli content >>= fun () ->
Lwt.return [mli;ml])
units >>= fun files ->
let files = List.concat files in

21
src/node_main.ml
View File

@ -206,14 +206,15 @@ module Cfg_file = struct
(req "log" log))
let read fp =
let open Data_encoding.Json in
read_file fp >|= function
Data_encoding_ezjsonm.read_file fp >|= function
| None -> None
| Some json -> Some (destruct t json)
| Some json -> Some (Data_encoding.Json.destruct t json)
let from_json json = Data_encoding.Json.destruct t json
let write out cfg =
Utils.write_file ~bin:false out Data_encoding.Json.(construct t cfg |> to_string)
Utils.write_file ~bin:false out
(Data_encoding.Json.construct t cfg |>
Data_encoding_ezjsonm.to_string)
end
module Cmdline = struct
@ -289,7 +290,7 @@ module Cmdline = struct
default_cfg_of_base_dir base_dir
in
let cfg =
match Utils.read_file ~bin:false config_file |> Data_encoding.Json.from_string with
match Utils.read_file ~bin:false config_file |> Data_encoding_ezjsonm.from_string with
| exception _ -> no_config ()
| Error msg -> corrupted_config msg
| Ok cfg -> try Cfg_file.from_json cfg with
@ -382,7 +383,7 @@ let init_node { sandbox ; sandbox_param ;
match sandbox_param with
| None -> Lwt.return (Some (patch_context None))
| Some file ->
Data_encoding.Json.read_file file >>= function
Data_encoding_ezjsonm.read_file file >>= function
| None ->
lwt_warn
"Can't parse sandbox parameters. (%s)" file >>= fun () ->
@ -427,11 +428,11 @@ let init_rpc { rpc_addr } node =
| Some (_addr, port) ->
lwt_log_notice "Starting the RPC server listening on port %d." port >>= fun () ->
let dir = Node_rpc.build_rpc_directory node in
RPC.(launch port dir) >>= fun server ->
RPC_server.launch port dir >>= fun server ->
Lwt.return (Some server)
let init_signal () =
let handler id = try Utils.exit id with _ -> () in
let handler id = try Lwt_exit.exit id with _ -> () in
ignore (Lwt_unix.on_signal Sys.sigint handler : Lwt_unix.signal_handler_id)
let main cfg =
@ -444,11 +445,11 @@ let main cfg =
init_rpc cfg node >>= fun rpc ->
init_signal ();
lwt_log_notice "The Tezos node is now running!" >>= fun () ->
Utils.termination_thread >>= fun x ->
Lwt_exit.termination_thread >>= fun x ->
lwt_log_notice "Shutting down the Tezos node..." >>= fun () ->
Node.shutdown node >>= fun () ->
lwt_log_notice "Shutting down the RPC server..." >>= fun () ->
Lwt_utils.may RPC.shutdown rpc >>= fun () ->
Lwt_utils.may RPC_server.shutdown rpc >>= fun () ->
lwt_log_notice "BYE (%d)" x >>= fun () ->
return ()

12
src/proto/bootstrap/storage.ml
View File

@ -16,19 +16,19 @@ let prevalidation_key = [ version ; "prevalidation" ]
type t = Storage_functors.context
type error += Invalid_sandbox_parameter of string
type error += Invalid_sandbox_parameter
let get_sandboxed c =
Context.get c sandboxed_key >>= function
| None -> return None
| Some json ->
match Data_encoding.Json.from_string (MBytes.to_string json) with
| Error err -> fail (Invalid_sandbox_parameter err)
| Ok json -> return (Some json)
| Some bytes ->
match Data_encoding.Binary.of_bytes Data_encoding.json bytes with
| None -> fail Invalid_sandbox_parameter
| Some json -> return (Some json)
let set_sandboxed c json =
Context.set c sandboxed_key
(MBytes.of_string (Data_encoding.Json.to_string json))
(Data_encoding.Binary.to_bytes Data_encoding.json json)
let prepare (c : Context.t) : t tzresult Lwt.t =
get_sandboxed c >>=? fun sandbox ->

7
src/proto/environment/data_encoding.mli
View File

@ -170,13 +170,6 @@ val mu : string -> ('a encoding -> 'a encoding) -> 'a encoding
module Json : sig
(** Read a JSON document from a string. *)
val from_string : string -> (json, string) result
(** Write a JSON document to a string. This goes via an intermediate
buffer and so may be slow on large documents. *)
val to_string : json -> string
val schema : 'a encoding -> json_schema
val construct : 't encoding -> 't -> json
val destruct : 't encoding -> json -> 't

349
src/utils/cli_entries.ml
View File

@ -16,21 +16,30 @@ exception Command_not_found
exception Bad_argument of int * string * string
exception Command_failed of string
(* A simple structure for command interpreters. *)
type 'a params =
| Prefix : string * 'a params -> 'a params
| Param : string * string * (string -> 'p Lwt.t) * 'a params -> ('p -> 'a) params
| Stop : (unit -> unit Lwt.t) params
| More : (string list -> unit Lwt.t) params
| Seq : string * string * (string -> 'p Lwt.t) -> ('p list -> unit Lwt.t) params
(* 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
| Param : string * string *
(string -> 'p Lwt.t) *
('a, 'arg, 'ret) tparams ->
('p -> 'a, 'arg, 'ret) tparams
| Stop :
('arg -> 'ret Lwt.t, 'arg, 'ret) tparams
| More :
(string list -> 'arg -> 'ret Lwt.t, 'arg, 'ret) tparams
| Seq : string * string *
(string -> 'p Lwt.t) ->
('p list -> 'arg -> 'ret Lwt.t, 'arg, 'ret) tparams
(* A command wraps a callback with its type and info *)
and command =
and ('arg, 'ret) tcommand =
| Command
: 'a params * 'a *
: ('a, 'arg, 'ret) tparams * 'a *
desc option * tag list * group option *
(Arg.key * Arg.spec * Arg.doc) list
-> command
-> ('arg, 'ret) tcommand
and desc = string
and group = string
@ -77,25 +86,15 @@ let command ?desc ?(tags = []) ?group ?(args = []) params cb =
(* Param combinators *)
let string n desc next = param n desc (fun s -> return s) next
(* Error combinators for use in commands *)
let kasprintf cont fmt =
let buffer = Buffer.create 100 in
let ppf = Format.formatter_of_buffer buffer in
Format.kfprintf (fun ppf ->
Format.fprintf ppf "%!";
cont (Buffer.contents buffer))
ppf fmt
let error fmt = kasprintf (fun msg -> Lwt.fail (Command_failed msg)) fmt
let message fmt = kasprintf (Format.eprintf "%s\n%!") fmt
let answer fmt = kasprintf (Format.printf "%s\n%!") fmt
let param_error fmt = kasprintf (fun msg -> Lwt.fail (Failure msg)) fmt
(* Command execution *)
let exec (Command (params, cb, _, _, _, _)) args =
let exec
(type arg) (type ret)
(Command (params, cb, _, _, _, _)) (last : arg) args =
let rec exec
: type a. int -> a params -> a -> string list -> unit Lwt.t = fun i params cb args ->
: type a. int -> (a, arg, ret) tparams -> a -> string list -> ret Lwt.t
= fun i params cb args ->
match params, args with
| Stop, [] -> cb ()
| Stop, [] -> cb last
| Stop, _ -> Lwt.fail Command_not_found
| Seq (_, _, f), seq ->
let rec do_seq i acc = function
@ -108,8 +107,8 @@ let exec (Command (params, cb, _, _, _, _)) args =
| exn -> Lwt.fail exn) >>= fun v ->
do_seq (succ i) (v :: acc) rest in
do_seq i [] seq >>= fun parsed ->
cb parsed
| More, rest -> cb rest
cb parsed last
| More, rest -> cb rest last
| Prefix (n, next), p :: rest when n = p ->
exec (succ i) next cb rest
| Param (_, _, f, next), p :: rest ->
@ -122,116 +121,125 @@ let exec (Command (params, cb, _, _, _, _)) args =
| _ -> Lwt.fail Command_not_found
in exec 1 params cb args
module Command_tree = struct
type level =
{ stop : command option ;
prefix : (string * tree) list }
and param_level =
{ stop : command option ;
tree : tree }
and tree =
| TPrefix of level
| TParam of param_level
| TStop of command
| TMore of command
| TEmpty
let insert root (Command (params, _, _, _, _, _) as command) =
let rec insert_tree
: type a. tree -> a params -> tree
= fun t c -> match t, c with
| TEmpty, Stop -> TStop command
| TEmpty, More -> TMore command
| TEmpty, Seq _ -> TMore command
| TEmpty, Param (_, _, _, next) ->
TParam { tree = insert_tree TEmpty next ; stop = None }
| TEmpty, Prefix (n, next) ->
TPrefix { stop = None ; prefix = [ (n, insert_tree TEmpty next) ] }
| TStop command, Param (_, _, _, next) ->
TParam { tree = insert_tree TEmpty next ; stop = Some command }
| TStop command, Prefix (n, next) ->
TPrefix { stop = Some command ;
prefix = [ (n, insert_tree TEmpty next) ] }
| TParam t, Param (_, _, _, next) ->
TParam { t with tree = insert_tree t.tree next }
| TPrefix ({ prefix } as l), Prefix (n, next) ->
let rec insert_prefix = function
| [] -> [ (n, insert_tree TEmpty next) ]
| (n', t) :: rest when n = n' -> (n, insert_tree t next) :: rest
| item :: rest -> item :: insert_prefix rest in
TPrefix { l with prefix = insert_prefix prefix }
| TPrefix ({ stop = None } as l), Stop ->
TPrefix { l with stop = Some command }
| TParam ({ stop = None } as l), Stop ->
TParam { l with stop = Some command }
| _, _ ->
Pervasives.failwith
"Cli_entries.Command_tree.insert: conflicting commands" in
insert_tree root params
let make commands =
List.fold_left insert TEmpty commands
let dispatcher tree args =
let rec loop = function
| TStop c, [] -> exec c args
| TPrefix { stop = Some c }, [] -> exec c args
| TMore c, _ -> exec c args
| TPrefix { prefix }, n :: rest ->
begin try
let t = List.assoc n prefix in
loop (t, rest)
with Not_found -> Lwt.fail Command_not_found end
| TParam { tree }, _ :: rest ->
loop (tree, rest)
| _, _ -> Lwt.fail Command_not_found
in
loop (tree, args)
let inline_dispatcher tree () =
let state = ref (tree, []) in
fun arg -> match !state, arg with
| (( TStop c |
TMore c |
TPrefix { stop = Some c } |
TParam { stop = Some c}), acc),
`End ->
state := (TEmpty, []) ;
`Res (exec c (List.rev acc))
| (TMore c, acc), `Arg n ->
state := (TMore c, n :: acc) ;
`Nop
| (TPrefix { prefix }, acc), `Arg n ->
begin try
let t = List.assoc n prefix in
state := (t, n :: acc) ;
begin match t with
| 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
| _ -> `Nop end
| _, _ -> `Fail Command_not_found
end
(* Command dispatch tree *)
type ('arg, 'ret) level =
{ stop : ('arg, 'ret) tcommand option ;
prefix : (string * ('arg, 'ret) tree) list }
and ('arg, 'ret) param_level =
{ stop : ('arg, 'ret) tcommand 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
| TEmpty
let insert_in_dispatch_tree
(type arg) (type ret)
root (Command (params, _, _, _, _, _) as command) =
let rec insert_tree
: type a. (arg, ret) tree -> (a, arg, ret) tparams -> (arg, ret) tree
= fun t c -> match t, c with
| TEmpty, Stop -> TStop command
| TEmpty, More -> TMore command
| TEmpty, Seq _ -> TMore command
| TEmpty, Param (_, _, _, next) ->
TParam { tree = insert_tree TEmpty next ; stop = None }
| TEmpty, Prefix (n, next) ->
TPrefix { stop = None ; prefix = [ (n, insert_tree TEmpty next) ] }
| TStop command, Param (_, _, _, next) ->
TParam { tree = insert_tree TEmpty next ; stop = Some command }
| TStop command, Prefix (n, next) ->
TPrefix { stop = Some command ;
prefix = [ (n, insert_tree TEmpty next) ] }
| TParam t, Param (_, _, _, next) ->
TParam { t with tree = insert_tree t.tree next }
| TPrefix ({ prefix } as l), Prefix (n, next) ->
let rec insert_prefix = function
| [] -> [ (n, insert_tree TEmpty next) ]
| (n', t) :: rest when n = n' -> (n, insert_tree t next) :: rest
| item :: rest -> item :: insert_prefix rest in
TPrefix { l with prefix = insert_prefix prefix }
| TPrefix ({ stop = None } as l), Stop ->
TPrefix { l with stop = Some command }
| TParam ({ stop = None } as l), Stop ->
TParam { l with stop = Some command }
| _, _ ->
Pervasives.failwith
"Cli_entries.Command_tree.insert: conflicting commands" in
insert_tree root params
let make_dispatch_tree commands =
List.fold_left insert_in_dispatch_tree TEmpty commands
let tree_dispatch tree last args =
let rec loop = function
| TStop c, [] -> exec c last args
| TPrefix { stop = Some c }, [] -> exec c last args
| TMore c, _ -> exec c last args
| TPrefix { prefix }, n :: rest ->
begin try
let t = List.assoc n prefix in
loop (t, rest)
with Not_found -> Lwt.fail Command_not_found end
| TParam { tree }, _ :: rest ->
loop (tree, rest)
| _, _ -> Lwt.fail Command_not_found
in
loop (tree, args)
let inline_tree_dispatch tree last =
let state = ref (tree, []) in
fun arg -> match !state, arg with
| (( TStop c |
TMore c |
TPrefix { stop = Some c } |
TParam { stop = Some c}), acc),
`End ->
state := (TEmpty, []) ;
`Res (exec c last (List.rev acc))
| (TMore c, acc), `Arg n ->
state := (TMore c, n :: acc) ;
`Nop
| (TPrefix { prefix }, acc), `Arg n ->
begin try
let t = List.assoc n prefix in
state := (t, n :: acc) ;
begin match t with
| 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
| _ -> `Nop end
| _, _ -> `Fail Command_not_found
(* Try a list of commands on a list of arguments *)
let dispatcher commands =
let tree = Command_tree.make commands in
fun args -> Command_tree.dispatcher tree args
let dispatch commands =
let tree = make_dispatch_tree commands in
tree_dispatch tree
(* Argument-by-argument dispatcher to be used during argument parsing *)
let inline_dispatcher commands =
let tree = Command_tree.make commands in
Command_tree.inline_dispatcher tree
let inline_dispatch commands =
let tree = make_dispatch_tree commands in
inline_tree_dispatch tree
(* Command line help for a set of commands *)
let usage commands options =
let usage
(type arg) (type ret)
commands options =
let trim s = (* config-file wokaround *)
Utils.split '\n' s |>
List.map String.trim |>
String.concat "\n" in
let rec help : type a. Format.formatter -> a params -> unit = fun ppf -> function
let rec help
: type a. Format.formatter -> (a, arg, ret) tparams -> unit
= fun ppf -> function
| Stop -> ()
| More -> Format.fprintf ppf "..."
| Seq (n, "", _) -> Format.fprintf ppf "[ (%s) ...]" n
@ -242,7 +250,9 @@ let usage commands options =
| Prefix (n, next) -> Format.fprintf ppf "%s %a" n help next
| 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 params -> unit = fun ppf -> function
let rec help_sum
: type a. Format.formatter -> (a, arg, ret) tparams -> unit
= fun ppf -> function
| Stop -> ()
| More -> Format.fprintf ppf "..."
| Seq (n, _, _) -> Format.fprintf ppf "[ (%s) ... ]" n
@ -250,13 +260,21 @@ let usage commands options =
| Param (n, _, _, Stop) -> Format.fprintf ppf "(%s)" n
| 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 params -> unit = fun ppf -> function
| Stop -> ()
| More -> Format.fprintf ppf "..."
| Seq (n, desc, _) -> Format.fprintf ppf "(%s): @[<hov>%a@]" n Format.pp_print_text (trim desc)
| Prefix (_, next) -> help_args ppf next
| Param (n, desc, _, Stop) -> Format.fprintf ppf "(%s): @[<hov>%a@]" n Format.pp_print_text (trim desc)
| Param (n, desc, _, next) -> Format.fprintf ppf "(%s): @[<hov>%a@]@,%a" n Format.pp_print_text (trim desc) help_args next in
let rec help_args
: type a. Format.formatter -> (a, arg, ret) tparams -> unit
= fun ppf -> function
| Stop -> ()
| More -> Format.fprintf ppf "..."
| Seq (n, desc, _) ->
Format.fprintf ppf "(%s): @[<hov>%a@]"
n Format.pp_print_text (trim desc)
| Prefix (_, next) -> help_args ppf next
| Param (n, desc, _, Stop) ->
Format.fprintf ppf "(%s): @[<hov>%a@]"
n Format.pp_print_text (trim desc)
| Param (n, desc, _, next) ->
Format.fprintf ppf "(%s): @[<hov>%a@]@,%a"
n Format.pp_print_text (trim desc) help_args next in
let option_help ppf (n, opt, desc) =
Format.fprintf ppf "%s%s" n
Arg.(let rec example opt = match opt with
@ -277,27 +295,38 @@ let usage commands options =
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
if String.length small < 50 then begin
Format.fprintf ppf "@[<v 2>%s@,@[<hov>%a@]"
small
Format.pp_print_text (match desc with None -> "undocumented command" | Some desc -> trim desc)
small Format.pp_print_text desc
end else begin
Format.fprintf ppf "@[<v 2>%a@,@[<hov 0>%a@]@,%a"
help_sum p
Format.pp_print_text (match desc with None -> "undocumented command" | Some desc -> trim desc)
Format.pp_print_text desc
help_args p ;
end ;
if options = [] then
Format.fprintf ppf "@]"
else
Format.fprintf ppf "@,%a@]" (Format.pp_print_list option_help) options in
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
Format.fprintf ppf "@[<v 2>%s:@,%a@]"
(match n with None -> "Miscellaneous commands" | Some n -> group_title n)
title
(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 ]@]@,@[<v 2>Options:@,%a@]@,%a@]"
"@[<v>@[<v 2>Usage:@,%s [ options ] command [ command options ]@]@,\
@[<v 2>Options:@,%a@]@,\
%a@]"
Sys.argv.(0)
(Format.pp_print_list option_help) options
(Format.pp_print_list group_help) by_group in
@ -312,3 +341,39 @@ let usage commands options =
(g, ref [ c ]) :: acc)
[] commands |> List.sort compare 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

42
src/utils/cli_entries.mli
View File

@ -14,29 +14,13 @@ exception Command_not_found
exception Bad_argument of int * string * string
exception Command_failed of string
type 'a params =
| Prefix: string * 'a params -> 'a params
| Param: string * string * (string -> 'p Lwt.t) * 'a params -> ('p -> 'a) params
| Stop: (unit -> unit Lwt.t) params
| More: (string list -> unit Lwt.t) params
| Seq : string * string * (string -> 'p Lwt.t) -> ('p list -> unit Lwt.t) params
and command =
| Command
: 'a params * 'a *
desc option * tag list * group option *
(Arg.key * Arg.spec * Arg.doc) list
-> command
type 'a params
type command
and desc = string
and group = string
and tag = string
val error: ('a, Format.formatter, unit, 'b Lwt.t) format4 -> 'a
val param_error: ('a, Format.formatter, unit, 'b Lwt.t) format4 -> 'a
val message: ('a, Format.formatter, unit, unit) format4 -> 'a
val answer: ('a, Format.formatter, unit, unit) format4 -> 'a
val param:
name: string ->
desc: string ->
@ -49,12 +33,13 @@ val stop: (unit -> unit Lwt.t) params
val seq:
name: string ->
desc: string ->
(string -> 'p Lwt.t) -> ('p list -> unit Lwt.t) params
(string -> 'p Lwt.t) ->
('p list -> unit -> unit Lwt.t) params
(* [seq_of_param (param ~name ~desc f) = seq ~name ~desc f] *)
val seq_of_param:
((unit -> unit Lwt.t) params -> ('a -> unit -> unit Lwt.t) params) ->
('a list -> unit Lwt.t) params
((unit -> unit Lwt.t) params ->
('a -> unit -> unit Lwt.t) params) ->
('a list -> unit -> unit Lwt.t) params
val command:
?desc:desc ->
@ -68,7 +53,7 @@ val register_tag: tag -> string -> unit
val usage:
command list -> (string * Arg.spec * string) list -> string
val inline_dispatcher:
val inline_dispatch:
command list ->
unit ->
[> `Arg of string | `End ] ->
@ -76,3 +61,14 @@ val inline_dispatcher:
| `Fail of exn
| `Nop
| `Res of unit 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

56
src/utils/data_encoding_ezjsonm.ml Normal file
View File

@ -0,0 +1,56 @@
(**************************************************************************)
(* *)
(* Copyright (c) 2014 - 2016. *)
(* Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* All rights reserved. No warranty, explicit or implicit, provided. *)
(* *)
(**************************************************************************)
let to_root = function
| `O ctns -> `O ctns
| `A ctns -> `A ctns
| `Null -> `O []
| oth -> `A [ oth ]
let to_string j = Ezjsonm.to_string ~minify:false (to_root j)
let from_string s =
try Ok (Ezjsonm.from_string s :> Data_encoding.json)
with Ezjsonm.Parse_error (_, msg) -> Error msg
let from_stream (stream: string Lwt_stream.t) =
let buffer = ref "" in
Lwt_stream.filter_map
(fun str ->
buffer := !buffer ^ str ;
try
let json = Ezjsonm.from_string !buffer in
buffer := "" ;
Some (Ok json)
with Ezjsonm.Parse_error (_, msg) ->
if String.length str = 32 * 1024 then None
else Some (Error msg))
stream
let write_file file json =
let json = to_root json in
let open Lwt in
catch
(fun () ->
Lwt_io.(with_file ~mode:Output file (fun chan ->
let str = to_string json in
write chan str >>= fun _ ->
return true)))
(fun _ -> return false)
let read_file file =
let open Lwt in
catch
(fun () ->
Lwt_io.(with_file ~mode:Input file (fun chan ->
read chan >>= fun str ->
return (Some (Ezjsonm.from_string str :> Data_encoding.json)))))
(fun _ ->
(* TODO log error or use Error_monad. *)
return None)

26
src/utils/data_encoding_ezjsonm.mli 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. *)
(* *)
(**************************************************************************)
(** Read a JSON document from a string. *)
val from_string : string -> (Data_encoding.json, string) result
(** Read a stream of JSON documents from a stream of strings.
A single JSON document may be represented in multiple consecutive
strings. But only the first document of a string is considered. *)
val from_stream : string Lwt_stream.t -> (Data_encoding.json, string) result Lwt_stream.t
(** Write a JSON document to a string. This goes via an intermediate
buffer and so may be slow on large documents. *)
val to_string : Data_encoding.json -> string
(** Loads a JSON file in memory *)
val read_file : string -> Data_encoding.json option Lwt.t
(** (Over)write a JSON file from in memory data *)
val write_file : string -> Data_encoding.json -> bool Lwt.t

2
src/utils/error_monad.ml
View File

@ -18,7 +18,7 @@ type 'err full_error_category =
let json_pp encoding ppf x =
Format.pp_print_string ppf @@
Data_encoding.Json.to_string @@
Data_encoding_ezjsonm.to_string @@
Data_encoding.Json.(construct encoding x)
module Make() = struct

2
src/utils/logging.ml
View File

@ -54,7 +54,7 @@ module Make(S : sig val name: string end) : LOG = struct
let log_error fmt = ign_log_f ~section ~level:Lwt_log.Error fmt
let fatal_error fmt =
Format.kasprintf
(fun s -> Lwt_log.ign_fatal ~section s; Utils.exit 1)
(fun s -> Lwt_log.ign_fatal ~section s; Lwt_exit.exit 1)
fmt
let lwt_debug fmt = log_f ~section ~level:Lwt_log.Debug fmt

23
src/utils/lwt_exit.ml Normal file
View File

@ -0,0 +1,23 @@
(**************************************************************************)
(* *)
(* Copyright (c) 2014 - 2016. *)
(* Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* All rights reserved. No warranty, explicit or implicit, provided. *)
(* *)
(**************************************************************************)
exception Exit
let termination_thread, exit_wakener = Lwt.wait ()
let exit x = Lwt.wakeup exit_wakener x; raise Exit
let () =
Lwt.async_exception_hook :=
(function
| Exit -> ()
| exn ->
Printf.eprintf "Uncaught (asynchronous) exception: %S\n%s\n%!"
(Printexc.to_string exn) (Printexc.get_backtrace ());
Lwt.wakeup exit_wakener 1)

18
src/utils/lwt_exit.mli Normal file
View File

@ -0,0 +1,18 @@
(**************************************************************************)
(* *)
(* Copyright (c) 2014 - 2016. *)
(* Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* All rights reserved. No warranty, explicit or implicit, provided. *)
(* *)
(**************************************************************************)
(** A global thread that resumes the first time {!exit} is called
anywhere in the program. Called by the main to wait for any other
thread in the system to call {!exit}. *)
val termination_thread: int Lwt.t
(** Awakens the {!termination_thread} with the given return value, and
raises an exception that cannot be caught, except by a
catch-all. Should only be called once. *)
val exit: int -> 'a

34
src/utils/lwt_utils.ml
View File

@ -263,3 +263,37 @@ let write_mbytes ?(pos=0) ?len descr buf =
| nb_written -> inner (pos + nb_written) (len - nb_written) in
inner pos len
let (>>=) = Lwt.bind
let remove_dir dir =
let rec remove dir =
let files = Lwt_unix.files_of_directory dir in
Lwt_stream.iter_s
(fun file ->
if file = "." || file = ".." then
Lwt.return ()
else begin
let file = Filename.concat dir file in
if Sys.is_directory file
then remove file
else Lwt_unix.unlink file
end)
files >>= fun () ->
Lwt_unix.rmdir dir in
if Sys.file_exists dir && Sys.is_directory dir then
remove dir
else
Lwt.return ()
let rec create_dir ?(perm = 0o755) dir =
if Sys.file_exists dir then
Lwt.return ()
else begin
create_dir (Filename.dirname dir) >>= fun () ->
Lwt_unix.mkdir dir perm
end
let create_file ?(perm = 0o644) name content =
Lwt_unix.openfile name Unix.([O_TRUNC; O_CREAT; O_WRONLY]) perm >>= fun fd ->
Lwt_unix.write_string fd content 0 (String.length content) >>= fun _ ->
Lwt_unix.close fd

4
src/utils/lwt_utils.mli
View File

@ -35,3 +35,7 @@ val read_mbytes:
val write_mbytes:
?pos:int -> ?len:int -> Lwt_unix.file_descr -> MBytes.t -> unit Lwt.t
val remove_dir: string -> unit Lwt.t
val create_dir: ?perm:int -> string -> unit Lwt.t
val create_file: ?perm:int -> string -> string -> unit Lwt.t

2
test/.merlin
View File

@ -1,6 +1,8 @@
REC
S .
B .
S ../src/minutils
B ../src/minutils
S ../src/utils
B ../src/utils
S ../src/node/db

8
test/Makefile
View File

@ -13,6 +13,7 @@ OCAMLFLAGS = \
SOURCE_DIRECTORIES := \
lib \
$(addprefix ../src/, \
minutils \
utils \
compiler \
node/db \
@ -37,7 +38,7 @@ PACKAGES := \
lwt.unix \
ocplib-endian \
ocplib-ocamlres \
ocplib-json-typed \
ocplib-json-typed.bson \
ocplib-resto.directory \
sodium \
unix \
@ -47,7 +48,9 @@ PACKAGES := \
############################################################################
## External packages
NODELIB := ../src/utils.cmxa ../src/compiler.cmxa ../src/node.cmxa
NODELIB := \
../src/minutils.cmxa ../src/utils.cmxa \
../src/compiler.cmxa ../src/node.cmxa
CLIENTLIB := ../src/client.cmxa \
$(patsubst ../src/client/embedded/%/, \
../src/proto/client_embedded_proto_%.cmxa, \
@ -221,6 +224,7 @@ COVERAGESRCDIR= \
-I ../src/proto \
-I ../src/proto/bootstrap \
-I ../src/proto/demo \
-I ../src/minutils \
-I ../src/utils
bisect:

12
test/test_basic.ml
View File

@ -13,7 +13,17 @@ open Tezos_context
open Error_monad
open Hash
let () = Random.self_init ()
let () =
Random.self_init () ;
let log channel msg = match channel with
| "stdout" ->
print_endline msg ;
Lwt.return ()
| "stderr" ->
prerr_endline msg ;
Lwt.return ()
| _ -> Lwt.return () in
Cli_entries.log_hook := Some log
let should_fail f t =
t >>= function

13
test/test_data_encoding.ml
View File

@ -104,15 +104,16 @@ let test_simple_values _ =
Lwt.return_unit
let test_json testdir =
let open Data_encoding_ezjsonm in
let file = testdir // "testing_data_encoding.tezos" in
let v = `Float 42. in
let f_str = Json.to_string v in
let f_str = to_string v in
Assert.equal_string ~msg:__LOC__ f_str "[\n 42\n]";
Json.read_file (testdir // "NONEXISTINGFILE") >>= fun rf ->
read_file (testdir // "NONEXISTINGFILE") >>= fun rf ->
Assert.is_none ~msg:__LOC__ rf;
Json.write_file file v >>= fun success ->
write_file file v >>= fun success ->
Assert.is_true ~msg:__LOC__ success;
Json.read_file file >>= fun opt ->
read_file file >>= fun opt ->
Assert.is_some ~msg:__LOC__ opt;
Lwt.return ()
@ -267,7 +268,7 @@ let test_json_input testdir =
}
|}
in
Json.read_file file >>= function
Data_encoding_ezjsonm.read_file file >>= function
None -> Assert.fail_msg "Cannot parse \"good.json\"."
| Some json ->
let (id, value, popup) = Json.destruct enc json in
@ -293,7 +294,7 @@ let test_json_input testdir =
}
|}
in
Json.read_file file >>= function
Data_encoding_ezjsonm.read_file file >>= function
None -> Assert.fail_msg "Cannot parse \"unknown.json\"."
| Some json ->
Assert.test_fail ~msg:__LOC__