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

Extract the js_of_ocaml compatible part of utils.

Browse Source
This commit is contained in:
Benjamin Canou 2016-12-01 18:27:53 +01:00
parent 69f682357f
commit e7c39578b4
48 changed files with 458 additions and 340 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) \

6
src/client/client_aliases.ml
View File

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

2
src/client/client_config.ml
View File

@ -135,7 +135,7 @@ let parse_args ?version usage dispatcher =
(* parse once again with contextual options *)
Arg.parse_argv_dynamic
~current:(ref 0) Sys.argv args (anon dispatch) (usage base_args) ;
Utils.create_dir (Filename.dirname config_file#get) >>= fun () ->
Lwt_utils.create_dir (Filename.dirname config_file#get) >>= fun () ->
file_group#write config_file#get ;
Lwt.return ()
with Sys_error msg ->

10
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 () =
@ -286,8 +286,8 @@ let schema url () =
Client_node_rpcs.describe ~recurse:false args >>= function
| Static { service = Some { input ; output } } ->
Cli_entries.message "Input schema:\n%s\nOutput schema:\n%s\n%!"
(Data_encoding.Json.to_string (Json_schema.to_json input))
(Data_encoding.Json.to_string (Json_schema.to_json output))
(Data_encoding_ezjsonm.to_string (Json_schema.to_json input))
(Data_encoding_ezjsonm.to_string (Json_schema.to_json output))
| _ ->
Cli_entries.message
"No service found at this URL (but this is a valid prefix)\n%!"
@ -309,7 +309,7 @@ let call url () =
error "%s" msg
| Ok json ->
Client_node_rpcs.get_json args json >>= fun json ->
Cli_entries.message "Output:\n%s\n%!" (Data_encoding.Json.to_string json)
Cli_entries.message "Output:\n%s\n%!" (Data_encoding_ezjsonm.to_string json)
end
| _ ->
Cli_entries.message

10
src/client/client_node_rpcs.ml
View File

@ -29,7 +29,7 @@ let make_request service json =
^ ":" ^ string_of_int Client_config.incoming_port#get in
let string_uri = String.concat "/" (serv :: service) in
let uri = Uri.of_string string_uri in
let reqbody = Data_encoding.Json.to_string json in
let reqbody = Data_encoding_ezjsonm.to_string json in
let tzero = Unix.gettimeofday () in
catch
(fun () ->
@ -61,7 +61,7 @@ let get_streamed_json service json =
lwt_log_error
"Failed to parse json: %s" msg >>= fun () ->
Lwt.return None)
(Data_encoding.Json.from_stream ansbody))
(Data_encoding_ezjsonm.from_stream ansbody))
| err, _ansbody ->
(if Client_config.print_timings#get then
message "Request to /%s failed in %gs"
@ -83,7 +83,7 @@ let get_json service json =
else Lwt.return ()) >>= fun () ->
log_response cpt code ansbody >>= fun () ->
if ansbody = "" then Lwt.return `Null
else match Data_encoding.Json.from_string ansbody with
else match Data_encoding_ezjsonm.from_string ansbody with
| Error _ -> error "the RPC server returned malformed JSON"
| Ok res -> Lwt.return res
end
@ -103,7 +103,7 @@ let parse_answer service path json =
match RPC.read_answer service json with
| Error msg -> (* TODO print_error *)
error "request to /%s returned wrong JSON (%s)\n%s"
(String.concat "/" path) msg (Data_encoding.Json.to_string json)
(String.concat "/" path) msg (Data_encoding_ezjsonm.to_string json)
| Ok v -> return v
let call_service0 service arg =
@ -124,7 +124,7 @@ let call_streamed_service0 service arg =
Lwt_stream.map_s (parse_answer service path) st
module Services = Node_rpc_services
let errors = call_service0 RPC.Error.service
let errors = call_service0 Services.Error.service
let forge_block ?net ?predecessor ?timestamp fitness ops header =
call_service0 Services.forge_block
(net, predecessor, timestamp, fitness, ops, header)

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

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

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

2
src/client_main.ml
View File

@ -24,7 +24,7 @@ let () =
prerr_endline msg ;
Lwt.return ()
| log ->
Utils.create_dir Client_config.(base_dir#get // "logs" // log) >>= fun () ->
Lwt_utils.create_dir Client_config.(base_dir#get // "logs" // log) >>= fun () ->
Lwt_io.with_file
~flags: Unix.[ O_APPEND ; O_CREAT ; O_WRONLY ]
~mode: Lwt_io.Output

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

47
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
@ -278,40 +274,9 @@ val register_describe_directory_service:
('prefix, 'prefix, bool option, Description.directory_descr) service ->
'prefix directory
(** A handle on the server worker. *)
type server
exception Cannot_parse of Arg.descr * string * string list
(** Promise a running RPC serve ; takes the port. To call
an RPC at /p/a/t/h/ in the provided service, one must call the URI
/call/p/a/t/h/. Calling /list/p/a/t/h/ will list the services
prefixed by /p/a/t/h/, if any. Calling /schema/p/a/t/h/ will
describe the input and output of the service, if it is
callable. Calling /pipe will read a sequence of services to call in
sequence from the request body, see {!pipe_encoding}.
The optional [pre_hook] is called with the path part of the URL
before resolving each request, to delegate the answering to
another resolution mechanism. Its result is ignored if the return
code is [404]. The optional [post_hook] is called if both the
[pre_hook] and the serviced answered with a [404] code. *)
val launch : int ->
?pre_hook: (string -> string Answer.answer Lwt.t) ->
?post_hook: (string -> string Answer.answer Lwt.t) ->
unit directory -> server Lwt.t
(** Kill an RPC server. *)
val shutdown : server -> unit Lwt.t
(** Retrieve the root service of the server *)
val root_service : server -> unit directory
(** Change the root service of the server *)
val set_root_service : server -> unit directory -> unit
module Error : sig
val service: (unit, unit, unit, Json_schema.schema) service
val encoding: error list Data_encoding.t
val wrap:
'a Data_encoding.t -> 'a tzresult Data_encoding.encoding
end
(** Resolve a service. *)
val lookup:
'prefix directory -> 'prefix -> string list ->
(Data_encoding.json option -> Data_encoding.json Answer.answer Lwt.t) Lwt.t

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)

61
src/node/net/RPC.ml → src/node/net/RPC_server.ml
View File

@ -7,24 +7,9 @@
(* *)
(**************************************************************************)
open RPC
open Logging.RPC
module Arg = Resto.Arg
module Path = Resto.Path
module Description = Resto.Description
let read_answer = Resto.read_answer
let forge_request = Resto.forge_request
let service ?description ~input ~output path =
Resto.service
?description
~input:(Data_encoding.Json.convert input)
~output:(Data_encoding.Json.convert output)
path
type ('prefix, 'params, 'input, 'output) service =
('prefix, 'params, 'input, 'output) Resto.service
include RestoDirectory
(* public types *)
type server = (* hidden *)
{ shutdown : unit -> unit Lwt.t ;
@ -99,7 +84,7 @@ let launch port ?pre_hook ?post_hook root =
match req.meth with
| `POST -> begin
Cohttp_lwt_body.to_string body >>= fun body ->
match Data_encoding.Json.from_string body with
match Data_encoding_ezjsonm.from_string body with
| Error msg -> Lwt.fail (Cannot_parse_body msg)
| Ok body -> Lwt.return (Some body)
end
@ -111,10 +96,10 @@ let launch port ?pre_hook ?post_hook root =
| Empty ->
Cohttp_lwt_body.empty
| Single json ->
Cohttp_lwt_body.of_string (Data_encoding.Json.to_string json)
Cohttp_lwt_body.of_string (Data_encoding_ezjsonm.to_string json)
| Stream s ->
let stream =
create_stream io con Data_encoding.Json.to_string s in
create_stream io con Data_encoding_ezjsonm.to_string s in
Cohttp_lwt_body.of_stream stream in
lwt_log_info "(%s) RPC %s"
(Cohttp.Connection.to_string con)
@ -171,41 +156,3 @@ let set_root_service server root = server.root <- root
let shutdown server =
server.shutdown ()
module Error = struct
let service =
service
~description: "Schema for all the RPC errors from the shell"
~input: Data_encoding.empty
~output: Data_encoding.json_schema
Path.(root / "errors")
let encoding =
let open Data_encoding in
let path, _ = forge_request service () () in
describe
~description:
(Printf.sprintf
"The full list of error is available with \
the global RPC `/%s`" (String.concat "/" path))
(conv
~schema:Json_schema.any
(fun exn -> `A (List.map json_of_error exn))
(function `A exns -> List.map error_of_json exns | _ -> [])
json)
let wrap param_encoding =
let open Data_encoding in
union [
case
(obj1 (req "ok" param_encoding))
(function Ok x -> Some x | _ -> None)
(fun x -> Ok x) ;
case
(obj1 (req "error" encoding))
(function Error x -> Some x | _ -> None)
(fun x -> Error x) ;
]
end

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

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__