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

Jbuilder: use --dev option

Browse Source
This commit is contained in:
Milo Davis 2017-11-13 14:29:28 +01:00 committed by Grégoire
parent 6a38f76956
commit 32a466556e
99 changed files with 210 additions and 295 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
Makefile
View File

@ -1,15 +1,15 @@
all:
@jbuilder build tezos.install
@jbuilder build tezos.install --dev
@cp _build/default/src/node_main.exe tezos-node
@cp _build/default/src/client_main.exe tezos-client
@cp _build/default/src/compiler_main.exe tezos-protocol-compiler
doc-html:
@jbuilder build @doc
@jbuilder build @doc --dev
build-test:
@jbuilder build @buildtest
@jbuilder build @buildtest --dev
test:
@jbuilder runtest

6
src/client/client_generic_rpcs.ml
View File

@ -16,7 +16,6 @@ open Json_schema
(*-- Assisted, schema directed input fill in --------------------------------*)
exception Erroneous_construct
exception Unsupported_construct
type input = {
@ -132,7 +131,7 @@ let editor_fill_in schema =
random_fill_in schema >>= function
| Error msg -> Lwt.return (Error msg)
| Ok json ->
Lwt_io.(with_file Output tmp (fun fp ->
Lwt_io.(with_file ~mode:Output tmp (fun fp ->
write_line fp (Data_encoding_ezjsonm.to_string json))) >>= fun () ->
edit ()
and edit () =
@ -160,7 +159,7 @@ let editor_fill_in schema =
Lwt.return (Error msg)
and reread () =
(* finally reread the file *)
Lwt_io.(with_file Input tmp (fun fp -> read fp)) >>= fun text ->
Lwt_io.(with_file ~mode:Input tmp (fun fp -> read fp)) >>= fun text ->
match Data_encoding_ezjsonm.from_string text with
| Ok r -> Lwt.return (Ok r)
| Error msg -> Lwt.return (Error (Printf.sprintf "bad input: %s" msg))
@ -350,7 +349,6 @@ let call_with_json url json (cctxt: Client_commands.context) =
"Failed to parse the provided json: %s\n%!"
err
| Ok json ->
let open RPC.Description in
Client_rpcs.get_json cctxt.rpc_config `POST args json >>=? fun json ->
cctxt.message "%a"
Json_repr.(pp (module Ezjsonm)) json >>= fun () ->

1
src/client/client_helpers.ml
View File

@ -8,7 +8,6 @@
(**************************************************************************)
open Client_commands
open Client_config
let unique_switch =
Cli_entries.switch

2
src/client/client_keys.ml
View File

@ -162,7 +162,7 @@ let alias_keys cctxt name =
let rec find_key = function
| [] -> return None
| (key_name, pkh) :: tl ->
if String.(key_name = name)
if key_name = name
then
Public_key.find_opt cctxt name >>=? fun pkm ->
Secret_key.find_opt cctxt name >>=? fun pks ->

1
src/client/embedded/alpha/client_baking_daemon.ml
View File

@ -8,7 +8,6 @@
(**************************************************************************)
open Client_commands
open Logging.Client.Baking
let run cctxt ?max_priority ~delay ?min_date delegates ~endorsement ~denunciation ~baking =
(* TODO really detach... *)

1
src/client/embedded/alpha/client_baking_endorsement.ml
View File

@ -9,7 +9,6 @@
open Logging.Client.Endorsement
open Client_commands
open Cli_entries
module Ed25519 = Environment.Ed25519

5
src/client/embedded/alpha/client_baking_forge.ml
View File

@ -20,7 +20,7 @@ let generate_seed_nonce () =
| Error _ -> assert false
| Ok nonce -> nonce
let rec forge_block_header
let forge_block_header
cctxt block delegate_sk shell priority seed_nonce_hash =
Client_proto_rpcs.Constants.stamp_threshold
cctxt block >>=? fun stamp_threshold ->
@ -620,6 +620,3 @@ let create
lwt_log_info "Starting baking daemon" >>= fun () ->
worker_loop () >>= fun () ->
return ()
(* FIXME bug in ocamldep ?? *)
open Level

2
src/client/embedded/alpha/client_baking_main.ml
View File

@ -7,9 +7,7 @@
(* *)
(**************************************************************************)
open Cli_entries
open Client_commands
open Client_proto_contracts
let mine_block cctxt block
?force ?max_priority ?(free_baking=false) ?src_sk delegate =

2
src/client/embedded/alpha/client_baking_operations.ml
View File

@ -9,8 +9,6 @@
module Ed25519 = Environment.Ed25519
open Operation
type operation = {
hash: Operation_hash.t ;
content: Operation.t option

3
src/client/embedded/alpha/client_baking_revelation.ml
View File

@ -7,7 +7,6 @@
(* *)
(**************************************************************************)
open Cli_entries
open Tezos_context
let inject_seed_nonce_revelation rpc_config block ?force ?async nonces =
@ -22,8 +21,6 @@ let inject_seed_nonce_revelation rpc_config block ?force ?async nonces =
Client_node_rpcs.inject_operation rpc_config ?force ?async bytes >>=? fun oph ->
return oph
type Error_monad.error += Bad_revelation
let forge_seed_nonce_revelation
(cctxt: Client_commands.context)
block ?(force = false) nonces =

4
src/client/embedded/alpha/client_proto_args.ml
View File

@ -115,8 +115,8 @@ let tez_arg ~default ~parameter ~doc =
let tez_param ~name ~desc next =
Cli_entries.param
name
(desc ^ " in \xEA\x9C\xA9\n" ^ tez_format)
~name
~desc:(desc ^ " in \xEA\x9C\xA9\n" ^ tez_format)
(tez_parameter name)
next

1
src/client/embedded/alpha/client_proto_contracts.ml
View File

@ -134,7 +134,6 @@ let get_manager cctxt block source =
| None -> Client_proto_rpcs.Context.Contract.manager cctxt block source
let get_delegate cctxt block source =
let open Client_keys in
match Contract.is_default source with
| Some hash -> return hash
| None ->

2
src/client/embedded/alpha/client_proto_nonces.ml
View File

@ -7,8 +7,6 @@
(* *)
(**************************************************************************)
open Cli_entries
(* TODO locking... *)
type t = (Block_hash.t * Nonce.t) list

5
src/client/embedded/alpha/client_proto_programs.ml
View File

@ -101,7 +101,6 @@ let commands () =
data_parameter
@@ stop)
(fun (trace_stack, amount, no_print_source) program storage input cctxt ->
let open Data_encoding in
let print_errors errs =
cctxt.warning "%a"
(Michelson_v1_error_reporter.report_errors
@ -147,7 +146,6 @@ let commands () =
@@ Program.source_param
@@ stop)
(fun (show_types, emacs_mode, no_print_source) program cctxt ->
let open Data_encoding in
Client_proto_rpcs.Helpers.typecheck_code
cctxt.rpc_config cctxt.config.block program.expanded >>= fun res ->
if emacs_mode then
@ -191,7 +189,6 @@ let commands () =
data_parameter
@@ stop)
(fun no_print_source data exp_ty cctxt ->
let open Data_encoding in
Client_proto_rpcs.Helpers.typecheck_data cctxt.Client_commands.rpc_config
cctxt.config.block (data.expanded, exp_ty.expanded) >>= function
| Ok () ->
@ -214,7 +211,6 @@ let commands () =
data_parameter
@@ stop)
(fun () data cctxt ->
let open Data_encoding in
Client_proto_rpcs.Helpers.hash_data cctxt.Client_commands.rpc_config
cctxt.config.block (data.expanded) >>= function
| Ok hash ->
@ -237,7 +233,6 @@ let commands () =
@@ Client_keys.Secret_key.alias_param
@@ stop)
(fun () data (_, key) cctxt ->
let open Data_encoding in
Client_proto_rpcs.Helpers.hash_data cctxt.rpc_config
cctxt.config.block (data.expanded) >>= function
| Ok hash ->

2
src/client/embedded/alpha/client_proto_rpcs.ml
View File

@ -185,8 +185,6 @@ module Helpers = struct
module Forge = struct
open Operation
module Manager = struct
let operations cctxt
block ~net_id ~branch ~source ?sourcePubKey ~counter ~fee operations =

4
src/client/embedded/alpha/jbuild
View File

@ -2,11 +2,13 @@
(library
((name client_embedded_alpha)
(public_name tezos.client.embedded.alpha)
(libraries (tezos_embedded_protocol_alpha
tezos_embedded_raw_protocol_alpha
client_lib))
(library_flags (:standard -linkall))
(flags (:standard -w +27-30-40@8
(flags (:standard -w -9+27-30-32-40@8
-safe-string
-open Error_monad
-open Hash
-open Utils

2
src/client/embedded/alpha/michelson_macros.mli
View File

@ -7,8 +7,6 @@
(* *)
(**************************************************************************)
open Micheline
type 'l node = ('l, string) Micheline.node
val expand : 'l node -> 'l node

2
src/client/embedded/alpha/michelson_v1_error_reporter.ml
View File

@ -17,7 +17,7 @@ let print_ty (type t) ppf (annot, (ty : t ty)) =
|> Micheline.strip_locations
|> Michelson_v1_printer.print_expr_unwrapped ppf
let rec print_stack_ty (type t) ?(depth = max_int) ppf (s : t stack_ty) =
let print_stack_ty (type t) ?(depth = max_int) ppf (s : t stack_ty) =
let rec loop
: type t. int -> Format.formatter -> t stack_ty -> unit
= fun depth ppf -> function

2
src/client/embedded/alpha/michelson_v1_parser.ml
View File

@ -59,7 +59,7 @@ let parse_toplevel ?check source =
| [ ast ] -> ast
| asts ->
let start = min_point asts and stop = max_point asts in
Seq (Michelson_macros.{ start ; stop }, asts, None) in
Seq ({ start ; stop }, asts, None) in
expand_all source ast
let parse_expression ?check source =

16
src/client/embedded/alpha/michelson_v1_parser.mli
View File

@ -9,23 +9,21 @@
(** The result of parsing and expanding a Michelson V1 script or data. *)
type parsed =
{ source :
{
source : string ;
(** The original source code. *)
string ;
unexpanded :
unexpanded : string Micheline.canonical ;
(** Original expression with macros. *)
string Micheline.canonical ;
expanded :
expanded : Script.expr ;
(** Expression with macros fully expanded. *)
Script.expr ;
expansion_table :
(int * (Micheline_parser.location * int list)) list ;
(** Associates unexpanded nodes to their parsing locations and
the nodes expanded from it in the expanded expression. *)
(int * (Micheline_parser.location * int list)) list ;
unexpansion_table :
unexpansion_table : (int * int) list ;
(** Associates an expanded node to its source in the unexpanded
expression. *)
(int * int) list }
}
val parse_toplevel : ?check:bool -> string -> parsed tzresult
val parse_expression : ?check:bool -> string -> parsed tzresult

4
src/client/embedded/genesis/jbuild
View File

@ -2,12 +2,14 @@
(library
((name client_embedded_genesis)
(public_name tezos.client.embedded.genesis)
(libraries (tezos_embedded_raw_protocol_genesis
tezos_embedded_protocol_genesis
tezos_protocol_environment_alpha
client_lib))
(library_flags (:standard -linkall))
(flags (:standard -w +27-30-40@8
(flags (:standard -w -9+27-30-32-40@8
-safe-string
-open Error_monad
-open Hash
-open Utils

3
src/client/jbuild
View File

@ -10,7 +10,8 @@
node_db
node_updater
tezos_protocol_compiler))
(flags (:standard -w +27-30-40@8
(flags (:standard -w -9+27-30-32-40@8
-safe-string
-open Error_monad
-open Hash
-open Utils

1
src/client_main.ml
View File

@ -9,7 +9,6 @@
(* Tezos Command line interface - Main Program *)
open Lwt.Infix
open Client_commands
open Error_monad

3
src/compiler/jbuild
View File

@ -21,7 +21,8 @@
ocplib-endian
ocplib-ocamlres
unix))
(flags (:standard -w +27-30-40@8
(flags (:standard -w -9+27-30-32-40@8
-safe-string
-opaque
-open Error_monad
-open Hash

5
src/compiler/native.ml
View File

@ -53,7 +53,6 @@ let preloaded_cmis : (string, Env.Persistent_signature.t) Hashtbl.t =
(* Set hook *)
let () =
let open Env.Persistent_signature in
Env.Persistent_signature.load :=
(fun ~unit_name ->
try Some (Hashtbl.find preloaded_cmis (String.capitalize_ascii unit_name))
@ -154,12 +153,12 @@ let hash_file file =
let buf = BytesLabels.create buflen in
let fd = Unix.openfile file [Unix.O_RDONLY] 0o600 in
let state = init ~size:32 () in
let rec loop () =
let loop () =
match Unix.read fd buf 0 buflen with
| 0 -> ()
| nb_read ->
Bytes.update state @@
if nb_read = buflen then buf else BytesLabels.sub buf 0 nb_read
if nb_read = buflen then buf else BytesLabels.sub buf ~pos:0 ~len:nb_read
in
loop () ;
Unix.close fd ;

2
src/environment/jbuild
View File

@ -52,5 +52,5 @@
(library
((name tezos_protocol_environment_sigs)
(public_name tezos.protocol_environment.sigs)
(flags (:standard -nopervasives))
(flags (:standard -safe-string -w -9-32 -nopervasives))
(modules ("V1"))))

3
src/environment/sigs_packer/jbuild
View File

@ -2,5 +2,6 @@
(executable
((name sigs_packer)
(public_name tezos-protocol-environment-sigs-packer)))
(public_name tezos-protocol-environment-sigs-packer)
(flags (:standard -w -9-32 -safe-string))))

14
src/environment/sigs_packer/sigs_packer.ml
View File

@ -14,7 +14,7 @@ let dump_file oc file =
let rec loop () =
let len = input ic buf 0 buflen in
if len <> 0 then begin
Printf.fprintf oc "%s" (if len = buflen then buf else Bytes.sub buf 0 len) ;
Printf.fprintf oc "%s" (Bytes.to_string (if len = buflen then buf else Bytes.sub buf 0 len)) ;
loop ()
end
in
@ -32,15 +32,15 @@ let include_mli oc file =
let unit =
String.capitalize_ascii
(Filename.chop_extension (Filename.basename file)) in
Printf.fprintf stdout "module %s : sig\n" unit ;
Printf.fprintf stdout "# 1 %S\n" file ;
dump_file stdout file ;
Printf.fprintf stdout "end\n" ;
Printf.fprintf oc "module %s : sig\n" unit ;
Printf.fprintf oc "# 1 %S\n" file ;
dump_file oc file ;
Printf.fprintf oc "end\n" ;
if unit = "Result" then
Printf.fprintf stdout
Printf.fprintf oc
"type ('a, 'b) result = ('a, 'b) Result.result = \
\ Ok of 'a | Error of 'b\n" ;
if List.mem unit opened_modules then Printf.fprintf stdout "open %s\n" unit
if List.mem unit opened_modules then Printf.fprintf oc "open %s\n" unit
let () =
Printf.fprintf stdout "module type T = sig\n" ;

6
src/environment/v1/tezos_data.mli
View File

@ -95,11 +95,11 @@ module Protocol : sig
(** An OCaml source component of a protocol implementation. *)
and component = {
(** The OCaml module name. *)
(* The OCaml module name. *)
name : string ;
(** The OCaml interface source code *)
(* The OCaml interface source code *)
interface : string option ;
(** The OCaml source code *)
(* The OCaml source code *)
implementation : string ;
}

2
src/environment/v1/z.mli
View File

@ -64,11 +64,13 @@ val of_string: string -> t
external to_int64: t -> int64 = "ml_z_to_int64"
(** Converts to a 64-bit integer. May raise [Overflow]. *)
external of_int64: int64 -> t = "ml_z_of_int64"
(** Converts from a 64-bit integer. *)
external to_int: t -> int = "ml_z_to_int"
(** Converts to a base integer. May raise an [Overflow]. *)
external of_int: int -> t = "ml_z_of_int" [@@ noalloc]
(** Converts from a base integer. *)

9
src/jbuild
View File

@ -4,7 +4,8 @@
((name compiler_main)
(public_name tezos-protocol-compiler)
(libraries (tezos_protocol_compiler))
(flags (:standard -w +27-30-40@8
(flags (:standard -w -9+27-30-32-40@8
-safe-string
-linkall))
(modules (Compiler_main))))
@ -15,7 +16,8 @@
tezos_embedded_protocol_genesis
tezos_embedded_protocol_demo
tezos_embedded_protocol_alpha))
(flags (:standard -w +27-30-40@8
(flags (:standard -w -9+27-30-32-40@8
-safe-string
-linkall))
(modules (Node_main))))
@ -23,6 +25,7 @@
((name client_main)
(public_name tezos-client)
(libraries (lwt utils client_lib client_embedded_genesis client_embedded_alpha))
(flags (:standard -w +27-30-40@8
(flags (:standard -w -9+27-30-32-40@8
-safe-string
-linkall))
(modules (Client_main))))

2
src/micheline/jbuild
View File

@ -11,7 +11,7 @@
minutils
utils
))
(flags (:standard -w +27-30-40@8))
(flags (:standard -w -9+27-30-32-40@8 -safe-string))
(wrapped false)))

1
src/micheline/micheline_printer.ml
View File

@ -7,7 +7,6 @@
(* *)
(**************************************************************************)
open Error_monad
open Micheline
type location = { comment : string option }

1
src/micheline/micheline_printer.mli
View File

@ -7,7 +7,6 @@
(* *)
(**************************************************************************)
open Error_monad
open Micheline
val print_string : Format.formatter -> string -> unit

2
src/minutils/compare.ml
View File

@ -159,7 +159,7 @@ end
module Option(P : S) = struct
type t = P.t option
let rec compare xs ys =
let compare xs ys =
match xs, ys with
| None, None -> 0
| None, _ -> -1

36
src/minutils/data_encoding.ml
View File

@ -7,8 +7,6 @@
(* *)
(**************************************************************************)
open Utils
type json =
[ `O of (string * json) list
| `Bool of bool
@ -17,10 +15,6 @@ type json =
| `Null
| `String of string ]
and document =
[ `O of (string * json) list
| `A of json list ]
type json_schema = Json_schema.schema
exception No_case_matched
@ -172,8 +166,7 @@ and 'a t = {
type 'a encoding = 'a t
let rec classify : type a l. a t -> Kind.t = fun e ->
let open Kind in
let rec classify : type a. a t -> Kind.t = fun e ->
match e.encoding with
(* Fixed *)
| Null -> `Fixed 0
@ -222,8 +215,6 @@ module Json = struct
exception Parse_error of string
type nonrec json = json
let wrap_error f =
fun str ->
try f str
@ -292,7 +283,7 @@ module Json = struct
| _ -> e
and lift_union_in_pair
: type a a_l b b_l. pair_builder -> Kind.t -> a t -> b t -> (a * b) t
: type a b. pair_builder -> Kind.t -> a t -> b t -> (a * b) t
= fun b p e1 e2 ->
match lift_union e1, lift_union e2 with
| e1, { encoding = Union (_kind, tag, cases) } ->
@ -323,7 +314,7 @@ module Json = struct
cases)
| e1, e2 -> b.build p e1 e2
let rec json : type a l. a desc -> a Json_encoding.encoding =
let rec json : type a. a desc -> a Json_encoding.encoding =
let open Json_encoding in
function
| Null -> null
@ -362,19 +353,19 @@ module Json = struct
| Delayed f -> get_json (f ())
and field_json
: type a l. a field -> a Json_encoding.field =
: type a. a field -> a Json_encoding.field =
let open Json_encoding in
function
| Req (name, e) -> req name (get_json e)
| Opt (_, name, e) -> opt name (get_json e)
| Dft (name, e, d) -> dft name (get_json e) d
and case_json : type a l. a case -> a Json_encoding.case =
and case_json : type a. a case -> a Json_encoding.case =
let open Json_encoding in
function
| Case { encoding = e ; proj ; inj ; _ } -> case (get_json e) proj inj
and get_json : type a l. a t -> a Json_encoding.encoding = fun e ->
and get_json : type a. a t -> a Json_encoding.encoding = fun e ->
match e.json_encoding with
| None ->
let json_encoding = json (lift_union e).encoding in
@ -459,7 +450,7 @@ module Encoding = struct
let array e = dynamic_size (Variable.array e)
let list e = dynamic_size (Variable.list e)
let conv (type l) proj inj ?schema encoding =
let conv proj inj ?schema encoding =
make @@ Conv { proj ; inj ; encoding ; schema }
let string_enum l = dynamic_size (Variable.string_enum l)
@ -546,7 +537,7 @@ module Encoding = struct
raw_merge_objs (obj2 f10 f9) (obj8 f8 f7 f6 f5 f4 f3 f2 f1)
let merge_objs o1 o2 =
let rec is_obj : type a l. a t -> bool = fun e ->
let rec is_obj : type a. a t -> bool = fun e ->
match e.encoding with
| Obj _ -> true
| Objs _ (* by construction *) -> true
@ -587,7 +578,7 @@ module Encoding = struct
raw_merge_tups (tup2 e10 e9) (tup8 e8 e7 e6 e5 e4 e3 e2 e1)
let merge_tups t1 t2 =
let rec is_tup : type a l. a t -> bool = fun e ->
let rec is_tup : type a. a t -> bool = fun e ->
match e.encoding with
| Tup _ -> true
| Tups _ (* by construction *) -> true
@ -745,7 +736,6 @@ module Binary = struct
}
let rec length : type x. x t -> x -> int = fun e ->
let open Kind in
match e.encoding with
(* Fixed *)
| Null -> fun _ -> 0
@ -780,7 +770,7 @@ let rec length : type x. x t -> x -> int = fun e ->
| Case { tag = None } -> None
| Case { encoding = e ; proj ; tag = Some _ } ->
let length v = tag_size sz + length e v in
Some (fun v -> Utils.map_option length (proj v)) in
Some (fun v -> Utils.map_option ~f:length (proj v)) in
apply (Utils.filter_map case_length cases)
| Mu (`Dynamic, _name, self) ->
fun v -> length (self e) v
@ -953,8 +943,7 @@ let rec length : type x. x t -> x -> int = fun e ->
end
let rec write_rec
: type a l. a t -> a -> MBytes.t -> int -> int = fun e ->
let open Kind in
: type a. a t -> a -> MBytes.t -> int -> int = fun e ->
let open Writer in
match e.encoding with
| Null -> (fun () _buf ofs -> ofs)
@ -1159,8 +1148,7 @@ let rec length : type x. x t -> x -> int = fun e ->
end
let rec read_rec : type a l. a t-> MBytes.t -> int -> int -> int * a = fun e ->
let open Kind in
let rec read_rec : type a. a t-> MBytes.t -> int -> int -> int * a = fun e ->
let open Reader in
match e.encoding with
| Null -> (fun _buf ofs _len -> ofs, ())

2
src/minutils/jbuild
View File

@ -7,5 +7,5 @@
lwt
ocplib-json-typed.bson
ocplib-resto.directory))
(flags (:standard -w +27-30-40@8))
(flags (:standard -w -9+27-30-32-40@8 -safe-string))
(wrapped false)))

4
src/minutils/utils.ml
View File

@ -147,7 +147,7 @@ let rec remove_elem_from_list nb = function
| l when nb <= 0 -> l
| _ :: tl -> remove_elem_from_list (nb - 1) tl
let rec split_list_at n l =
let split_list_at n l =
let rec split n acc = function
| [] -> List.rev acc, []
| l when n <= 0 -> List.rev acc, l
@ -196,7 +196,7 @@ let write_file ?(bin=false) fn contents =
let (<<) g f = fun a -> g (f a)
let rec (--) i j =
let (--) i j =
let rec loop acc j =
if j < i then acc else loop (j :: acc) (pred j) in
loop [] j

1
src/minutils/utils.mli
View File

@ -62,6 +62,7 @@ val filter_map: ('a -> 'b option) -> 'a list -> 'b list
(** [list_rev_sub l n] is [List.rev l] capped to max [n] elements *)
val list_rev_sub : 'a list -> int -> 'a list
(** [list_sub l n] is [l] capped to max [n] elements *)
val list_sub: 'a list -> int -> 'a list

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

@ -10,7 +10,6 @@
(** Tezos - Versioned (key x value) store (over Irmin) *)
open Hash
open Logging.Db
module IrminPath = Irmin.Path.String_list
@ -95,9 +94,6 @@ let checkout_exn index key =
| Some p -> Lwt.return p
exception Preexistent_context of Block_hash.t
exception Empty_head of Block_hash.t
let raw_commit ~time ~message context =
let info =
Irmin.Info.v ~date:(Time.to_seconds time) ~author:"Tezos" message in
@ -116,6 +112,7 @@ let commit ~time ~message context =
Lwt_utils.Idle_waiter.force_idle
context.index.repack_scheduler
begin fun () ->
let open Logging.Db in
lwt_debug "begin git repack" >>= fun () ->
let command =
"git",
@ -138,8 +135,6 @@ let commit ~time ~message context =
(*-- Generic Store Primitives ------------------------------------------------*)
type key = string list
let data_key key = "data" :: key
let undata_key = function
| "data" :: key -> key

3
src/node/db/jbuild
View File

@ -4,7 +4,8 @@
((name node_db)
(public_name tezos.node.db)
(libraries (utils minutils leveldb irmin irmin-unix))
(flags (:standard -w +27-30-40@8
(flags (:standard -w -9+27-30-32-40@8
-safe-string
-open Error_monad
-open Hash
-open Utils

18
src/node/db/persist.ml
View File

@ -121,7 +121,6 @@ module MakeBytesStore
type t = S.t
type key = K.t
type value = MBytes.t
let to_path k =
let suffix = K.to_path k in
@ -228,8 +227,8 @@ module MakePersistentSet
| true -> dig K.length K.prefix x
| false -> Lwt.return x
let iter c ~f = fold c () (fun x () -> f x)
let elements c = fold c [] (fun p xs -> Lwt.return (p :: xs))
let iter c ~f = fold c () ~f:(fun x () -> f x)
let elements c = fold c [] ~f:(fun p xs -> Lwt.return (p :: xs))
end
@ -239,7 +238,7 @@ module MakeBufferedPersistentSet
include MakePersistentSet(S)(K)
let read c =
fold c Set.empty (fun p set -> Lwt.return (Set.add p set))
fold c Set.empty ~f:(fun p set -> Lwt.return (Set.add p set))
let write c set =
S.set c inited_key empty >>= fun c ->
@ -307,8 +306,8 @@ module MakePersistentMap
| true -> dig K.length K.prefix x
| false -> Lwt.return x
let iter c ~f = fold c () (fun k v () -> f k v)
let bindings c = fold c [] (fun k v acc -> Lwt.return ((k, v) :: acc))
let iter c ~f = fold c () ~f:(fun k v () -> f k v)
let bindings c = fold c [] ~f:(fun k v acc -> Lwt.return ((k, v) :: acc))
end
@ -317,7 +316,7 @@ module MakeBufferedPersistentMap
include MakePersistentMap(S)(K)(C)
let read c = fold c Map.empty (fun k v m -> Lwt.return (Map.add k v m))
let read c = fold c Map.empty ~f:(fun k v m -> Lwt.return (Map.add k v m))
let write c m =
clear c >>= fun c ->
@ -399,10 +398,7 @@ module MakeImperativeProxy
{ rdata: rdata ;
state: [ `Inited of Scheduler.data | `Initing of Scheduler.data Lwt.t ] ;
wakener: Store.value Lwt.u }
type store = Store.t
type state = Scheduler.state
type key = Store.key
type value = Store.value
type t =
{ tbl : data Table.t ;
@ -594,7 +590,7 @@ module MakeHashResolver
| [d] ->
Store.list t [prefix] >>= fun prefixes ->
Lwt_list.filter_map_p (fun prefix ->
match remove_prefix d (List.hd (List.rev prefix)) with
match remove_prefix ~prefix:d (List.hd (List.rev prefix)) with
| None -> Lwt.return_none
| Some _ -> Lwt.return (Some (build prefix))
) prefixes

3
src/node/db/persist.mli
View File

@ -9,9 +9,6 @@
(** Tezos - Persistent structures on top of {!Context} *)
open Lwt
(** Keys in (kex x value) database implementations *)
type key = string list

1
src/node/db/raw_store.ml
View File

@ -8,7 +8,6 @@
(**************************************************************************)
module List = ListLabels
open Logging.Db
type t = LevelDB.db
type key = string list

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

@ -7,8 +7,6 @@
(* *)
(**************************************************************************)
open Store_sigs
type t = Raw_store.t
type global_store = t

2
src/node/db/store_helpers.ml
View File

@ -140,7 +140,7 @@ module Make_indexed_substore (S : STORE) (I : INDEX) = struct
list t prefix >>= fun prefixes ->
Lwt_list.map_p (function
| `Key prefix | `Dir prefix ->
match Utils.remove_prefix d (List.hd (List.rev prefix)) with
match Utils.remove_prefix ~prefix:d (List.hd (List.rev prefix)) with
| None -> Lwt.return_nil
| Some _ -> loop (i+1) prefix [])
prefixes

4
src/node/main/jbuild
View File

@ -2,8 +2,10 @@
(library
((name node_main_lib)
(public_name tezos.node.main)
(libraries (utils minutils cmdliner node_net node_shell))
(flags (:standard -w +27-30-40@8
(flags (:standard -w -9+27-30-32-40@8
-safe-string
-open Error_monad
-open Hash
-open Utils

4
src/node/main/node_config_file.ml
View File

@ -7,8 +7,6 @@
(* *)
(**************************************************************************)
open P2p_types
let (//) = Filename.concat
let home =
@ -318,7 +316,7 @@ let update
Utils.first_some
peer_table_size cfg.net.limits.max_known_peer_ids ;
binary_chunks_size =
Utils.map_option (fun x -> x lsl 10) binary_chunks_size ;
Utils.map_option ~f:(fun x -> x lsl 10) binary_chunks_size ;
} in
let net : net = {
expected_pow =

2
src/node/main/node_config_file.mli
View File

@ -7,8 +7,6 @@
(* *)
(**************************************************************************)
open P2p_types
type t = {
data_dir : string ;
net : net ;

5
src/node/main/node_run_command.ml
View File

@ -47,7 +47,6 @@ let protocol_dir data_dir = data_dir // "protocol"
let lock_file data_dir = data_dir // "lock"
let init_logger ?verbosity (log_config : Node_config_file.log) =
let open Logging in
begin
match verbosity with
| Some level ->
@ -61,7 +60,7 @@ let init_logger ?verbosity (log_config : Node_config_file.log) =
match Sys.getenv "LWT_LOG" with
| rules -> Some rules
| exception Not_found -> log_config.rules in
Utils.iter_option Lwt_log_core.load_rules rules
Utils.iter_option ~f:Lwt_log_core.load_rules rules
end ;
Logging.init ~template:log_config.template log_config.output
@ -202,7 +201,7 @@ let run ?verbosity ?sandbox (config : Node_config_file.t) =
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_server.shutdown rpc >>= fun () ->
Lwt_utils.may ~f:RPC_server.shutdown rpc >>= fun () ->
lwt_log_notice "BYE (%d)" x >>= fun () ->
Logging.close () >>= fun () ->
return ()

3
src/node/main/node_shared_arg.ml
View File

@ -8,7 +8,6 @@
(**************************************************************************)
open Cmdliner
open P2p_types
open Logging.Node.Main
let (//) = Filename.concat
@ -51,7 +50,7 @@ let wrap
let rpc_tls =
Utils.map_option
(fun (cert, key) -> { Node_config_file.cert ; key })
~f:(fun (cert, key) -> { Node_config_file.cert ; key })
rpc_tls in
(* when `--expected-connections` is used,

2
src/node/main/node_shared_arg.mli
View File

@ -7,8 +7,6 @@
(* *)
(**************************************************************************)
open P2p_types
type t = {
data_dir: string option ;
config_file: string ;

3
src/node/net/jbuild
View File

@ -4,7 +4,8 @@
((name node_net)
(public_name tezos.node.net)
(libraries (utils minutils conduit-lwt-unix cohttp cohttp-lwt-unix))
(flags (:standard -w +27-30-40@8
(flags (:standard -w -9+27-30-32-40@8
-safe-string
-open Error_monad
-open Hash
-open Utils

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

@ -131,9 +131,9 @@ let may_create_discovery_worker _config pool =
let create_maintenance_worker limits pool disco =
let bounds =
bounds
limits.min_connections
limits.expected_connections
limits.max_connections
~min:limits.min_connections
~expected:limits.expected_connections
~max:limits.max_connections
in
P2p_maintenance.run
~connection_timeout:limits.authentification_timeout
@ -214,7 +214,7 @@ module Real = struct
let get_metadata { pool } conn =
P2p_connection_pool.Peer_ids.get_metadata pool conn
let rec recv _net conn =
let recv _net conn =
P2p_connection_pool.read conn >>=? fun msg ->
lwt_debug "message read from %a"
Connection_info.pp
@ -611,7 +611,6 @@ module RPC = struct
(opt "last_miss" Time.encoding))
let info_of_point_info i =
let open P2p_connection_pool in
let open P2p_connection_pool_types in
let state = match Point_info.State.get i with
| Requested _ -> Requested

15
src/node/net/p2p_connection.ml
View File

@ -238,7 +238,7 @@ module Reader = struct
mutable worker: unit Lwt.t ;
}
let rec read_message st init_mbytes =
let read_message st init_mbytes =
let rec loop status =
Lwt_unix.yield () >>= fun () ->
let open Data_encoding.Binary in
@ -306,8 +306,8 @@ module Reader = struct
end ;
st.worker <-
Lwt_utils.worker "reader"
(fun () -> worker_loop st [])
(fun () -> Canceler.cancel st.canceler) ;
~run:(fun () -> worker_loop st [])
~cancel:(fun () -> Canceler.cancel st.canceler) ;
st
let shutdown st =
@ -327,7 +327,7 @@ module Writer = struct
binary_chunks_size: int ; (* in bytes *)
}
let rec send_message st buf =
let send_message st buf =
let rec loop = function
| [] -> return ()
| buf :: l ->
@ -429,8 +429,8 @@ module Writer = struct
end ;
st.worker <-
Lwt_utils.worker "writer"
(fun () -> worker_loop st)
(fun () -> Canceler.cancel st.canceler) ;
~run:(fun () -> worker_loop st)
~cancel:(fun () -> Canceler.cancel st.canceler) ;
st
let shutdown st =
@ -480,9 +480,6 @@ let accept
end ;
return conn
exception Not_available
exception Connection_closed
let catch_closed_pipe f =
Lwt.catch f begin function
| Lwt_pipe.Closed -> fail P2p_io_scheduler.Connection_closed

10
src/node/net/p2p_connection_pool.ml
View File

@ -140,8 +140,8 @@ module Answerer = struct
} in
st.worker <-
Lwt_utils.worker "answerer"
(fun () -> worker_loop st)
(fun () -> Canceler.cancel canceler) ;
~run:(fun () -> worker_loop st)
~cancel:(fun () -> Canceler.cancel canceler) ;
st
let shutdown st =
@ -682,8 +682,6 @@ let pool_stat { io_sched } =
(***************************************************************************)
type error += Rejected of Peer_id.t
type error += Unexpected_point_state
type error += Unexpected_peer_id_state
type error += Pending_connection
type error += Connected
type error += Connection_closed = P2p_io_scheduler.Connection_closed
@ -781,7 +779,7 @@ and authenticate pool ?point_info canceler fd point =
if incoming then
Point.Table.remove pool.incoming point
else
iter_option Point_info.State.set_disconnected point_info ;
iter_option ~f:Point_info.State.set_disconnected point_info ;
Lwt.return (Error err)
end >>=? fun (info, auth_fd) ->
(* Authentication correct! *)
@ -857,7 +855,7 @@ and authenticate pool ?point_info canceler fd point =
Lwt.return (Error err)
end >>=? fun conn ->
let id_point =
match info.id_point, map_option Point_info.point point_info with
match info.id_point, map_option ~f:Point_info.point point_info with
| (addr, _), Some (_, port) -> addr, Some port
| id_point, None -> id_point in
return

5
src/node/net/p2p_connection_pool.mli
View File

@ -337,7 +337,7 @@ module Log_event : sig
type t =
(** Pool-level events *)
(* Pool-level events *)
| Too_few_connections
| Too_many_connections
@ -347,10 +347,11 @@ module Log_event : sig
| Gc_points
(** Garbage collection of known point table has been triggered. *)
| Gc_peer_ids
(** Garbage collection of known peer_ids table has been triggered. *)
(** Connection-level events *)
(* Connection-level events *)
| Incoming_connection of Point.t
(** We accept(2)-ed an incoming connection *)

1
src/node/net/p2p_connection_pool_types.ml
View File

@ -300,7 +300,6 @@ module Peer_info = struct
| External_disconnection
let kind_encoding =
let open Data_encoding in
Data_encoding.string_enum [
"incoming_request", Accepting_request ;
"rejecting_request", Rejecting_request ;

1
src/node/net/p2p_discovery.ml
View File

@ -7,7 +7,6 @@
(* *)
(**************************************************************************)
open P2p_types
include Logging.Make (struct let name = "p2p.discovery" end)
type t = ()

6
src/node/net/p2p_io_scheduler.ml
View File

@ -171,8 +171,8 @@ module Scheduler(IO : IO) = struct
} in
st.worker <-
Lwt_utils.worker IO.name
(fun () -> worker_loop st)
(fun () -> Canceler.cancel st.canceler) ;
~run:(fun () -> worker_loop st)
~cancel:(fun () -> Canceler.cancel st.canceler) ;
st
let create_connection st in_param out_param canceler id =
@ -418,7 +418,7 @@ let read_now conn ?pos ?len buf =
| None ->
try
map_option
(read_from conn ?pos ?len buf)
~f:(read_from conn ?pos ?len buf)
(Lwt_pipe.pop_now conn.read_queue)
with Lwt_pipe.Closed -> Some (Error [Connection_closed])

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

@ -185,8 +185,8 @@ let run ~connection_timeout bounds pool disco =
} in
st.maintain_worker <-
Lwt_utils.worker "maintenance"
(fun () -> worker_loop st)
(fun () -> Canceler.cancel canceler) ;
~run:(fun () -> worker_loop st)
~cancel:(fun () -> Canceler.cancel canceler) ;
st
let maintain { just_maintained ; please_maintain } =

2
src/node/net/p2p_types.ml
View File

@ -7,8 +7,6 @@
(* *)
(**************************************************************************)
open Logging.Net
module Canceler = Lwt_utils.Canceler
module Version = struct

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

@ -62,8 +62,8 @@ let run ~backlog pool ?addr port =
} in
st.worker <-
Lwt_utils.worker "welcome"
(fun () -> worker_loop st)
(fun () -> Canceler.cancel st.canceler) ;
~run:(fun () -> worker_loop st)
~cancel:(fun () -> Canceler.cancel st.canceler) ;
Lwt.return st
end begin fun exn ->
lwt_log_error

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

@ -54,7 +54,7 @@ let locked_set_head chain_store data block =
Lwt.return hash
in
Chain_traversal.new_blocks
data.current_head block >>= fun (ancestor, path) ->
~from_block:data.current_head ~to_block:block >>= fun (ancestor, path) ->
let ancestor = Block.hash ancestor in
pop_blocks ancestor data.current_head >>= fun () ->
Lwt_list.fold_left_s push_block ancestor path >>= fun _ ->

19
src/node/shell/distributed_db.ml
View File

@ -38,10 +38,6 @@ module Make_raw
with type key := Hash.t
and type value := Disk_table.value) = struct
type key = Hash.t
type value = Disk_table.value
type param = Disk_table.store
module Request = struct
type param = Request_message.param request_param
let active { active } = active ()
@ -73,7 +69,6 @@ end
module Fake_operation_storage = struct
type store = State.Net.t
type key = Operation_hash.t
type value = Operation.t
let known _ _ = Lwt.return_false
let read _ _ = Lwt.return (Error_monad.error_exn Not_found)
@ -98,7 +93,6 @@ module Raw_operation =
module Block_header_storage = struct
type store = State.Net.t
type key = Block_hash.t
type value = Block_header.t
let known = State.Block.known_valid
let read net_state h =
@ -106,7 +100,7 @@ module Block_header_storage = struct
return (State.Block.header b)
let read_opt net_state h =
State.Block.read_opt net_state h >>= fun b ->
Lwt.return (Utils.map_option State.Block.header b)
Lwt.return (Utils.map_option ~f:State.Block.header b)
let read_exn net_state h =
State.Block.read_exn net_state h >>= fun b ->
Lwt.return (State.Block.header b)
@ -129,7 +123,6 @@ module Raw_block_header =
module Operation_hashes_storage = struct
type store = State.Net.t
type key = Block_hash.t * int
type value = Operation_hash.t list
let known net_state (h, _) = State.Block.known_valid net_state h
let read net_state (h, i) =
@ -207,7 +200,6 @@ end
module Operations_storage = struct
type store = State.Net.t
type key = Block_hash.t * int
type value = Operation.t list
let known net_state (h, _) = State.Block.known_valid net_state h
let read net_state (h, i) =
@ -276,7 +268,6 @@ end
module Protocol_storage = struct
type store = State.t
type key = Protocol_hash.t
type value = Protocol.t
let known = State.Protocol.known
let read = State.Protocol.read
@ -351,8 +342,6 @@ let db { global_db } = global_db
module P2p_reader = struct
type t = p2p_reader
let may_activate global_db state net_id f =
match Net_id.Table.find state.peer_active_nets net_id with
| net_db ->
@ -858,11 +847,6 @@ let watch_protocol { protocol_db } =
Raw_protocol.Table.watch protocol_db.table
module Raw = struct
type 'a t =
| Bootstrap
| Advertise of P2p_types.Point.t list
| Message of 'a
| Disconnect
let encoding = P2p.Raw.encoding Message.cfg.encoding
let supported_versions = Message.cfg.versions
end
@ -902,7 +886,6 @@ module Make
type t = Kind.t
type key = Table.key
type value = Table.value
type param = Table.param
let known t k = Table.known (Kind.proj t) k
type error += Missing_data = Table.Missing_data
type error += Canceled = Table.Canceled

1
src/node/shell/distributed_db_functors.ml
View File

@ -323,7 +323,6 @@ end = struct
include Logging.Make(struct let name = "node.distributed_db.scheduler." ^ Hash.name end)
type key = Hash.t
type param = Request.param
type t = {
param: Request.param ;

3
src/node/shell/jbuild
View File

@ -4,7 +4,8 @@
((name node_shell)
(public_name tezos.node.shell)
(libraries (utils minutils node_net node_db node_updater ezjsonm ocplib-json-typed.bson))
(flags (:standard -w +27-30-40@8
(flags (:standard -w -9+27-30-32-40@8
-safe-string
-open Error_monad
-open Hash
-open Utils

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

@ -619,7 +619,7 @@ module RPC = struct
let block_stream, stopper =
Validator.new_head_watcher node.mainnet_validator in
let first_run = ref true in
let rec next () =
let next () =
if !first_run then begin
first_run := false ;
Chain.head node.mainnet_net >>= fun head ->

6
src/node/shell/prevalidator.ml
View File

@ -40,8 +40,6 @@ let list_pendings ~from_block ~to_block old_mempool =
(** Worker *)
exception Invalid_operation of Operation_hash.t
open Prevalidation
type t = {
@ -73,7 +71,7 @@ let create net_db =
Chain.head net_state >>= fun head ->
let timestamp = ref (Time.now ()) in
(start_prevalidation head !timestamp () >|= ref) >>= fun validation_state ->
(start_prevalidation ~predecessor:head ~timestamp:!timestamp () >|= ref) >>= fun validation_state ->
let pending = Operation_hash.Table.create 53 in
let head = ref head in
let operations = ref empty_result in
@ -92,7 +90,7 @@ let create net_db =
Lwt.return_unit in
let reset_validation_state head timestamp =
start_prevalidation head timestamp () >>= fun state ->
start_prevalidation ~predecessor:head ~timestamp () >>= fun state ->
validation_state := state;
Lwt.return_unit in

7
src/node/shell/validator.ml
View File

@ -365,9 +365,6 @@ let apply_block net_state db
module Context_db = struct
type key = Block_hash.t
type value = State.Block.t
type data =
{ validator: net_validator ;
state: [ `Inited of Block_header.t tzresult
@ -608,7 +605,7 @@ module Context_db = struct
end
let rec create_validator ?parent worker ?max_child_ttl state db net =
let create_validator ?parent worker ?max_child_ttl state db net =
let net_id = State.Net.id net in
let net_db = Distributed_db.activate db net in
@ -776,8 +773,6 @@ let rec create_validator ?parent worker ?max_child_ttl state db net =
Lwt.return v
type error += Unknown_network of Net_id.t
let create state db =
let validators : net_validator Lwt.t Net_id.Table.t =

3
src/node/updater/jbuild
View File

@ -4,7 +4,8 @@
((name node_updater)
(public_name tezos.node.updater)
(libraries (utils minutils micheline tezos_protocol_compiler node_db dynlink))
(flags (:standard -w +27-30-40@8
(flags (:standard -w -9+27-30-32-40@8
-safe-string
-open Error_monad
-open Hash
-open Utils

8
src/proto/alpha/jbuild
View File

@ -27,7 +27,7 @@ let () =
(library
((name tezos_protocol_environment_alpha)
(public_name tezos.protocol_environment.alpha)
(library_flags (:standard -linkall))
(library_flags (:standard -linkall -w -9 -safe-string))
(libraries (node_updater))
(modules (Environment))))
@ -36,8 +36,8 @@ let () =
(public_name tezos.embedded_raw_protocol.alpha)
(libraries (tezos_protocol_environment_alpha))
(library_flags (:standard -linkall))
(flags (:standard -nopervasives -nostdlib
-w +a-4-6-7-9-29-40..42-44-45-48
(flags (:standard -nopervasives -nostdlib -safe-string
-w +a-4-6-7-9-29-32-40..42-44-45-48
-warn-error -a+8
-open Tezos_protocol_environment_alpha__Environment
-open Error_monad
@ -48,7 +48,7 @@ let () =
(library
((name tezos_embedded_protocol_alpha)
(public_name tezos.embedded_protocol.alpha)
(library_flags (:standard -linkall))
(library_flags (:standard -linkall -w -9-32 -safe-string))
(libraries (tezos_embedded_raw_protocol_alpha node_shell))
(modules (Registerer))))

6
src/proto/demo/jbuild
View File

@ -32,8 +32,8 @@
((name tezos_embedded_raw_protocol_demo)
(libraries (tezos_protocol_environment_demo))
(library_flags (:standard -linkall))
(flags (:standard -nopervasives -nostdlib
-w +a-4-6-7-9-29-40..42-44-45-48
(flags (:standard -nopervasives -nostdlib -safe-string
-w +a-4-6-7-9-29-32-40..42-44-45-48
-warn-error -a+8
-open Tezos_protocol_environment_demo__Environment
-open Error_monad
@ -43,7 +43,7 @@
(library
((name tezos_embedded_protocol_demo)
(library_flags (:standard -linkall))
(library_flags (:standard -linkall -w -9-32 -safe-string))
(libraries (tezos_embedded_raw_protocol_demo node_shell))
(modules (Registerer))))

9
src/proto/genesis/jbuild
View File

@ -25,15 +25,17 @@
(library
((name tezos_protocol_environment_genesis)
(public_name tezos.protocol_environment.genesis)
(libraries (node_updater))
(modules (Environment))))
(library
((name tezos_embedded_raw_protocol_genesis)
(public_name tezos.embedded_raw_protocol.genesis)
(libraries (tezos_protocol_environment_genesis))
(library_flags (:standard -linkall))
(flags (:standard -nopervasives -nostdlib
-w +a-4-6-7-9-29-40..42-44-45-48
(flags (:standard -nopervasives -nostdlib -safe-string
-w +a-4-6-7-9-29-32-40..42-44-45-48
-warn-error -a+8
-open Tezos_protocol_environment_genesis__Environment
-open Error_monad
@ -43,7 +45,8 @@
(library
((name tezos_embedded_protocol_genesis)
(library_flags (:standard -linkall))
(public_name tezos.embedded_protocol.genesis)
(library_flags (:standard -linkall -w -9-32 -safe-string))
(libraries (tezos_embedded_raw_protocol_genesis node_shell))
(modules (Registerer))))

4
src/utils/base58.ml
View File

@ -168,8 +168,8 @@ module MakeEncodings(E: sig
let check_ambiguous_prefix prefix encodings =
List.iter
(fun (Encoding { encoded_prefix = s }) ->
if remove_prefix s prefix <> None ||
remove_prefix prefix s <> None then
if remove_prefix ~prefix:s prefix <> None ||
remove_prefix ~prefix s <> None then
Format.ksprintf invalid_arg
"Base58.register_encoding: duplicate prefix: %S, %S." s prefix)
encodings

11
src/utils/cli_entries.ml
View File

@ -287,14 +287,14 @@ let command ?group ~desc options params handler =
(* Param combinators *)
let string ~name ~desc next =
param name desc { converter=(fun _ s -> return s) ; autocomplete=None } next
param ~name ~desc { converter=(fun _ s -> return s) ; autocomplete=None } next
(* Help commands *)
let help_group =
{ name = "man" ;
title = "Access the documentation" }
let rec string_contains ~needle ~haystack =
let string_contains ~needle ~haystack =
try
Some (Str.search_forward (Str.regexp_string needle) haystack 0)
with Not_found ->
@ -539,7 +539,7 @@ let has_args : type a ctx. (a, ctx) args -> bool = function
| NoArgs -> false
| AddArg (_,_) -> true
let rec print_options_brief (type ctx) =
let print_options_brief (type ctx) =
let help_option :
type a. Format.formatter -> (a, ctx) arg -> unit =
fun ppf -> function
@ -631,7 +631,7 @@ let contains_params_args :
in help params
let print_command :
type a ctx ret. ?prefix: string -> ?highlights:string list -> Format.formatter -> (ctx, ret) command -> unit
type ctx ret. ?prefix: string -> ?highlights:string list -> Format.formatter -> (ctx, ret) command -> unit
= fun ?(prefix = "") ?(highlights=[]) ppf (Command { params ; desc ; options=Argument { spec } }) ->
if contains_params_args params spec
then
@ -686,7 +686,6 @@ let command_args_help ppf command =
command
let usage
(type ctx) (type ret)
ppf
?global_options
~details
@ -727,7 +726,7 @@ let usage
Format.fprintf ppf "@]"
let command_usage
(type ctx) (type ret) ppf commands =
ppf commands =
let exe = Filename.basename Sys.executable_name in
let prefix = exe ^ " [global options] " in
Format.fprintf ppf

4
src/utils/cli_entries.mli
View File

@ -21,6 +21,7 @@ val parameter : ?autocomplete:('ctx -> string list tzresult Lwt.t) ->
(** {2 Flags and Options } *)
(** {3 Options and Switches } *)
(** Type for option or switch *)
type ('a, 'ctx) arg
@ -37,6 +38,7 @@ val default_arg : doc:string -> parameter:string ->
default:string ->
('p, 'ctx) parameter ->
('p, 'ctx) arg
(** Create a boolean switch.
The value will be set to [true] if the switch is provided and [false] if it is not. *)
val switch : doc:string -> parameter:string ->
@ -144,6 +146,7 @@ val prefix:
string ->
('a, 'ctx, 'ret) params ->
('a, 'ctx, 'ret) params
(** Multiple words given in sequence for a command line *)
val prefixes:
string list ->
@ -154,6 +157,7 @@ val prefixes:
val fixed:
string list ->
('ctx -> 'ret tzresult Lwt.t, 'ctx, 'ret) params
(** End the description of the command line *)
val stop:
('ctx -> 'ret tzresult Lwt.t, 'ctx, 'ret) params

3
src/utils/crypto_box.ml
View File

@ -7,8 +7,6 @@
(* *)
(**************************************************************************)
open Utils
(** Tezos - X25519/XSalsa20-Poly1305 cryptography *)
type secret_key = Sodium.Box.secret_key
@ -16,7 +14,6 @@ type public_key = Sodium.Box.public_key
type channel_key = Sodium.Box.channel_key
type nonce = Sodium.Box.nonce
type target = Z.t
exception TargetNot256Bit
module Public_key_hash = Hash.Make_Blake2B (Base58) (struct
let name = "Crypto_box.Public_key_hash"

4
src/utils/error_monad.ml
View File

@ -40,8 +40,6 @@ module Make() = struct
pp: Format.formatter -> 'err -> unit ; } ->
error_kind
type registred_errors = error_kind list
let error_kinds
: error_kind list ref
= ref []
@ -281,7 +279,7 @@ module Make() = struct
filter_map_s f t >>=? fun rt ->
return (rh :: rt)
let rec filter_map_p f l =
let filter_map_p f l =
match l with
| [] -> return []
| h :: t ->

4
src/utils/hash.ml
View File

@ -7,14 +7,11 @@
(* *)
(**************************************************************************)
open Error_monad
let (//) = Filename.concat
let (>>=) = Lwt.bind
let (>|=) = Lwt.(>|=)
open Error_monad
open Utils
let () =
let expected_primitive = "blake2b"
@ -549,7 +546,6 @@ module Generic_hash =
module Net_id = struct
type t = string
type net_id = t
let name = "Net_id"
let title = "Network identifier"

2
src/utils/jbuild
View File

@ -18,7 +18,7 @@
;; Internal
minutils
))
(flags (:standard -w +27-30-40@8))
(flags (:standard -w -9+27-30-32-40@8 -safe-string))
(wrapped false)))

2
src/utils/lwt_dropbox.ml
View File

@ -30,7 +30,7 @@ let notify_put dropbox =
dropbox.put_waiter <- None ;
Lwt.wakeup_later w ()
let rec put dropbox elt =
let put dropbox elt =
if dropbox.closed then
raise Closed
else begin

2
src/utils/lwt_pipe.ml
View File

@ -91,7 +91,7 @@ let rec push ({ closed ; queue ; current_size ;
wait_pop q >>= fun () ->
push q elt
let rec push_now ({ closed ; queue ; compute_size ;
let push_now ({ closed ; queue ; compute_size ;
current_size ; max_size
} as q) elt =
if closed then raise Closed ;

2
src/utils/lwt_utils.ml
View File

@ -358,7 +358,7 @@ let stable_sort cmp l =
let sort = stable_sort
let rec read_bytes ?(pos = 0) ?len fd buf =
let read_bytes ?(pos = 0) ?len fd buf =
let len = match len with None -> Bytes.length buf - pos | Some l -> l in
let rec inner pos len =
if len = 0 then

1
src/utils/time.ml
View File

@ -7,7 +7,6 @@
(* *)
(**************************************************************************)
open Error_monad
open CalendarLib
module T = struct

3
test/lib/jbuild
View File

@ -3,4 +3,5 @@
(library
((name test_lib)
(libraries (kaputt utils minutils))
(wrapped false)))
(wrapped false)
(flags (:standard -w -9-32 -safe-string))))

2
test/lib/node_helpers.ml
View File

@ -38,7 +38,7 @@ let fork_node ?(timeout = 4) ?(port = 18732) ?sandbox () =
let null_fd = Unix.(openfile "/dev/null" [O_RDONLY] 0o644) in
let exe =
let (//) = Filename.concat in
Filename.(Sys.getcwd () // ".." // "src" // "node_main.exe") in
Sys.getcwd () // ".." // "src" // "node_main.exe" in
let pid =
Unix.create_process exe
[| "tezos-node" ;

4
test/p2p/jbuild
View File

@ -5,7 +5,9 @@
test_p2p_connection_pool
test_p2p_io_scheduler))
(libraries (minutils utils test_lib node_net))
(flags (:standard -linkall
(flags (:standard -w -9-32
-linkall
-safe-string
-open Error_monad
-open Hash
-open Utils

1
test/p2p/test_p2p_connection.ml
View File

@ -370,7 +370,6 @@ let spec = Arg.[
]
let main () =
let open Utils in
let anon_fun _num_peers = raise (Arg.Bad "No anonymous argument.") in
let usage_msg = "Usage: %s.\nArguments are:" in
Arg.parse spec anon_fun usage_msg ;

3
test/proto_alpha/jbuild
View File

@ -10,7 +10,8 @@
client_lib
client_embedded_genesis
client_embedded_alpha))
(flags (:standard -open Error_monad
(flags (:standard -w -9-32 -safe-string
-open Error_monad
-open Hash
-open Tezos_data
-open Tezos_protocol_environment_alpha

1
test/proto_alpha/proto_alpha_helpers.mli
View File

@ -171,6 +171,7 @@ module Assert : sig
val unknown_contract : msg:string -> 'a tzresult -> unit
(** [unknown_contract ~msg result] raises if result is not a
[Storage_error]. *)
val non_existing_contract : msg:string -> 'a tzresult -> unit
val balance_too_low : msg:string -> 'a tzresult -> unit
val non_spendable : msg:string -> 'a tzresult -> unit

4
test/shell/jbuild
View File

@ -11,7 +11,9 @@
tezos_embedded_protocol_demo
tezos_embedded_protocol_alpha
tezos_embedded_protocol_genesis))
(flags (:standard -open Error_monad
(flags (:standard -w -9-32
-safe-string
-open Error_monad
-open Hash
-open Utils
-open Tezos_data))))

2
test/shell/test_context.ml
View File

@ -93,7 +93,7 @@ type t = {
let wrap_context_init f base_dir =
let root = base_dir // "context" in
Context.init root >>= fun idx ->
Context.init ~root ?patch_context:None >>= fun idx ->
Context.commit_genesis idx
~net_id
~time:genesis.time

5
test/shell/test_store.ml
View File

@ -217,7 +217,6 @@ let test_hashset (type t)
(Make_substore(Store)(struct let name = ["test_set"] end))
(Block_hash)
(BlockSet) in
let open BlockSet in
let bhset : BlockSet.t = BlockSet.add bh2 (BlockSet.add bh1 BlockSet.empty) in
StoreSet.store_all s bhset >>= fun () ->
StoreSet.read_all s >>= fun bhset' ->
@ -227,8 +226,8 @@ let test_hashset (type t)
StoreSet.store_all s bhset2 >>= fun () ->
StoreSet.read_all s >>= fun bhset2' ->
Assert.equal_block_set ~msg:__LOC__ bhset2 bhset2' ;
StoreSet.fold s BlockSet.empty
(fun bh acc -> Lwt.return (BlockSet.add bh acc)) >>= fun bhset2'' ->
StoreSet.fold s ~init:BlockSet.empty
~f:(fun bh acc -> Lwt.return (BlockSet.add bh acc)) >>= fun bhset2'' ->
Assert.equal_block_set ~msg:__LOC__ bhset2 bhset2'' ;
Store.store s ["day";"current"] (MBytes.of_string "Mercredi") >>= fun () ->
StoreSet.remove_all s >>= fun () ->

4
test/utils/jbuild
View File

@ -7,7 +7,9 @@
test_stream_data_encoding
test_utils))
(libraries (minutils utils test_lib))
(flags (:standard -open Error_monad
(flags (:standard -w -9-32
-safe-string
-open Error_monad
-open Hash
-open Utils
-open Tezos_data))))

1
test/utils/test_data_encoding.ml
View File

@ -1,5 +1,4 @@
open Data_encoding
open Hash
open Error_monad
let (>>=) = Lwt.bind

1
test/utils/test_merkle.ml
View File

@ -8,7 +8,6 @@
(**************************************************************************)
open Error_monad
open Hash
let rec (--) i j =
if j < i then []

34
test/utils/test_stream_data_encoding.ml
View File

@ -1,5 +1,4 @@
open Data_encoding
open Hash
open Error_monad
let (>>=) = Lwt.bind
@ -22,7 +21,7 @@ let rec fold_left_pending f accu l =
| a::l -> fold_left_pending f (f accu a l) l
let test_read_simple_bin_ko_invalid_data
?msg ?(not_equal=Assert.not_equal) encoding value =
?(not_equal=Assert.not_equal) encoding value =
let len_data = MBytes.length (Binary.to_bytes encoding value) in
if classify encoding != `Variable && len_data > 0 then
for sz = 1 to len_data do
@ -64,14 +63,14 @@ let test_read_simple_bin_ko_invalid_data
let unexpected loc =
loc ^ ": This case should not happen"
let test_read_simple_bin_ko_await ?msg encoding value =
let test_read_simple_bin_ko_await encoding value =
let len_data = MBytes.length (Binary.to_bytes encoding value) in
if classify encoding != `Variable && len_data > 0 then
for sz = 1 to len_data do
let l = Binary.to_bytes_list sz encoding value in
match List.rev l with
| [] -> Assert.fail_msg "%s" (unexpected __LOC__)
| e::r ->
| _ :: r ->
let l = List.rev r in (* last mbyte removed !! *)
ignore(
fold_left_pending
@ -96,7 +95,7 @@ let test_read_simple_bin_ko_await ?msg encoding value =
| Binary.Error ->
if not (classify encoding == `Variable) then
Assert.fail_msg "%s" (unexpected __LOC__)
| Binary.Success result ->
| Binary.Success _ ->
Assert.fail_msg "%s" (unexpected __LOC__)
end;
_done
@ -139,7 +138,7 @@ let test_read_simple_bin_ok ?msg ?(equal=Assert.equal) encoding value =
done
let test_check_simple_bin_ko_invalid_data
?msg ?(not_equal=Assert.not_equal) encoding value =
encoding value =
let len_data = MBytes.length (Binary.to_bytes encoding value) in
if classify encoding != `Variable && len_data > 0 then
for sz = 1 to len_data do
@ -168,7 +167,7 @@ let test_check_simple_bin_ko_invalid_data
match status with
| Binary.Await _ -> ()
| Binary.Error -> ()
| Binary.Success {res; remaining} ->
| Binary.Success { remaining } ->
Assert.equal ~msg:__LOC__ remaining [];
(* res is unit for check *)
end;
@ -177,14 +176,14 @@ let test_check_simple_bin_ko_invalid_data
)
done
let test_check_simple_bin_ko_await ?msg encoding value =
let test_check_simple_bin_ko_await encoding value =
let len_data = MBytes.length (Binary.to_bytes encoding value) in
if classify encoding != `Variable && len_data > 0 then
for sz = 1 to len_data do
let l = Binary.to_bytes_list sz encoding value in
match List.rev l with
| [] -> Assert.fail_msg "%s" (unexpected __LOC__)
| e::r ->
| _ :: r ->
let l = List.rev r in (* last mbyte removed !! *)
ignore(
fold_left_pending
@ -209,7 +208,7 @@ let test_check_simple_bin_ko_await ?msg encoding value =
| Binary.Error ->
if not (classify encoding == `Variable) then
Assert.fail_msg "%s" (unexpected __LOC__)
| Binary.Success result ->
| Binary.Success _ ->
Assert.fail_msg "%s" (unexpected __LOC__)
end;
_done
@ -217,7 +216,7 @@ let test_check_simple_bin_ko_await ?msg encoding value =
)
done
let test_check_simple_bin_ok ?msg ?(equal=Assert.equal) encoding value =
let test_check_simple_bin_ok encoding value =
let len_data = max 1 (MBytes.length (Binary.to_bytes encoding value)) in
for sz = 1 to len_data do
ignore(
@ -238,7 +237,7 @@ let test_check_simple_bin_ok ?msg ?(equal=Assert.equal) encoding value =
)status _todo
in
match status with
| Binary.Success {res; remaining} ->
| Binary.Success { remaining } ->
Assert.equal ~msg:__LOC__ remaining [];
(* res is unit for check *)
| Binary.Await _ -> Assert.fail_msg "%s" (unexpected __LOC__)
@ -254,15 +253,14 @@ let test_check_simple_bin_ok ?msg ?(equal=Assert.equal) encoding value =
let test_simple
~msg ?(equal=Assert.equal) ?(not_equal=Assert.not_equal) enc value
=
test_check_simple_bin_ok ~msg:(msg ^ ": binary-ok") ~equal enc value;
test_check_simple_bin_ko_await ~msg:(msg ^ ": binary-ko_await") enc value;
test_check_simple_bin_ko_invalid_data
~msg:(msg ^ ": binary-invalid_data") ~not_equal enc value;
test_check_simple_bin_ok enc value;
test_check_simple_bin_ko_await enc value;
test_check_simple_bin_ko_invalid_data enc value;
test_read_simple_bin_ok ~msg:(msg ^ ": binary-ok") ~equal enc value;
test_read_simple_bin_ko_await ~msg:(msg ^ ": binary-ko_await") enc value;
test_read_simple_bin_ko_await enc value;
test_read_simple_bin_ko_invalid_data
~msg:(msg ^ ": binary-invalid_data") ~not_equal enc value
~not_equal enc value

1
test/utils/test_utils.ml
View File

@ -8,7 +8,6 @@
(**************************************************************************)
open Error_monad
open Hash
let rec (--) i j =
if j < i then []