diff --git a/Makefile b/Makefile index adedcb579..11a293050 100644 --- a/Makefile +++ b/Makefile @@ -2,7 +2,10 @@ DEV ?= --dev all: - @jbuilder build tezos.install ${DEV} + @jbuilder build ${DEV} \ + src/node_main.exe \ + src/client_main.exe \ + src/compiler_main.exe @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 diff --git a/jbuild b/jbuild index a30ff1f86..ebd7a0e59 100644 --- a/jbuild +++ b/jbuild @@ -1,63 +1,5 @@ (jbuild_version 1) -(alias - ((name runtest_indent) - (deps ( ;; Hack... list all directories - (glob_files scripts/*.ml) - (glob_files scripts/*.mli) - (glob_files src/*.ml) - (glob_files src/*.mli) - (glob_files src/attacker/*.ml) - (glob_files src/attacker/*.mli) - (glob_files src/client/*.ml) - (glob_files src/client/*.mli) - (glob_files src/client/embedded/alpha/*.ml) - (glob_files src/client/embedded/alpha/*.mli) - (glob_files src/client/embedded/demo/*.ml) - (glob_files src/client/embedded/demo/*.mli) - (glob_files src/client/embedded/genesis/*.ml) - (glob_files src/client/embedded/genesis/*.mli) - (glob_files src/compiler/*.ml) - (glob_files src/compiler/*.mli) - (glob_files src/environment/sigs_packer/*.ml) - (glob_files src/environment/sigs_packer/*.mli) - (glob_files src/environment/v1/*.ml) - (glob_files src/environment/v1/*.mli) - (glob_files src/micheline/*.ml) - (glob_files src/micheline/*.mli) - (glob_files src/minutils/*.ml) - (glob_files src/minutils/*.mli) - (glob_files src/node/db/*.ml) - (glob_files src/node/db/*.mli) - (glob_files src/node/main/*.ml) - (glob_files src/node/main/*.mli) - (glob_files src/node/net/*.ml) - (glob_files src/node/net/*.mli) - (glob_files src/node/shell/*.ml) - (glob_files src/node/shell/*.mli) - (glob_files src/node/updater/*.ml) - (glob_files src/node/updater/*.mli) - (glob_files src/proto/alpha/*.ml) - (glob_files src/proto/alpha/*.mli) - (glob_files src/proto/demo/*.ml) - (glob_files src/proto/demo/*.mli) - (glob_files src/proto/genesis/*.ml) - (glob_files src/proto/genesis/*.mli) - (glob_files src/utils/*.ml) - (glob_files src/utils/*.mli) - (glob_files test/lib/*.ml) - (glob_files test/lib/*.mli) - (glob_files test/p2p/*.ml) - (glob_files test/p2p/*.mli) - (glob_files test/proto_alpha/*.ml) - (glob_files test/proto_alpha/*.mli) - (glob_files test/shell/*.ml) - (glob_files test/shell/*.mli) - (glob_files test/utils/*.ml) - (glob_files test/utils/*.mli) - )) - (action (run bash ${path:scripts/test-ocp-indent.sh})))) - (alias ((name runtest) - (deps ((alias runtest_indent))))) + (deps ((alias_rec runtest_indent))))) diff --git a/lib_base/block_header.ml b/lib_base/block_header.ml new file mode 100644 index 000000000..978b02c79 --- /dev/null +++ b/lib_base/block_header.ml @@ -0,0 +1,90 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2017. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +type shell_header = { + level: Int32.t ; + proto_level: int ; (* uint8 *) + predecessor: Block_hash.t ; + timestamp: Time.t ; + validation_passes: int ; (* uint8 *) + operations_hash: Operation_list_list_hash.t ; + fitness: MBytes.t list ; +} + +let shell_header_encoding = + let open Data_encoding in + conv + (fun { level ; proto_level ; predecessor ; + timestamp ; validation_passes ; operations_hash ; fitness } -> + (level, proto_level, predecessor, + timestamp, validation_passes, operations_hash, fitness)) + (fun (level, proto_level, predecessor, + timestamp, validation_passes, operations_hash, fitness) -> + { level ; proto_level ; predecessor ; + timestamp ; validation_passes ; operations_hash ; fitness }) + (obj7 + (req "level" int32) + (req "proto" uint8) + (req "predecessor" Block_hash.encoding) + (req "timestamp" Time.encoding) + (req "validation_pass" uint8) + (req "operations_hash" Operation_list_list_hash.encoding) + (req "fitness" Fitness.encoding)) + +type t = { + shell: shell_header ; + proto: MBytes.t ; +} + +let encoding = + let open Data_encoding in + conv + (fun { shell ; proto } -> (shell, proto)) + (fun (shell, proto) -> { shell ; proto }) + (merge_objs + shell_header_encoding + (obj1 (req "data" Variable.bytes))) + +let pp fmt op = + Format.pp_print_string fmt @@ + Data_encoding_ezjsonm.to_string (Data_encoding.Json.construct encoding op) + +let compare b1 b2 = + let (>>) x y = if x = 0 then y () else x in + let rec list compare xs ys = + match xs, ys with + | [], [] -> 0 + | _ :: _, [] -> -1 + | [], _ :: _ -> 1 + | x :: xs, y :: ys -> + compare x y >> fun () -> list compare xs ys in + Block_hash.compare b1.shell.predecessor b2.shell.predecessor >> fun () -> + compare b1.proto b2.proto >> fun () -> + Operation_list_list_hash.compare + b1.shell.operations_hash b2.shell.operations_hash >> fun () -> + Time.compare b1.shell.timestamp b2.shell.timestamp >> fun () -> + list compare b1.shell.fitness b2.shell.fitness + +let equal b1 b2 = compare b1 b2 = 0 + +let (=) = equal +let (<>) x y = compare x y <> 0 +let (<) x y = compare x y < 0 +let (<=) x y = compare x y <= 0 +let (>=) x y = compare x y >= 0 +let (>) x y = compare x y > 0 +let min x y = if x <= y then x else y +let max x y = if x <= y then y else x + +let to_bytes v = Data_encoding.Binary.to_bytes encoding v +let of_bytes b = Data_encoding.Binary.of_bytes encoding b +let of_bytes_exn b = Data_encoding.Binary.of_bytes_exn encoding b + +let hash block = Block_hash.hash_bytes [to_bytes block] +let hash_raw bytes = Block_hash.hash_bytes [bytes] diff --git a/lib_base/block_header.mli b/lib_base/block_header.mli new file mode 100644 index 000000000..bfe33a418 --- /dev/null +++ b/lib_base/block_header.mli @@ -0,0 +1,29 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2017. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +type shell_header = { + level: Int32.t ; + proto_level: int ; (* uint8 *) + predecessor: Block_hash.t ; + timestamp: Time.t ; + validation_passes: int ; (* uint8 *) + operations_hash: Operation_list_list_hash.t ; + fitness: MBytes.t list ; +} + +val shell_header_encoding: shell_header Data_encoding.t + +type t = { + shell: shell_header ; + proto: MBytes.t ; +} + +include S.HASHABLE with type t := t + and type hash := Block_hash.t +val of_bytes_exn: MBytes.t -> t diff --git a/src/utils/data_encoding_ezjsonm.ml b/lib_base/data_encoding_ezjsonm.ml similarity index 100% rename from src/utils/data_encoding_ezjsonm.ml rename to lib_base/data_encoding_ezjsonm.ml diff --git a/src/utils/data_encoding_ezjsonm.mli b/lib_base/data_encoding_ezjsonm.mli similarity index 100% rename from src/utils/data_encoding_ezjsonm.mli rename to lib_base/data_encoding_ezjsonm.mli diff --git a/lib_base/fitness.ml b/lib_base/fitness.ml new file mode 100644 index 000000000..a16ed70b5 --- /dev/null +++ b/lib_base/fitness.ml @@ -0,0 +1,65 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2017. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +type t = MBytes.t list + +(* Fitness comparison: + - shortest lists are smaller ; + - lexicographical order for lists of the same length. *) +let compare_bytes b1 b2 = + let len1 = MBytes.length b1 in + let len2 = MBytes.length b2 in + let c = compare len1 len2 in + if c <> 0 + then c + else + let rec compare_byte b1 b2 pos len = + if pos = len + then 0 + else + let c = compare (MBytes.get_char b1 pos) (MBytes.get_char b2 pos) in + if c <> 0 + then c + else compare_byte b1 b2 (pos+1) len + in + compare_byte b1 b2 0 len1 + +let compare f1 f2 = + let rec compare_rec f1 f2 = match f1, f2 with + | [], [] -> 0 + | i1 :: f1, i2 :: f2 -> + let i = compare_bytes i1 i2 in + if i = 0 then compare_rec f1 f2 else i + | _, _ -> assert false in + let len = compare (List.length f1) (List.length f2) in + if len = 0 then compare_rec f1 f2 else len + +let equal f1 f2 = compare f1 f2 = 0 + +let (=) = equal +let (<>) x y = compare x y <> 0 +let (<) x y = compare x y < 0 +let (<=) x y = compare x y <= 0 +let (>=) x y = compare x y >= 0 +let (>) x y = compare x y > 0 +let min x y = if x <= y then x else y +let max x y = if x <= y then y else x + +let rec pp fmt = function + | [] -> () + | [f] -> Format.fprintf fmt "%s" (Hex_encode.hex_of_bytes f) + | f1 :: f -> Format.fprintf fmt "%s::%a" (Hex_encode.hex_of_bytes f1) pp f + +let encoding = + let open Data_encoding in + describe ~title: "Tezos block fitness" + (list bytes) + +let to_bytes v = Data_encoding.Binary.to_bytes encoding v +let of_bytes b = Data_encoding.Binary.of_bytes encoding b diff --git a/lib_base/fitness.mli b/lib_base/fitness.mli new file mode 100644 index 000000000..2bd4a8ef4 --- /dev/null +++ b/lib_base/fitness.mli @@ -0,0 +1,10 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2017. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +include S.T with type t = MBytes.t list diff --git a/lib_base/jbuild b/lib_base/jbuild new file mode 100644 index 000000000..f16802c6e --- /dev/null +++ b/lib_base/jbuild @@ -0,0 +1,22 @@ +(jbuild_version 1) + +(library + ((name tezos_base) + (public_name tezos-base) + (flags (:standard -open Tezos_stdlib + -open Tezos_stdlib_lwt + -open Tezos_crypto + -open Tezos_data_encoding + -open Tezos_error_monad)) + (libraries (tezos-stdlib + tezos-stdlib-lwt + tezos-crypto + tezos-data-encoding + tezos-error-monad + ezjsonm + calendar)))) + +(alias + ((name runtest_indent) + (deps ((glob_files *.ml) (glob_files *.mli))) + (action (run bash ${libexec:tezos-stdlib:test-ocp-indent.sh} ${<})))) diff --git a/lib_base/operation.ml b/lib_base/operation.ml new file mode 100644 index 000000000..ff09183bb --- /dev/null +++ b/lib_base/operation.ml @@ -0,0 +1,59 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2017. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +type shell_header = { + branch: Block_hash.t ; +} + +let shell_header_encoding = + let open Data_encoding in + conv + (fun { branch } -> branch) + (fun branch -> { branch }) + (obj1 (req "branch" Block_hash.encoding)) + +type t = { + shell: shell_header ; + proto: MBytes.t ; +} +let encoding = + let open Data_encoding in + conv + (fun { shell ; proto } -> (shell, proto)) + (fun (shell, proto) -> { shell ; proto }) + (merge_objs + shell_header_encoding + (obj1 (req "data" Variable.bytes))) + +let pp fmt op = + Format.pp_print_string fmt @@ + Data_encoding_ezjsonm.to_string (Data_encoding.Json.construct encoding op) + +let compare o1 o2 = + let (>>) x y = if x = 0 then y () else x in + Block_hash.compare o1.shell.branch o1.shell.branch >> fun () -> + MBytes.compare o1.proto o2.proto +let equal b1 b2 = compare b1 b2 = 0 + +let (=) = equal +let (<>) x y = compare x y <> 0 +let (<) x y = compare x y < 0 +let (<=) x y = compare x y <= 0 +let (>=) x y = compare x y >= 0 +let (>) x y = compare x y > 0 +let min x y = if x <= y then x else y +let max x y = if x <= y then y else x + +let to_bytes v = Data_encoding.Binary.to_bytes encoding v +let of_bytes b = Data_encoding.Binary.of_bytes encoding b +let of_bytes_exn b = Data_encoding.Binary.of_bytes_exn encoding b + +let hash op = Operation_hash.hash_bytes [to_bytes op] +let hash_raw bytes = Operation_hash.hash_bytes [bytes] + diff --git a/lib_base/operation.mli b/lib_base/operation.mli new file mode 100644 index 000000000..2c3cfdcf6 --- /dev/null +++ b/lib_base/operation.mli @@ -0,0 +1,22 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2017. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +type shell_header = { + branch: Block_hash.t ; +} +val shell_header_encoding: shell_header Data_encoding.t + +type t = { + shell: shell_header ; + proto: MBytes.t ; +} + +include S.HASHABLE with type t := t + and type hash := Operation_hash.t +val of_bytes_exn: MBytes.t -> t diff --git a/lib_base/protocol.ml b/lib_base/protocol.ml new file mode 100644 index 000000000..f71822c6b --- /dev/null +++ b/lib_base/protocol.ml @@ -0,0 +1,71 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2017. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +type t = { + expected_env: env_version ; + components: component list ; +} + +and component = { + name: string ; + interface: string option ; + implementation: string ; +} + +and env_version = V1 + +let component_encoding = + let open Data_encoding in + conv + (fun { name ; interface; implementation } -> + (name, interface, implementation)) + (fun (name, interface, implementation) -> + { name ; interface ; implementation }) + (obj3 + (req "name" string) + (opt "interface" string) + (req "implementation" string)) + +let env_version_encoding = + let open Data_encoding in + conv + (function V1 -> 0) + (function 0 -> V1 | _ -> failwith "unexpected environment version") + int16 + +let encoding = + let open Data_encoding in + conv + (fun { expected_env ; components } -> (expected_env, components)) + (fun (expected_env, components) -> { expected_env ; components }) + (obj2 + (req "expected_env_version" env_version_encoding) + (req "components" (list component_encoding))) + +let pp fmt op = + Format.pp_print_string fmt @@ + Data_encoding_ezjsonm.to_string (Data_encoding.Json.construct encoding op) + +let compare = Pervasives.compare +let equal = (=) + +let (=) = equal +let (<>) x y = compare x y <> 0 +let (<) x y = compare x y < 0 +let (<=) x y = compare x y <= 0 +let (>=) x y = compare x y >= 0 +let (>) x y = compare x y > 0 +let min x y = if x <= y then x else y +let max x y = if x <= y then y else x + +let to_bytes v = Data_encoding.Binary.to_bytes encoding v +let of_bytes b = Data_encoding.Binary.of_bytes encoding b +let of_bytes_exn b = Data_encoding.Binary.of_bytes_exn encoding b +let hash proto = Protocol_hash.hash_bytes [to_bytes proto] +let hash_raw proto = Protocol_hash.hash_bytes [proto] diff --git a/lib_base/protocol.mli b/lib_base/protocol.mli new file mode 100644 index 000000000..66e019277 --- /dev/null +++ b/lib_base/protocol.mli @@ -0,0 +1,29 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2017. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +type t = { + expected_env: env_version ; + components: component list ; +} + +and component = { + name: string ; + interface: string option ; + implementation: string ; +} + +and env_version = V1 + +val component_encoding: component Data_encoding.t +val env_version_encoding: env_version Data_encoding.t + +include S.HASHABLE with type t := t + and type hash := Protocol_hash.t +val of_bytes_exn: MBytes.t -> t + diff --git a/lib_base/s.ml b/lib_base/s.ml new file mode 100644 index 000000000..061eee0ac --- /dev/null +++ b/lib_base/s.ml @@ -0,0 +1,42 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2017. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +module type T = sig + + type t + + val compare: t -> t -> int + val equal: t -> t -> bool + + val (=): t -> t -> bool + val (<>): t -> t -> bool + val (<): t -> t -> bool + val (<=): t -> t -> bool + val (>=): t -> t -> bool + val (>): t -> t -> bool + val min: t -> t -> t + val max: t -> t -> t + + val pp: Format.formatter -> t -> unit + + val encoding: t Data_encoding.t + val to_bytes: t -> MBytes.t + val of_bytes: MBytes.t -> t option + +end + +module type HASHABLE = sig + + include T + + type hash + val hash: t -> hash + val hash_raw: MBytes.t -> hash + +end diff --git a/lib_base/tezos-base.opam b/lib_base/tezos-base.opam new file mode 100644 index 000000000..523511e2f --- /dev/null +++ b/lib_base/tezos-base.opam @@ -0,0 +1,26 @@ +opam-version: "1.2" +version: "dev" +maintainer: "contact@tezos.com" +authors: [ "Tezos devteam" ] +homepage: "https://www.tezos.com/" +bug-reports: "https://gitlab.com/tezos/tezos/issues" +dev-repo: "https://gitlab.com/tezos/tezos.git" +license: "unreleased" +depends: [ + "ocamlfind" { build } + "jbuilder" { build & >= "1.0+beta15" } + "base-bigarray" + "tezos-stdlib" + "tezos-stdlib-lwt" + "tezos-crypto" + "tezos-data-encoding" + "tezos-error-monad" + "ezjsonm" + "calendar" +] +build: [ + [ "jbuilder" "build" "-p" name "-j" jobs ] +] +build-test: [ + [ "jbuilder" "runtest" "-p" name "-j" jobs ] +] diff --git a/src/utils/time.ml b/lib_base/time.ml similarity index 100% rename from src/utils/time.ml rename to lib_base/time.ml diff --git a/src/utils/time.mli b/lib_base/time.mli similarity index 100% rename from src/utils/time.mli rename to lib_base/time.mli diff --git a/lib_base/tzPervasives.ml b/lib_base/tzPervasives.ml new file mode 100644 index 000000000..461f7c378 --- /dev/null +++ b/lib_base/tzPervasives.ml @@ -0,0 +1,33 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2017. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +include Tezos_stdlib +include Tezos_stdlib_lwt +include Tezos_crypto +include Tezos_data_encoding +include Tezos_error_monad + +module List = struct + include List + include Tezos_stdlib.TzList +end +module String = struct + include String + include Tezos_stdlib.TzString +end + +module Time = Time +module Data_encoding_ezjsonm = Data_encoding_ezjsonm +module Fitness = Fitness +module Block_header = Block_header +module Operation = Operation +module Protocol = Protocol + +include Utils.Infix +include Error_monad diff --git a/lib_base/tzPervasives.mli b/lib_base/tzPervasives.mli new file mode 100644 index 000000000..4e26a615d --- /dev/null +++ b/lib_base/tzPervasives.mli @@ -0,0 +1,33 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2017. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +include (module type of (struct include Tezos_stdlib end)) +include (module type of (struct include Tezos_data_encoding end)) +include (module type of (struct include Tezos_stdlib_lwt end)) +include (module type of (struct include Tezos_crypto end)) +include (module type of (struct include Tezos_error_monad end)) + +module List : sig + include (module type of (struct include List end)) + include (module type of (struct include Tezos_stdlib.TzList end)) +end +module String : sig + include (module type of (struct include String end)) + include (module type of (struct include Tezos_stdlib.TzString end)) +end + +module Time = Time +module Data_encoding_ezjsonm = Data_encoding_ezjsonm +module Fitness = Fitness +module Block_header = Block_header +module Operation = Operation +module Protocol = Protocol + +include (module type of (struct include Utils.Infix end)) +include (module type of (struct include Error_monad end)) diff --git a/src/utils/base58.ml b/lib_crypto/base58.ml similarity index 89% rename from src/utils/base58.ml rename to lib_crypto/base58.ml index df3fca9ef..b52420d3d 100644 --- a/src/utils/base58.ml +++ b/lib_crypto/base58.ml @@ -7,16 +7,11 @@ (* *) (**************************************************************************) -open Utils open Lwt.Infix let base = 58 let zbase = Z.of_int base -let log2 x = log x /. log 2. -let log2_base = log2 (float_of_int base) - - module Alphabet = struct type t = { encode: string ; decode: string } @@ -53,7 +48,7 @@ module Alphabet = struct done; !res - let pp ppf { encode } = Format.fprintf ppf "%s" encode + let pp ppf { encode ; _ } = Format.fprintf ppf "%s" encode end @@ -75,7 +70,7 @@ let count_leading_char s c = let of_char ?(alphabet=Alphabet.default) x = let pos = String.get alphabet.decode (int_of_char x) in - if pos = '\255' then failwith "Invalid data" ; + if pos = '\255' then Pervasives.failwith "Invalid data" ; int_of_char pos let to_char ?(alphabet=Alphabet.default) x = @@ -149,12 +144,12 @@ type 'a encoding = { wrap: 'a -> data ; } -let simple_decode ?alphabet { prefix ; of_raw } s = +let simple_decode ?alphabet { prefix ; of_raw ; _ } s = safe_decode ?alphabet s |> - remove_prefix ~prefix |> - Utils.apply_option ~f:of_raw + TzString.remove_prefix ~prefix |> + Option.apply ~f:of_raw -let simple_encode ?alphabet { prefix ; to_raw } d = +let simple_encode ?alphabet { prefix ; to_raw ; _ } d = safe_encode ?alphabet (prefix ^ to_raw d) type registred_encoding = Encoding : 'a encoding -> registred_encoding @@ -167,9 +162,9 @@ module MakeEncodings(E: sig let check_ambiguous_prefix prefix encodings = List.iter - (fun (Encoding { encoded_prefix = s }) -> - if remove_prefix ~prefix:s prefix <> None || - remove_prefix ~prefix s <> None then + (fun (Encoding { encoded_prefix = s ; _ }) -> + if TzString.remove_prefix ~prefix:s prefix <> None || + TzString.remove_prefix ~prefix s <> None then Format.ksprintf invalid_arg "Base58.register_encoding: duplicate prefix: %S, %S." s prefix) encodings @@ -205,11 +200,11 @@ module MakeEncodings(E: sig let check_encoded_prefix enc p l = if enc.encoded_prefix <> p then - Format.kasprintf failwith + Format.kasprintf Pervasives.failwith "Unexpected prefix %s (expected %s)" p enc.encoded_prefix ; if enc.encoded_length <> l then - Format.kasprintf failwith + Format.kasprintf Pervasives.failwith "Unexpected encoded length %d for %s (expected %d)" l p enc.encoded_length @@ -217,14 +212,15 @@ module MakeEncodings(E: sig try let rec find s = function | [] -> None - | Encoding { prefix ; of_raw ; wrap } :: encodings -> - match remove_prefix ~prefix s with + | Encoding { prefix ; of_raw ; wrap ; _ } :: encodings -> + match TzString.remove_prefix ~prefix s with | None -> find s encodings - | Some msg -> of_raw msg |> Utils.map_option ~f:wrap in + | Some msg -> of_raw msg |> Option.map ~f:wrap in let s = safe_decode ?alphabet s in find s !encodings with Invalid_argument _ -> None + end type 'a resolver = @@ -235,7 +231,6 @@ type 'a resolver = module MakeResolvers(R: sig type context - val encodings: registred_encoding list ref end) = struct let resolvers = ref [] @@ -252,14 +247,14 @@ module MakeResolvers(R: sig let n = String.length request in let min = raw_decode ~alphabet (request ^ String.make (len - n) zero) in let max = raw_decode ~alphabet (request ^ String.make (len - n) last) in - let prefix_len = Utils.common_prefix min max in + let prefix_len = TzString.common_prefix min max in String.sub min 0 prefix_len let complete ?alphabet context request = let rec find s = function | [] -> Lwt.return_nil | Resolver { encoding ; resolver } :: resolvers -> - if not (has_prefix ~prefix:encoding.encoded_prefix s) then + if not (TzString.has_prefix ~prefix:encoding.encoded_prefix s) then find s resolvers else let prefix = @@ -273,11 +268,11 @@ module MakeResolvers(R: sig String.sub prefix ignored (len - ignored) end in resolver context msg >|= fun msgs -> - filter_map + TzList.filter_map (fun msg -> let res = simple_encode encoding ?alphabet msg in - Utils.remove_prefix ~prefix:request res |> - Utils.map_option ~f:(fun _ -> res)) + TzString.remove_prefix ~prefix:request res |> + Option.map ~f:(fun _ -> res)) msgs in find request !resolvers @@ -286,7 +281,6 @@ end include MakeEncodings(struct let encodings = [] end) include MakeResolvers(struct type context = unit - let encodings = encodings end) let register_resolver enc f = register_resolver enc (fun () s -> f s) @@ -296,7 +290,6 @@ module Make(C: sig type context end) = struct include MakeEncodings(struct let encodings = !encodings end) include MakeResolvers(struct type context = C.context - let encodings = encodings end) end diff --git a/src/utils/base58.mli b/lib_crypto/base58.mli similarity index 100% rename from src/utils/base58.mli rename to lib_crypto/base58.mli diff --git a/src/utils/hash.ml b/lib_crypto/blake2B.ml similarity index 50% rename from src/utils/hash.ml rename to lib_crypto/blake2B.ml index de3fc64ea..aa311f578 100644 --- a/src/utils/hash.ml +++ b/lib_crypto/blake2B.ml @@ -7,12 +7,6 @@ (* *) (**************************************************************************) -let (//) = Filename.concat -let (>>=) = Lwt.bind -let (>|=) = Lwt.(>|=) - -open Error_monad - let () = let expected_primitive = "blake2b" and primitive = Sodium.Generichash.primitive in @@ -24,130 +18,9 @@ let () = exit 1 end -(*-- Signatures -------------------------------------------------------------*) - -module type MINIMAL_HASH = sig - - type t - - val name: string - val title: string - - val hash_bytes: MBytes.t list -> t - val hash_string: string list -> t - val size: int (* in bytes *) - val compare: t -> t -> int - val equal: t -> t -> bool - - val to_hex: t -> string - val of_hex: string -> t option - val of_hex_exn: string -> t - - val to_string: t -> string - val of_string: string -> t option - val of_string_exn: string -> t - - val to_bytes: t -> MBytes.t - val of_bytes: MBytes.t -> t option - val of_bytes_exn: MBytes.t -> t - - val read: MBytes.t -> int -> t - val write: MBytes.t -> int -> t -> unit - - val to_path: t -> string list -> string list - val of_path: string list -> t option - val of_path_exn: string list -> t - - val prefix_path: string -> string list - val path_length: int - -end - -module type INTERNAL_MINIMAL_HASH = sig - include MINIMAL_HASH - module Table : Hashtbl.S with type key = t -end - -module type HASH = sig - - include MINIMAL_HASH - - val of_b58check_exn: string -> t - val of_b58check_opt: string -> t option - val to_b58check: t -> string - val to_short_b58check: t -> string - val encoding: t Data_encoding.t - val pp: Format.formatter -> t -> unit - val pp_short: Format.formatter -> t -> unit - type Base58.data += Hash of t - val b58check_encoding: t Base58.encoding - - module Set : sig - include Set.S with type elt = t - val encoding: t Data_encoding.t - end - - module Map : sig - include Map.S with type key = t - val encoding: 'a Data_encoding.t -> 'a t Data_encoding.t - end - -end - -module type INTERNAL_HASH = sig - include HASH - val of_b58check: string -> t tzresult - val param: - ?name:string -> - ?desc:string -> - ('a, 'arg, 'ret) Cli_entries.params -> - (t -> 'a, 'arg, 'ret) Cli_entries.params - val random_set_elt: Set.t -> t - module Table : Hashtbl.S with type key = t -end - -module type INTERNAL_MERKLE_TREE = sig - type elt - include INTERNAL_HASH - val compute: elt list -> t - val empty: t - type path = - | Left of path * t - | Right of t * path - | Op - val compute_path: elt list -> int -> path - val check_path: path -> elt -> t * int - val path_encoding: path Data_encoding.t -end - -module type MERKLE_TREE = sig - type elt - include HASH - val compute: elt list -> t - val empty: t - type path = - | Left of path * t - | Right of t * path - | Op - val compute_path: elt list -> int -> path - val check_path: path -> elt -> t * int - val path_encoding: path Data_encoding.t -end - -module type Name = sig - val name: string - val title: string - val size: int option -end - -module type PrefixedName = sig - include Name - val b58check_prefix: string -end - (*-- Type specific Hash builder ---------------------------------------------*) -module Make_minimal_Blake2B (K : Name) = struct +module Make_minimal (K : S.Name) = struct type t = Sodium.Generichash.hash @@ -212,19 +85,6 @@ module Make_minimal_Blake2B (K : Name) = struct l ; final state - let fold_read f buf off len init = - let last = off + len * size in - if last > MBytes.length buf then - invalid_arg "Hash.read_set: invalid size."; - let rec loop acc off = - if off >= last then - acc - else - let hash = read buf off in - loop (f hash acc) (off + size) - in - loop init off - let path_length = 6 let to_path key l = let key = to_hex key in @@ -263,7 +123,7 @@ module Make_minimal_Blake2B (K : Name) = struct end -module Make_Blake2B (R : sig +module Make (R : sig val register_encoding: prefix: string -> length:int -> @@ -271,9 +131,9 @@ module Make_Blake2B (R : sig of_raw: (string -> 'a option) -> wrap: ('a -> Base58.data) -> 'a Base58.encoding - end) (K : PrefixedName) = struct + end) (K : S.PrefixedName) = struct - include Make_minimal_Blake2B(K) + include Make_minimal(K) (* Serializers *) @@ -382,7 +242,7 @@ module Generic_Merkle_tree (H : sig | [] -> H.empty | [x] -> H.leaf x | _ :: _ :: _ -> - let last = Utils.list_last_exn xs in + let last = TzList.last_exn xs in let n = List.length xs in let a = Array.make (n+1) (H.leaf last) in List.iteri (fun i x -> a.(i) <- H.leaf x) xs ; @@ -414,7 +274,7 @@ module Generic_Merkle_tree (H : sig | [] -> invalid_arg "compute_path" | [_] -> Op | _ :: _ :: _ -> - let last = Utils.list_last_exn xs in + let last = TzList.last_exn xs in let n = List.length xs in if i < 0 || n <= i then invalid_arg "compute_path" ; let a = Array.make (n+1) (H.leaf last) in @@ -471,13 +331,13 @@ module Make_merkle_tree wrap: ('a -> Base58.data) -> 'a Base58.encoding end) - (K : PrefixedName) + (K : S.PrefixedName) (Contents: sig type t val to_bytes: t -> MBytes.t end) = struct - include Make_Blake2B (R) (K) + include Make (R) (K) type elt = Contents.t @@ -494,215 +354,9 @@ module Make_merkle_tree end -(*-- Pre-instanciated hashes ------------------------------------------------*) - -module Block_hash = - Make_Blake2B (Base58) (struct - let name = "Block_hash" - let title = "A Tezos block ID" - let b58check_prefix = Base58.Prefix.block_hash - let size = None - end) - -module Operation_hash = - Make_Blake2B (Base58) (struct - let name = "Operation_hash" - let title = "A Tezos operation ID" - let b58check_prefix = Base58.Prefix.operation_hash - let size = None - end) - -module Operation_list_hash = - Make_merkle_tree (Base58) (struct - let name = "Operation_list_hash" - let title = "A list of operations" - let b58check_prefix = Base58.Prefix.operation_list_hash - let size = None - end) (Operation_hash) - -module Operation_list_list_hash = - Make_merkle_tree (Base58) (struct - let name = "Operation_list_list_hash" - let title = "A list of list of operations" - let b58check_prefix = Base58.Prefix.operation_list_list_hash - let size = None - end) (Operation_list_hash) - -module Protocol_hash = - Make_Blake2B (Base58) (struct - let name = "Protocol_hash" - let title = "A Tezos protocol ID" - let b58check_prefix = Base58.Prefix.protocol_hash - let size = None - end) - -module Generic_hash = - Make_minimal_Blake2B (struct +include + Make_minimal (struct let name = "Generic_hash" let title = "" let size = None end) - -module Net_id = struct - - type t = string - - let name = "Net_id" - let title = "Network identifier" - - let size = 4 - - let extract bh = - MBytes.substring (Block_hash.to_bytes bh) 0 4 - - let hash_bytes l = extract (Block_hash.hash_bytes l) - let hash_string l = extract (Block_hash.hash_string l) - - let of_block_hash bh = hash_bytes [Block_hash.to_bytes bh] - - type Base58.data += Hash of t - - let of_string s = - if String.length s <> size then None else Some s - let of_string_exn s = - match of_string s with - | None -> - let msg = - Printf.sprintf "%s.of_string: wrong string size (%d)" - name (String.length s) in - raise (Invalid_argument msg) - | Some h -> h - let to_string s = s - - let of_hex s = of_string (Hex_encode.hex_decode s) - let of_hex_exn s = of_string_exn (Hex_encode.hex_decode s) - let to_hex s = Hex_encode.hex_encode (to_string s) - - let compare = String.compare - let equal = String.equal - - let of_bytes b = - if MBytes.length b <> size then - None - else - Some (MBytes.to_string b) - let of_bytes_exn b = - match of_bytes b with - | None -> - let msg = - Printf.sprintf "%s.of_bytes: wrong string size (%d)" - name (MBytes.length b) in - raise (Invalid_argument msg) - | Some h -> h - let to_bytes = MBytes.of_string - - let read src off = of_bytes_exn @@ MBytes.sub src off size - let write dst off h = MBytes.blit (to_bytes h) 0 dst off size - - let b58check_encoding = - Base58.register_encoding - ~prefix: Base58.Prefix.net_id - ~length: size - ~wrap: (fun s -> Hash s) - ~of_raw:of_string ~to_raw: (fun h -> h) - - let of_b58check_opt s = - Base58.simple_decode b58check_encoding s - let of_b58check_exn s = - match Base58.simple_decode b58check_encoding s with - | Some x -> x - | None -> Format.kasprintf Pervasives.failwith "Unexpected hash (%s)" name - let of_b58check s = - match Base58.simple_decode b58check_encoding s with - | Some x -> Ok x - | None -> generic_error "Unexpected hash (%s)" name - let to_b58check s = Base58.simple_encode b58check_encoding s - let to_short_b58check = to_b58check - - let encoding = - let open Data_encoding in - splitted - ~binary: (Fixed.string size) - ~json: - (describe ~title: (title ^ " (Base58Check-encoded Blake2B hash)") @@ - conv to_b58check (Data_encoding.Json.wrap_error of_b58check_exn) string) - - let param ?(name=name) ?(desc=title) t = - Cli_entries.(param ~name ~desc (parameter (fun _ str -> Lwt.return (of_b58check str))) t) - - let pp ppf t = - Format.pp_print_string ppf (to_b58check t) - - let pp_short ppf t = - Format.pp_print_string ppf (to_short_b58check t) - - module Set = struct - include Set.Make(struct type nonrec t = t let compare = compare end) - exception Found of elt - let random_elt s = - let n = Random.int (cardinal s) in - try - ignore - (fold (fun x i -> if i = n then raise (Found x) ; i+1) s 0 : int) ; - assert false - with Found x -> x - let encoding = - Data_encoding.conv - elements - (fun l -> List.fold_left (fun m x -> add x m) empty l) - Data_encoding.(list encoding) - end - let random_set_elt = Set.random_elt - - module Map = struct - include Map.Make(struct type nonrec t = t let compare = compare end) - let encoding arg_encoding = - Data_encoding.conv - bindings - (fun l -> List.fold_left (fun m (k,v) -> add k v m) empty l) - Data_encoding.(list (tup2 encoding arg_encoding)) - end - - let fold_read f buf off len init = - let last = off + len * size in - if last > MBytes.length buf then - invalid_arg "Hash.read_set: invalid size."; - let rec loop acc off = - if off >= last then - acc - else - let hash = read buf off in - loop (f hash acc) (off + size) - in - loop init off - - let path_length = 1 - let to_path key l = to_hex key :: l - let of_path path = - let path = String.concat "" path in - of_hex path - let of_path_exn path = - let path = String.concat "" path in - of_hex_exn path - - let prefix_path p = - let p = Hex_encode.hex_encode p in - [ p ] - - module Table = struct - include Hashtbl.Make(struct - type nonrec t = t - let hash = Hashtbl.hash - let equal = equal - end) - end - -end - -let () = - Base58.check_encoded_prefix Block_hash.b58check_encoding "B" 51 ; - Base58.check_encoded_prefix Operation_hash.b58check_encoding "o" 51 ; - Base58.check_encoded_prefix Operation_list_hash.b58check_encoding "Lo" 52 ; - Base58.check_encoded_prefix Operation_list_list_hash.b58check_encoding "LLo" 53 ; - Base58.check_encoded_prefix Protocol_hash.b58check_encoding "P" 51 ; - Base58.check_encoded_prefix Net_id.b58check_encoding "Net" 15 diff --git a/lib_crypto/blake2B.mli b/lib_crypto/blake2B.mli new file mode 100644 index 000000000..0ab75be05 --- /dev/null +++ b/lib_crypto/blake2B.mli @@ -0,0 +1,75 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2017. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +(** Tezos - Manipulation and creation of hashes *) + +(** {2 Predefined Hashes } ****************************************************) + +include S.INTERNAL_MINIMAL_HASH + +(** Builds a new Hash type using Blake2B. *) +module Make_minimal (Name : S.Name) : S.INTERNAL_MINIMAL_HASH +module Make + (Register : sig + val register_encoding: + prefix: string -> + length: int -> + to_raw: ('a -> string) -> + of_raw: (string -> 'a option) -> + wrap: ('a -> Base58.data) -> + 'a Base58.encoding + end) + (Name : S.PrefixedName) : S.INTERNAL_HASH + +(**/**) + +module Make_merkle_tree + (R : sig + val register_encoding: + prefix: string -> + length:int -> + to_raw: ('a -> string) -> + of_raw: (string -> 'a option) -> + wrap: ('a -> Base58.data) -> + 'a Base58.encoding + end) + (K : S.PrefixedName) + (Contents: sig + type t + val to_bytes: t -> MBytes.t + end) : sig + include S.INTERNAL_HASH + type elt = Contents.t + val empty: t + val compute: elt list -> t + type path = + | Left of path * t + | Right of t * path + | Op + val path_encoding: path Data_encoding.t + val compute_path: elt list -> int -> path + val check_path: path -> elt -> t * int +end + +module Generic_Merkle_tree (H : sig + type t + type elt + val encoding : t Data_encoding.t + val empty : t + val leaf : elt -> t + val node : t -> t -> t + end) : sig + val compute : H.elt list -> H.t + type path = + | Left of path * H.t + | Right of H.t * path + | Op + val compute_path: H.elt list -> int -> path + val check_path: path -> H.elt -> H.t * int +end diff --git a/lib_crypto/block_hash.ml b/lib_crypto/block_hash.ml new file mode 100644 index 000000000..85dd71738 --- /dev/null +++ b/lib_crypto/block_hash.ml @@ -0,0 +1,18 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2017. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +include Blake2B.Make (Base58) (struct + let name = "Block_hash" + let title = "A Tezos block ID" + let b58check_prefix = Base58.Prefix.block_hash + let size = None + end) + +let () = + Base58.check_encoded_prefix b58check_encoding "B" 51 diff --git a/lib_crypto/block_hash.mli b/lib_crypto/block_hash.mli new file mode 100644 index 000000000..c38290500 --- /dev/null +++ b/lib_crypto/block_hash.mli @@ -0,0 +1,10 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2017. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +include S.INTERNAL_HASH diff --git a/src/utils/crypto_box.ml b/lib_crypto/crypto_box.ml similarity index 95% rename from src/utils/crypto_box.ml rename to lib_crypto/crypto_box.ml index 3ccf9ce24..4d7fb27d7 100644 --- a/src/utils/crypto_box.ml +++ b/lib_crypto/crypto_box.ml @@ -15,7 +15,7 @@ type channel_key = Sodium.Box.channel_key type nonce = Sodium.Box.nonce type target = Z.t -module Public_key_hash = Hash.Make_Blake2B (Base58) (struct +module Public_key_hash = Blake2B.Make (Base58) (struct let name = "Crypto_box.Public_key_hash" let title = "A Cryptobox public key ID" let b58check_prefix = Base58.Prefix.cryptobox_public_key_hash @@ -45,7 +45,7 @@ let fast_box_open ck msg nonce = | Sodium.Verification_failure -> None let compare_target hash target = - let hash = Z.of_bits (Hash.Generic_hash.to_string hash) in + let hash = Z.of_bits (Blake2B.to_string hash) in Z.compare hash target <= 0 let make_target f = @@ -70,7 +70,7 @@ let default_target = make_target 24. let check_proof_of_work pk nonce target = let hash = - Hash.Generic_hash.hash_bytes [ + Blake2B.hash_bytes [ Sodium.Box.Bigbytes.of_public_key pk ; Sodium.Box.Bigbytes.of_nonce nonce ; ] in diff --git a/src/utils/crypto_box.mli b/lib_crypto/crypto_box.mli similarity index 97% rename from src/utils/crypto_box.mli rename to lib_crypto/crypto_box.mli index c7497d5b9..96b03784f 100644 --- a/src/utils/crypto_box.mli +++ b/lib_crypto/crypto_box.mli @@ -21,7 +21,7 @@ val make_target : float -> target type secret_key type public_key -module Public_key_hash : Hash.INTERNAL_HASH +module Public_key_hash : S.INTERNAL_HASH type channel_key val public_key_encoding : public_key Data_encoding.t diff --git a/lib_crypto/ed25519.ml b/lib_crypto/ed25519.ml new file mode 100644 index 000000000..4c884f04d --- /dev/null +++ b/lib_crypto/ed25519.ml @@ -0,0 +1,247 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2017. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +module Public_key_hash = Blake2B.Make(Base58)(struct + let name = "Ed25519.Public_key_hash" + let title = "An Ed25519 public key ID" + let b58check_prefix = Base58.Prefix.ed25519_public_key_hash + let size = Some 20 + end) + +let () = + Base58.check_encoded_prefix Public_key_hash.b58check_encoding "tz1" 36 + +module Public_key = struct + + type t = Sodium.Sign.public_key + let compare = Sodium.Sign.compare_public_keys + let (=) xs ys = compare xs ys = 0 + let (<>) xs ys = compare xs ys <> 0 + let (<) xs ys = compare xs ys < 0 + let (<=) xs ys = compare xs ys <= 0 + let (>=) xs ys = compare xs ys >= 0 + let (>) xs ys = compare xs ys > 0 + let max x y = if x >= y then x else y + let min x y = if x <= y then x else y + + type Base58.data += + | Public_key of t + + let b58check_encoding = + Base58.register_encoding + ~prefix: Base58.Prefix.ed25519_public_key + ~length:Sodium.Sign.public_key_size + ~to_raw:(fun x -> Bytes.to_string (Sodium.Sign.Bytes.of_public_key x)) + ~of_raw:(fun x -> + try Some (Sodium.Sign.Bytes.to_public_key (Bytes.of_string x)) + with _ -> None) + ~wrap:(fun x -> Public_key x) + + let of_b58check_opt s = Base58.simple_decode b58check_encoding s + let of_b58check_exn s = + match Base58.simple_decode b58check_encoding s with + | Some x -> x + | None -> Pervasives.failwith "Unexpected hash (ed25519 public key)" + let of_b58check s = + match Base58.simple_decode b58check_encoding s with + | Some x -> Ok x + | None -> generic_error "Unexpected hash (ed25519 public key)" + let to_b58check s = Base58.simple_encode b58check_encoding s + + let of_bytes s = Sodium.Sign.Bytes.to_public_key s + + let param ?(name="ed25519-public") ?(desc="Ed25519 public key (b58check-encoded)") t = + Cli_entries.(param ~name ~desc (parameter (fun _ str -> Lwt.return (of_b58check str))) t) + + let () = + Base58.check_encoded_prefix b58check_encoding "edpk" 54 + + let encoding = + let open Data_encoding in + splitted + ~json: + (describe + ~title: "An Ed25519 public key (Base58Check encoded)" @@ + conv + (fun s -> Base58.simple_encode b58check_encoding s) + (fun s -> + match Base58.simple_decode b58check_encoding s with + | Some x -> x + | None -> Data_encoding.Json.cannot_destruct + "Ed25519 public key: unexpected prefix.") + string) + ~binary: + (conv + Sodium.Sign.Bigbytes.of_public_key + Sodium.Sign.Bigbytes.to_public_key + (Fixed.bytes Sodium.Sign.public_key_size)) + + let hash v = + Public_key_hash.hash_bytes + [ Sodium.Sign.Bigbytes.of_public_key v ] + +end + +module Secret_key = struct + + type t = Sodium.Sign.secret_key + + let to_public_key = Sodium.Sign.secret_key_to_public_key + + type Base58.data += + | Secret_key of t + + let b58check_encoding = + Base58.register_encoding + ~prefix: Base58.Prefix.ed25519_secret_key + ~length:Sodium.Sign.secret_key_size + ~to_raw:(fun x -> Bytes.to_string (Sodium.Sign.Bytes.of_secret_key x)) + ~of_raw:(fun x -> + try Some (Sodium.Sign.Bytes.to_secret_key (Bytes.of_string x)) + with _ -> None) + ~wrap:(fun x -> Secret_key x) + + let of_b58check_opt s = Base58.simple_decode b58check_encoding s + let of_b58check_exn s = + match Base58.simple_decode b58check_encoding s with + | Some x -> x + | None -> Pervasives.failwith "Unexpected hash (ed25519 secret key)" + let of_b58check s = + match Base58.simple_decode b58check_encoding s with + | Some x -> Ok x + | None -> generic_error "Unexpected hash (ed25519 public key)" + let to_b58check s = Base58.simple_encode b58check_encoding s + + let of_bytes s = Sodium.Sign.Bytes.to_secret_key s + + let param ?(name="ed25519-secret") ?(desc="Ed25519 secret key (b58check-encoded)") t = + Cli_entries.(param ~name ~desc (parameter (fun _ str -> Lwt.return (of_b58check str))) t) + + let () = + Base58.check_encoded_prefix b58check_encoding "edsk" 98 + + let encoding = + let open Data_encoding in + splitted + ~json: + (describe + ~title: "An Ed25519 secret key (Base58Check encoded)" @@ + conv + (fun s -> Base58.simple_encode b58check_encoding s) + (fun s -> + match Base58.simple_decode b58check_encoding s with + | Some x -> x + | None -> Data_encoding.Json.cannot_destruct + "Ed25519 secret key: unexpected prefix.") + string) + ~binary: + (conv + Sodium.Sign.Bigbytes.of_secret_key + Sodium.Sign.Bigbytes.to_secret_key + (Fixed.bytes Sodium.Sign.secret_key_size)) + +end + +let sign key msg = + Sodium.Sign.Bigbytes.(of_signature @@ sign_detached key msg) + +module Signature = struct + + type t = MBytes.t + + type Base58.data += + | Signature of t + + let b58check_encoding = + Base58.register_encoding + ~prefix: Base58.Prefix.ed25519_signature + ~length:Sodium.Sign.signature_size + ~to_raw:MBytes.to_string + ~of_raw:(fun s -> Some (MBytes.of_string s)) + ~wrap:(fun x -> Signature x) + + let of_b58check_opt s = Base58.simple_decode b58check_encoding s + let of_b58check_exn s = + match Base58.simple_decode b58check_encoding s with + | Some x -> x + | None -> Pervasives.failwith "Unexpected hash (ed25519 signature)" + let of_b58check s = + match Base58.simple_decode b58check_encoding s with + | Some x -> Ok x + | None -> generic_error "Unexpected hash (ed25519 public key)" + let to_b58check s = Base58.simple_encode b58check_encoding s + + let of_bytes s = MBytes.of_string (Bytes.to_string s) + + let param ?(name="signature") ?(desc="Signature (b58check-encoded)") t = + Cli_entries.(param ~name ~desc (parameter (fun _ str -> Lwt.return (of_b58check str))) t) + + let () = + Base58.check_encoded_prefix b58check_encoding "edsig" 99 + + let encoding = + let open Data_encoding in + splitted + ~json: + (describe + ~title: "An Ed25519 signature (Base58Check encoded)" @@ + conv + (fun s -> Base58.simple_encode b58check_encoding s) + (fun s -> + match Base58.simple_decode b58check_encoding s with + | Some x -> x + | None -> Data_encoding.Json.cannot_destruct + "Ed25519 signature: unexpected prefix.") + string) + ~binary: (Fixed.bytes Sodium.Sign.signature_size) + + let check public_key signature msg = + try + Sodium.Sign.Bigbytes.(verify public_key (to_signature signature) msg) ; + true + with _ -> false + + let append key msg = + MBytes.concat msg (sign key msg) + + let concat msg signature = + MBytes.concat msg signature + +end + +module Seed = struct + + type t = Sodium.Sign.seed + + let to_hex s = + Sodium.Sign.Bytes.of_seed s + |> Bytes.to_string + |> Hex_encode.hex_encode + + let of_hex s = + Hex_encode.hex_decode s + |> Bytes.of_string + |> Sodium.Sign.Bytes.to_seed + + let generate () = + (* Seed is 32 bytes long *) + Sodium.Random.Bytes.generate Sodium.Sign.seed_size + |> Sodium.Sign.Bytes.to_seed + + let extract = + Sodium.Sign.secret_key_to_seed +end + +let generate_key () = + let secret, pub = Sodium.Sign.random_keypair () in + (Public_key.hash pub, pub, secret) + +let generate_seeded_key seed = + let secret, pub = Sodium.Sign.seed_keypair seed in + (Public_key.hash pub, pub, secret) diff --git a/lib_crypto/ed25519.mli b/lib_crypto/ed25519.mli new file mode 100644 index 000000000..be1fa0e8b --- /dev/null +++ b/lib_crypto/ed25519.mli @@ -0,0 +1,110 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2017. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +(** Tezos - Ed25519 cryptography *) + +(** {2 Hashed public keys for user ID} ***************************************) + +module Public_key_hash : S.INTERNAL_HASH + +(** {2 Signature} ************************************************************) + +module Public_key : sig + + include Compare.S + val encoding: t Data_encoding.t + + val param: + ?name:string -> + ?desc:string -> + ('a, 'b, 'c) Cli_entries.params -> + (t -> 'a, 'b, 'c) Cli_entries.params + + val hash: t -> Public_key_hash.t + + type Base58.data += + | Public_key of t + + val of_b58check: string -> t tzresult + val of_b58check_exn: string -> t + val of_b58check_opt: string -> t option + val to_b58check: t -> string + + val of_bytes: Bytes.t -> t + +end + +module Secret_key : sig + + type t + val encoding: t Data_encoding.t + + val param: + ?name:string -> + ?desc:string -> + ('a, 'b, 'c) Cli_entries.params -> + (t -> 'a, 'b, 'c) Cli_entries.params + + val to_public_key: t -> Public_key.t + + type Base58.data += + | Secret_key of t + + val of_b58check: string -> t tzresult + val of_b58check_exn: string -> t + val of_b58check_opt: string -> t option + val to_b58check: t -> string + + val of_bytes: Bytes.t -> t + +end + +module Signature : sig + + type t + val encoding: t Data_encoding.t + + val param: + ?name:string -> + ?desc:string -> + ('a, 'b, 'c) Cli_entries.params -> + (t -> 'a, 'b, 'c) Cli_entries.params + + type Base58.data += + | Signature of t + + val of_b58check: string -> t tzresult + val of_b58check_exn: string -> t + val of_b58check_opt: string -> t option + val to_b58check: t -> string + + val of_bytes: Bytes.t -> t + + (** Checks a signature *) + val check: Public_key.t -> t -> MBytes.t -> bool + + (** Append a signature *) + val append: Secret_key.t -> MBytes.t -> MBytes.t + val concat: MBytes.t -> t -> MBytes.t + +end + +module Seed : sig + type t + val to_hex : t -> string + val of_hex : string -> t + val generate : unit -> t + val extract : Secret_key.t -> t +end + +val sign: Secret_key.t -> MBytes.t -> Signature.t + +val generate_key: unit -> (Public_key_hash.t * Public_key.t * Secret_key.t) +val generate_seeded_key: Seed.t -> (Public_key_hash.t * Public_key.t * Secret_key.t) + diff --git a/lib_crypto/jbuild b/lib_crypto/jbuild new file mode 100644 index 000000000..a7c57c548 --- /dev/null +++ b/lib_crypto/jbuild @@ -0,0 +1,21 @@ +(jbuild_version 1) + +(library + ((name tezos_crypto) + (public_name tezos-crypto) + (flags (:standard -open Tezos_stdlib + -open Tezos_data_encoding + -open Tezos_stdlib_lwt + -open Tezos_error_monad__Error_monad)) + (libraries (tezos-stdlib + tezos-stdlib-lwt + tezos-data-encoding + tezos-error-monad + nocrypto + sodium + zarith)))) + +(alias + ((name runtest_indent) + (deps ((glob_files *.ml) (glob_files *.mli))) + (action (run bash ${libexec:tezos-stdlib:test-ocp-indent.sh} ${<})))) diff --git a/lib_crypto/net_id.ml b/lib_crypto/net_id.ml new file mode 100644 index 000000000..787e0cc3d --- /dev/null +++ b/lib_crypto/net_id.ml @@ -0,0 +1,150 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2017. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +type t = string + +let name = "Net_id" +let title = "Network identifier" + +let size = 4 + +let extract bh = + MBytes.substring (Block_hash.to_bytes bh) 0 4 + +let hash_bytes l = extract (Block_hash.hash_bytes l) +let hash_string l = extract (Block_hash.hash_string l) + +let of_block_hash bh = hash_bytes [Block_hash.to_bytes bh] + +type Base58.data += Hash of t + +let of_string s = + if String.length s <> size then None else Some s +let of_string_exn s = + match of_string s with + | None -> + let msg = + Printf.sprintf "%s.of_string: wrong string size (%d)" + name (String.length s) in + raise (Invalid_argument msg) + | Some h -> h +let to_string s = s + +let of_hex s = of_string (Hex_encode.hex_decode s) +let of_hex_exn s = of_string_exn (Hex_encode.hex_decode s) +let to_hex s = Hex_encode.hex_encode (to_string s) + +let compare = String.compare +let equal = String.equal + +let of_bytes b = + if MBytes.length b <> size then + None + else + Some (MBytes.to_string b) +let of_bytes_exn b = + match of_bytes b with + | None -> + let msg = + Printf.sprintf "%s.of_bytes: wrong string size (%d)" + name (MBytes.length b) in + raise (Invalid_argument msg) + | Some h -> h +let to_bytes = MBytes.of_string + +let read src off = of_bytes_exn @@ MBytes.sub src off size +let write dst off h = MBytes.blit (to_bytes h) 0 dst off size + +let b58check_encoding = + Base58.register_encoding + ~prefix: Base58.Prefix.net_id + ~length: size + ~wrap: (fun s -> Hash s) + ~of_raw:of_string ~to_raw: (fun h -> h) + +let of_b58check_opt s = + Base58.simple_decode b58check_encoding s +let of_b58check_exn s = + match Base58.simple_decode b58check_encoding s with + | Some x -> x + | None -> Format.kasprintf Pervasives.failwith "Unexpected hash (%s)" name +let of_b58check s = + match Base58.simple_decode b58check_encoding s with + | Some x -> Ok x + | None -> generic_error "Unexpected hash (%s)" name +let to_b58check s = Base58.simple_encode b58check_encoding s +let to_short_b58check = to_b58check + +let encoding = + let open Data_encoding in + splitted + ~binary: (Fixed.string size) + ~json: + (describe ~title: (title ^ " (Base58Check-encoded Blake2B hash)") @@ + conv to_b58check (Data_encoding.Json.wrap_error of_b58check_exn) string) + +let param ?(name=name) ?(desc=title) t = + Cli_entries.(param ~name ~desc (parameter (fun _ str -> Lwt.return (of_b58check str))) t) + +let pp ppf t = + Format.pp_print_string ppf (to_b58check t) + +let pp_short ppf t = + Format.pp_print_string ppf (to_short_b58check t) + +module Set = struct + include Set.Make(struct type nonrec t = t let compare = compare end) + exception Found of elt + let random_elt s = + let n = Random.int (cardinal s) in + try + ignore + (fold (fun x i -> if i = n then raise (Found x) ; i+1) s 0 : int) ; + assert false + with Found x -> x + let encoding = + Data_encoding.conv + elements + (fun l -> List.fold_left (fun m x -> add x m) empty l) + Data_encoding.(list encoding) +end +let random_set_elt = Set.random_elt + +module Map = struct + include Map.Make(struct type nonrec t = t let compare = compare end) + let encoding arg_encoding = + Data_encoding.conv + bindings + (fun l -> List.fold_left (fun m (k,v) -> add k v m) empty l) + Data_encoding.(list (tup2 encoding arg_encoding)) +end + +let path_length = 1 +let to_path key l = to_hex key :: l +let of_path path = + let path = String.concat "" path in + of_hex path +let of_path_exn path = + let path = String.concat "" path in + of_hex_exn path + +let prefix_path p = + let p = Hex_encode.hex_encode p in + [ p ] + +module Table = struct + include Hashtbl.Make(struct + type nonrec t = t + let hash = Hashtbl.hash + let equal = equal + end) +end + +let () = + Base58.check_encoded_prefix b58check_encoding "Net" 15 diff --git a/lib_crypto/net_id.mli b/lib_crypto/net_id.mli new file mode 100644 index 000000000..4a6c70353 --- /dev/null +++ b/lib_crypto/net_id.mli @@ -0,0 +1,11 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2017. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +include S.INTERNAL_HASH +val of_block_hash: Block_hash.t -> t diff --git a/lib_crypto/operation_hash.ml b/lib_crypto/operation_hash.ml new file mode 100644 index 000000000..7ce7496db --- /dev/null +++ b/lib_crypto/operation_hash.ml @@ -0,0 +1,19 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2017. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +include Blake2B.Make (Base58) (struct + let name = "Operation_hash" + let title = "A Tezos operation ID" + let b58check_prefix = Base58.Prefix.operation_hash + let size = None + end) + +let () = + Base58.check_encoded_prefix b58check_encoding "o" 51 + diff --git a/lib_crypto/operation_hash.mli b/lib_crypto/operation_hash.mli new file mode 100644 index 000000000..c38290500 --- /dev/null +++ b/lib_crypto/operation_hash.mli @@ -0,0 +1,10 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2017. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +include S.INTERNAL_HASH diff --git a/lib_crypto/operation_list_hash.ml b/lib_crypto/operation_list_hash.ml new file mode 100644 index 000000000..eb7c9093c --- /dev/null +++ b/lib_crypto/operation_list_hash.ml @@ -0,0 +1,18 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2017. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +include Blake2B.Make_merkle_tree (Base58) (struct + let name = "Operation_list_hash" + let title = "A list of operations" + let b58check_prefix = Base58.Prefix.operation_list_hash + let size = None + end) (Operation_hash) + +let () = + Base58.check_encoded_prefix b58check_encoding "Lo" 52 diff --git a/lib_crypto/operation_list_hash.mli b/lib_crypto/operation_list_hash.mli new file mode 100644 index 000000000..9ad1c3510 --- /dev/null +++ b/lib_crypto/operation_list_hash.mli @@ -0,0 +1,11 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2017. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +include S.INTERNAL_MERKLE_TREE with type elt = Operation_hash.t + diff --git a/lib_crypto/operation_list_list_hash.ml b/lib_crypto/operation_list_list_hash.ml new file mode 100644 index 000000000..b9d678b13 --- /dev/null +++ b/lib_crypto/operation_list_list_hash.ml @@ -0,0 +1,18 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2017. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +include Blake2B.Make_merkle_tree (Base58) (struct + let name = "Operation_list_list_hash" + let title = "A list of list of operations" + let b58check_prefix = Base58.Prefix.operation_list_list_hash + let size = None + end) (Operation_list_hash) + +let () = + Base58.check_encoded_prefix b58check_encoding "LLo" 53 ; diff --git a/lib_crypto/operation_list_list_hash.mli b/lib_crypto/operation_list_list_hash.mli new file mode 100644 index 000000000..c9f2c631e --- /dev/null +++ b/lib_crypto/operation_list_list_hash.mli @@ -0,0 +1,10 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2017. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +include S.INTERNAL_MERKLE_TREE with type elt = Operation_list_hash.t diff --git a/lib_crypto/protocol_hash.ml b/lib_crypto/protocol_hash.ml new file mode 100644 index 000000000..3973c8170 --- /dev/null +++ b/lib_crypto/protocol_hash.ml @@ -0,0 +1,19 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2017. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +include Blake2B.Make (Base58) (struct + let name = "Protocol_hash" + let title = "A Tezos protocol ID" + let b58check_prefix = Base58.Prefix.protocol_hash + let size = None + end) + +let () = + Base58.check_encoded_prefix b58check_encoding "P" 51 + diff --git a/lib_crypto/protocol_hash.mli b/lib_crypto/protocol_hash.mli new file mode 100644 index 000000000..c38290500 --- /dev/null +++ b/lib_crypto/protocol_hash.mli @@ -0,0 +1,10 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2017. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +include S.INTERNAL_HASH diff --git a/src/utils/hash.mli b/lib_crypto/s.ml similarity index 71% rename from src/utils/hash.mli rename to lib_crypto/s.ml index 2f151dea1..b44408115 100644 --- a/src/utils/hash.mli +++ b/lib_crypto/s.ml @@ -7,10 +7,6 @@ (* *) (**************************************************************************) -open Error_monad - -(** Tezos - Manipulation and creation of hashes *) - (** {2 Hash Types} ************************************************************) @@ -144,61 +140,3 @@ module type PrefixedName = sig include Name val b58check_prefix : string end - -(** Builds a new Hash type using Blake2B. *) -module Make_minimal_Blake2B (Name : Name) : INTERNAL_MINIMAL_HASH -module Make_Blake2B - (Register : sig - val register_encoding: - prefix: string -> - length: int -> - to_raw: ('a -> string) -> - of_raw: (string -> 'a option) -> - wrap: ('a -> Base58.data) -> - 'a Base58.encoding - end) - (Name : PrefixedName) : INTERNAL_HASH - -(** {2 Predefined Hashes } ****************************************************) - -(** Blocks hashes / IDs. *) -module Block_hash : INTERNAL_HASH - -(** Operations hashes / IDs. *) -module Operation_hash : INTERNAL_HASH - -(** List of operations hashes / IDs. *) -module Operation_list_hash : - INTERNAL_MERKLE_TREE with type elt = Operation_hash.t - -module Operation_list_list_hash : - INTERNAL_MERKLE_TREE with type elt = Operation_list_hash.t - -(** Protocol versions / source hashes. *) -module Protocol_hash : INTERNAL_HASH - -module Net_id : sig - include INTERNAL_HASH - val of_block_hash: Block_hash.t -> t -end - -module Generic_hash : INTERNAL_MINIMAL_HASH - -(**/**) - -module Generic_Merkle_tree (H : sig - type t - type elt - val encoding : t Data_encoding.t - val empty : t - val leaf : elt -> t - val node : t -> t -> t - end) : sig - val compute : H.elt list -> H.t - type path = - | Left of path * H.t - | Right of H.t * path - | Op - val compute_path: H.elt list -> int -> path - val check_path: path -> H.elt -> H.t * int -end diff --git a/lib_crypto/tezos-crypto.opam b/lib_crypto/tezos-crypto.opam new file mode 100644 index 000000000..1d07a98c8 --- /dev/null +++ b/lib_crypto/tezos-crypto.opam @@ -0,0 +1,21 @@ +opam-version: "1.2" +version: "dev" +maintainer: "contact@tezos.com" +authors: [ "Tezos devteam" ] +homepage: "https://www.tezos.com/" +bug-reports: "https://gitlab.com/tezos/tezos/issues" +dev-repo: "https://gitlab.com/tezos/tezos.git" +license: "unreleased" +depends: [ + "ocamlfind" { build } + "jbuilder" { build & >= "1.0+beta15" } + "base-bigarray" + "tezos-base" + "lwt" +] +build: [ + [ "jbuilder" "build" "-p" name "-j" jobs ] +] +build-test: [ + [ "jbuilder" "runtest" "-p" name "-j" jobs ] +] diff --git a/src/minutils/data_encoding.ml b/lib_data_encoding/data_encoding.ml similarity index 99% rename from src/minutils/data_encoding.ml rename to lib_data_encoding/data_encoding.ml index 036380b40..c48091cd0 100644 --- a/src/minutils/data_encoding.ml +++ b/lib_data_encoding/data_encoding.ml @@ -227,7 +227,7 @@ module Json = struct int32 (fun i -> let j = Int64.to_int32 i in - if Compare.Int64.(=) (Int64.of_int32 j) i then Some j else None) + if Int64.equal (Int64.of_int32 j) i then Some j else None) Int64.of_int32 ; case string @@ -770,8 +770,8 @@ module Binary = struct | 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 ~f:length (proj v)) in - apply (Utils.filter_map case_length cases) + Some (fun v -> Option.map ~f:length (proj v)) in + apply (TzList.filter_map case_length cases) | Mu (`Dynamic, _name, self) -> fun v -> length (self e) v | Obj (Opt (`Dynamic, _, e)) -> @@ -820,7 +820,7 @@ module Binary = struct match proj v with | None -> None | Some v -> Some (length v)) in - apply (Utils.filter_map case_length cases) + apply (TzList.filter_map case_length cases) | Mu (`Variable, _name, self) -> fun v -> length (self e) v (* Recursive*) @@ -1132,7 +1132,7 @@ module Binary = struct let union r sz cases = let read_cases = - Utils.filter_map + TzList.filter_map (function | (Case { tag = None }) -> None | (Case { encoding = e ; inj ; tag = Some tag }) -> diff --git a/src/minutils/data_encoding.mli b/lib_data_encoding/data_encoding.mli similarity index 100% rename from src/minutils/data_encoding.mli rename to lib_data_encoding/data_encoding.mli diff --git a/src/minutils/hex_encode.ml b/lib_data_encoding/hex_encode.ml similarity index 100% rename from src/minutils/hex_encode.ml rename to lib_data_encoding/hex_encode.ml diff --git a/src/minutils/hex_encode.mli b/lib_data_encoding/hex_encode.mli similarity index 100% rename from src/minutils/hex_encode.mli rename to lib_data_encoding/hex_encode.mli diff --git a/lib_data_encoding/jbuild b/lib_data_encoding/jbuild new file mode 100644 index 000000000..b1b854d12 --- /dev/null +++ b/lib_data_encoding/jbuild @@ -0,0 +1,14 @@ +(jbuild_version 1) + +(library + ((name tezos_data_encoding) + (public_name tezos-data-encoding) + (libraries (tezos-stdlib ocplib-json-typed ocplib-json-typed.bson)) + (flags (:standard -w -9+27-30-32-40@8 + -safe-string + -open Tezos_stdlib)))) + +(alias + ((name runtest_indent) + (deps ((glob_files *.ml) (glob_files *.mli))) + (action (run bash ${libexec:tezos-stdlib:test-ocp-indent.sh} ${<})))) diff --git a/lib_data_encoding/tezos-data-encoding.install b/lib_data_encoding/tezos-data-encoding.install new file mode 100644 index 000000000..43e331c82 --- /dev/null +++ b/lib_data_encoding/tezos-data-encoding.install @@ -0,0 +1,26 @@ +lib: [ + "_build/install/default/lib/tezos-data-encoding/META" {"META"} + "_build/install/default/lib/tezos-data-encoding/opam" {"opam"} + "_build/install/default/lib/tezos-data-encoding/tezos_data_encoding__Data_encoding.cmi" + "_build/install/default/lib/tezos-data-encoding/tezos_data_encoding__Data_encoding.cmx" + "_build/install/default/lib/tezos-data-encoding/tezos_data_encoding__Data_encoding.cmt" + "_build/install/default/lib/tezos-data-encoding/tezos_data_encoding__Data_encoding.cmti" + "_build/install/default/lib/tezos-data-encoding/data_encoding.mli" + "_build/install/default/lib/tezos-data-encoding/tezos_data_encoding__Hex_encode.cmi" + "_build/install/default/lib/tezos-data-encoding/tezos_data_encoding__Hex_encode.cmx" + "_build/install/default/lib/tezos-data-encoding/tezos_data_encoding__Hex_encode.cmt" + "_build/install/default/lib/tezos-data-encoding/tezos_data_encoding__Hex_encode.cmti" + "_build/install/default/lib/tezos-data-encoding/hex_encode.mli" + "_build/install/default/lib/tezos-data-encoding/tezos_data_encoding.cmi" + "_build/install/default/lib/tezos-data-encoding/tezos_data_encoding.cmx" + "_build/install/default/lib/tezos-data-encoding/tezos_data_encoding.cmt" + "_build/install/default/lib/tezos-data-encoding/tezos_data_encoding.ml-gen" + "_build/install/default/lib/tezos-data-encoding/tezos_data_encoding.cma" + "_build/install/default/lib/tezos-data-encoding/tezos_data_encoding.cmxa" + "_build/install/default/lib/tezos-data-encoding/tezos_data_encoding.a" + "_build/install/default/lib/tezos-data-encoding/tezos_data_encoding.cmxs" +] +doc: [ + "_build/install/default/doc/tezos-data-encoding/README.md" + "_build/install/default/doc/tezos-data-encoding/CHANGES.alphanet" +] diff --git a/lib_data_encoding/tezos-data-encoding.opam b/lib_data_encoding/tezos-data-encoding.opam new file mode 100644 index 000000000..d6ad27dad --- /dev/null +++ b/lib_data_encoding/tezos-data-encoding.opam @@ -0,0 +1,23 @@ +opam-version: "1.2" +version: "dev" +maintainer: "contact@tezos.com" +authors: [ "Tezos devteam" ] +homepage: "https://www.tezos.com/" +bug-reports: "https://gitlab.com/tezos/tezos/issues" +dev-repo: "https://gitlab.com/tezos/tezos.git" +license: "unreleased" +depends: [ + "ocamlfind" { build } + "jbuilder" { build & >= "1.0+beta15" } + "base-bigarray" + "tezos-stdlib" + "ocplib-json-typed" + "ocplib-endian" + "js_of_ocaml" +] +build: [ + [ "jbuilder" "build" "-p" name "-j" jobs ] +] +build-test: [ + [ "jbuilder" "runtest" "-p" name "-j" jobs ] +] diff --git a/src/utils/error_monad.ml b/lib_error_monad/error_monad.ml similarity index 97% rename from src/utils/error_monad.ml rename to lib_error_monad/error_monad.ml index 84d794c06..a70a7f1c6 100644 --- a/src/utils/error_monad.ml +++ b/lib_error_monad/error_monad.ml @@ -55,7 +55,7 @@ module Make() = struct category ~id:name ~title ~description ?pp encoding from_error to_error = if List.exists - (fun (Error_kind { id }) -> name = id) + (fun (Error_kind { id ; _ }) -> name = id) !error_kinds then invalid_arg (Printf.sprintf @@ -77,7 +77,7 @@ module Make() = struct category ; from_error ; encoding_case ; - pp = Utils.unopt ~default:(json_pp name encoding) pp } :: !error_kinds + pp = Option.unopt ~default:(json_pp name encoding) pp } :: !error_kinds let register_wrapped_error_kind category ~id ~title ~description ?pp @@ -100,7 +100,7 @@ module Make() = struct | None -> let cases = List.map - (fun (Error_kind { encoding_case }) -> encoding_case ) + (fun (Error_kind { encoding_case ; _ }) -> encoding_case ) !error_kinds in let json_encoding = Data_encoding.union cases in let encoding = @@ -127,7 +127,7 @@ module Make() = struct let rec find e = function | [] -> `Temporary (* assert false (\* See "Generic error" *\) *) - | Error_kind { from_error ; category } :: rest -> + | Error_kind { from_error ; category ; _ } :: rest -> match from_error e with | Some x -> begin match category with @@ -148,15 +148,12 @@ module Make() = struct let pp ppf error = let rec find = function | [] -> assert false (* See "Generic error" *) - | Error_kind { from_error ; pp } :: errors -> + | Error_kind { from_error ; pp ; _ } :: errors -> match from_error error with | None -> find errors | Some x -> pp ppf x in find !error_kinds - let registred_errors () = !error_kinds - - (*-- Monad definition --------------------------------------------------------*) let (>>=) = Lwt.(>>=) diff --git a/src/utils/error_monad.mli b/lib_error_monad/error_monad.mli similarity index 100% rename from src/utils/error_monad.mli rename to lib_error_monad/error_monad.mli diff --git a/src/utils/error_monad_sig.ml b/lib_error_monad/error_monad_sig.ml similarity index 100% rename from src/utils/error_monad_sig.ml rename to lib_error_monad/error_monad_sig.ml diff --git a/lib_error_monad/jbuild b/lib_error_monad/jbuild new file mode 100644 index 000000000..d0396b2c8 --- /dev/null +++ b/lib_error_monad/jbuild @@ -0,0 +1,15 @@ +(jbuild_version 1) + +(library + ((name tezos_error_monad) + (public_name tezos-error-monad) + (flags (:standard -open Tezos_stdlib + -open Tezos_data_encoding)) + (libraries (tezos-stdlib + tezos-data-encoding + lwt)))) + +(alias + ((name runtest_indent) + (deps ((glob_files *.ml) (glob_files *.mli))) + (action (run bash ${libexec:tezos-stdlib:test-ocp-indent.sh} ${<})))) diff --git a/lib_error_monad/tezos-error-monad.opam b/lib_error_monad/tezos-error-monad.opam new file mode 100644 index 000000000..cf1548716 --- /dev/null +++ b/lib_error_monad/tezos-error-monad.opam @@ -0,0 +1,21 @@ +opam-version: "1.2" +version: "dev" +maintainer: "contact@tezos.com" +authors: [ "Tezos devteam" ] +homepage: "https://www.tezos.com/" +bug-reports: "https://gitlab.com/tezos/tezos/issues" +dev-repo: "https://gitlab.com/tezos/tezos.git" +license: "unreleased" +depends: [ + "ocamlfind" { build } + "jbuilder" { build & >= "1.0+beta15" } + "base-bigarray" + "tezos-stdlib" + "tezos-data-encoding" +] +build: [ + [ "jbuilder" "build" "-p" name "-j" jobs ] +] +build-test: [ + [ "jbuilder" "runtest" "-p" name "-j" jobs ] +] diff --git a/src/minutils/compare.ml b/lib_stdlib/compare.ml similarity index 100% rename from src/minutils/compare.ml rename to lib_stdlib/compare.ml diff --git a/src/minutils/compare.mli b/lib_stdlib/compare.mli similarity index 100% rename from src/minutils/compare.mli rename to lib_stdlib/compare.mli diff --git a/lib_stdlib/jbuild b/lib_stdlib/jbuild new file mode 100644 index 000000000..f03c2626a --- /dev/null +++ b/lib_stdlib/jbuild @@ -0,0 +1,15 @@ +(jbuild_version 1) + +(library + ((name tezos_stdlib) + (public_name tezos-stdlib) + (libraries (ocplib-endian.bigstring cstruct stringext)))) + +(alias + ((name runtest_indent) + (deps ((glob_files *.ml) (glob_files *.mli))) + (action (run bash ${path:test-ocp-indent.sh} ${<})))) + +(install + ((section libexec) + (files ((test-ocp-indent.sh as test-ocp-indent.sh))))) \ No newline at end of file diff --git a/src/minutils/mBytes.ml b/lib_stdlib/mBytes.ml similarity index 98% rename from src/minutils/mBytes.ml rename to lib_stdlib/mBytes.ml index 1efafb4e0..ecd4d8c89 100644 --- a/src/minutils/mBytes.ml +++ b/lib_stdlib/mBytes.ml @@ -33,7 +33,7 @@ external unsafe_blit_bigstring_to_bytes = "caml_blit_bigstring_to_string" [@@noalloc] (** HACK: force Cstruct at link which provides the previous primitives. *) -let dummy = Cstruct.byte_to_int +let _dummy = Cstruct.byte_to_int let invalid_bounds j l = invalid_arg (Printf.sprintf "invalid bounds (index %d, length %d)" j l) diff --git a/src/minutils/mBytes.mli b/lib_stdlib/mBytes.mli similarity index 100% rename from src/minutils/mBytes.mli rename to lib_stdlib/mBytes.mli diff --git a/lib_stdlib/option.ml b/lib_stdlib/option.ml new file mode 100644 index 000000000..d89c3d71d --- /dev/null +++ b/lib_stdlib/option.ml @@ -0,0 +1,34 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2017. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +let map ~f = function + | None -> None + | Some x -> Some (f x) + +let apply ~f = function + | None -> None + | Some x -> f x + +let iter ~f = function + | None -> () + | Some x -> f x + +let unopt ~default = function + | None -> default + | Some x -> x + +let unopt_map ~f ~default = function + | None -> default + | Some x -> f x + +let first_some a b = match a, b with + | None, None -> None + | None, Some v -> Some v + | Some v, _ -> Some v + diff --git a/lib_stdlib/option.mli b/lib_stdlib/option.mli new file mode 100644 index 000000000..bd4b32f81 --- /dev/null +++ b/lib_stdlib/option.mli @@ -0,0 +1,27 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2017. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +(** [Some (f x)] if input is [Some x], or [None] if it's [None] **) +val map: f:('a -> 'b) -> 'a option -> 'b option + +(** [(f x)] if input is [Some x], or [None] if it's [None] **) +val apply: f:('a -> 'b option) -> 'a option -> 'b option + +(** Call [(f x)] if input is [Some x], noop if it's [None] **) +val iter: f:('a -> unit) -> 'a option -> unit + +(** [x] if input is [Some x], default if it's [None] **) +val unopt: default:'a -> 'a option -> 'a + +(** [unopt_map f d x] is [y] if [x] is [Some y], [d] if [x] is [None] **) +val unopt_map: f:('a -> 'b) -> default:'b -> 'a option -> 'b + +(** First input of form [Some x], or [None] if none **) +val first_some: 'a option -> 'a option -> 'a option + diff --git a/src/utils/ring.ml b/lib_stdlib/ring.ml similarity index 100% rename from src/utils/ring.ml rename to lib_stdlib/ring.ml diff --git a/src/utils/ring.mli b/lib_stdlib/ring.mli similarity index 100% rename from src/utils/ring.mli rename to lib_stdlib/ring.mli diff --git a/scripts/test-ocp-indent.sh b/lib_stdlib/test-ocp-indent.sh similarity index 52% rename from scripts/test-ocp-indent.sh rename to lib_stdlib/test-ocp-indent.sh index 0fa7e6854..b511d5f6f 100755 --- a/scripts/test-ocp-indent.sh +++ b/lib_stdlib/test-ocp-indent.sh @@ -2,13 +2,21 @@ tmp_dir="$(mktemp -d -t tezos_build.XXXXXXXXXX)" failed=no -fix=${1:-""} +if [ "$1" = "fix" ]; then + fix=yes + shift 1 +fi -for f in ` find \( -name _build -or \ - -name .git -or \ - -wholename ./src/environment/v1.ml -or \ - -name registerer.ml \) -prune -or \ - \( -name \*.ml -or -name \*.mli \) -print`; do +files="$@" +if [ -z "$files" ]; then +files=` find \( -name _build -or \ + -name .git -or \ + -wholename ./src/environment/v1.ml -or \ + -name registerer.ml \) -prune -or \ + \( -name \*.ml -or -name \*.mli \) -print` +fi + +for f in $files ; do ff=$(basename $f) ocp-indent $f > $tmp_dir/$ff diff -U 3 $f $tmp_dir/$ff diff --git a/lib_stdlib/tezos-base.install b/lib_stdlib/tezos-base.install new file mode 100644 index 000000000..88dea3310 --- /dev/null +++ b/lib_stdlib/tezos-base.install @@ -0,0 +1,29 @@ +lib: [ + "_build/install/default/lib/tezos-base/META" {"META"} + "_build/install/default/lib/tezos-base/opam" {"opam"} + "_build/install/default/lib/tezos-base/tezos_base__MBytes.cmi" + "_build/install/default/lib/tezos-base/tezos_base__MBytes.cmx" + "_build/install/default/lib/tezos-base/tezos_base__MBytes.cmt" + "_build/install/default/lib/tezos-base/tezos_base__MBytes.cmti" + "_build/install/default/lib/tezos-base/mBytes.mli" + "_build/install/default/lib/tezos-base/tezos_base.cmi" + "_build/install/default/lib/tezos-base/tezos_base.cmx" + "_build/install/default/lib/tezos-base/tezos_base.cmt" + "_build/install/default/lib/tezos-base/tezos_base.ml-gen" + "_build/install/default/lib/tezos-base/tezos_base__Utils.cmi" + "_build/install/default/lib/tezos-base/tezos_base__Utils.cmx" + "_build/install/default/lib/tezos-base/tezos_base__Utils.cmt" + "_build/install/default/lib/tezos-base/tezos_base__Utils.cmti" + "_build/install/default/lib/tezos-base/utils.mli" + "_build/install/default/lib/tezos-base/tezos_base.cma" + "_build/install/default/lib/tezos-base/tezos_base.cmxa" + "_build/install/default/lib/tezos-base/tezos_base.a" + "_build/install/default/lib/tezos-base/tezos_base.cmxs" +] +libexec: [ + "_build/install/default/lib/tezos-base/test-ocp-indent.sh" {"test-ocp-indent.sh"} +] +doc: [ + "_build/install/default/doc/tezos-base/README.md" + "_build/install/default/doc/tezos-base/CHANGES.alphanet" +] diff --git a/lib_stdlib/tezos-stdlib.opam b/lib_stdlib/tezos-stdlib.opam new file mode 100644 index 000000000..a5fc48f5d --- /dev/null +++ b/lib_stdlib/tezos-stdlib.opam @@ -0,0 +1,22 @@ +opam-version: "1.2" +version: "dev" +maintainer: "contact@tezos.com" +authors: [ "Tezos devteam" ] +homepage: "https://www.tezos.com/" +bug-reports: "https://gitlab.com/tezos/tezos/issues" +dev-repo: "https://gitlab.com/tezos/tezos.git" +license: "unreleased" +depends: [ + "ocamlfind" { build } + "jbuilder" { build & >= "1.0+beta15" } + "base-bigarray" + "cstruct" + "ocplib-endian.bigstring" + "stringext" +] +build: [ + [ "jbuilder" "build" "-p" name "-j" jobs ] +] +build-test: [ + [ "jbuilder" "runtest" "-p" name "-j" jobs ] +] diff --git a/lib_stdlib/tzList.ml b/lib_stdlib/tzList.ml new file mode 100644 index 000000000..3b05942f0 --- /dev/null +++ b/lib_stdlib/tzList.ml @@ -0,0 +1,135 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2017. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +let may_cons xs x = match x with None -> xs | Some x -> x :: xs + +let filter_map f l = + List.rev @@ List.fold_left (fun acc x -> may_cons acc (f x)) [] l + +let rev_sub l n = + if n < 0 then + invalid_arg "Utils.rev_sub: `n` must be non-negative."; + let rec append_rev_sub acc l = function + | 0 -> acc + | n -> + match l with + | [] -> acc + | hd :: tl -> append_rev_sub (hd :: acc) tl (n - 1) in + append_rev_sub [] l n + +let sub l n = rev_sub l n |> List.rev + +let hd_opt = function + | [] -> None + | h :: _ -> Some h + +let rec last_exn = function + | [] -> raise Not_found + | [x] -> x + | _ :: xs -> last_exn xs + +let merge_filter2 + ?(finalize = List.rev) ?(compare = compare) + ?(f = Option.first_some) + l1 l2 = + let sort = List.sort compare in + let rec merge_aux acc = function + | [], [] -> finalize acc + | r1, [] -> finalize acc @ (filter_map (fun x1 -> f (Some x1) None) r1) + | [], r2 -> finalize acc @ (filter_map (fun x2 -> f None (Some x2)) r2) + | ((h1 :: t1) as r1), ((h2 :: t2) as r2) -> + if compare h1 h2 > 0 then + merge_aux (may_cons acc (f None (Some h2))) (r1, t2) + else if compare h1 h2 < 0 then + merge_aux (may_cons acc (f (Some h1) None)) (t1, r2) + else (* m1 = m2 *) + merge_aux (may_cons acc (f (Some h1) (Some h2))) (t1, t2) + in + merge_aux [] (sort l1, sort l2) + +let merge2 ?finalize ?compare ?(f = fun x1 _x1 -> x1) l1 l2 = + merge_filter2 ?finalize ?compare + ~f:(fun x1 x2 -> match x1, x2 with + | None, None -> assert false + | Some x1, None -> Some x1 + | None, Some x2 -> Some x2 + | Some x1, Some x2 -> Some (f x1 x2)) + l1 l2 + +let rec remove nb = function + | [] -> [] + | l when nb <= 0 -> l + | _ :: tl -> remove (nb - 1) tl + +let rec repeat n x = if n <= 0 then [] else x :: repeat (pred n) x + +let take_n_unsorted n l = + let rec loop acc n = function + | [] -> l + | _ when n <= 0 -> List.rev acc + | x :: xs -> loop (x :: acc) (pred n) xs in + loop [] n l + +module Bounded(E: Set.OrderedType) : sig + + type t + val create: int -> t + val insert: E.t -> t -> unit + val get: t -> E.t list + +end = struct + + (* TODO one day replace the list by an heap array *) + + type t = { + bound : int ; + mutable size : int ; + mutable data : E.t list ; + } + + let create bound = + if bound <= 0 then invalid_arg "Utils.Bounded(_).create" ; + { bound ; size = 0 ; data = [] } + + let rec push x = function + | [] -> [x] + | (y :: xs) as ys -> + if E.compare x y <= 0 + then x :: ys + else y :: push x xs + + let insert x t = + if t.size < t.bound then begin + t.size <- t.size + 1 ; + t.data <- push x t.data + end else if E.compare (List.hd t.data) x < 0 then + t.data <- push x (List.tl t.data) + + let get { data ; _ } = data + +end + +let take_n_sorted (type a) compare n l = + let module B = Bounded(struct type t = a let compare = compare end) in + let t = B.create n in + List.iter (fun x -> B.insert x t) l ; + B.get t + +let take_n ?compare n l = + match compare with + | None -> take_n_unsorted n l + | Some compare -> take_n_sorted compare n l + +let select n l = + let rec loop n acc = function + | [] -> invalid_arg "Utils.select" + | x :: xs when n <= 0 -> x, List.rev_append acc xs + | x :: xs -> loop (pred n) (x :: acc) xs + in + loop n [] l diff --git a/lib_stdlib/tzList.mli b/lib_stdlib/tzList.mli new file mode 100644 index 000000000..aa01c1c64 --- /dev/null +++ b/lib_stdlib/tzList.mli @@ -0,0 +1,65 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2017. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +(** [remove nb list] remove the first [nb] elements from the list [list]. *) +val remove: int -> 'a list -> 'a list + +(** [repeat n x] is a list of [n] [x]'s **) +val repeat: int -> 'a -> 'a list + +(** [take_n n l] returns the [n] first elements of [l]. When [compare] + is provided, it returns the [n] greatest element of [l]. *) +val take_n: ?compare:('a -> 'a -> int) -> int -> 'a list -> 'a list + +(** Bounded sequence: keep only the [n] greatest elements. *) +module Bounded(E: Set.OrderedType) : sig + type t + val create: int -> t + val insert: E.t -> t -> unit + val get: t -> E.t list +end + +(** [select n l] is ([n]th element of [l], [l] without that element) **) +val select: int -> 'a list -> 'a * 'a list + + +(** [filter_map f l] is [[y for x in l where (f x) = Some y]] **) +val filter_map: ('a -> 'b option) -> 'a list -> 'b list + +(** [rev_sub l n] is [List.rev l] capped to max [n] elements *) +val rev_sub : 'a list -> int -> 'a list + +(** [sub l n] is [l] capped to max [n] elements *) +val sub: 'a list -> int -> 'a list + +(** Like [List.hd], but [Some hd] or [None] if empty **) +val hd_opt: 'a list -> 'a option + +(** Last elt of list, or raise Not_found if empty **) +val last_exn: 'a list -> 'a + +(** [merge_filter2 ~compare ~f l1 l2] merges two lists ordered by [compare] + and whose items can be merged with [f]. Item is discarded or kept whether + [f] returns [Some] or [None] *) +val merge_filter2 : + ?finalize:('a list -> 'a list) -> + ?compare:('a -> 'a -> int) -> + ?f:('a option -> 'a option -> 'a option) -> + 'a list -> 'a list -> + 'a list + +(** [merge2 ~compare ~f l1 l2] merges two lists ordered by [compare] and + whose items can be merged with [f] *) +val merge2 : + ?finalize:('a list -> 'a list) -> + ?compare:('a -> 'a -> int) -> + ?f:('a -> 'a -> 'a) -> + 'a list -> 'a list -> + 'a list + diff --git a/lib_stdlib/tzString.ml b/lib_stdlib/tzString.ml new file mode 100644 index 000000000..5941d05fd --- /dev/null +++ b/lib_stdlib/tzString.ml @@ -0,0 +1,75 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2017. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +module Map = Map.Make (String) + +let split delim ?(dup = true) ?(limit = max_int) path = + let l = String.length path in + let rec do_slashes acc limit i = + if i >= l then + List.rev acc + else if String.get path i = delim then + if dup then + do_slashes acc limit (i + 1) + else + do_split acc limit (i + 1) + else + do_split acc limit i + and do_split acc limit i = + if limit <= 0 then + if i = l then + List.rev acc + else + List.rev (String.sub path i (l - i) :: acc) + else + do_component acc (pred limit) i i + and do_component acc limit i j = + if j >= l then + if i = j then + List.rev acc + else + List.rev (String.sub path i (j - i) :: acc) + else if String.get path j = delim then + do_slashes (String.sub path i (j - i) :: acc) limit j + else + do_component acc limit i (j + 1) in + if limit > 0 then + do_slashes [] limit 0 + else + [ path ] + +let split_path path = split '/' path + +let has_prefix ~prefix s = + let x = String.length prefix in + let n = String.length s in + n >= x && String.sub s 0 x = prefix + +let remove_prefix ~prefix s = + let x = String.length prefix in + let n = String.length s in + if n >= x && String.sub s 0 x = prefix then + Some (String.sub s x (n - x)) + else + None + +let common_prefix s1 s2 = + let last = min (String.length s1) (String.length s2) in + let rec loop i = + if last <= i then last + else if s1.[i] = s2.[i] then + loop (i+1) + else + i in + loop 0 + +let mem_char s c = + match String.index s c with + | exception Not_found -> false + | _ -> true diff --git a/lib_stdlib/tzString.mli b/lib_stdlib/tzString.mli new file mode 100644 index 000000000..1d3f834ce --- /dev/null +++ b/lib_stdlib/tzString.mli @@ -0,0 +1,31 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2017. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +module Map : Map.S with type key = string + +(** Splits a string on slashes, grouping multiple slashes, and + ignoring slashes at the beginning and end of string. *) +val split_path: string -> string list + +(** Splits a string on a delimier character, grouping multiple + delimiters, and ignoring delimiters at the beginning and end of + string, if [limit] is passed, stops after [limit] split(s). *) +val split: char -> ?dup:bool -> ?limit: int -> string -> string list + +(** [true] if input has prefix **) +val has_prefix: prefix:string -> string -> bool + +(** Some (input with [prefix] removed), if string has [prefix], else [None] **) +val remove_prefix: prefix:string -> string -> string option + +(** Length of common prefix of input strings *) +val common_prefix: string -> string -> int + +(** Test whether a string contains a given character *) +val mem_char: string -> char -> bool diff --git a/lib_stdlib/utils.ml b/lib_stdlib/utils.ml new file mode 100644 index 000000000..940ff1f7d --- /dev/null +++ b/lib_stdlib/utils.ml @@ -0,0 +1,61 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2017. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +module Infix = struct + + let (<<) g f = fun a -> g (f a) + + let (--) i j = + let rec loop acc j = + if j < i then acc else loop (j :: acc) (pred j) in + loop [] j + +end + +let display_paragraph ppf description = + Format.fprintf ppf "@[%a@]" + (Format.pp_print_list ~pp_sep:Format.pp_print_newline + (fun ppf line -> + Format.pp_print_list ~pp_sep:Format.pp_print_space + (fun ppf w -> + (* replace   by real spaces... *) + Format.fprintf ppf "%s@ " + (Stringext.replace_all ~pattern:"\xC2\xA0" ~with_:" " w)) + ppf + (TzString.split ' ' line))) + (TzString.split ~dup:false '\n' description) + +let finalize f g = try let res = f () in g (); res with exn -> g (); raise exn + +let read_file ?(bin=false) fn = + let ic = (if bin then open_in_bin else open_in) fn in + finalize (fun () -> + let len = in_channel_length ic in + really_input_string ic len) + (fun () -> close_in ic) + +let write_file ?(bin=false) fn contents = + let oc = (if bin then open_out_bin else open_out) fn in + finalize (fun () -> + let contents = Bytes.unsafe_of_string contents in + output oc contents 0 @@ Bytes.length contents + ) + (fun () -> close_out oc) + +let mkdir dir = + let safe_mkdir dir = + if not (Sys.file_exists dir) then + try Unix.mkdir dir 0o755 + with Unix.Unix_error(Unix.EEXIST,_,_) -> () in + let rec aux dir = + if not (Sys.file_exists dir) then begin + aux (Filename.dirname dir); + safe_mkdir dir; + end in + aux dir diff --git a/lib_stdlib/utils.mli b/lib_stdlib/utils.mli new file mode 100644 index 000000000..8c4bb09f4 --- /dev/null +++ b/lib_stdlib/utils.mli @@ -0,0 +1,32 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2017. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +module Infix : sig + + (** Compose functions from right to left. *) + val (<<) : ('b -> 'c) -> ('a -> 'b) -> 'a -> 'c + + (** Sequence: [i--j] is the sequence [i;i+1;...;j-1;j] *) + val (--) : int -> int -> int list + +end + +(** Print a paragraph in a box **) +val display_paragraph: Format.formatter -> string -> unit + +(** [finalize f g ] ensures g() called after f(), even if exception raised **) +val finalize: (unit -> 'a) -> (unit -> unit) -> 'a + +(** Return contents of file at given filename. **) +val read_file: ?bin:bool -> string -> string + +(** [write_file p c] writes c to file at path p **) +val write_file: ?bin:bool -> string -> string -> unit + +val mkdir: string -> unit diff --git a/src/utils/cli_entries.ml b/lib_stdlib_lwt/cli_entries.ml similarity index 95% rename from src/utils/cli_entries.ml rename to lib_stdlib_lwt/cli_entries.ml index 45421c4ad..b48fb602d 100644 --- a/src/utils/cli_entries.ml +++ b/lib_stdlib_lwt/cli_entries.ml @@ -10,8 +10,6 @@ (* Tezos Command line interface - Command Line Parsing *) open Error_monad -open Lwt.Infix -open Utils (* User catchable exceptions *) type error += Bad_argument of int * string @@ -59,14 +57,14 @@ type ('a, 'arg) args = ('a * 'b, 'args) args let parse_arg : - type a ctx. (a, ctx) arg -> string option StringMap.t -> ctx -> a tzresult Lwt.t = + type a ctx. (a, ctx) arg -> string option TzString.Map.t -> ctx -> a tzresult Lwt.t = fun spec args_dict ctx -> match spec with | Arg { parameter ; kind={ converter } } -> begin try begin - match StringMap.find parameter args_dict with + match TzString.Map.find parameter args_dict with | None -> return None | Some s -> (converter ctx s) >>|? fun x -> @@ -85,17 +83,17 @@ let parse_arg : "Value provided as default for '%s' could not be parsed by converter function." parameter) end >>=? fun default -> begin try - match StringMap.find parameter args_dict with + match TzString.Map.find parameter args_dict with | None -> return default | Some s -> converter ctx s with Not_found -> return default end | Switch { parameter } -> - return (StringMap.mem parameter args_dict) + return (TzString.Map.mem parameter args_dict) (* Argument parsing *) let rec parse_args : - type a ctx. (a, ctx) args -> string option StringMap.t -> ctx -> a tzresult Lwt.t = + type a ctx. (a, ctx) args -> string option TzString.Map.t -> ctx -> a tzresult Lwt.t = fun spec args_dict ctx -> match spec with | NoArgs -> return () @@ -104,15 +102,15 @@ let rec parse_args : parse_args rest args_dict ctx >>|? fun rest -> (arg, rest) -let empty_args_dict = StringMap.empty +let empty_args_dict = TzString.Map.empty let rec make_arities_dict : - type a b. int StringMap.t -> (a, b) args -> int StringMap.t = + type a b. int TzString.Map.t -> (a, b) args -> int TzString.Map.t = fun acc -> function | NoArgs -> acc | AddArg (arg, rest) -> let recur parameter num = - make_arities_dict (StringMap.add parameter num acc) rest in + make_arities_dict (TzString.Map.add parameter num acc) rest in begin match arg with | Arg { parameter } -> recur parameter 1 @@ -136,13 +134,13 @@ let make_args_dict_consume help_flag ignore_autocomplete spec args = make_args_dict true arities acc remaining_args >>=? fun (dict, _) -> return (dict, "bash_autocomplete" :: prev_arg :: cur_arg :: script :: remaining_args) | arg :: tl -> - if StringMap.mem arg arities - then let arity = StringMap.find arg arities in + if TzString.Map.mem arg arities + then let arity = TzString.Map.find arg arities in check_help_flag help_flag tl >>=? fun () -> match arity, tl with - | 0, tl' -> make_args_dict completing arities (StringMap.add arg None acc) tl' + | 0, tl' -> make_args_dict completing arities (TzString.Map.add arg None acc) tl' | 1, value :: tl' -> - make_args_dict completing arities (StringMap.add arg (Some value) acc) tl' + make_args_dict completing arities (TzString.Map.add arg (Some value) acc) tl' | 1, [] when completing -> return (acc, []) | 1, [] -> @@ -150,7 +148,7 @@ let make_args_dict_consume help_flag ignore_autocomplete spec args = | _, _ -> raise (Failure "cli_entries: Arguments with arity not equal to 1 or 0 not supported") else return (acc, args) - in make_args_dict false (make_arities_dict StringMap.empty spec) StringMap.empty args + in make_args_dict false (make_arities_dict TzString.Map.empty spec) TzString.Map.empty args let make_args_dict_filter help_flag spec args = let rec make_args_dict arities (dict, other_args) args = @@ -158,19 +156,19 @@ let make_args_dict_filter help_flag spec args = match args with | [] -> return (dict, other_args) | arg :: tl -> - if StringMap.mem arg arities - then let arity = StringMap.find arg arities in + if TzString.Map.mem arg arities + then let arity = TzString.Map.find arg arities in check_help_flag help_flag tl >>=? fun () -> match arity, tl with - | 0, tl -> make_args_dict arities (StringMap.add arg None dict, other_args) tl - | 1, value :: tl' -> make_args_dict arities (StringMap.add arg (Some value) dict, other_args) tl' + | 0, tl -> make_args_dict arities (TzString.Map.add arg None dict, other_args) tl + | 1, value :: tl' -> make_args_dict arities (TzString.Map.add arg (Some value) dict, other_args) tl' | 1, [] -> fail (Option_expected_argument arg) | _, _ -> raise (Failure "cli_entries: Arguments with arity not equal to 1 or 0 not suppored") else make_args_dict arities (dict, arg :: other_args) tl in make_args_dict - (make_arities_dict StringMap.empty spec) - (StringMap.empty, []) + (make_arities_dict TzString.Map.empty spec) + (TzString.Map.empty, []) args >>|? fun (dict, remaining) -> (dict, List.rev remaining) @@ -269,7 +267,6 @@ let parse_initial_options : (* Some combinators for writing commands concisely. *) let param ~name ~desc kind next = Param (name, desc, kind, next) -let seq ~name ~desc kind = Seq (name, desc, kind) let seq_of_param param = match param Stop with | Param (n, desc, parameter, Stop) -> Seq (n, desc, parameter) @@ -475,12 +472,12 @@ let find_command tree initial_arguments = | TParam { stop = Some _ }), ("-help" | "--help") :: _ -> fail (Help_flag ( gather_commands tree)) | TStop c, [] -> return (c, empty_args_dict, initial_arguments) - | TStop (Command { options=Argument { spec }} as c), args -> + | TStop (Command { options=Argument { spec } } as c), args -> if not (has_options c) then fail (Extra_arguments (List.rev acc, c)) else make_args_dict (Help_flag [c]) spec args >>=? fun args_dict -> return (c, args_dict, initial_arguments) - | TSeq (Command { options=Argument { spec }} as c, _), remaining -> + | TSeq (Command { options=Argument { spec } } as c, _), remaining -> if List.exists (function "-help" | "--help" -> true | _ -> false) remaining then fail (Help_flag ( gather_commands tree)) else @@ -508,7 +505,7 @@ let find_command tree initial_arguments = in help tree initial_arguments [] let trim s = (* config-file wokaround *) - Utils.split '\n' s |> + TzString.split '\n' s |> List.map String.trim |> String.concat "\n" @@ -678,13 +675,6 @@ let print_group print_command ppf ({ title }, commands) = title (Format.pp_print_list print_command) commands -let command_args_help ppf command = - Format.fprintf ppf - "%a" - (fun ppf (Command { params ; options=Argument { spec } }) -> - print_commandline ppf ([], spec, params)) - command - let usage ppf ?global_options @@ -778,7 +768,7 @@ let rec remaining_spec : else parameter :: (remaining_spec seen rest) let complete_options (type ctx) continuation args args_spec ind (ctx : ctx) = - let arities = make_arities_dict StringMap.empty args_spec in + let arities = make_arities_dict TzString.Map.empty args_spec in let rec complete_spec : type a. string -> (a, ctx) args -> string list tzresult Lwt.t = fun name -> function | NoArgs -> return [] @@ -795,11 +785,11 @@ let complete_options (type ctx) continuation args args_spec ind (ctx : ctx) = Pervasives.failwith "cli_entries internal autocomplete error" | arg :: tl -> - if StringMap.mem arg arities + if TzString.Map.mem arg arities then let seen = StringSet.add arg seen in begin - match StringMap.find arg arities, tl with + match TzString.Map.find arg arities, tl with | 0, args when ind = 0 -> continuation args 0 >>|? fun cont_args -> remaining_spec seen args_spec @ cont_args @@ -853,7 +843,7 @@ let autocomplete ~script ~cur_arg ~prev_arg ~args ~tree ~global_options cctxt = | [] -> None | hd :: tl -> if hd = prev_arg - then Some (Utils.unopt ~default:(n + 1) (ind (n + 1) tl)) + then Some (Option.unopt ~default:(n + 1) (ind (n + 1) tl)) else (ind (n + 1) tl) in begin if prev_arg = script diff --git a/src/utils/cli_entries.mli b/lib_stdlib_lwt/cli_entries.mli similarity index 100% rename from src/utils/cli_entries.mli rename to lib_stdlib_lwt/cli_entries.mli diff --git a/lib_stdlib_lwt/jbuild b/lib_stdlib_lwt/jbuild new file mode 100644 index 000000000..8437bad48 --- /dev/null +++ b/lib_stdlib_lwt/jbuild @@ -0,0 +1,19 @@ +(jbuild_version 1) + +(library + ((name tezos_stdlib_lwt) + (public_name tezos-stdlib-lwt) + (flags (:standard -w -9-30 + -open Tezos_stdlib + -open Tezos_data_encoding + -open Tezos_error_monad)) + (libraries (tezos-stdlib + tezos-data-encoding + tezos-error-monad + lwt.unix + ipaddr.unix)))) + +(alias + ((name runtest_indent) + (deps ((glob_files *.ml) (glob_files *.mli))) + (action (run bash ${libexec:tezos-stdlib:test-ocp-indent.sh} ${<})))) diff --git a/src/utils/logging.ml b/lib_stdlib_lwt/logging.ml similarity index 100% rename from src/utils/logging.ml rename to lib_stdlib_lwt/logging.ml diff --git a/src/utils/logging.mli b/lib_stdlib_lwt/logging.mli similarity index 100% rename from src/utils/logging.mli rename to lib_stdlib_lwt/logging.mli diff --git a/lib_stdlib_lwt/lwt_canceler.ml b/lib_stdlib_lwt/lwt_canceler.ml new file mode 100644 index 000000000..aa560c3a1 --- /dev/null +++ b/lib_stdlib_lwt/lwt_canceler.ml @@ -0,0 +1,53 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2017. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +open Lwt.Infix + +type t = { + cancelation: unit Lwt_condition.t ; + cancelation_complete: unit Lwt_condition.t ; + mutable cancel_hook: unit -> unit Lwt.t ; + mutable canceling: bool ; + mutable canceled: bool ; +} + +let create () = + let cancelation = Lwt_condition.create () in + let cancelation_complete = Lwt_condition.create () in + { cancelation ; cancelation_complete ; + cancel_hook = (fun () -> Lwt.return ()) ; + canceling = false ; + canceled = false ; + } + +let cancel st = + if st.canceled then + Lwt.return () + else if st.canceling then + Lwt_condition.wait st.cancelation_complete + else begin + st.canceling <- true ; + Lwt_condition.broadcast st.cancelation () ; + Lwt.finalize + st.cancel_hook + (fun () -> + st.canceled <- true ; + Lwt_condition.broadcast st.cancelation_complete () ; + Lwt.return ()) + end + +let on_cancel st cb = + let hook = st.cancel_hook in + st.cancel_hook <- (fun () -> hook () >>= cb) + +let cancelation st = + if st.canceling then Lwt.return () + else Lwt_condition.wait st.cancelation + +let canceled st = st.canceling diff --git a/lib_stdlib_lwt/lwt_canceler.mli b/lib_stdlib_lwt/lwt_canceler.mli new file mode 100644 index 000000000..cb6d27bfd --- /dev/null +++ b/lib_stdlib_lwt/lwt_canceler.mli @@ -0,0 +1,15 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2017. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +type t +val create : unit -> t +val cancel : t -> unit Lwt.t +val cancelation : t -> unit Lwt.t +val on_cancel : t -> (unit -> unit Lwt.t) -> unit +val canceled : t -> bool diff --git a/src/utils/lwt_dropbox.ml b/lib_stdlib_lwt/lwt_dropbox.ml similarity index 100% rename from src/utils/lwt_dropbox.ml rename to lib_stdlib_lwt/lwt_dropbox.ml diff --git a/src/utils/lwt_dropbox.mli b/lib_stdlib_lwt/lwt_dropbox.mli similarity index 100% rename from src/utils/lwt_dropbox.mli rename to lib_stdlib_lwt/lwt_dropbox.mli diff --git a/src/utils/lwt_exit.ml b/lib_stdlib_lwt/lwt_exit.ml similarity index 100% rename from src/utils/lwt_exit.ml rename to lib_stdlib_lwt/lwt_exit.ml diff --git a/src/utils/lwt_exit.mli b/lib_stdlib_lwt/lwt_exit.mli similarity index 100% rename from src/utils/lwt_exit.mli rename to lib_stdlib_lwt/lwt_exit.mli diff --git a/lib_stdlib_lwt/lwt_idle_waiter.ml b/lib_stdlib_lwt/lwt_idle_waiter.ml new file mode 100644 index 000000000..47b7b7e12 --- /dev/null +++ b/lib_stdlib_lwt/lwt_idle_waiter.ml @@ -0,0 +1,87 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2017. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +open Error_monad + +type t = + { mutable pending_tasks : unit Lwt.u list ; + mutable pending_idle : (unit -> unit Lwt.t) list ; + mutable running_tasks : int ; + mutable running_idle : bool ; + mutable prevent_tasks : bool } + +let create () = + { pending_tasks = [] ; + pending_idle = [] ; + running_tasks = 0 ; + running_idle = false ; + prevent_tasks = false } + +let rec may_run_idle_tasks w = + if w.running_tasks = 0 && not w.running_idle then + match w.pending_idle with + | [] -> () + | pending_idle -> + w.running_idle <- true ; + w.prevent_tasks <- false ; + w.pending_idle <- [] ; + Lwt.async (fun () -> + let pending_idle = List.rev pending_idle in + Lwt_list.iter_s (fun f -> f ()) pending_idle >>= fun () -> + w.running_idle <- false ; + let pending_tasks = List.rev w.pending_tasks in + w.pending_tasks <- [] ; + List.iter (fun u -> Lwt.wakeup u ()) pending_tasks ; + may_run_idle_tasks w ; + Lwt.return ()) + +let wrap_error f = + Lwt.catch + (fun () -> f () >>= fun r -> Lwt.return (Ok r)) + (fun exn -> Lwt.return (Error exn)) + +let unwrap_error = function + | Ok r -> Lwt.return r + | Error exn -> Lwt.fail exn + +let wakeup_error u = function + | Ok r -> Lwt.wakeup u r + | Error exn -> Lwt.wakeup_exn u exn + +let rec task w f = + if w.running_idle || w.prevent_tasks then + let t, u = Lwt.task () in + w.pending_tasks <- u :: w.pending_tasks ; + t >>= fun () -> task w f + else begin + w.running_tasks <- w.running_tasks + 1 ; + wrap_error f >>= fun res -> + w.running_tasks <- w.running_tasks - 1 ; + may_run_idle_tasks w ; + unwrap_error res + end + +let when_idle w f = + let t, u = Lwt.task () in + let canceled = ref false in + Lwt.on_cancel t (fun () -> canceled := true) ; + let f () = + if !canceled then + Lwt.return () + else + wrap_error f >>= fun res -> + wakeup_error u res ; + Lwt.return () in + w.pending_idle <- f :: w.pending_idle ; + may_run_idle_tasks w ; + t + +let force_idle w f = + w.prevent_tasks <- true ; + when_idle w f diff --git a/lib_stdlib_lwt/lwt_idle_waiter.mli b/lib_stdlib_lwt/lwt_idle_waiter.mli new file mode 100644 index 000000000..b1474b86d --- /dev/null +++ b/lib_stdlib_lwt/lwt_idle_waiter.mli @@ -0,0 +1,33 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2017. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +type t +(** A lightweight scheduler to run tasks concurrently as well as + special callbacks that must be run in mutual exclusion with the + tasks (and each other). *) + +val create : unit -> t +(** Creates a new task / idle callback scheduler *) + +val task : t -> (unit -> 'a Lwt.t) -> 'a Lwt.t +(** Schedule a task to be run as soon as no idle callbacks is + running, or as soon as the next idle callback has been run if it + was scheduled by {!force_idle}. *) + +val when_idle : t -> (unit -> 'a Lwt.t) -> 'a Lwt.t +(** Runs a callback as soon as no task is running. Does not prevent + new tasks from being scheduled, the calling code should ensure + that some idle time will eventually come. Calling this function + from inside the callback will result in a dead lock. *) + +val force_idle : t -> (unit -> 'a Lwt.t) -> 'a Lwt.t +(** Runs a callback as soon as possible. Lets all current tasks + finish, but postpones all new tasks until the end of the + callback. Calling this function from inside the callback will + result in a dead lock. *) diff --git a/lib_stdlib_lwt/lwt_lock_file.ml b/lib_stdlib_lwt/lwt_lock_file.ml new file mode 100644 index 000000000..fcebcb0bd --- /dev/null +++ b/lib_stdlib_lwt/lwt_lock_file.ml @@ -0,0 +1,58 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2017. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +open Error_monad + +let create_inner + lock_command + ?(close_on_exec=true) + ?(unlink_on_exit=false) fn = + protect begin fun () -> + Lwt_unix.openfile fn Unix.[O_CREAT ; O_WRONLY; O_TRUNC] 0o644 >>= fun fd -> + if close_on_exec then Lwt_unix.set_close_on_exec fd ; + Lwt_unix.lockf fd lock_command 0 >>= fun () -> + if unlink_on_exit then + Lwt_main.at_exit (fun () -> Lwt_unix.unlink fn) ; + let pid_str = string_of_int @@ Unix.getpid () in + Lwt_unix.write_string fd pid_str 0 (String.length pid_str) >>= fun _ -> + return () + end + +let create = create_inner Unix.F_TLOCK + +let blocking_create + ?timeout + ?(close_on_exec=true) + ?(unlink_on_exit=false) fn = + let create () = + create_inner Unix.F_LOCK ~close_on_exec ~unlink_on_exit fn in + match timeout with + | None -> create () + | Some duration -> Lwt_utils.with_timeout duration (fun _ -> create ()) + +let is_locked fn = + if not @@ Sys.file_exists fn then return false else + protect begin fun () -> + Lwt_unix.openfile fn [Unix.O_RDONLY] 0o644 >>= fun fd -> + Lwt.finalize (fun () -> + Lwt.try_bind + (fun () -> Lwt_unix.(lockf fd F_TEST 0)) + (fun () -> return false) + (fun _ -> return true)) + (fun () -> Lwt_unix.close fd) + end + +let get_pid fn = + let open Lwt_io in + Lwt_utils.protect begin fun () -> + with_file ~mode:Input fn begin fun ic -> + read ic >>= fun content -> + return (int_of_string content) + end + end diff --git a/src/utils/IO.mli b/lib_stdlib_lwt/lwt_lock_file.mli similarity index 64% rename from src/utils/IO.mli rename to lib_stdlib_lwt/lwt_lock_file.mli index 90a338308..7176dfbf2 100644 --- a/src/utils/IO.mli +++ b/lib_stdlib_lwt/lwt_lock_file.mli @@ -9,15 +9,16 @@ open Error_monad -val mkdir: string -> unit +val create : + ?close_on_exec:bool -> + ?unlink_on_exit:bool -> + string -> unit tzresult Lwt.t -val check_dir: string -> unit tzresult Lwt.t -val is_directory: string -> bool - -val with_file_in: string -> (MBytes.t -> 'a Lwt.t) -> 'a Lwt.t -val with_file_out: string -> MBytes.t -> unit Lwt.t - -val remove_file: ?cleanup:bool -> string -> unit Lwt.t - -val fold: string -> init:'a -> f:(string -> 'a -> 'a Lwt.t) -> 'a Lwt.t +val blocking_create : + ?timeout:float -> + ?close_on_exec:bool -> + ?unlink_on_exit:bool -> + string -> unit tzresult Lwt.t +val is_locked : string -> bool tzresult Lwt.t +val get_pid : string -> int tzresult Lwt.t diff --git a/src/utils/lwt_pipe.ml b/lib_stdlib_lwt/lwt_pipe.ml similarity index 92% rename from src/utils/lwt_pipe.ml rename to lib_stdlib_lwt/lwt_pipe.ml index c673dcf16..bb44b12fb 100644 --- a/src/utils/lwt_pipe.ml +++ b/lib_stdlib_lwt/lwt_pipe.ml @@ -67,8 +67,8 @@ let wait_pop q = q.pop_waiter <- Some (waiter, wakener) ; Lwt.protected waiter -let length { queue } = Queue.length queue -let is_empty { queue } = Queue.is_empty queue +let length { queue ; _ } = Queue.length queue +let is_empty { queue ; _ } = Queue.is_empty queue let rec empty q = if is_empty q @@ -78,7 +78,7 @@ let rec empty q = exception Closed let rec push ({ closed ; queue ; current_size ; - max_size ; compute_size} as q) elt = + max_size ; compute_size ; _ } as q) elt = let elt_size = compute_size elt in if closed then Lwt.fail Closed @@ -92,7 +92,7 @@ let rec push ({ closed ; queue ; current_size ; push q elt let push_now ({ closed ; queue ; compute_size ; - current_size ; max_size + current_size ; max_size ; _ } as q) elt = if closed then raise Closed ; let elt_size = compute_size elt in @@ -113,7 +113,7 @@ let safe_push_now q elt = try push_now_exn q elt with _ -> () -let rec pop ({ closed ; queue ; empty ; current_size } as q) = +let rec pop ({ closed ; queue ; empty ; current_size ; _ } as q) = if not (Queue.is_empty queue) then let (elt_size, elt) = Queue.pop queue in notify_pop q ; @@ -126,7 +126,7 @@ let rec pop ({ closed ; queue ; empty ; current_size } as q) = wait_push q >>= fun () -> pop q -let rec peek ({ closed ; queue } as q) = +let rec peek ({ closed ; queue ; _ } as q) = if not (Queue.is_empty queue) then let (_elt_size, elt) = Queue.peek queue in Lwt.return elt @@ -138,7 +138,7 @@ let rec peek ({ closed ; queue } as q) = exception Empty -let pop_now_exn ({ closed ; queue ; empty ; current_size } as q) = +let pop_now_exn ({ closed ; queue ; empty ; current_size ; _ } as q) = if Queue.is_empty queue then (if closed then raise Closed else raise Empty) ; let (elt_size, elt) = Queue.pop queue in diff --git a/src/utils/lwt_pipe.mli b/lib_stdlib_lwt/lwt_pipe.mli similarity index 100% rename from src/utils/lwt_pipe.mli rename to lib_stdlib_lwt/lwt_pipe.mli diff --git a/src/utils/lwt_utils.ml b/lib_stdlib_lwt/lwt_utils.ml similarity index 67% rename from src/utils/lwt_utils.ml rename to lib_stdlib_lwt/lwt_utils.ml index 9fdf86406..d83809486 100644 --- a/src/utils/lwt_utils.ml +++ b/lib_stdlib_lwt/lwt_utils.ml @@ -58,132 +58,8 @@ let canceler () in cancelation, cancel, on_cancel -module Canceler = struct - - type t = { - cancelation: unit Lwt_condition.t ; - cancelation_complete: unit Lwt_condition.t ; - mutable cancel_hook: unit -> unit Lwt.t ; - mutable canceling: bool ; - mutable canceled: bool ; - } - - let create () = - let cancelation = LC.create () in - let cancelation_complete = LC.create () in - { cancelation ; cancelation_complete ; - cancel_hook = (fun () -> Lwt.return ()) ; - canceling = false ; - canceled = false ; - } - - let cancel st = - if st.canceled then - Lwt.return () - else if st.canceling then - LC.wait st.cancelation_complete - else begin - st.canceling <- true ; - LC.broadcast st.cancelation () ; - Lwt.finalize - st.cancel_hook - (fun () -> - st.canceled <- true ; - LC.broadcast st.cancelation_complete () ; - Lwt.return ()) - end - - let on_cancel st cb = - let hook = st.cancel_hook in - st.cancel_hook <- (fun () -> hook () >>= cb) - - let cancelation st = - if st.canceling then Lwt.return () - else LC.wait st.cancelation - - let canceled st = st.canceling - -end - module Idle_waiter = struct - type t = - { mutable pending_tasks : unit Lwt.u list ; - mutable pending_idle : (unit -> unit Lwt.t) list ; - mutable running_tasks : int ; - mutable running_idle : bool ; - mutable prevent_tasks : bool } - - let create () = - { pending_tasks = [] ; - pending_idle = [] ; - running_tasks = 0 ; - running_idle = false ; - prevent_tasks = false } - - let rec may_run_idle_tasks w = - if w.running_tasks = 0 && not w.running_idle then - match w.pending_idle with - | [] -> () - | pending_idle -> - w.running_idle <- true ; - w.prevent_tasks <- false ; - w.pending_idle <- [] ; - Lwt.async (fun () -> - let pending_idle = List.rev pending_idle in - Lwt_list.iter_s (fun f -> f ()) pending_idle >>= fun () -> - w.running_idle <- false ; - let pending_tasks = List.rev w.pending_tasks in - w.pending_tasks <- [] ; - List.iter (fun u -> Lwt.wakeup u ()) pending_tasks ; - may_run_idle_tasks w ; - Lwt.return ()) - - let wrap_error f = - Lwt.catch - (fun () -> f () >>= fun r -> Lwt.return (Ok r)) - (fun exn -> Lwt.return (Error exn)) - - let unwrap_error = function - | Ok r -> Lwt.return r - | Error exn -> Lwt.fail exn - - let wakeup_error u = function - | Ok r -> Lwt.wakeup u r - | Error exn -> Lwt.wakeup_exn u exn - - let rec task w f = - if w.running_idle || w.prevent_tasks then - let t, u = Lwt.task () in - w.pending_tasks <- u :: w.pending_tasks ; - t >>= fun () -> task w f - else begin - w.running_tasks <- w.running_tasks + 1 ; - wrap_error f >>= fun res -> - w.running_tasks <- w.running_tasks - 1 ; - may_run_idle_tasks w ; - unwrap_error res - end - - let when_idle w f = - let t, u = Lwt.task () in - let canceled = ref false in - Lwt.on_cancel t (fun () -> canceled := true) ; - let f () = - if !canceled then - Lwt.return () - else - wrap_error f >>= fun res -> - wakeup_error u res ; - Lwt.return () in - w.pending_idle <- f :: w.pending_idle ; - may_run_idle_tasks w ; - t - - let force_idle w f = - w.prevent_tasks <- true ; - when_idle w f - end type trigger = @@ -433,7 +309,7 @@ let rec create_dir ?(perm = 0o755) dir = Lwt_unix.mkdir dir perm | true -> Lwt_unix.stat dir >>= function - | {st_kind = S_DIR} -> Lwt.return_unit + | { st_kind = S_DIR ; _ } -> Lwt.return_unit | _ -> failwith "Not a directory" let create_file ?(perm = 0o644) name content = @@ -455,8 +331,8 @@ let protect ?on_error ?canceler t = match canceler with | None -> never_ending | Some canceler -> - ( Canceler.cancelation canceler >>= fun () -> - fail Canceled ) in + (Lwt_canceler.cancelation canceler >>= fun () -> + fail Canceled ) in let res = Lwt.pick [ cancelation ; Lwt.catch t (fun exn -> fail (Exn exn)) ] in @@ -464,7 +340,7 @@ let protect ?on_error ?canceler t = | Ok _ -> res | Error err -> let canceled = - Utils.unopt_map canceler ~default:false ~f:Canceler.canceled in + Option.unopt_map canceler ~default:false ~f:Lwt_canceler.canceled in let err = if canceled then [Canceled] else err in match on_error with | None -> Lwt.return (Error err) @@ -483,7 +359,7 @@ let () = (function Timeout -> Some () | _ -> None) (fun () -> Timeout) -let with_timeout ?(canceler = Canceler.create ()) timeout f = +let with_timeout ?(canceler = Lwt_canceler.create ()) timeout f = let timeout = Lwt_unix.sleep timeout in let target = f canceler in Lwt.choose [ timeout ; (target >|= fun _ -> ()) ] >>= fun () -> @@ -492,63 +368,13 @@ let with_timeout ?(canceler = Canceler.create ()) timeout f = Lwt.cancel timeout ; target end else begin - Canceler.cancel canceler >>= fun () -> + Lwt_canceler.cancel canceler >>= fun () -> fail Timeout end let unless cond f = if cond then Lwt.return () else f () -module Lock_file = struct - let create_inner - lock_command - ?(close_on_exec=true) - ?(unlink_on_exit=false) fn = - protect begin fun () -> - Lwt_unix.openfile fn Unix.[O_CREAT ; O_WRONLY; O_TRUNC] 0o644 >>= fun fd -> - if close_on_exec then Lwt_unix.set_close_on_exec fd ; - Lwt_unix.lockf fd lock_command 0 >>= fun () -> - if unlink_on_exit then - Lwt_main.at_exit (fun () -> Lwt_unix.unlink fn) ; - let pid_str = string_of_int @@ Unix.getpid () in - Lwt_unix.write_string fd pid_str 0 (String.length pid_str) >>= fun _ -> - return () - end - - let create = create_inner Unix.F_TLOCK - - let blocking_create - ?timeout - ?(close_on_exec=true) - ?(unlink_on_exit=false) fn = - let create () = - create_inner Unix.F_LOCK ~close_on_exec ~unlink_on_exit fn in - match timeout with - | None -> create () - | Some duration -> with_timeout duration (fun _ -> create ()) - - let is_locked fn = - if not @@ Sys.file_exists fn then return false else - protect begin fun () -> - Lwt_unix.openfile fn [Unix.O_RDONLY] 0o644 >>= fun fd -> - Lwt.finalize (fun () -> - Lwt.try_bind - (fun () -> Lwt_unix.(lockf fd F_TEST 0)) - (fun () -> return false) - (fun _ -> return true)) - (fun () -> Lwt_unix.close fd) - end - - let get_pid fn = - let open Lwt_io in - protect begin fun () -> - with_file ~mode:Input fn begin fun ic -> - read ic >>= fun content -> - return (int_of_string content) - end - end -end - let of_sockaddr = function | Unix.ADDR_UNIX _ -> None | Unix.ADDR_INET (addr, port) -> @@ -562,7 +388,7 @@ let getaddrinfo ~passive ~node ~service = ( AI_SOCKTYPE SOCK_STREAM :: (if passive then [AI_PASSIVE] else []) ) >>= fun addr -> let points = - Utils.filter_map - (fun { ai_addr } -> of_sockaddr ai_addr) + TzList.filter_map + (fun { ai_addr ; _ } -> of_sockaddr ai_addr) addr in Lwt.return points diff --git a/src/utils/lwt_utils.mli b/lib_stdlib_lwt/lwt_utils.mli similarity index 51% rename from src/utils/lwt_utils.mli rename to lib_stdlib_lwt/lwt_utils.mli index d093778c0..1fc73e561 100644 --- a/src/utils/lwt_utils.mli +++ b/lib_stdlib_lwt/lwt_utils.mli @@ -11,51 +11,11 @@ val may: f:('a -> unit Lwt.t) -> 'a option -> unit Lwt.t val never_ending: 'a Lwt.t -val canceler : unit -> +val canceler: unit -> (unit -> unit Lwt.t) * (unit -> unit Lwt.t) * ((unit -> unit Lwt.t) -> unit) -module Canceler : sig - - type t - val create : unit -> t - val cancel : t -> unit Lwt.t - val cancelation : t -> unit Lwt.t - val on_cancel : t -> (unit -> unit Lwt.t) -> unit - val canceled : t -> bool - -end - -module Idle_waiter : sig - - type t - (** A lightweight scheduler to run tasks concurrently as well as - special callbacks that must be run in mutual exclusion with the - tasks (and each other). *) - - val create : unit -> t - (** Creates a new task / idle callback scheduler *) - - val task : t -> (unit -> 'a Lwt.t) -> 'a Lwt.t - (** Schedule a task to be run as soon as no idle callbacks is - running, or as soon as the next idle callback has been run if it - was scheduled by {!force_idle}. *) - - val when_idle : t -> (unit -> 'a Lwt.t) -> 'a Lwt.t - (** Runs a callback as soon as no task is running. Does not prevent - new tasks from being scheduled, the calling code should ensure - that some idle time will eventually come. Calling this function - from inside the callback will result in a dead lock. *) - - val force_idle : t -> (unit -> 'a Lwt.t) -> 'a Lwt.t - (** Runs a callback as soon as possible. Lets all current tasks - finish, but postpones all new tasks until the end of the - callback. Calling this function from inside the callback will - result in a dead lock. *) - -end - val worker: string -> run:(unit -> unit Lwt.t) -> @@ -88,32 +48,16 @@ open Error_monad type error += Canceled val protect : ?on_error:(error list -> 'a tzresult Lwt.t) -> - ?canceler:Canceler.t -> + ?canceler:Lwt_canceler.t -> (unit -> 'a tzresult Lwt.t) -> 'a tzresult Lwt.t type error += Timeout val with_timeout: - ?canceler:Canceler.t -> - float -> (Canceler.t -> 'a tzresult Lwt.t) -> 'a tzresult Lwt.t + ?canceler:Lwt_canceler.t -> + float -> (Lwt_canceler.t -> 'a tzresult Lwt.t) -> 'a tzresult Lwt.t val unless: bool -> (unit -> unit Lwt.t) -> unit Lwt.t -module Lock_file : sig - val create : - ?close_on_exec:bool -> - ?unlink_on_exit:bool -> - string -> unit tzresult Lwt.t - - val blocking_create : - ?timeout:float -> - ?close_on_exec:bool -> - ?unlink_on_exit:bool -> - string -> unit tzresult Lwt.t - - val is_locked : string -> bool tzresult Lwt.t - val get_pid : string -> int tzresult Lwt.t -end - val getaddrinfo: passive:bool -> node:string -> service:string -> diff --git a/src/utils/watcher.ml b/lib_stdlib_lwt/lwt_watcher.ml similarity index 100% rename from src/utils/watcher.ml rename to lib_stdlib_lwt/lwt_watcher.ml diff --git a/src/utils/watcher.mli b/lib_stdlib_lwt/lwt_watcher.mli similarity index 100% rename from src/utils/watcher.mli rename to lib_stdlib_lwt/lwt_watcher.mli diff --git a/lib_stdlib_lwt/tezos-stdlib-lwt.opam b/lib_stdlib_lwt/tezos-stdlib-lwt.opam new file mode 100644 index 000000000..c92cc1f11 --- /dev/null +++ b/lib_stdlib_lwt/tezos-stdlib-lwt.opam @@ -0,0 +1,24 @@ +opam-version: "1.2" +version: "dev" +maintainer: "contact@tezos.com" +authors: [ "Tezos devteam" ] +homepage: "https://www.tezos.com/" +bug-reports: "https://gitlab.com/tezos/tezos/issues" +dev-repo: "https://gitlab.com/tezos/tezos.git" +license: "unreleased" +depends: [ + "ocamlfind" { build } + "jbuilder" { build & >= "1.0+beta15" } + "base-bigarray" + "tezos-stdlib" + "tezos-data-encoding" + "tezos-error-monad" + "lwt.unix" + "ipaddr.unix" +] +build: [ + [ "jbuilder" "build" "-p" name "-j" jobs ] +] +build-test: [ + [ "jbuilder" "runtest" "-p" name "-j" jobs ] +] diff --git a/scripts/jbuild b/scripts/jbuild new file mode 100644 index 000000000..3d579b2cb --- /dev/null +++ b/scripts/jbuild @@ -0,0 +1,2 @@ +(jbuild_version 1) + diff --git a/src/attacker/attacker_minimal.ml b/src/attacker/attacker_minimal.ml index 347145bbf..5d90afa91 100644 --- a/src/attacker/attacker_minimal.ml +++ b/src/attacker/attacker_minimal.ml @@ -11,7 +11,6 @@ open Format include Logging.Make(struct let name = "attacker" end) module Proto = Client_embedded_proto_alpha -module Ed25519 = Proto.Local_environment.Environment.Ed25519 (* the genesis block and network *) let genesis_block_hashed = Block_hash.of_b58check diff --git a/src/client/client_aliases.ml b/src/client/client_aliases.ml index 9fd0de1ce..7e534ab1d 100644 --- a/src/client/client_aliases.ml +++ b/src/client/client_aliases.ml @@ -266,7 +266,7 @@ module Alias = functor (Entity : Entity) -> struct >>=? fun content -> of_source cctxt content in begin - match Utils.split ~limit:1 ':' s with + match String.split ~limit:1 ':' s with | [ "alias" ; alias ]-> find cctxt alias | [ "text" ; text ] -> diff --git a/src/client/client_config.ml b/src/client/client_config.ml index 230593092..71f47bc08 100644 --- a/src/client/client_config.ml +++ b/src/client/client_config.ml @@ -76,11 +76,10 @@ module Cfg_file = struct (base_dir, Some node_addr, Some node_port, Some tls, Some web_port)) (fun (base_dir, node_addr, node_port, tls, web_port) -> - let open Utils in - let node_addr = unopt ~default:default.node_addr node_addr in - let node_port = unopt ~default:default.node_port node_port in - let tls = unopt ~default:default.tls tls in - let web_port = unopt ~default:default.web_port web_port in + let node_addr = Option.unopt ~default:default.node_addr node_addr in + let node_port = Option.unopt ~default:default.node_port node_port in + let tls = Option.unopt ~default:default.tls tls in + let web_port = Option.unopt ~default:default.web_port web_port in { base_dir ; node_addr ; node_port ; tls ; web_port }) (obj5 (req "base_dir" string) @@ -272,11 +271,11 @@ let parse_config_args (ctx : Client_commands.context) argv = Format.eprintf "Error: %s is not a directory.@." base_dir ; exit 1 ; end ; - IO.mkdir base_dir ; + Utils.mkdir base_dir ; if Sys.file_exists config_dir && not (Sys.is_directory config_dir) then begin Format.eprintf "Error: %s is not a directory.@." config_dir ; exit 1 ; end ; - IO.mkdir config_dir ; + Utils.mkdir config_dir ; if not (Sys.file_exists config_file) then Cfg_file.write config_file cfg ; (cfg, { block ; print_timings = timings ; log_requests ; force ; protocol }, remaining) diff --git a/src/client/client_debug.ml b/src/client/client_debug.ml index 91d72faa6..ec7f88447 100644 --- a/src/client/client_debug.ml +++ b/src/client/client_debug.ml @@ -27,25 +27,25 @@ let pp_block ppf @ Operations hash: %a\ @ Operations: @[%a@]\ @ Data (hex encoded): \"%s\"@]" - Hash.Block_hash.pp hash + Block_hash.pp hash Context.pp_test_network test_network level proto_level - Hash.Block_hash.pp predecessor - Hash.Protocol_hash.pp protocol - Hash.Net_id.pp net_id + Block_hash.pp predecessor + Protocol_hash.pp protocol + Net_id.pp net_id Time.pp_hum timestamp (Format.pp_print_list ~pp_sep:Format.pp_print_space Format.pp_print_string) (List.map Hex_encode.hex_of_bytes fitness) - Hash.Operation_list_list_hash.pp operations_hash + Operation_list_list_hash.pp operations_hash (fun ppf -> function | None -> Format.fprintf ppf "None" | Some operations -> Format.pp_print_list ~pp_sep:Format.pp_print_newline (Format.pp_print_list ~pp_sep:Format.pp_print_space - (fun ppf (oph, _) -> Hash.Operation_hash.pp ppf oph)) + (fun ppf (oph, _) -> Operation_hash.pp ppf oph)) ppf operations) operations (Hex_encode.hex_of_bytes data) @@ -65,7 +65,7 @@ let stuck_node_report (cctxt : Client_commands.context) file = print_title "Registered protocols:" 2 >>=? fun () -> return @@ Format.pp_print_list ~pp_sep:Format.pp_print_newline - (fun ppf (protocol, _) -> Hash.Protocol_hash.pp ppf protocol) + (fun ppf (protocol, _) -> Protocol_hash.pp ppf protocol) ppf (Client_commands.get_versions ()) >>=? fun () -> skip_line () >>=? fun () -> diff --git a/src/client/client_generic_rpcs.ml b/src/client/client_generic_rpcs.ml index 266abb942..e7584f5fa 100644 --- a/src/client/client_generic_rpcs.ml +++ b/src/client/client_generic_rpcs.ml @@ -171,8 +171,6 @@ let editor_fill_in schema = (*-- Nice list display ------------------------------------------------------*) -module StringMap = Map.Make(String) - let rec count = let open RPC.Description in function @@ -184,14 +182,14 @@ let rec count = match subdirs with | None -> 0 | Some (Suffixes subdirs) -> - StringMap.fold (fun _ t r -> r + count t) subdirs 0 + RPC.StringMap.fold (fun _ t r -> r + count t) subdirs 0 | Some (Arg (_, subdir)) -> count subdir in service + subdirs (*-- Commands ---------------------------------------------------------------*) let list url cctxt = - let args = Utils.split '/' url in + let args = String.split '/' url in Client_node_rpcs.describe cctxt.rpc_config ~recurse:true args >>=? fun tree -> let open RPC.Description in @@ -202,7 +200,7 @@ let list url cctxt = let display_paragraph ppf description = Format.fprintf ppf "@, @[%a@]" (fun ppf words -> List.iter (Format.fprintf ppf "%s@ ") words) - (Utils.split ' ' description) + (String.split ' ' description) in let display_arg ppf arg = match arg.RPC.Arg.descr with @@ -236,7 +234,7 @@ let list url cctxt = | Static { services ; subdirs = None } -> display_services ppf (path, tpath, services) | Static { services ; subdirs = Some (Suffixes subdirs) } -> begin - match RPC.MethMap.cardinal services, StringMap.bindings subdirs with + match RPC.MethMap.cardinal services, RPC.StringMap.bindings subdirs with | 0, [] -> () | 0, [ n, solo ] -> display ppf (path @ [ n ], tpath @ [ n ], solo) @@ -290,7 +288,7 @@ let list url cctxt = let schema url cctxt = - let args = Utils.split '/' url in + let args = String.split '/' url in let open RPC.Description in Client_node_rpcs.describe cctxt.rpc_config ~recurse:false args >>=? function | Static { services } -> begin @@ -315,7 +313,7 @@ let schema url cctxt = return () let format url cctxt = - let args = Utils.split '/' url in + let args = String.split '/' url in let open RPC.Description in Client_node_rpcs.describe cctxt.rpc_config ~recurse:false args >>=? function | Static { services } -> begin @@ -354,7 +352,7 @@ let fill_in schema = | _ -> editor_fill_in schema let call url cctxt = - let args = Utils.split '/' url in + let args = String.split '/' url in let open RPC.Description in Client_node_rpcs.describe cctxt.rpc_config ~recurse:false args >>=? function | Static { services } -> begin @@ -381,7 +379,7 @@ let call url cctxt = return () let call_with_json url json (cctxt: Client_commands.context) = - let args = Utils.split '/' url in + let args = String.split '/' url in match Data_encoding_ezjsonm.from_string json with | Error err -> cctxt.error diff --git a/src/client/client_keys.ml b/src/client/client_keys.ml index bba4edff2..070f11363 100644 --- a/src/client/client_keys.ml +++ b/src/client/client_keys.ml @@ -7,8 +7,6 @@ (* *) (**************************************************************************) -module Ed25519 = Tezos_protocol_environment.Ed25519 - module Public_key_hash = Client_aliases.Alias (struct type t = Ed25519.Public_key_hash.t let encoding = Ed25519.Public_key_hash.encoding @@ -33,33 +31,12 @@ module Secret_key = Client_aliases.Alias (struct let name = "secret key" end) -module Seed = struct - - let to_hex s = - Sodium.Sign.Bytes.of_seed s - |> Bytes.to_string - |> Hex_encode.hex_encode - - let of_hex s = - Hex_encode.hex_decode s - |> Bytes.of_string - |> Sodium.Sign.Bytes.to_seed - - let generate () = - (* Seed is 32 bytes long *) - Sodium.Random.Bytes.generate Sodium.Sign.seed_size - |> Sodium.Sign.Bytes.to_seed - - let extract = - Sodium.Sign.secret_key_to_seed -end - let gen_keys ?seed cctxt name = let seed = match seed with - | None -> Seed.generate () + | None -> Ed25519.Seed.generate () | Some s -> s in - let secret_key, public_key = Sodium.Sign.seed_keypair seed in + let _, public_key, secret_key = Ed25519.generate_seeded_key seed in Secret_key.add cctxt name secret_key >>=? fun () -> Public_key.add cctxt name public_key >>=? fun () -> Public_key_hash.add @@ -102,8 +79,8 @@ let gen_keys_containing ?(prefix=false) ~containing ~name (cctxt : Client_comman (fun key -> try ignore (Str.search_forward re key 0); true with Not_found -> false) in let rec loop attempts = - let seed = Seed.generate () in - let secret_key, public_key = Sodium.Sign.seed_keypair seed in + let seed = Ed25519.Seed.generate () in + let _, public_key, secret_key = Ed25519.generate_seeded_key seed in let hash = Ed25519.Public_key_hash.to_b58check @@ Ed25519.Public_key.hash public_key in if matches hash then @@ -208,7 +185,7 @@ let commands () = (fun () name sk cctxt -> Public_key.find_opt cctxt name >>=? function | None -> - let pk = Sodium.Sign.secret_key_to_public_key sk in + let pk = Ed25519.Secret_key.to_public_key sk in Public_key_hash.add cctxt name (Ed25519.Public_key.hash pk) >>=? fun () -> Public_key.add cctxt name pk >>=? fun () -> diff --git a/src/client/client_keys.mli b/src/client/client_keys.mli index c43e6e1a5..3e6c9bfee 100644 --- a/src/client/client_keys.mli +++ b/src/client/client_keys.mli @@ -7,20 +7,11 @@ (* *) (**************************************************************************) -module Ed25519 = Tezos_protocol_environment.Ed25519 - module Public_key_hash : Client_aliases.Alias with type t = Ed25519.Public_key_hash.t module Public_key : Client_aliases.Alias with type t = Ed25519.Public_key.t module Secret_key : Client_aliases.Alias with type t = Ed25519.Secret_key.t -module Seed : sig - val to_hex : Sodium.Sign.seed -> string - val of_hex : string -> Sodium.Sign.seed - val generate : unit -> Sodium.Sign.seed - val extract : Secret_key.t -> Sodium.Sign.seed -end - val get_key: Client_commands.context -> Public_key_hash.t -> @@ -35,7 +26,7 @@ val list_keys: (string * Public_key_hash.t * bool * bool) list tzresult Lwt.t val gen_keys: - ?seed: Sodium.Sign.seed -> + ?seed: Ed25519.Seed.t -> Client_commands.context -> string -> unit tzresult Lwt.t diff --git a/src/client/client_rpcs.ml b/src/client/client_rpcs.ml index 6361e548f..d03f3f74b 100644 --- a/src/client/client_rpcs.ml +++ b/src/client/client_rpcs.ml @@ -7,9 +7,6 @@ (* *) (**************************************************************************) -open Error_monad -open Lwt.Infix - type logger = Logger : { log_request: Uri.t -> Data_encoding.json -> 'a Lwt.t ; log_success: @@ -158,7 +155,7 @@ let pp_error ppf (config, err) = msg (Format.pp_print_list (fun ppf s -> Format.fprintf ppf "> %s" s)) - (Utils.split '\n' json) + (String.split '\n' json) | Unexpected_json (path, json, msg) -> Format.fprintf ppf "@[RPC request returned unexpected JSON:@,\ Path: %a@,\ @@ -166,7 +163,7 @@ let pp_error ppf (config, err) = @[JSON data:@,%a@]@]" pp_path path (Format.pp_print_list (fun ppf s -> Format.fprintf ppf "%s" s)) - (Utils.split '\n' msg) + (String.split '\n' msg) Json_repr.(pp (module Ezjsonm)) json let () = diff --git a/src/client/embedded/alpha/client_baking_blocks.ml b/src/client/embedded/alpha/client_baking_blocks.ml index 9fb8fdf58..a1d1fa8b9 100644 --- a/src/client/embedded/alpha/client_baking_blocks.ml +++ b/src/client/embedded/alpha/client_baking_blocks.ml @@ -74,7 +74,7 @@ let blocks_from_cycle cctxt block cycle = let length = Int32.to_int (Raw_level.diff level.level first) in Client_node_rpcs.Blocks.predecessors cctxt block length >>=? fun blocks -> let blocks = - Utils.remove_elem_from_list + List.remove (length - (1 + Int32.to_int (Raw_level.diff last first))) blocks in if Raw_level.(level.level = last) then Client_node_rpcs.Blocks.hash cctxt block >>=? fun last -> diff --git a/src/client/embedded/alpha/client_baking_endorsement.ml b/src/client/embedded/alpha/client_baking_endorsement.ml index 9b05a1375..ec0c546a5 100644 --- a/src/client/embedded/alpha/client_baking_endorsement.ml +++ b/src/client/embedded/alpha/client_baking_endorsement.ml @@ -10,8 +10,6 @@ open Logging.Client.Endorsement open Client_commands -module Ed25519 = Environment.Ed25519 - module State : sig val get_endorsement: diff --git a/src/client/embedded/alpha/client_baking_forge.ml b/src/client/embedded/alpha/client_baking_forge.ml index 0196d94da..1c88ae192 100644 --- a/src/client/embedded/alpha/client_baking_forge.ml +++ b/src/client/embedded/alpha/client_baking_forge.ml @@ -7,7 +7,6 @@ (* *) (**************************************************************************) - open Client_commands open Logging.Client.Baking @@ -30,7 +29,7 @@ let forge_block_header Tezos_context.Block_header.forge_unsigned shell { priority ; seed_nonce_hash ; proof_of_work_nonce } in let signed_header = - Environment.Ed25519.Signature.append delegate_sk unsigned_header in + Ed25519.Signature.append delegate_sk unsigned_header in let block_hash = Block_hash.hash_bytes [signed_header] in if Baking.check_hash block_hash stamp_threshold then signed_header @@ -52,10 +51,10 @@ let assert_valid_operations_hash shell_header operations = Operation_list_list_hash.compute (List.map Operation_list_hash.compute (List.map - (List.map Tezos_data.Operation.hash) operations)) in + (List.map Tezos_base.Operation.hash) operations)) in fail_unless (Operation_list_list_hash.equal - operations_hash shell_header.Tezos_data.Block_header.operations_hash) + operations_hash shell_header.Tezos_base.Block_header.operations_hash) (failure "Client_baking_forge.inject_block: \ inconsistent header.") @@ -64,7 +63,7 @@ let inject_block cctxt ?force ?net_id ~shell_header ~priority ~seed_nonce_hash ~src_sk operations = assert_valid_operations_hash shell_header operations >>=? fun () -> - let block = `Hash shell_header.Tezos_data.Block_header.predecessor in + let block = `Hash shell_header.Tezos_base.Block_header.predecessor in forge_block_header cctxt block src_sk shell_header priority seed_nonce_hash >>=? fun signed_header -> Client_node_rpcs.inject_block cctxt @@ -72,7 +71,7 @@ let inject_block cctxt return block_hash type error += - | Failed_to_preapply of Tezos_data.Operation.t * error list + | Failed_to_preapply of Tezos_base.Operation.t * error list let () = register_error_kind @@ -81,13 +80,13 @@ let () = ~title: "Fail to preapply an operation" ~description: "" ~pp:(fun ppf (op, err) -> - let h = Tezos_data.Operation.hash op in + let h = Tezos_base.Operation.hash op in Format.fprintf ppf "@[Failed to preapply %a:@ %a@]" Operation_hash.pp_short h pp_print_error err) Data_encoding. (obj2 - (req "operation" (dynamic_size Tezos_data.Operation.encoding)) + (req "operation" (dynamic_size Tezos_base.Operation.encoding)) (req "error" Node_rpc_services.Error.encoding)) (function | Failed_to_preapply (hash, err) -> Some (hash, err) @@ -181,9 +180,9 @@ let forge_block cctxt block [operations] else Lwt.return_error @@ - Utils.filter_map + List.filter_map (fun op -> - let h = Tezos_data.Operation.hash op in + let h = Tezos_base.Operation.hash op in try Some (Failed_to_preapply (op, snd @@ Operation_hash.Map.find h result.refused)) with Not_found -> @@ -491,7 +490,7 @@ let bake cctxt state = List.sort (fun (_,_,h1,_,_) (_,_,h2,_,_) -> match - Fitness.compare h1.Tezos_data.Block_header.fitness h2.fitness + Fitness.compare h1.Tezos_base.Block_header.fitness h2.fitness with | 0 -> Time.compare h1.timestamp h2.timestamp diff --git a/src/client/embedded/alpha/client_baking_forge.mli b/src/client/embedded/alpha/client_baking_forge.mli index 101c06682..d5ba7d440 100644 --- a/src/client/embedded/alpha/client_baking_forge.mli +++ b/src/client/embedded/alpha/client_baking_forge.mli @@ -21,7 +21,7 @@ val inject_block: priority:int -> seed_nonce_hash:Nonce_hash.t -> src_sk:secret_key -> - Tezos_data.Operation.t list list -> + Tezos_base.Operation.t list list -> Block_hash.t tzresult Lwt.t (** [inject_block cctxt blk ?force ~priority ~timestamp ~fitness ~seed_nonce ~src_sk ops] tries to inject a block in the node. If @@ -30,13 +30,13 @@ val inject_block: precomputed). [src_sk] is used to sign the block header. *) type error += - | Failed_to_preapply of Tezos_data.Operation.t * error list + | Failed_to_preapply of Tezos_base.Operation.t * error list val forge_block: Client_rpcs.config -> Client_proto_rpcs.block -> ?force:bool -> - ?operations:Tezos_data.Operation.t list -> + ?operations:Tezos_base.Operation.t list -> ?best_effort:bool -> ?sort:bool -> ?timestamp:Time.t -> diff --git a/src/client/embedded/alpha/client_baking_operations.ml b/src/client/embedded/alpha/client_baking_operations.ml index 29f87a03e..6a3473c69 100644 --- a/src/client/embedded/alpha/client_baking_operations.ml +++ b/src/client/embedded/alpha/client_baking_operations.ml @@ -7,8 +7,6 @@ (* *) (**************************************************************************) -module Ed25519 = Environment.Ed25519 - type operation = { hash: Operation_hash.t ; content: Operation.t option diff --git a/src/client/embedded/alpha/client_proto_context.ml b/src/client/embedded/alpha/client_proto_context.ml index 5cb6797ac..c2e261c1e 100644 --- a/src/client/embedded/alpha/client_proto_context.ml +++ b/src/client/embedded/alpha/client_proto_context.ml @@ -12,7 +12,6 @@ open Client_proto_contracts open Client_proto_programs open Client_keys open Client_commands -module Ed25519 = Environment.Ed25519 let get_balance cctxt block contract = Client_proto_rpcs.Context.Contract.balance cctxt block contract @@ -28,7 +27,7 @@ let rec find_predecessor rpc_config h n = find_predecessor rpc_config h (n-1) let get_branch rpc_config block branch = - let branch = Utils.unopt ~default:0 branch in (* TODO export parameter *) + let branch = Option.unopt ~default:0 branch in (* TODO export parameter *) let block = Client_rpcs.last_baked_block block in begin match block with @@ -64,7 +63,7 @@ let transfer rpc_config ~destination ?parameters ~fee () >>=? fun bytes -> Client_node_rpcs.Blocks.predecessor rpc_config block >>=? fun predecessor -> let signature = Ed25519.sign src_sk bytes in - let signed_bytes = MBytes.concat bytes signature in + let signed_bytes = Ed25519.Signature.concat bytes signature in let oph = Operation_hash.hash_bytes [ signed_bytes ] in Client_proto_rpcs.Helpers.apply_operation rpc_config block predecessor oph bytes (Some signature) >>=? fun contracts -> @@ -77,7 +76,7 @@ let originate rpc_config ?force ?net_id ~block ?signature bytes = let signed_bytes = match signature with | None -> bytes - | Some signature -> MBytes.concat bytes signature in + | Some signature -> Ed25519.Signature.concat bytes signature in Client_node_rpcs.Blocks.predecessor rpc_config block >>=? fun predecessor -> let oph = Operation_hash.hash_bytes [ signed_bytes ] in Client_proto_rpcs.Helpers.apply_operation rpc_config block @@ -141,8 +140,8 @@ let delegate_contract rpc_config Client_proto_rpcs.Helpers.Forge.Manager.delegation rpc_config block ~branch ~source ?sourcePubKey:src_pk ~counter ~fee delegate_opt >>=? fun bytes -> - let signature = Environment.Ed25519.sign manager_sk bytes in - let signed_bytes = MBytes.concat bytes signature in + let signature = Ed25519.sign manager_sk bytes in + let signed_bytes = Ed25519.Signature.concat bytes signature in let oph = Operation_hash.hash_bytes [ signed_bytes ] in Client_node_rpcs.inject_operation rpc_config ?force ~net_id signed_bytes >>=? fun injected_oph -> @@ -225,7 +224,7 @@ let dictate rpc_config ?force block command seckey = Client_proto_rpcs.Helpers.Forge.Dictator.operation rpc_config block ~branch command >>=? fun bytes -> let signature = Ed25519.sign seckey bytes in - let signed_bytes = MBytes.concat bytes signature in + let signed_bytes = Ed25519.Signature.concat bytes signature in let oph = Operation_hash.hash_bytes [ signed_bytes ] in Client_node_rpcs.inject_operation rpc_config ?force ~net_id signed_bytes >>=? fun injected_oph -> @@ -469,7 +468,7 @@ let commands () = @@ Protocol_hash.param ~name:"version" ~desc:"Protocol version (b58check)" @@ prefixes [ "with" ; "key" ] - @@ Environment.Ed25519.Secret_key.param + @@ Ed25519.Secret_key.param ~name:"password" ~desc:"Dictator's key" @@ stop) begin fun force hash seckey cctxt -> @@ -485,7 +484,7 @@ let commands () = @@ Protocol_hash.param ~name:"version" ~desc:"Protocol version (b58check)" @@ prefixes [ "with" ; "key" ] - @@ Environment.Ed25519.Secret_key.param + @@ Ed25519.Secret_key.param ~name:"password" ~desc:"Dictator's key" @@ stop) begin fun force hash seckey cctxt -> diff --git a/src/client/embedded/alpha/client_proto_contracts.ml b/src/client/embedded/alpha/client_proto_contracts.ml index 8024e1a5c..af8cfcfc6 100644 --- a/src/client/embedded/alpha/client_proto_contracts.ml +++ b/src/client/embedded/alpha/client_proto_contracts.ml @@ -7,8 +7,6 @@ (* *) (**************************************************************************) -module Ed25519 = Environment.Ed25519 - module ContractEntity = struct type t = Contract.t let encoding = Contract.encoding @@ -50,7 +48,7 @@ module ContractAlias = struct | None -> RawContractAlias.rev_find cctxt c let get_contract cctxt s = - match Utils.split ~limit:1 ':' s with + match String.split ~limit:1 ':' s with | [ "key" ; key ]-> find_key cctxt key | _ -> find cctxt s @@ -85,7 +83,7 @@ module ContractAlias = struct return (list1 @ list2)) (fun cctxt s -> begin - match Utils.split ~limit:1 ':' s with + match String.split ~limit:1 ':' s with | [ "alias" ; alias ]-> find cctxt alias | [ "key" ; text ] -> @@ -236,7 +234,7 @@ let commands () = let new_tags = match tags with | None -> new_tags - | Some tags -> Utils.merge_list2 tags new_tags in + | Some tags -> List.merge2 tags new_tags in Contract_tags.update cctxt alias new_tags) ; command ~group ~desc: "remove tag(s) from a contract in the wallet" @@ -252,7 +250,7 @@ let commands () = match tags with | None -> [] | Some tags -> - Utils.merge_filter_list2 + List.merge_filter2 ~f:(fun x1 x2 -> match x1, x2 with | None, None -> assert false | None, Some _ -> None diff --git a/src/client/embedded/alpha/client_proto_programs.ml b/src/client/embedded/alpha/client_proto_programs.ml index a1165db74..cb7aaaef8 100644 --- a/src/client/embedded/alpha/client_proto_programs.ml +++ b/src/client/embedded/alpha/client_proto_programs.ml @@ -7,7 +7,6 @@ (* *) (**************************************************************************) -module Ed25519 = Environment.Ed25519 open Client_proto_args open Michelson_v1_printer diff --git a/src/client/embedded/alpha/client_proto_rpcs.mli b/src/client/embedded/alpha/client_proto_rpcs.mli index 31697df9f..ac3815074 100644 --- a/src/client/embedded/alpha/client_proto_rpcs.mli +++ b/src/client/embedded/alpha/client_proto_rpcs.mli @@ -151,7 +151,7 @@ module Helpers : sig val apply_operation: Client_rpcs.config -> - block -> Block_hash.t -> Operation_hash.t -> MBytes.t -> MBytes.t option -> + block -> Block_hash.t -> Operation_hash.t -> MBytes.t -> Ed25519.Signature.t option -> (Contract.t list) tzresult Lwt.t val run_code: Client_rpcs.config -> @@ -289,7 +289,7 @@ module Helpers : sig branch:Block_hash.t -> source:public_key -> period:Voting_period.t -> - proposals:Hash.Protocol_hash.t list -> + proposals:Protocol_hash.t list -> unit -> MBytes.t tzresult Lwt.t val ballot: Client_rpcs.config -> @@ -297,7 +297,7 @@ module Helpers : sig branch:Block_hash.t -> source:public_key -> period:Voting_period.t -> - proposal:Hash.Protocol_hash.t -> + proposal:Protocol_hash.t -> ballot:Vote.ballot -> unit -> MBytes.t tzresult Lwt.t end diff --git a/src/client/embedded/alpha/jbuild b/src/client/embedded/alpha/jbuild index 660e2984b..a605b63f6 100644 --- a/src/client/embedded/alpha/jbuild +++ b/src/client/embedded/alpha/jbuild @@ -3,16 +3,19 @@ (library ((name client_embedded_alpha) (public_name tezos.client.embedded.alpha) - (libraries (tezos_embedded_protocol_alpha + (libraries (tezos-base + tezos_embedded_protocol_alpha tezos_embedded_raw_protocol_alpha client_lib)) (library_flags (:standard -linkall)) (flags (:standard -w -9+27-30-32-40@8 -safe-string - -open Error_monad - -open Hash - -open Utils - -open Tezos_data + -open Tezos_base__TzPervasives -open Tezos_protocol_environment_alpha -open Tezos_embedded_raw_protocol_alpha -open Tezos_context)))) + +(alias + ((name runtest_indent) + (deps ((glob_files *.ml) (glob_files *.mli))) + (action (run bash ${libexec:tezos-stdlib:test-ocp-indent.sh} ${<})))) diff --git a/src/client/embedded/genesis/client_proto_main.ml b/src/client/embedded/genesis/client_proto_main.ml index c1d94ae54..5447e734d 100644 --- a/src/client/embedded/genesis/client_proto_main.ml +++ b/src/client/embedded/genesis/client_proto_main.ml @@ -42,7 +42,7 @@ let bake rpc_config ?timestamp block command fitness seckey = Client_node_rpcs.Blocks.info rpc_config block >>=? fun bi -> forge_block rpc_config ?timestamp block bi.net_id command fitness >>=? fun blk -> - let signed_blk = Environment.Ed25519.Signature.append seckey blk in + let signed_blk = Ed25519.Signature.append seckey blk in Client_node_rpcs.inject_block rpc_config signed_blk [] let int64_parameter = @@ -107,7 +107,7 @@ let commands () = ~desc:"Hardcoded number of validation passes (integer)" int_parameter @@ prefixes [ "and" ; "key" ] - @@ Environment.Ed25519.Secret_key.param + @@ Ed25519.Secret_key.param ~name:"password" ~desc:"Dictator's key" @@ stop) begin fun timestamp hash fitness validation_passes seckey cctxt -> diff --git a/src/client/embedded/genesis/jbuild b/src/client/embedded/genesis/jbuild index 0bd25a4e8..0905d63ea 100644 --- a/src/client/embedded/genesis/jbuild +++ b/src/client/embedded/genesis/jbuild @@ -3,16 +3,19 @@ (library ((name client_embedded_genesis) (public_name tezos.client.embedded.genesis) - (libraries (tezos_embedded_raw_protocol_genesis + (libraries (tezos-base + tezos_embedded_raw_protocol_genesis tezos_embedded_protocol_genesis tezos_protocol_environment_alpha client_lib)) (library_flags (:standard -linkall)) (flags (:standard -w -9+27-30-32-40@8 -safe-string - -open Error_monad - -open Hash - -open Utils - -open Tezos_data + -open Tezos_base__TzPervasives -open Tezos_protocol_environment_genesis -open Tezos_embedded_raw_protocol_genesis)))) + +(alias + ((name runtest_indent) + (deps ((glob_files *.ml) (glob_files *.mli))) + (action (run bash ${libexec:tezos-stdlib:test-ocp-indent.sh} ${<})))) diff --git a/src/client/jbuild b/src/client/jbuild index c6b16f630..b7848d9b7 100644 --- a/src/client/jbuild +++ b/src/client/jbuild @@ -3,14 +3,17 @@ (library ((name client_lib) (public_name tezos.client) - (libraries (node_shell + (libraries (tezos-base + node_shell node_db node_updater tezos_protocol_compiler)) (flags (:standard -w -9+27-30-32-40@8 -safe-string - -open Error_monad - -open Hash - -open Utils - -open Tezos_data)) + -open Tezos_base__TzPervasives)) (wrapped false))) + +(alias + ((name runtest_indent) + (deps ((glob_files *.ml) (glob_files *.mli))) + (action (run bash ${libexec:tezos-stdlib:test-ocp-indent.sh} ${<})))) diff --git a/src/client_main.ml b/src/client_main.ml index 4c4cadd11..3e3699f64 100644 --- a/src/client_main.ml +++ b/src/client_main.ml @@ -10,7 +10,6 @@ (* Tezos Command line interface - Main Program *) open Client_commands -open Error_monad let cctxt config rpc_config = let startup = @@ -58,13 +57,13 @@ let main () = | None -> return (Some version, Client_commands.commands_for_version version) | Some given_version -> begin - if not (Hash.Protocol_hash.equal version given_version) then + if not (Protocol_hash.equal version given_version) then Format.eprintf "@[Warning:@,\ The protocol provided via `-protocol` (%a)@,\ is not the one retrieved from the node (%a).@." - Hash.Protocol_hash.pp_short given_version - Hash.Protocol_hash.pp_short version ; + Protocol_hash.pp_short given_version + Protocol_hash.pp_short version ; return (Some version, Client_commands.commands_for_version given_version) end end diff --git a/src/compiler/jbuild b/src/compiler/jbuild index 8bc665d09..5724a2931 100644 --- a/src/compiler/jbuild +++ b/src/compiler/jbuild @@ -12,8 +12,7 @@ (library ((name tezos_protocol_compiler) (public_name tezos.protocol_compiler) - (libraries (utils - minutils + (libraries (tezos-base tezos_protocol_environment_sigs compiler-libs compiler-libs.optcomp @@ -24,7 +23,9 @@ (flags (:standard -w -9+27-30-32-40@8 -safe-string -opaque - -open Error_monad - -open Hash - -open Utils - -open Tezos_data)))) + -open Tezos_base__TzPervasives)))) + +(alias + ((name runtest_indent) + (deps ((glob_files *.ml) (glob_files *.mli))) + (action (run bash ${libexec:tezos-stdlib:test-ocp-indent.sh} ${<})))) diff --git a/src/environment/jbuild b/src/environment/jbuild index 59b41aa56..b9d235e57 100644 --- a/src/environment/jbuild +++ b/src/environment/jbuild @@ -34,6 +34,7 @@ v1/time.mli v1/base58.mli v1/hash.mli + v1/blake2B.mli v1/ed25519.mli ;; Tezos specifics diff --git a/src/environment/sigs_packer/jbuild b/src/environment/sigs_packer/jbuild index 705c140e0..7e59f8ad0 100644 --- a/src/environment/sigs_packer/jbuild +++ b/src/environment/sigs_packer/jbuild @@ -3,5 +3,10 @@ (executable ((name sigs_packer) (public_name tezos-protocol-environment-sigs-packer) + (package tezos) (flags (:standard -w -9-32 -safe-string)))) +(alias + ((name runtest_indent) + (deps ((glob_files *.ml) (glob_files *.mli))) + (action (run bash ${libexec:tezos-stdlib:test-ocp-indent.sh} ${<})))) diff --git a/src/environment/v1/blake2B.mli b/src/environment/v1/blake2B.mli new file mode 100644 index 000000000..b199b0083 --- /dev/null +++ b/src/environment/v1/blake2B.mli @@ -0,0 +1,24 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2017. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +(** Builds a new Hash type using Blake2B. *) + +module Make_minimal (Name : Hash.Name) : Hash.MINIMAL_HASH +module Make + (Register : sig + val register_encoding: + prefix: string -> + length: int -> + to_raw: ('a -> string) -> + of_raw: (string -> 'a option) -> + wrap: ('a -> Base58.data) -> + 'a Base58.encoding + end) + (Name : Hash.PrefixedName) : HASH + diff --git a/src/environment/v1/hash.mli b/src/environment/v1/hash.mli index 747d4b82f..bf08c72b1 100644 --- a/src/environment/v1/hash.mli +++ b/src/environment/v1/hash.mli @@ -111,21 +111,6 @@ module type PrefixedName = sig val b58check_prefix : string end -(** Builds a new Hash type using Blake2B. *) - -module Make_minimal_Blake2B (Name : Name) : MINIMAL_HASH -module Make_Blake2B - (Register : sig - val register_encoding: - prefix: string -> - length: int -> - to_raw: ('a -> string) -> - of_raw: (string -> 'a option) -> - wrap: ('a -> Base58.data) -> - 'a Base58.encoding - end) - (Name : PrefixedName) : HASH - (** {2 Predefined Hashes } ****************************************************) (** Blocks hashes / IDs. *) diff --git a/src/jbuild b/src/jbuild index 385c793c3..032618754 100644 --- a/src/jbuild +++ b/src/jbuild @@ -3,6 +3,7 @@ (executable ((name compiler_main) (public_name tezos-protocol-compiler) + (package tezos) (libraries (tezos_protocol_compiler)) (flags (:standard -w -9+27-30-32-40@8 -safe-string @@ -12,22 +13,32 @@ (executable ((name node_main) (public_name tezos-node) - (libraries (node_db node_main_lib node_net cmdliner + (package tezos) + (libraries (tezos-base + node_db node_main_lib node_net cmdliner tezos_embedded_protocol_genesis tezos_embedded_protocol_demo tezos_embedded_protocol_alpha)) (flags (:standard -w -9+27-30-32-40@8 -safe-string + -open Tezos_base__TzPervasives -linkall)) (modules (Node_main)))) (executable ((name client_main) (public_name tezos-client) - (libraries (lwt utils client_lib + (package tezos) + (libraries (tezos-base client_lib client_embedded_genesis client_embedded_alpha)) (flags (:standard -w -9+27-30-32-40@8 -safe-string + -open Tezos_base__TzPervasives -linkall)) (modules (Client_main)))) + +(alias + ((name runtest_indent) + (deps ((glob_files *.ml) (glob_files *.mli))) + (action (run bash ${libexec:tezos-stdlib:test-ocp-indent.sh} ${<})))) diff --git a/src/micheline/jbuild b/src/micheline/jbuild index 648cb66e9..28c0fe80d 100644 --- a/src/micheline/jbuild +++ b/src/micheline/jbuild @@ -8,10 +8,14 @@ ;; External uutf ;; Internal - minutils - utils + tezos-base )) - (flags (:standard -w -9+27-30-32-40@8 -safe-string)) + (flags (:standard -w -9+27-30-32-40@8 + -safe-string + -open Tezos_base__TzPervasives)) (wrapped false))) - +(alias + ((name runtest_indent) + (deps ((glob_files *.ml) (glob_files *.mli))) + (action (run bash ${libexec:tezos-stdlib:test-ocp-indent.sh} ${<})))) diff --git a/src/micheline/micheline_parser.ml b/src/micheline/micheline_parser.ml index cb47ca3ff..0d71e43a9 100644 --- a/src/micheline/micheline_parser.ml +++ b/src/micheline/micheline_parser.ml @@ -7,7 +7,6 @@ (* *) (**************************************************************************) -open Error_monad open Micheline type 'a parsing_result = 'a * error list diff --git a/src/minutils/jbuild b/src/minutils/jbuild deleted file mode 100644 index 37b04c6cb..000000000 --- a/src/minutils/jbuild +++ /dev/null @@ -1,12 +0,0 @@ -(jbuild_version 1) - -(library - ((name minutils) - (public_name tezos.minutils) - (libraries (cstruct - lwt - ocplib-json-typed.bson - ocplib-resto-directory - ocplib-endian.bigstring)) - (flags (:standard -w -9+27-30-32-40@8 -safe-string)) - (wrapped false))) diff --git a/src/minutils/utils.ml b/src/minutils/utils.ml deleted file mode 100644 index ce45d679a..000000000 --- a/src/minutils/utils.ml +++ /dev/null @@ -1,316 +0,0 @@ -(**************************************************************************) -(* *) -(* Copyright (c) 2014 - 2017. *) -(* Dynamic Ledger Solutions, Inc. *) -(* *) -(* All rights reserved. No warranty, explicit or implicit, provided. *) -(* *) -(**************************************************************************) - -module StringMap = Map.Make (String) - -let split delim ?(dup = true) ?(limit = max_int) path = - let l = String.length path in - let rec do_slashes acc limit i = - if i >= l then - List.rev acc - else if String.get path i = delim then - if dup then - do_slashes acc limit (i + 1) - else - do_split acc limit (i + 1) - else - do_split acc limit i - and do_split acc limit i = - if limit <= 0 then - if i = l then - List.rev acc - else - List.rev (String.sub path i (l - i) :: acc) - else - do_component acc (pred limit) i i - and do_component acc limit i j = - if j >= l then - if i = j then - List.rev acc - else - List.rev (String.sub path i (j - i) :: acc) - else if String.get path j = delim then - do_slashes (String.sub path i (j - i) :: acc) limit j - else - do_component acc limit i (j + 1) in - if limit > 0 then - do_slashes [] limit 0 - else - [ path ] - -let split_path path = split '/' path - -let map_option ~f = function - | None -> None - | Some x -> Some (f x) - -let apply_option ~f = function - | None -> None - | Some x -> f x - -let iter_option ~f = function - | None -> () - | Some x -> f x - -let unopt ~default = function - | None -> default - | Some x -> x - -let unopt_map ~f ~default = function - | None -> default - | Some x -> f x - -let may_cons xs x = match x with None -> xs | Some x -> x :: xs - -let unopt_list l = - List.rev @@ List.fold_left may_cons [] l - -let first_some a b = match a, b with - | None, None -> None - | None, Some v -> Some v - | Some v, _ -> Some v - -let filter_map f l = - List.rev @@ List.fold_left (fun acc x -> may_cons acc (f x)) [] l - -let list_rev_sub l n = - if n < 0 then - invalid_arg "Utils.list_rev_sub: `n` must be non-negative."; - let rec append_rev_sub acc l = function - | 0 -> acc - | n -> - match l with - | [] -> acc - | hd :: tl -> append_rev_sub (hd :: acc) tl (n - 1) in - append_rev_sub [] l n - -let list_sub l n = list_rev_sub l n |> List.rev - -let list_hd_opt = function - | [] -> None - | h :: _ -> Some h - -let rec list_last_exn = function - | [] -> raise Not_found - | [x] -> x - | _ :: xs -> list_last_exn xs - -let merge_filter_list2 - ?(finalize = List.rev) ?(compare = compare) - ?(f = first_some) - l1 l2 = - let sort = List.sort compare in - let rec merge_aux acc = function - | [], [] -> finalize acc - | r1, [] -> finalize acc @ (filter_map (fun x1 -> f (Some x1) None) r1) - | [], r2 -> finalize acc @ (filter_map (fun x2 -> f None (Some x2)) r2) - | ((h1 :: t1) as r1), ((h2 :: t2) as r2) -> - if compare h1 h2 > 0 then - merge_aux (may_cons acc (f None (Some h2))) (r1, t2) - else if compare h1 h2 < 0 then - merge_aux (may_cons acc (f (Some h1) None)) (t1, r2) - else (* m1 = m2 *) - merge_aux (may_cons acc (f (Some h1) (Some h2))) (t1, t2) - in - merge_aux [] (sort l1, sort l2) - -let merge_list2 ?finalize ?compare ?(f = fun x1 _x1 -> x1) l1 l2 = - merge_filter_list2 ?finalize ?compare - ~f:(fun x1 x2 -> match x1, x2 with - | None, None -> assert false - | Some x1, None -> Some x1 - | None, Some x2 -> Some x2 - | Some x1, Some x2 -> Some (f x1 x2)) - l1 l2 - -let display_paragraph ppf description = - Format.fprintf ppf "@[%a@]" - (Format.pp_print_list ~pp_sep:Format.pp_print_newline - (fun ppf line -> - Format.pp_print_list ~pp_sep:Format.pp_print_space - (fun ppf w -> - (* replace   by real spaces... *) - Format.fprintf ppf "%s@ " - (Stringext.replace_all ~pattern:"\xC2\xA0" ~with_:" " w)) - ppf - (split ' ' line))) - (split ~dup:false '\n' description) - -let rec remove_elem_from_list nb = function - | [] -> [] - | l when nb <= 0 -> l - | _ :: tl -> remove_elem_from_list (nb - 1) tl - -let split_list_at n l = - let rec split n acc = function - | [] -> List.rev acc, [] - | l when n <= 0 -> List.rev acc, l - | hd :: tl -> split (n - 1) (hd :: acc) tl in - split n [] l - -let has_prefix ~prefix s = - let x = String.length prefix in - let n = String.length s in - n >= x && String.sub s 0 x = prefix - -let remove_prefix ~prefix s = - let x = String.length prefix in - let n = String.length s in - if n >= x && String.sub s 0 x = prefix then - Some (String.sub s x (n - x)) - else - None - -let common_prefix s1 s2 = - let last = min (String.length s1) (String.length s2) in - let rec loop i = - if last <= i then last - else if s1.[i] = s2.[i] then - loop (i+1) - else - i in - loop 0 - -let finalize f g = try let res = f () in g (); res with exn -> g (); raise exn - -let read_file ?(bin=false) fn = - let ic = (if bin then open_in_bin else open_in) fn in - finalize (fun () -> - let len = in_channel_length ic in - really_input_string ic len) - (fun () -> close_in ic) - -let write_file ?(bin=false) fn contents = - let oc = (if bin then open_out_bin else open_out) fn in - finalize (fun () -> - let contents = Bytes.unsafe_of_string contents in - output oc contents 0 @@ Bytes.length contents - ) - (fun () -> close_out oc) - -let (<<) g f = fun a -> g (f a) - -let (--) i j = - let rec loop acc j = - if j < i then acc else loop (j :: acc) (pred j) in - loop [] j - -let rec repeat n x = if n <= 0 then [] else x :: repeat (pred n) x - -let take_n_unsorted n l = - let rec loop acc n = function - | [] -> l - | _ when n <= 0 -> List.rev acc - | x :: xs -> loop (x :: acc) (pred n) xs in - loop [] n l - -module Bounded(E: Set.OrderedType) : sig - - type t - val create: int -> t - val insert: E.t -> t -> unit - val get: t -> E.t list - -end = struct - - (* TODO one day replace the list by an heap array *) - - type t = { - bound : int ; - mutable size : int ; - mutable data : E.t list ; - } - - let create bound = - if bound <= 0 then invalid_arg "Utils.Bounded(_).create" ; - { bound ; size = 0 ; data = [] } - - let rec push x = function - | [] -> [x] - | (y :: xs) as ys -> - if E.compare x y <= 0 - then x :: ys - else y :: push x xs - - let insert x t = - if t.size < t.bound then begin - t.size <- t.size + 1 ; - t.data <- push x t.data - end else if E.compare (List.hd t.data) x < 0 then - t.data <- push x (List.tl t.data) - - let get { data } = data - -end - -let take_n_sorted (type a) compare n l = - let module B = Bounded(struct type t = a let compare = compare end) in - let t = B.create n in - List.iter (fun x -> B.insert x t) l ; - B.get t - -let take_n ?compare n l = - match compare with - | None -> take_n_unsorted n l - | Some compare -> take_n_sorted compare n l - -let select n l = - let rec loop n acc = function - | [] -> invalid_arg "Utils.select" - | x :: xs when n <= 0 -> x, List.rev_append acc xs - | x :: xs -> loop (pred n) (x :: acc) xs - in - loop n [] l - - -let mem_char s c = - match String.index s c with - | exception Not_found -> false - | _ -> true - -let check_port port = - if mem_char port '[' || mem_char port ']' || mem_char port ':' then - invalid_arg "Utils.parse_addr_port (invalid character in port)" - -let parse_addr_port s = - let len = String.length s in - if len = 0 then - ("", "") - else if s.[0] = '[' then begin (* inline IPv6 *) - match String.rindex s ']' with - | exception Not_found -> - invalid_arg "Utils.parse_addr_port (missing ']')" - | pos -> - let addr = String.sub s 1 (pos - 1) in - let port = - if pos = len - 1 then - "" - else if s.[pos+1] <> ':' then - invalid_arg "Utils.parse_addr_port (unexpected char after ']')" - else - String.sub s (pos + 2) (len - pos - 2) in - check_port port ; - addr, port - end else begin - match String.rindex s ']' with - | _pos -> - invalid_arg "Utils.parse_addr_port (unexpected char ']')" - | exception Not_found -> - match String.index s ':' with - | exception _ -> s, "" - | pos -> - match String.index_from s (pos+1) ':' with - | exception _ -> - let addr = String.sub s 0 pos in - let port = String.sub s (pos + 1) (len - pos - 1) in - check_port port ; - addr, port - | _pos -> - invalid_arg "Utils.parse_addr_port: IPv6 addresses must be bracketed" - end diff --git a/src/minutils/utils.mli b/src/minutils/utils.mli deleted file mode 100644 index 2be06789a..000000000 --- a/src/minutils/utils.mli +++ /dev/null @@ -1,129 +0,0 @@ -(**************************************************************************) -(* *) -(* Copyright (c) 2014 - 2017. *) -(* Dynamic Ledger Solutions, Inc. *) -(* *) -(* All rights reserved. No warranty, explicit or implicit, provided. *) -(* *) -(**************************************************************************) - -module StringMap : Map.S with type key = string - -(** Splits a string on slashes, grouping multiple slashes, and - ignoring slashes at the beginning and end of string. *) -val split_path: string -> string list - -(** Splits a string on a delimier character, grouping multiple - delimiters, and ignoring delimiters at the beginning and end of - string, if [limit] is passed, stops after [limit] split(s). *) -val split: char -> ?dup:bool -> ?limit: int -> string -> string list - -(** [Some (f x)] if input is [Some x], or [None] if it's [None] **) -val map_option: f:('a -> 'b) -> 'a option -> 'b option - -(** [(f x)] if input is [Some x], or [None] if it's [None] **) -val apply_option: f:('a -> 'b option) -> 'a option -> 'b option - -(** Call [(f x)] if input is [Some x], noop if it's [None] **) -val iter_option: f:('a -> unit) -> 'a option -> unit - -(** [x] if input is [Some x], default if it's [None] **) -val unopt: default:'a -> 'a option -> 'a - -(** [unopt_map f d x] is [y] if [x] is [Some y], [d] if [x] is [None] **) -val unopt_map: f:('a -> 'b) -> default:'b -> 'a option -> 'b - -(** [x] for elements [Some x] in input. [None]s are dropped. **) -val unopt_list: 'a option list -> 'a list - -(** First input of form [Some x], or [None] if none **) -val first_some: 'a option -> 'a option -> 'a option - -(** Print a paragraph in a box **) -val display_paragraph: Format.formatter -> string -> unit - -(** [remove nb list] remove the first [nb] elements from the list [list]. *) -val remove_elem_from_list: int -> 'a list -> 'a list - -(** Return pair (list of first n items, remaining items) **) -val split_list_at: int -> 'a list -> 'a list * 'a list - -(** [true] if input has prefix **) -val has_prefix: prefix:string -> string -> bool - -(** Some (input with [prefix] removed), if string has [prefix], else [None] **) -val remove_prefix: prefix:string -> string -> string option - -(** Length of common prefix of input strings *) -val common_prefix: string -> string -> int - -(** [filter_map f l] is [[y for x in l where (f x) = Some y]] **) -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 - -(** Like [List.hd], but [Some hd] or [None] if empty **) -val list_hd_opt: 'a list -> 'a option - -(** Last elt of list, or raise Not_found if empty **) -val list_last_exn: 'a list -> 'a - -(** [merge_filter_list2 ~compare ~f l1 l2] merges two lists ordered by [compare] - and whose items can be merged with [f]. Item is discarded or kept whether - [f] returns [Some] or [None] *) -val merge_filter_list2 : - ?finalize:('a list -> 'a list) -> - ?compare:('a -> 'a -> int) -> - ?f:('a option -> 'a option -> 'a option) -> - 'a list -> 'a list -> - 'a list - -(** [merge_list2 ~compare ~f l1 l2] merges two lists ordered by [compare] and - whose items can be merged with [f] *) -val merge_list2 : - ?finalize:('a list -> 'a list) -> - ?compare:('a -> 'a -> int) -> - ?f:('a -> 'a -> 'a) -> - 'a list -> 'a list -> - 'a list - -(** [finalize f g ] ensures g() called after f(), even if exception raised **) -val finalize: (unit -> 'a) -> (unit -> unit) -> 'a - -(** Return contents of file at given filename. **) -val read_file: ?bin:bool -> string -> string - -(** [write_file p c] writes c to file at path p **) -val write_file: ?bin:bool -> string -> string -> unit - -(** Compose functions from right to left. *) -val (<<) : ('b -> 'c) -> ('a -> 'b) -> 'a -> 'c - -(** Sequence: [i--j] is the sequence [i;i+1;...;j-1;j] *) -val (--) : int -> int -> int list - -(** [repeat n x] is a list of [n] [x]'s **) -val repeat: int -> 'a -> 'a list - -(** [take_n n l] returns the [n] first elements of [l]. When [compare] - is provided, it returns the [n] greatest element of [l]. *) -val take_n: ?compare:('a -> 'a -> int) -> int -> 'a list -> 'a list - -(** Bounded sequence: keep only the [n] greatest elements. *) -module Bounded(E: Set.OrderedType) : sig - type t - val create: int -> t - val insert: E.t -> t -> unit - val get: t -> E.t list -end - -(** [select n l] is ([n]th element of [l], [l] without that element) **) -val select: int -> 'a list -> 'a * 'a list - -(** [parse_addr_port uri] is (node, service) where [node] is the DNS or - IP and service is the optional port number or service name. *) -val parse_addr_port: string -> string * string diff --git a/src/node/db/context.ml b/src/node/db/context.ml index 62b162d1a..7728f1df1 100644 --- a/src/node/db/context.ml +++ b/src/node/db/context.ml @@ -9,8 +9,6 @@ (** Tezos - Versioned (key x value) store (over Irmin) *) -open Hash - module IrminPath = Irmin.Path.String_list module MBytesContent = struct @@ -197,7 +195,7 @@ let pp_test_network ppf = function | Forking { protocol ; expiration } -> Format.fprintf ppf "@[Forking %a (expires %a)@]" - Hash.Protocol_hash.pp + Protocol_hash.pp protocol Time.pp_hum expiration @@ -207,9 +205,9 @@ let pp_test_network ppf = function @ Genesis: %a\ @ Net id: %a\ @ Expiration: %a@]" - Hash.Protocol_hash.pp protocol - Hash.Block_hash.pp genesis - Hash.Net_id.pp net_id + Protocol_hash.pp protocol + Block_hash.pp genesis + Net_id.pp net_id Time.pp_hum expiration let test_network_encoding = diff --git a/src/node/db/jbuild b/src/node/db/jbuild index eed488e8d..891d1377a 100644 --- a/src/node/db/jbuild +++ b/src/node/db/jbuild @@ -3,11 +3,13 @@ (library ((name node_db) (public_name tezos.node.db) - (libraries (utils minutils irmin-leveldb)) + (libraries (tezos-base leveldb irmin-leveldb)) (flags (:standard -w -9+27-30-32-40@8 -safe-string - -open Error_monad - -open Hash - -open Utils - -open Tezos_data)) + -open Tezos_base__TzPervasives)) (wrapped false))) + +(alias + ((name runtest_indent) + (deps ((glob_files *.ml) (glob_files *.mli))) + (action (run bash ${libexec:tezos-stdlib:test-ocp-indent.sh} ${<})))) diff --git a/src/node/db/raw_store.ml b/src/node/db/raw_store.ml index 25925f8c4..3e8ac8d0e 100644 --- a/src/node/db/raw_store.ml +++ b/src/node/db/raw_store.ml @@ -44,7 +44,7 @@ let known t key = Lwt.return (LevelDB.mem t (concat key)) let read_opt t key = - Lwt.return (map_option ~f:MBytes.of_string (LevelDB.get t (concat key))) + Lwt.return (Option.map ~f:MBytes.of_string (LevelDB.get t (concat key))) let read t key = match LevelDB.get t (concat key) with diff --git a/src/node/db/store.mli b/src/node/db/store.mli index a3cf2e93d..5673d458b 100644 --- a/src/node/db/store.mli +++ b/src/node/db/store.mli @@ -8,7 +8,6 @@ (**************************************************************************) open Store_sigs -open Tezos_data type t type global_store = t diff --git a/src/node/db/store_helpers.ml b/src/node/db/store_helpers.ml index a34f27493..8a5be045b 100644 --- a/src/node/db/store_helpers.ml +++ b/src/node/db/store_helpers.ml @@ -57,7 +57,7 @@ module Make_substore (S : STORE) (N : NAME) type value = MBytes.t let name_length = List.length N.name let to_key k = N.name @ k - let of_key k = Utils.remove_elem_from_list name_length k + let of_key k = List.remove name_length k let known t k = S.known t (to_key k) let known_dir t k = S.known_dir t (to_key k) let read t k = S.read t (to_key k) @@ -86,7 +86,7 @@ module Make_indexed_substore (S : STORE) (I : INDEX) = struct let to_key i k = assert (List.length (I.to_path i []) = I.path_length) ; I.to_path i k - let of_key k = Utils.remove_elem_from_list I.path_length k + let of_key k = List.remove I.path_length k let known (t,i) k = S.known t (to_key i k) let known_dir (t,i) k = S.known_dir t (to_key i k) let read (t,i) k = S.read t (to_key i k) @@ -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 ~prefix:d (List.hd (List.rev prefix)) with + match String.remove_prefix ~prefix:d (List.hd (List.rev prefix)) with | None -> Lwt.return_nil | Some _ -> loop (i+1) prefix []) prefixes diff --git a/src/node/main/jbuild b/src/node/main/jbuild index ba54b73c9..38cc003fe 100644 --- a/src/node/main/jbuild +++ b/src/node/main/jbuild @@ -3,11 +3,13 @@ (library ((name node_main_lib) (public_name tezos.node.main) - (libraries (utils minutils cmdliner node_net node_shell)) + (libraries (tezos-base cmdliner node_net node_shell)) (flags (:standard -w -9+27-30-32-40@8 -safe-string - -open Error_monad - -open Hash - -open Utils - -open Tezos_data)) + -open Tezos_base__TzPervasives)) (wrapped false))) + +(alias + ((name runtest_indent) + (deps ((glob_files *.ml) (glob_files *.mli))) + (action (run bash ${libexec:tezos-stdlib:test-ocp-indent.sh} ${<})))) diff --git a/src/node/main/node_config_file.ml b/src/node/main/node_config_file.ml index df6ea183a..378caa55f 100644 --- a/src/node/main/node_config_file.ml +++ b/src/node/main/node_config_file.ml @@ -333,70 +333,69 @@ let update ?rpc_tls ?log_output ?bootstrap_threshold - cfg = - let data_dir = Utils.unopt ~default:cfg.data_dir data_dir in + cfg = let data_dir = Option.unopt ~default:cfg.data_dir data_dir in Node_data_version.ensure_data_dir data_dir >>=? fun () -> let peer_table_size = - map_option peer_table_size ~f:(fun i -> i, i / 4 * 3) in + Option.map peer_table_size ~f:(fun i -> i, i / 4 * 3) in let unopt_list ~default = function | [] -> default | l -> l in let limits : P2p.limits = { cfg.net.limits with min_connections = - Utils.unopt + Option.unopt ~default:cfg.net.limits.min_connections min_connections ; expected_connections = - Utils.unopt + Option.unopt ~default:cfg.net.limits.expected_connections expected_connections ; max_connections = - Utils.unopt + Option.unopt ~default:cfg.net.limits.max_connections max_connections ; max_download_speed = - Utils.first_some + Option.first_some max_download_speed cfg.net.limits.max_download_speed ; max_upload_speed = - Utils.first_some + Option.first_some max_upload_speed cfg.net.limits.max_upload_speed ; max_known_points = - Utils.first_some + Option.first_some peer_table_size cfg.net.limits.max_known_points ; max_known_peer_ids = - Utils.first_some + Option.first_some peer_table_size cfg.net.limits.max_known_peer_ids ; binary_chunks_size = - Utils.map_option ~f:(fun x -> x lsl 10) binary_chunks_size ; + Option.map ~f:(fun x -> x lsl 10) binary_chunks_size ; } in let net : net = { expected_pow = - Utils.unopt ~default:cfg.net.expected_pow expected_pow ; + Option.unopt ~default:cfg.net.expected_pow expected_pow ; bootstrap_peers = - Utils.unopt ~default:cfg.net.bootstrap_peers bootstrap_peers ; + Option.unopt ~default:cfg.net.bootstrap_peers bootstrap_peers ; listen_addr = - Utils.first_some listen_addr cfg.net.listen_addr ; + Option.first_some listen_addr cfg.net.listen_addr ; closed = cfg.net.closed || closed ; limits ; } and rpc : rpc = { listen_addr = - Utils.first_some rpc_listen_addr cfg.rpc.listen_addr ; + Option.first_some rpc_listen_addr cfg.rpc.listen_addr ; cors_origins = unopt_list ~default:cfg.rpc.cors_origins cors_origins ; cors_headers = unopt_list ~default:cfg.rpc.cors_headers cors_headers ; tls = - Utils.first_some rpc_tls cfg.rpc.tls ; + Option.first_some rpc_tls cfg.rpc.tls ; } and log : log = { cfg.log with - output = Utils.unopt ~default:cfg.log.output log_output ; + output = Option.unopt ~default:cfg.log.output log_output ; } and shell : shell = { bootstrap_threshold = - Utils.unopt + Option.unopt ~default:cfg.shell.bootstrap_threshold bootstrap_threshold ; timeout = cfg.shell.timeout ; @@ -405,7 +404,7 @@ let update return { data_dir ; net ; rpc ; log ; shell } let resolve_addr ?default_port ?(passive = false) peer = - let addr, port = Utils.parse_addr_port peer in + let addr, port = P2p.Point.parse_addr_port peer in let node = if addr = "" || addr = "_" then "::" else addr and service = match port, default_port with diff --git a/src/node/main/node_data_version.ml b/src/node/main/node_data_version.ml index b3db44e12..ffb229f65 100644 --- a/src/node/main/node_data_version.ml +++ b/src/node/main/node_data_version.ml @@ -7,8 +7,6 @@ (* *) (**************************************************************************) -open Error_monad - type t = string let data_version = "0.0.1" diff --git a/src/node/main/node_run_command.ml b/src/node/main/node_run_command.ml index bbc686429..27897595f 100644 --- a/src/node/main/node_run_command.ml +++ b/src/node/main/node_run_command.ml @@ -60,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 ~f:Lwt_log_core.load_rules rules + Option.iter ~f:Lwt_log_core.load_rules rules end ; Logging.init ~template:log_config.template log_config.output @@ -191,7 +191,7 @@ let init_signal () = let run ?verbosity ?sandbox (config : Node_config_file.t) = Node_data_version.ensure_data_dir config.data_dir >>=? fun () -> - Lwt_utils.Lock_file.create + Lwt_lock_file.create ~unlink_on_exit:true (lock_file config.data_dir) >>=? fun () -> init_signal () ; init_logger ?verbosity config.log >>= fun () -> @@ -228,7 +228,7 @@ let process sandbox verbosity args = else return () | None -> return () end >>=? fun () -> - Lwt_utils.Lock_file.is_locked + Lwt_lock_file.is_locked (lock_file config.data_dir) >>=? function | false -> run ?sandbox ?verbosity config diff --git a/src/node/main/node_shared_arg.ml b/src/node/main/node_shared_arg.ml index 371c128e8..c7dbd48f4 100644 --- a/src/node/main/node_shared_arg.ml +++ b/src/node/main/node_shared_arg.ml @@ -44,13 +44,13 @@ let wrap cors_origins cors_headers log_output = let actual_data_dir = - Utils.unopt ~default:Node_config_file.default_data_dir data_dir in + Option.unopt ~default:Node_config_file.default_data_dir data_dir in let config_file = - Utils.unopt ~default:(actual_data_dir // "config.json") config_file in + Option.unopt ~default:(actual_data_dir // "config.json") config_file in let rpc_tls = - Utils.map_option + Option.map ~f:(fun (cert, key) -> { Node_config_file.cert ; key }) rpc_tls in diff --git a/src/minutils/RPC.ml b/src/node/net/RPC.ml similarity index 94% rename from src/minutils/RPC.ml rename to src/node/net/RPC.ml index 4f07981d2..3005b3771 100644 --- a/src/minutils/RPC.ml +++ b/src/node/net/RPC.ml @@ -12,7 +12,8 @@ module Data = struct type schema = Data_encoding.json_schema let unit = Data_encoding.empty let schema = Data_encoding.Json.schema - module StringMap = Map.Make(String) + + module StringMap = Resto.StringMap let arg_encoding = let open Data_encoding in @@ -71,17 +72,17 @@ module Data = struct let static_subdirectories_descr_encoding = union [ case ~tag:0 (obj1 (req "suffixes" - (list (obj2 (req "name" string) - (req "tree" directory_descr_encoding))))) + (list (obj2 (req "name" string) + (req "tree" directory_descr_encoding))))) (function Suffixes map -> Some (StringMap.bindings map) | _ -> None) (fun m -> let add acc (n,t) = StringMap.add n t acc in Suffixes (List.fold_left add StringMap.empty m)) ; case ~tag:1 (obj1 (req "dynamic_dispatch" - (obj2 - (req "arg" arg_encoding) - (req "tree" directory_descr_encoding)))) + (obj2 + (req "arg" arg_encoding) + (req "tree" directory_descr_encoding)))) (function Arg (ty, tree) -> Some (ty, tree) | _ -> None) (fun (ty, tree) -> Arg (ty, tree)) ] in diff --git a/src/minutils/RPC.mli b/src/node/net/RPC.mli similarity index 99% rename from src/minutils/RPC.mli rename to src/node/net/RPC.mli index 48fcecfba..8cca91fef 100644 --- a/src/minutils/RPC.mli +++ b/src/node/net/RPC.mli @@ -9,7 +9,6 @@ (** Typed RPC services: definition, binding and dispatch. *) - module Data : Resto.ENCODING with type 'a t = 'a Data_encoding.t and type schema = Data_encoding.json_schema diff --git a/src/node/net/jbuild b/src/node/net/jbuild index 58507278f..67de6ee4d 100644 --- a/src/node/net/jbuild +++ b/src/node/net/jbuild @@ -3,11 +3,15 @@ (library ((name node_net) (public_name tezos.node.net) - (libraries (utils minutils lwt.unix ocplib-resto-cohttp)) + (libraries (tezos-base + mtime.clock.os + ocplib-resto-cohttp)) (flags (:standard -w -9+27-30-32-40@8 -safe-string - -open Error_monad - -open Hash - -open Utils - -open Tezos_data)) + -open Tezos_base__TzPervasives)) (wrapped false))) + +(alias + ((name runtest_indent) + (deps ((glob_files *.ml) (glob_files *.mli))) + (action (run bash ${libexec:tezos-stdlib:test-ocp-indent.sh} ${<})))) diff --git a/src/utils/moving_average.ml b/src/node/net/moving_average.ml similarity index 100% rename from src/utils/moving_average.ml rename to src/node/net/moving_average.ml diff --git a/src/utils/moving_average.mli b/src/node/net/moving_average.mli similarity index 100% rename from src/utils/moving_average.mli rename to src/node/net/moving_average.mli diff --git a/src/node/net/p2p.ml b/src/node/net/p2p.ml index 25cbe5672..588f527f4 100644 --- a/src/node/net/p2p.ml +++ b/src/node/net/p2p.ml @@ -74,9 +74,9 @@ type limits = { let create_scheduler limits = let max_upload_speed = - map_option limits.max_upload_speed ~f:(( * ) 1024) in + Option.map limits.max_upload_speed ~f:(( * ) 1024) in let max_download_speed = - map_option limits.max_upload_speed ~f:(( * ) 1024) in + Option.map limits.max_upload_speed ~f:(( * ) 1024) in P2p_io_scheduler.create ~read_buffer_size:limits.read_buffer_size ?max_upload_speed @@ -472,7 +472,7 @@ module RPC = struct let watch net = match net.pool with - | None -> Watcher.create_fake_stream () + | None -> Lwt_watcher.create_fake_stream () | Some pool -> P2p_connection_pool.watch pool let connect net point timeout = @@ -486,7 +486,7 @@ module RPC = struct match net.pool with | None -> None | Some pool -> - map_option + Option.map (P2p_connection_pool.Connection.find_by_peer_id pool peer_id) ~f:P2p_connection_pool.Connection.info @@ -632,8 +632,7 @@ module RPC = struct let info net point = match net.pool with | None -> None - | Some pool -> - map_option + | Some pool -> Option.map (P2p_connection_pool.Points.info pool point) ~f:info_of_point_info @@ -643,14 +642,14 @@ module RPC = struct match net.pool with | None -> [] | Some pool -> - unopt_map + Option.unopt_map (P2p_connection_pool.Points.info pool point) ~default:[] ~f:begin fun pi -> let evts = P2p_connection_pool_types.Point_info.fold_events pi ~init:[] ~f:(fun a e -> e :: a) in - (if rev then list_rev_sub else list_sub) evts max + (if rev then List.rev_sub else List.sub) evts max end let watch net point = @@ -790,13 +789,13 @@ module RPC = struct match net.pool with | None -> [] | Some pool -> - unopt_map + Option.unopt_map (P2p_connection_pool.Peer_ids.info pool peer_id) ~default:[] ~f:begin fun gi -> let evts = P2p_connection_pool_types.Peer_info.fold_events gi ~init:[] ~f:(fun a e -> e :: a) in - (if rev then list_rev_sub else list_sub) evts max + (if rev then List.rev_sub else List.sub) evts max end let watch net peer_id = diff --git a/src/node/net/p2p.mli b/src/node/net/p2p.mli index f95eb41f6..a2f963d73 100644 --- a/src/node/net/p2p.mli +++ b/src/node/net/p2p.mli @@ -211,7 +211,7 @@ module RPC : sig module Event = P2p_connection_pool.Log_event - val watch : ('msg, 'meta) net -> Event.t Lwt_stream.t * Watcher.stopper + val watch : ('msg, 'meta) net -> Event.t Lwt_stream.t * Lwt_watcher.stopper val connect : ('msg, 'meta) net -> Point.t -> float -> unit tzresult Lwt.t module Connection : sig @@ -256,7 +256,7 @@ module RPC : sig val events : ?max:int -> ?rev:bool -> ('msg, 'meta) net -> Point.t -> Event.t list val watch : - ('msg, 'meta) net -> Point.t -> Event.t Lwt_stream.t * Watcher.stopper + ('msg, 'meta) net -> Point.t -> Event.t Lwt_stream.t * Lwt_watcher.stopper end module Peer_id : sig @@ -294,7 +294,7 @@ module RPC : sig val events : ?max:int -> ?rev:bool -> ('msg, 'meta) net -> Peer_id.t -> Event.t list val watch : - ('msg, 'meta) net -> Peer_id.t -> Event.t Lwt_stream.t * Watcher.stopper + ('msg, 'meta) net -> Peer_id.t -> Event.t Lwt_stream.t * Lwt_watcher.stopper end diff --git a/src/node/net/p2p_connection.ml b/src/node/net/p2p_connection.ml index d07c3b2c6..afec47d5f 100644 --- a/src/node/net/p2p_connection.ml +++ b/src/node/net/p2p_connection.ml @@ -231,7 +231,7 @@ let next_conn_id = module Reader = struct type 'msg t = { - canceler: Canceler.t ; + canceler: Lwt_canceler.t ; conn: connection ; encoding: 'msg Data_encoding.t ; messages: (int * 'msg) tzresult Lwt_pipe.t ; @@ -278,7 +278,7 @@ module Reader = struct | Ok Some rem_mbytes -> worker_loop st rem_mbytes | Ok None -> - Canceler.cancel st.canceler >>= fun () -> + Lwt_canceler.cancel st.canceler >>= fun () -> Lwt.return_unit | Error [Lwt_utils.Canceled | Exn Lwt_pipe.Closed] -> lwt_debug "connection closed to %a" @@ -286,7 +286,7 @@ module Reader = struct Lwt.return_unit | Error _ as err -> Lwt_pipe.safe_push_now st.messages err ; - Canceler.cancel st.canceler >>= fun () -> + Lwt_canceler.cancel st.canceler >>= fun () -> Lwt.return_unit let run ?size conn encoding canceler = @@ -294,24 +294,24 @@ module Reader = struct | Ok (size, _) -> (Sys.word_size / 8) * 11 + size + Lwt_pipe.push_overhead | Error _ -> 0 (* we push Error only when we close the socket, we don't fear memory leaks in that case... *) in - let size = map_option size ~f:(fun max -> (max, compute_size)) in + let size = Option.map size ~f:(fun max -> (max, compute_size)) in let st = { canceler ; conn ; encoding ; messages = Lwt_pipe.create ?size () ; worker = Lwt.return_unit ; } in - Canceler.on_cancel st.canceler begin fun () -> + Lwt_canceler.on_cancel st.canceler begin fun () -> Lwt_pipe.close st.messages ; Lwt.return_unit end ; st.worker <- Lwt_utils.worker "reader" ~run:(fun () -> worker_loop st []) - ~cancel:(fun () -> Canceler.cancel st.canceler) ; + ~cancel:(fun () -> Lwt_canceler.cancel st.canceler) ; st let shutdown st = - Canceler.cancel st.canceler >>= fun () -> + Lwt_canceler.cancel st.canceler >>= fun () -> st.worker end @@ -319,7 +319,7 @@ end module Writer = struct type 'msg t = { - canceler: Canceler.t ; + canceler: Lwt_canceler.t ; conn: connection ; encoding: 'msg Data_encoding.t ; messages: (MBytes.t list * unit tzresult Lwt.u option) Lwt_pipe.t ; @@ -356,16 +356,16 @@ module Writer = struct lwt_log_error "@[error writing to %a@ %a@]" Connection_info.pp st.conn.info pp_print_error err >>= fun () -> - Canceler.cancel st.canceler >>= fun () -> + Lwt_canceler.cancel st.canceler >>= fun () -> Lwt.return_unit | Ok (buf, wakener) -> send_message st buf >>= fun res -> match res with | Ok () -> - iter_option wakener ~f:(fun u -> Lwt.wakeup_later u res) ; + Option.iter wakener ~f:(fun u -> Lwt.wakeup_later u res) ; worker_loop st | Error err -> - iter_option wakener + Option.iter wakener ~f:(fun u -> Lwt.wakeup_later u (Error [P2p_io_scheduler.Connection_closed])) ; @@ -377,14 +377,14 @@ module Writer = struct | [ P2p_io_scheduler.Connection_closed ] -> lwt_debug "connection closed to %a" Connection_info.pp st.conn.info >>= fun () -> - Canceler.cancel st.canceler >>= fun () -> + Lwt_canceler.cancel st.canceler >>= fun () -> Lwt.return_unit | err -> lwt_log_error "@[error writing to %a@ %a@]" Connection_info.pp st.conn.info pp_print_error err >>= fun () -> - Canceler.cancel st.canceler >>= fun () -> + Lwt_canceler.cancel st.canceler >>= fun () -> Lwt.return_unit let run @@ -411,18 +411,18 @@ module Writer = struct | buf_l, Some _ -> 2 * Sys.word_size + buf_list_size buf_l + Lwt_pipe.push_overhead in - let size = map_option size ~f:(fun max -> max, compute_size) in + let size = Option.map size ~f:(fun max -> max, compute_size) in let st = { canceler ; conn ; encoding ; messages = Lwt_pipe.create ?size () ; worker = Lwt.return_unit ; binary_chunks_size = binary_chunks_size ; } in - Canceler.on_cancel st.canceler begin fun () -> + Lwt_canceler.on_cancel st.canceler begin fun () -> Lwt_pipe.close st.messages ; while not (Lwt_pipe.is_empty st.messages) do let _, w = Lwt_pipe.pop_now_exn st.messages in - iter_option w + Option.iter w ~f:(fun u -> Lwt.wakeup_later u (Error [Exn Lwt_pipe.Closed])) done ; Lwt.return_unit @@ -430,11 +430,11 @@ module Writer = struct st.worker <- Lwt_utils.worker "writer" ~run:(fun () -> worker_loop st) - ~cancel:(fun () -> Canceler.cancel st.canceler) ; + ~cancel:(fun () -> Lwt_canceler.cancel st.canceler) ; st let shutdown st = - Canceler.cancel st.canceler >>= fun () -> + Lwt_canceler.cancel st.canceler >>= fun () -> st.worker end @@ -464,7 +464,7 @@ let accept | err -> Lwt.return (Error err) end >>=? fun accepted -> fail_unless accepted Rejected >>=? fun () -> - let canceler = Canceler.create () in + let canceler = Lwt_canceler.create () in let conn = { id = next_conn_id () ; fd ; info ; cryptobox_data } in let reader = Reader.run ?size:incoming_message_queue_size conn encoding canceler @@ -474,7 +474,7 @@ let accept conn encoding canceler in let conn = { conn ; reader ; writer } in - Canceler.on_cancel canceler begin fun () -> + Lwt_canceler.on_cancel canceler begin fun () -> P2p_io_scheduler.close fd >>= fun _ -> Lwt.return_unit end ; diff --git a/src/node/net/p2p_connection_pool.ml b/src/node/net/p2p_connection_pool.ml index 61d8e9684..f1f40558e 100644 --- a/src/node/net/p2p_connection_pool.ml +++ b/src/node/net/p2p_connection_pool.ml @@ -82,7 +82,7 @@ module Answerer = struct } type 'msg t = { - canceler: Canceler.t ; + canceler: Lwt_canceler.t ; conn: 'msg Message.t P2p_connection.t ; callback: 'msg callback ; mutable worker: unit Lwt.t ; @@ -103,7 +103,7 @@ module Answerer = struct (* if not sent then ?? TODO count dropped message ?? *) worker_loop st | Error _ -> - Canceler.cancel st.canceler >>= fun () -> + Lwt_canceler.cancel st.canceler >>= fun () -> Lwt.return_unit end | Ok (_, Advertise points) -> @@ -119,18 +119,18 @@ module Answerer = struct st.callback.message size msg >>= fun () -> worker_loop st | Ok (_, Disconnect) | Error [P2p_io_scheduler.Connection_closed] -> - Canceler.cancel st.canceler >>= fun () -> + Lwt_canceler.cancel st.canceler >>= fun () -> Lwt.return_unit | Error [P2p_connection.Decoding_error] -> (* TODO: Penalize peer... *) - Canceler.cancel st.canceler >>= fun () -> + Lwt_canceler.cancel st.canceler >>= fun () -> Lwt.return_unit | Error [Lwt_utils.Canceled] -> Lwt.return_unit | Error err -> lwt_log_error "@[Answerer unexpected error:@ %a@]" Error_monad.pp_print_error err >>= fun () -> - Canceler.cancel st.canceler >>= fun () -> + Lwt_canceler.cancel st.canceler >>= fun () -> Lwt.return_unit let run conn canceler callback = @@ -141,11 +141,11 @@ module Answerer = struct st.worker <- Lwt_utils.worker "answerer" ~run:(fun () -> worker_loop st) - ~cancel:(fun () -> Canceler.cancel canceler) ; + ~cancel:(fun () -> Lwt_canceler.cancel canceler) ; st let shutdown st = - Canceler.cancel st.canceler >>= fun () -> + Lwt_canceler.cancel st.canceler >>= fun () -> st.worker end @@ -356,11 +356,11 @@ type ('msg, 'meta) t = { (('msg, 'meta) connection, 'meta) Peer_info.t Peer_id.Table.t ; known_points : ('msg, 'meta) connection Point_info.t Point.Table.t ; connected_points : ('msg, 'meta) connection Point_info.t Point.Table.t ; - incoming : Canceler.t Point.Table.t ; + incoming : Lwt_canceler.t Point.Table.t ; io_sched : P2p_io_scheduler.t ; encoding : 'msg Message.t Data_encoding.t ; events : events ; - watcher : Log_event.t Watcher.input ; + watcher : Log_event.t Lwt_watcher.input ; mutable new_connection_hook : (Peer_id.t -> ('msg, 'meta) connection -> unit) list ; mutable latest_accepted_swap : Time.t ; @@ -375,7 +375,7 @@ and events = { } and ('msg, 'meta) connection = { - canceler : Canceler.t ; + canceler : Lwt_canceler.t ; messages : (int * 'msg) Lwt_pipe.t ; conn : 'msg Message.t P2p_connection.t ; peer_info : (('msg, 'meta) connection, 'meta) Peer_info.t ; @@ -398,10 +398,10 @@ module Pool_event = struct Lwt_condition.wait pool.events.new_connection end -let watch { watcher } = Watcher.create_stream watcher -let log { watcher } event = Watcher.notify watcher event +let watch { watcher } = Lwt_watcher.create_stream watcher +let log { watcher } event = Lwt_watcher.notify watcher event -module GcPointSet = Utils.Bounded(struct +module GcPointSet = List.Bounded(struct type t = Time.t * Point.t let compare (x, _) (y, _) = - (Time.compare x y) end) @@ -430,7 +430,7 @@ let register_point pool ?trusted _source_peer_id (addr, port as point) = match Point.Table.find pool.known_points point with | exception Not_found -> let point_info = Point_info.create ?trusted addr port in - iter_option pool.config.max_known_points ~f:begin fun (max, _) -> + Option.iter pool.config.max_known_points ~f:begin fun (max, _) -> if Point.Table.length pool.known_points >= max then gc_points pool end ; Point.Table.add pool.known_points point point_info ; @@ -452,7 +452,7 @@ let may_register_my_id_point pool = function case of a flood attack, the newly added infos will probably belong to peer_ids with the same (low) score and removing the most recent ones ensure that older (and probably legit) peer_id infos are kept. *) -module GcPeer_idSet = Utils.Bounded(struct +module GcPeer_idSet = List.Bounded(struct type t = float * Time.t * Peer_id.t let compare (s, t, _) (s', t', _) = let score_cmp = Pervasives.compare s s' in @@ -482,7 +482,7 @@ let register_peer pool peer_id = | exception Not_found -> Lwt_condition.broadcast pool.events.new_peer () ; let peer = Peer_info.create peer_id ~metadata:pool.meta_config.initial in - iter_option pool.config.max_known_peer_ids ~f:begin fun (max, _) -> + Option.iter pool.config.max_known_peer_ids ~f:begin fun (max, _) -> if Peer_id.Table.length pool.known_peer_ids >= max then gc_peer_ids pool end ; Peer_id.Table.add pool.known_peer_ids peer_id peer ; @@ -658,7 +658,7 @@ module Connection = struct P2p_connection.info conn let find_by_peer_id pool peer_id = - apply_option + Option.apply (Peer_ids.info pool peer_id) ~f:(fun p -> match Peer_info.State.get p with @@ -666,7 +666,7 @@ module Connection = struct | _ -> None) let find_by_point pool point = - apply_option + Option.apply (Points.info pool point) ~f:(fun p -> match Point_info.State.get p with @@ -725,7 +725,7 @@ let rec connect ~timeout pool point = fail_unless (active_connections pool <= pool.config.max_connections) Too_many_connections >>=? fun () -> - let canceler = Canceler.create () in + let canceler = Lwt_canceler.create () in Lwt_utils.with_timeout ~canceler timeout begin fun canceler -> let point_info = register_point pool pool.config.identity.peer_id point in @@ -787,7 +787,7 @@ and authenticate pool ?point_info canceler fd point = if incoming then Point.Table.remove pool.incoming point else - iter_option ~f:Point_info.State.set_disconnected point_info ; + Option.iter ~f:Point_info.State.set_disconnected point_info ; Lwt.return (Error err) end >>=? fun (info, auth_fd) -> (* Authentication correct! *) @@ -809,7 +809,7 @@ and authenticate pool ?point_info canceler fd point = Version.common info.versions pool.message_config.versions in let acceptable_point = - unopt_map connection_point_info + Option.unopt_map connection_point_info ~default:(not pool.config.closed_network) ~f:begin fun connection_point_info -> match Point_info.State.get connection_point_info with @@ -833,7 +833,7 @@ and authenticate pool ?point_info canceler fd point = match acceptable_versions with | Some version when acceptable_peer_id && acceptable_point -> begin log pool (Accepting_request (point, info.id_point, info.peer_id)) ; - iter_option connection_point_info + Option.iter connection_point_info ~f:(fun point_info -> Point_info.State.set_accepted point_info info.peer_id canceler) ; Peer_info.State.set_accepted peer_info info.id_point canceler ; @@ -857,13 +857,13 @@ and authenticate pool ?point_info canceler fd point = lwt_debug "authenticate: %a -> rejected %a" Point.pp point Connection_info.pp info >>= fun () -> - iter_option connection_point_info + Option.iter connection_point_info ~f:Point_info.State.set_disconnected ; Peer_info.State.set_disconnected peer_info ; Lwt.return (Error err) end >>=? fun conn -> let id_point = - match info.id_point, map_option ~f:Point_info.point point_info with + match info.id_point, Option.map ~f:Point_info.point point_info with | (addr, _), Some (_, port) -> addr, Some port | id_point, None -> id_point in return @@ -879,7 +879,7 @@ and authenticate pool ?point_info canceler fd point = acceptable_point acceptable_peer_id >>= fun () -> P2p_connection.kick auth_fd >>= fun () -> if not incoming then begin - iter_option ~f:Point_info.State.set_disconnected point_info ; + Option.iter ~f:Point_info.State.set_disconnected point_info ; (* FIXME Peer_info.State.set_disconnected ~requested:true peer_info ; *) end ; fail (Rejected info.peer_id) @@ -887,9 +887,9 @@ and authenticate pool ?point_info canceler fd point = and create_connection pool p2p_conn id_point point_info peer_info _version = let peer_id = Peer_info.peer_id peer_info in - let canceler = Canceler.create () in + let canceler = Lwt_canceler.create () in let size = - map_option pool.config.incoming_app_message_queue_size + Option.map pool.config.incoming_app_message_queue_size ~f:(fun qs -> qs, fun (size, _) -> (Sys.word_size / 8) * 11 + size + Lwt_pipe.push_overhead) in let messages = Lwt_pipe.create ?size () in @@ -911,7 +911,7 @@ and create_connection pool p2p_conn id_point point_info peer_info _version = messages ; canceler ; answerer ; wait_close = false ; last_sent_swap_request = None } in ignore (Lazy.force answerer) ; - iter_option point_info ~f:begin fun point_info -> + Option.iter point_info ~f:begin fun point_info -> let point = Point_info.point point_info in Point_info.State.set_running point_info peer_id conn ; Point.Table.add pool.connected_points point point_info ; @@ -920,13 +920,13 @@ and create_connection pool p2p_conn id_point point_info peer_info _version = Peer_info.State.set_running peer_info id_point conn ; Peer_id.Table.add pool.connected_peer_ids peer_id peer_info ; Lwt_condition.broadcast pool.events.new_connection () ; - Canceler.on_cancel canceler begin fun () -> + Lwt_canceler.on_cancel canceler begin fun () -> lwt_debug "Disconnect: %a (%a)" Peer_id.pp peer_id Id_point.pp id_point >>= fun () -> - iter_option ~f:Point_info.State.set_disconnected point_info ; + Option.iter ~f:Point_info.State.set_disconnected point_info ; log pool (Disconnection peer_id) ; Peer_info.State.set_disconnected peer_info ; - iter_option point_info ~f:begin fun point_info -> + Option.iter point_info ~f:begin fun point_info -> Point.Table.remove pool.connected_points (Point_info.point point_info) ; end ; Peer_id.Table.remove pool.connected_peer_ids peer_id ; @@ -964,7 +964,7 @@ and list_known_points pool _conn () = (fun _ point_info acc -> point_info :: acc) pool.known_points [] in let best_knowns = - Utils.take_n ~compare:compare_known_point_info 50 knowns in + List.take_n ~compare:compare_known_point_info 50 knowns in Lwt.return (List.map Point_info.point best_knowns) and active_connections pool = Peer_id.Table.length pool.connected_peer_ids @@ -1053,7 +1053,7 @@ let accept pool fd point = || pool.config.max_connections <= active_connections pool then Lwt.async (fun () -> Lwt_utils.safe_close fd) else - let canceler = Canceler.create () in + let canceler = Lwt_canceler.create () in Point.Table.add pool.incoming point canceler ; Lwt.async begin fun () -> Lwt_utils.with_timeout @@ -1095,7 +1095,7 @@ let create config meta_config message_config io_sched = io_sched ; encoding = Message.encoding message_config.encoding ; events ; - watcher = Watcher.create_input () ; + watcher = Lwt_watcher.create_input () ; new_connection_hook = [] ; latest_accepted_swap = Time.epoch ; latest_succesfull_swap = Time.epoch ; @@ -1118,7 +1118,7 @@ let destroy pool = Point.Table.fold (fun _point point_info acc -> match Point_info.State.get point_info with | Requested { cancel } | Accepted { cancel } -> - Canceler.cancel cancel >>= fun () -> acc + Lwt_canceler.cancel cancel >>= fun () -> acc | Running { data = conn } -> disconnect conn >>= fun () -> acc | Disconnected -> acc) @@ -1126,13 +1126,13 @@ let destroy pool = Peer_id.Table.fold (fun _peer_id peer_info acc -> match Peer_info.State.get peer_info with | Accepted { cancel } -> - Canceler.cancel cancel >>= fun () -> acc + Lwt_canceler.cancel cancel >>= fun () -> acc | Running { data = conn } -> disconnect conn >>= fun () -> acc | Disconnected -> acc) pool.known_peer_ids @@ Point.Table.fold (fun _point canceler acc -> - Canceler.cancel canceler >>= fun () -> acc) + Lwt_canceler.cancel canceler >>= fun () -> acc) pool.incoming Lwt.return_unit let on_new_connection pool f = diff --git a/src/node/net/p2p_connection_pool.mli b/src/node/net/p2p_connection_pool.mli index 0abcfc13a..1d9fb3dff 100644 --- a/src/node/net/p2p_connection_pool.mli +++ b/src/node/net/p2p_connection_pool.mli @@ -394,7 +394,7 @@ module Log_event : sig end -val watch: ('msg, 'meta) pool -> Log_event.t Lwt_stream.t * Watcher.stopper +val watch: ('msg, 'meta) pool -> Log_event.t Lwt_stream.t * Lwt_watcher.stopper (** [watch pool] is a [stream, close] a [stream] of events and a [close] function for this stream. *) diff --git a/src/node/net/p2p_connection_pool_types.ml b/src/node/net/p2p_connection_pool_types.ml index 5fd608356..6fc74991b 100644 --- a/src/node/net/p2p_connection_pool_types.ml +++ b/src/node/net/p2p_connection_pool_types.ml @@ -12,9 +12,9 @@ open P2p_types module Point_info = struct type 'data state = - | Requested of { cancel: Canceler.t } + | Requested of { cancel: Lwt_canceler.t } | Accepted of { current_peer_id: Peer_id.t ; - cancel: Canceler.t } + cancel: Lwt_canceler.t } | Running of { data: 'data ; current_peer_id: Peer_id.t } | Disconnected @@ -99,7 +99,7 @@ module Point_info = struct mutable greylisting_delay : float ; mutable greylisting_end : Time.t ; events : Event.t Ring.t ; - watchers : Event.t Watcher.input ; + watchers : Event.t Lwt_watcher.input ; } type 'data point_info = 'data t @@ -127,7 +127,7 @@ module Point_info = struct greylisting = greylisting_config ; greylisting_delay = 1. ; greylisting_end = Time.epoch ; - watchers = Watcher.create_input () ; + watchers = Lwt_watcher.create_input () ; } let point s = s.point @@ -155,7 +155,7 @@ module Point_info = struct let last_miss s = match s.last_failed_connection, - (map_option ~f:(fun (_, time) -> time) @@ + (Option.map ~f:(fun (_, time) -> time) @@ recent s.last_rejected_connection s.last_disconnection) with | (None, None) -> None | (None, (Some _ as a)) @@ -165,12 +165,12 @@ module Point_info = struct let fold_events { events } ~init ~f = Ring.fold events ~init ~f - let watch { watchers } = Watcher.create_stream watchers + let watch { watchers } = Lwt_watcher.create_stream watchers let log { events ; watchers } ?(timestamp = Time.now ()) kind = let event = { Event.kind ; timestamp } in Ring.add events event ; - Watcher.notify watchers event + Lwt_watcher.notify watchers event let log_incoming_rejection ?timestamp point_info peer_id = log point_info ?timestamp (Rejecting_request peer_id) @@ -178,9 +178,9 @@ module Point_info = struct module State = struct type 'data t = 'data state = - | Requested of { cancel: Canceler.t } + | Requested of { cancel: Lwt_canceler.t } | Accepted of { current_peer_id: Peer_id.t ; - cancel: Canceler.t } + cancel: Lwt_canceler.t } | Running of { data: 'data ; current_peer_id: Peer_id.t } | Disconnected @@ -284,7 +284,7 @@ module Peer_info = struct type 'data state = | Accepted of { current_point: Id_point.t ; - cancel: Canceler.t } + cancel: Lwt_canceler.t } | Running of { data: 'data ; current_point: Id_point.t } | Disconnected @@ -341,7 +341,7 @@ module Peer_info = struct mutable last_established_connection : (Id_point.t * Time.t) option ; mutable last_disconnection : (Id_point.t * Time.t) option ; events : Event.t Ring.t ; - watchers : Event.t Watcher.input ; + watchers : Event.t Lwt_watcher.input ; } type ('conn, 'meta) peer_info = ('conn, 'meta) t @@ -360,7 +360,7 @@ module Peer_info = struct last_established_connection = None ; last_disconnection = None ; events = Ring.create log_size ; - watchers = Watcher.create_input () ; + watchers = Lwt_watcher.create_input () ; } let encoding metadata_encoding = @@ -385,7 +385,7 @@ module Peer_info = struct last_established_connection ; last_disconnection ; events ; - watchers = Watcher.create_input () ; + watchers = Lwt_watcher.create_input () ; }) (obj9 (req "peer_id" Peer_id.encoding) @@ -429,9 +429,9 @@ module Peer_info = struct let log { events ; watchers } ?(timestamp = Time.now ()) point kind = let event = { Event.kind ; timestamp ; point } in Ring.add events event ; - Watcher.notify watchers event + Lwt_watcher.notify watchers event - let watch { watchers } = Watcher.create_stream watchers + let watch { watchers } = Lwt_watcher.create_stream watchers let log_incoming_rejection ?timestamp peer_info point = log peer_info ?timestamp point Rejecting_request @@ -440,7 +440,7 @@ module Peer_info = struct type 'data t = 'data state = | Accepted of { current_point: Id_point.t ; - cancel: Canceler.t } + cancel: Lwt_canceler.t } | Running of { data: 'data ; current_point: Id_point.t } | Disconnected diff --git a/src/node/net/p2p_connection_pool_types.mli b/src/node/net/p2p_connection_pool_types.mli index 97d55570c..489bc69de 100644 --- a/src/node/net/p2p_connection_pool_types.mli +++ b/src/node/net/p2p_connection_pool_types.mli @@ -75,10 +75,10 @@ module Point_info : sig module State : sig type 'conn t = - | Requested of { cancel: Canceler.t } + | Requested of { cancel: Lwt_canceler.t } (** We initiated a connection. *) | Accepted of { current_peer_id: Peer_id.t ; - cancel: Canceler.t } + cancel: Lwt_canceler.t } (** We accepted a incoming connection. *) | Running of { data: 'conn ; current_peer_id: Peer_id.t } @@ -95,11 +95,11 @@ module Point_info : sig val set_requested : ?timestamp:Time.t -> - 'conn point_info -> Canceler.t -> unit + 'conn point_info -> Lwt_canceler.t -> unit val set_accepted : ?timestamp:Time.t -> - 'conn point_info -> Peer_id.t -> Canceler.t -> unit + 'conn point_info -> Peer_id.t -> Lwt_canceler.t -> unit val set_running : ?timestamp:Time.t -> 'conn point_info -> Peer_id.t -> 'conn -> unit @@ -140,7 +140,7 @@ module Point_info : sig 'conn point_info -> init:'a -> f:('a -> Event.t -> 'a) -> 'a val watch : - 'conn point_info -> Event.t Lwt_stream.t * Watcher.stopper + 'conn point_info -> Event.t Lwt_stream.t * Lwt_watcher.stopper val log_incoming_rejection : ?timestamp:Time.t -> 'conn point_info -> Peer_id.t -> unit @@ -206,7 +206,7 @@ module Peer_info : sig type 'conn t = | Accepted of { current_point: Id_point.t ; - cancel: Canceler.t } + cancel: Lwt_canceler.t } (** We accepted a incoming connection, we greeted back and we are waiting for an acknowledgement. *) | Running of { data: 'conn ; @@ -224,7 +224,7 @@ module Peer_info : sig val set_accepted : ?timestamp:Time.t -> - ('conn, 'meta) peer_info -> Id_point.t -> Canceler.t -> unit + ('conn, 'meta) peer_info -> Id_point.t -> Lwt_canceler.t -> unit val set_running : ?timestamp:Time.t -> @@ -266,7 +266,7 @@ module Peer_info : sig ('conn, 'meta) peer_info -> init:'a -> f:('a -> Event.t -> 'a) -> 'a val watch : - ('conn, 'meta) peer_info -> Event.t Lwt_stream.t * Watcher.stopper + ('conn, 'meta) peer_info -> Event.t Lwt_stream.t * Lwt_watcher.stopper val log_incoming_rejection : ?timestamp:Time.t -> diff --git a/src/node/net/p2p_io_scheduler.ml b/src/node/net/p2p_io_scheduler.ml index 604c51f02..93bdb6f9a 100644 --- a/src/node/net/p2p_io_scheduler.ml +++ b/src/node/net/p2p_io_scheduler.ml @@ -34,7 +34,7 @@ type error += Connection_closed module Scheduler(IO : IO) = struct type t = { - canceler: Canceler.t ; + canceler: Lwt_canceler.t ; mutable worker: unit Lwt.t ; counter: Moving_average.t ; max_speed: int option ; @@ -48,7 +48,7 @@ module Scheduler(IO : IO) = struct and connection = { id: int ; mutable closed: bool ; - canceler: Canceler.t ; + canceler: Lwt_canceler.t ; in_param: IO.in_param ; out_param: IO.out_param ; mutable current_pop: MBytes.t tzresult Lwt.t ; @@ -65,7 +65,7 @@ module Scheduler(IO : IO) = struct Lwt.catch (fun () -> IO.close conn.out_param err) (fun _ -> Lwt.return_unit) >>= fun () -> - Canceler.cancel conn.canceler + Lwt_canceler.cancel conn.canceler end let waiter st conn = @@ -100,10 +100,10 @@ module Scheduler(IO : IO) = struct check_quota st >>= fun () -> lwt_debug "scheduler.wait(%s)" IO.name >>= fun () -> Lwt.pick [ - Canceler.cancelation st.canceler ; + Lwt_canceler.cancelation st.canceler ; wait_data st ] >>= fun () -> - if Canceler.canceled st.canceler then + if Lwt_canceler.canceled st.canceler then Lwt.return_unit else let prio, (conn, msg) = @@ -160,10 +160,10 @@ module Scheduler(IO : IO) = struct let create max_speed = let st = { - canceler = Canceler.create () ; + canceler = Lwt_canceler.create () ; worker = Lwt.return_unit ; counter = Moving_average.create ~init:0 ~alpha ; - max_speed ; quota = unopt ~default:0 max_speed ; + max_speed ; quota = Option.unopt ~default:0 max_speed ; quota_updated = Lwt_condition.create () ; readys = Lwt_condition.create () ; readys_high = Queue.create () ; @@ -172,7 +172,7 @@ module Scheduler(IO : IO) = struct st.worker <- Lwt_utils.worker IO.name ~run:(fun () -> worker_loop st) - ~cancel:(fun () -> Canceler.cancel st.canceler) ; + ~cancel:(fun () -> Lwt_canceler.cancel st.canceler) ; st let create_connection st in_param out_param canceler id = @@ -191,7 +191,7 @@ module Scheduler(IO : IO) = struct let update_quota st = debug "scheduler(%s).update_quota" IO.name ; - iter_option st.max_speed ~f:begin fun quota -> + Option.iter st.max_speed ~f:begin fun quota -> st.quota <- (min st.quota 0) + quota ; Lwt_condition.broadcast st.quota_updated () end ; @@ -210,7 +210,7 @@ module Scheduler(IO : IO) = struct let shutdown st = lwt_debug "--> scheduler(%s).shutdown" IO.name >>= fun () -> - Canceler.cancel st.canceler >>= fun () -> + Lwt_canceler.cancel st.canceler >>= fun () -> st.worker >>= fun () -> lwt_debug "<-- scheduler(%s).shutdown" IO.name >>= fun () -> Lwt.return_unit @@ -273,7 +273,7 @@ type connection = { id: int ; sched: t ; conn: Lwt_unix.file_descr ; - canceler: Canceler.t ; + canceler: Lwt_canceler.t ; read_conn: ReadScheduler.connection ; read_queue: MBytes.t tzresult Lwt_pipe.t ; write_conn: WriteScheduler.connection ; @@ -354,11 +354,11 @@ let register = raise Closed end else begin let id = incr cpt; !cpt in - let canceler = Canceler.create () in + let canceler = Lwt_canceler.create () in let read_size = - map_option st.read_queue_size ~f:(fun v -> v, read_size) in + Option.map st.read_queue_size ~f:(fun v -> v, read_size) in let write_size = - map_option st.write_queue_size ~f:(fun v -> v, write_size) in + Option.map st.write_queue_size ~f:(fun v -> v, write_size) in let read_queue = Lwt_pipe.create ?size:read_size () in let write_queue = Lwt_pipe.create ?size:write_size () in let read_conn = @@ -367,7 +367,7 @@ let register = and write_conn = WriteScheduler.create_connection st.write_scheduler write_queue conn canceler id in - Canceler.on_cancel canceler begin fun () -> + Lwt_canceler.on_cancel canceler begin fun () -> Inttbl.remove st.connected id ; Moving_average.destroy read_conn.counter ; Moving_average.destroy write_conn.counter ; @@ -394,9 +394,9 @@ let write_now { write_queue } msg = Lwt_pipe.push_now write_queue msg let read_from conn ?pos ?len buf msg = let maxlen = MBytes.length buf in - let pos = unopt ~default:0 pos in + let pos = Option.unopt ~default:0 pos in assert (0 <= pos && pos < maxlen) ; - let len = unopt ~default:(maxlen - pos) len in + let len = Option.unopt ~default:(maxlen - pos) len in assert (len <= maxlen - pos) ; match msg with | Ok msg -> @@ -417,7 +417,7 @@ let read_now conn ?pos ?len buf = Some (read_from conn ?pos ?len buf (Ok msg)) | None -> try - map_option + Option.map ~f:(read_from conn ?pos ?len buf) (Lwt_pipe.pop_now conn.read_queue) with Lwt_pipe.Closed -> Some (Error [Connection_closed]) @@ -436,8 +436,8 @@ let read conn ?pos ?len buf = let read_full conn ?pos ?len buf = let maxlen = MBytes.length buf in - let pos = unopt ~default:0 pos in - let len = unopt ~default:(maxlen - pos) len in + let pos = Option.unopt ~default:0 pos in + let len = Option.unopt ~default:(maxlen - pos) len in assert (0 <= pos && pos < maxlen) ; assert (len <= maxlen - pos) ; let rec loop pos len = @@ -472,11 +472,11 @@ let close ?timeout conn = begin match timeout with | None -> - return (Canceler.cancelation conn.canceler) + return (Lwt_canceler.cancelation conn.canceler) | Some timeout -> Lwt_utils.with_timeout ~canceler:conn.canceler timeout begin fun canceler -> - return (Canceler.cancelation canceler) + return (Lwt_canceler.cancelation canceler) end end >>=? fun _ -> conn.write_conn.current_push >>= fun res -> diff --git a/src/node/net/p2p_maintenance.ml b/src/node/net/p2p_maintenance.ml index 3bdc8e192..088f835ad 100644 --- a/src/node/net/p2p_maintenance.ml +++ b/src/node/net/p2p_maintenance.ml @@ -22,7 +22,7 @@ type bounds = { type 'meta pool = Pool : ('msg, 'meta) P2p_connection_pool.t -> 'meta pool type 'meta t = { - canceler: Canceler.t ; + canceler: Lwt_canceler.t ; connection_timeout: float ; bounds: bounds ; pool: 'meta pool ; @@ -40,7 +40,7 @@ let connectable st start_time expected = let Pool pool = st.pool in let now = Time.now () in let module Bounded_point_info = - Utils.Bounded(struct + List.Bounded(struct type t = (Time.t option * Point.t) let compare (t1, _) (t2, _) = match t1, t2 with @@ -120,7 +120,7 @@ and too_few_connections st n_connected = end else begin (* not enough contacts, ask the pals of our pals, discover the local network and then wait *) - iter_option ~f:P2p_discovery.restart st.disco ; + Option.iter ~f:P2p_discovery.restart st.disco ; P2p_connection_pool.broadcast_bootstrap_msg pool ; Lwt_utils.protect ~canceler:st.canceler begin fun () -> Lwt.pick [ @@ -172,7 +172,7 @@ let rec worker_loop st = | Error _ -> Lwt.return_unit let run ~connection_timeout bounds pool disco = - let canceler = Canceler.create () in + let canceler = Lwt_canceler.create () in let st = { canceler ; connection_timeout ; @@ -186,7 +186,7 @@ let run ~connection_timeout bounds pool disco = st.maintain_worker <- Lwt_utils.worker "maintenance" ~run:(fun () -> worker_loop st) - ~cancel:(fun () -> Canceler.cancel canceler) ; + ~cancel:(fun () -> Lwt_canceler.cancel canceler) ; st let maintain { just_maintained ; please_maintain } = @@ -198,7 +198,7 @@ let shutdown { canceler ; maintain_worker ; just_maintained } = - Canceler.cancel canceler >>= fun () -> + Lwt_canceler.cancel canceler >>= fun () -> maintain_worker >>= fun () -> Lwt_condition.broadcast just_maintained () ; Lwt.return_unit diff --git a/src/node/net/p2p_types.ml b/src/node/net/p2p_types.ml index 7a80c3c9f..d658ac94c 100644 --- a/src/node/net/p2p_types.ml +++ b/src/node/net/p2p_types.ml @@ -7,8 +7,6 @@ (* *) (**************************************************************************) -module Canceler = Lwt_utils.Canceler - module Version = struct type t = { name : string ; @@ -150,8 +148,51 @@ module Point = struct let is_local (addr, _) = Ipaddr.V6.is_private addr let is_global (addr, _) = not @@ Ipaddr.V6.is_private addr + let check_port port = + if String.mem_char port '[' || + String.mem_char port ']' || + String.mem_char port ':' then + invalid_arg "Utils.parse_addr_port (invalid character in port)" + + let parse_addr_port s = + let len = String.length s in + if len = 0 then + ("", "") + else if s.[0] = '[' then begin (* inline IPv6 *) + match String.rindex s ']' with + | exception Not_found -> + invalid_arg "Utils.parse_addr_port (missing ']')" + | pos -> + let addr = String.sub s 1 (pos - 1) in + let port = + if pos = len - 1 then + "" + else if s.[pos+1] <> ':' then + invalid_arg "Utils.parse_addr_port (unexpected char after ']')" + else + String.sub s (pos + 2) (len - pos - 2) in + check_port port ; + addr, port + end else begin + match String.rindex s ']' with + | _pos -> + invalid_arg "Utils.parse_addr_port (unexpected char ']')" + | exception Not_found -> + match String.index s ':' with + | exception _ -> s, "" + | pos -> + match String.index_from s (pos+1) ':' with + | exception _ -> + let addr = String.sub s 0 pos in + let port = String.sub s (pos + 1) (len - pos - 1) in + check_port port ; + addr, port + | _pos -> + invalid_arg "Utils.parse_addr_port: IPv6 addresses must be bracketed" + end + let of_string_exn str = - let addr, port = Utils.parse_addr_port str in + let addr, port = parse_addr_port str in let port = int_of_string port in if port < 0 && port > 1 lsl 16 - 1 then invalid_arg "port must be between 0 and 65535" ; diff --git a/src/node/net/p2p_types.mli b/src/node/net/p2p_types.mli index 9fd66a5f8..101602c1d 100644 --- a/src/node/net/p2p_types.mli +++ b/src/node/net/p2p_types.mli @@ -7,8 +7,6 @@ (* *) (**************************************************************************) -module Canceler = Lwt_utils.Canceler - (** Protocol version *) module Version : sig @@ -27,7 +25,7 @@ end (** Peer_id, i.e. persistent peer identifier *) -module Peer_id : Hash.INTERNAL_HASH +module Peer_id : Tezos_crypto.S.INTERNAL_HASH with type t = Crypto_box.Public_key_hash.t type addr = Ipaddr.V6.t @@ -48,6 +46,7 @@ module Point : sig val encoding : t Data_encoding.t val is_local : t -> bool val is_global : t -> bool + val parse_addr_port : string -> string * string module Map : Map.S with type key = t module Set : Set.S with type elt = t module Table : Hashtbl.S with type key = t diff --git a/src/node/net/p2p_welcome.ml b/src/node/net/p2p_welcome.ml index 9d2e3b1ef..8a3c311d6 100644 --- a/src/node/net/p2p_welcome.ml +++ b/src/node/net/p2p_welcome.ml @@ -8,13 +8,12 @@ (**************************************************************************) include Logging.Make (struct let name = "p2p.welcome" end) -open P2p_types type pool = Pool : ('msg, 'meta) P2p_connection_pool.t -> pool type t = { socket: Lwt_unix.file_descr ; - canceler: Canceler.t ; + canceler: Lwt_canceler.t ; pool: pool ; mutable worker: unit Lwt.t ; } @@ -52,8 +51,8 @@ let run ~backlog pool ?addr port = Lwt.catch begin fun () -> create_listening_socket ~backlog ?addr port >>= fun socket -> - let canceler = Canceler.create () in - Canceler.on_cancel canceler begin fun () -> + let canceler = Lwt_canceler.create () in + Lwt_canceler.on_cancel canceler begin fun () -> Lwt_utils.safe_close socket end ; let st = { @@ -63,7 +62,7 @@ let run ~backlog pool ?addr port = st.worker <- Lwt_utils.worker "welcome" ~run:(fun () -> worker_loop st) - ~cancel:(fun () -> Canceler.cancel st.canceler) ; + ~cancel:(fun () -> Lwt_canceler.cancel st.canceler) ; Lwt.return st end begin fun exn -> lwt_log_error @@ -73,5 +72,5 @@ let run ~backlog pool ?addr port = end let shutdown st = - Canceler.cancel st.canceler >>= fun () -> + Lwt_canceler.cancel st.canceler >>= fun () -> st.worker diff --git a/src/node/shell/block_validator.ml b/src/node/shell/block_validator.ml index ae2f3266e..bdf7ade26 100644 --- a/src/node/shell/block_validator.ml +++ b/src/node/shell/block_validator.ml @@ -8,13 +8,12 @@ (**************************************************************************) include Logging.Make(struct let name = "node.validator.block" end) -module Canceler = Lwt_utils.Canceler type 'a request = | Request_validation: { net_db: Distributed_db.net_db ; notify_new_block: State.Block.t -> unit ; - canceler: Canceler.t option ; + canceler: Lwt_canceler.t option ; peer: P2p.Peer_id.t option ; hash: Block_hash.t ; header: Block_header.t ; @@ -28,7 +27,7 @@ type t = { protocol_timeout: float ; mutable worker: unit Lwt.t ; messages: message Lwt_pipe.t ; - canceler: Canceler.t ; + canceler: Lwt_canceler.t ; } (** Block validation *) @@ -533,30 +532,30 @@ let rec worker_loop bv = | Error err -> lwt_log_error "@[Unexpected error:@ %a@]" pp_print_error err >>= fun () -> - Canceler.cancel bv.canceler >>= fun () -> + Lwt_canceler.cancel bv.canceler >>= fun () -> Lwt.return_unit let create ~protocol_timeout db = let protocol_validator = Protocol_validator.create db in - let canceler = Canceler.create () in + let canceler = Lwt_canceler.create () in let messages = Lwt_pipe.create () in let bv = { protocol_validator ; protocol_timeout ; canceler ; messages ; worker = Lwt.return_unit } in - Canceler.on_cancel bv.canceler begin fun () -> + Lwt_canceler.on_cancel bv.canceler begin fun () -> Lwt_pipe.close bv.messages ; Lwt.return_unit end ; bv.worker <- Lwt_utils.worker "block_validator" ~run:(fun () -> worker_loop bv) - ~cancel:(fun () -> Canceler.cancel bv.canceler) ; + ~cancel:(fun () -> Lwt_canceler.cancel bv.canceler) ; bv let shutdown { canceler ; worker } = - Canceler.cancel canceler >>= fun () -> + Lwt_canceler.cancel canceler >>= fun () -> worker let validate { messages ; protocol_validator ; protocol_timeout } diff --git a/src/node/shell/block_validator.mli b/src/node/shell/block_validator.mli index 59bd297a1..7436d14b4 100644 --- a/src/node/shell/block_validator.mli +++ b/src/node/shell/block_validator.mli @@ -46,7 +46,7 @@ val create: val validate: t -> - ?canceler:Lwt_utils.Canceler.t -> + ?canceler:Lwt_canceler.t -> ?peer:P2p.Peer_id.t -> ?notify_new_block:(State.Block.t -> unit) -> Distributed_db.net_db -> diff --git a/src/node/shell/bootstrap_pipeline.ml b/src/node/shell/bootstrap_pipeline.ml index 0b58d75d7..1b4db50db 100644 --- a/src/node/shell/bootstrap_pipeline.ml +++ b/src/node/shell/bootstrap_pipeline.ml @@ -8,10 +8,9 @@ (**************************************************************************) include Logging.Make(struct let name = "node.validator.bootstrap_pipeline" end) -module Canceler = Lwt_utils.Canceler type t = { - canceler: Canceler.t ; + canceler: Lwt_canceler.t ; block_header_timeout: float ; block_operations_timeout: float ; mutable headers_fetch_worker: unit Lwt.t ; @@ -94,13 +93,13 @@ let headers_fetch_worker_loop pipeline = lwt_log_info "request for header %a from peer %a timed out." Block_hash.pp_short bh P2p.Peer_id.pp_short pipeline.peer_id >>= fun () -> - Canceler.cancel pipeline.canceler >>= fun () -> + Lwt_canceler.cancel pipeline.canceler >>= fun () -> Lwt.return_unit | Error err -> pipeline.errors <- pipeline.errors @ err ; lwt_log_error "@[Unexpected error (headers fetch):@ %a@]" pp_print_error err >>= fun () -> - Canceler.cancel pipeline.canceler >>= fun () -> + Lwt_canceler.cancel pipeline.canceler >>= fun () -> Lwt.return_unit let rec operations_fetch_worker_loop pipeline = @@ -138,13 +137,13 @@ let rec operations_fetch_worker_loop pipeline = lwt_log_info "request for operations %a:%d from peer %a timed out." Block_hash.pp_short bh n P2p.Peer_id.pp_short pipeline.peer_id >>= fun () -> - Canceler.cancel pipeline.canceler >>= fun () -> + Lwt_canceler.cancel pipeline.canceler >>= fun () -> Lwt.return_unit | Error err -> pipeline.errors <- pipeline.errors @ err ; lwt_log_error "@[Unexpected error (operations fetch):@ %a@]" pp_print_error err >>= fun () -> - Canceler.cancel pipeline.canceler >>= fun () -> + Lwt_canceler.cancel pipeline.canceler >>= fun () -> Lwt.return_unit let rec validation_worker_loop pipeline = @@ -175,20 +174,20 @@ let rec validation_worker_loop pipeline = | Block_validator.Unavailable_protocol _ ] as err ) -> (* Propagate the error to the peer validator. *) pipeline.errors <- pipeline.errors @ err ; - Canceler.cancel pipeline.canceler >>= fun () -> + Lwt_canceler.cancel pipeline.canceler >>= fun () -> Lwt.return_unit | Error err -> pipeline.errors <- pipeline.errors @ err ; lwt_log_error "@[Unexpected error (validator):@ %a@]" pp_print_error err >>= fun () -> - Canceler.cancel pipeline.canceler >>= fun () -> + Lwt_canceler.cancel pipeline.canceler >>= fun () -> Lwt.return_unit let create ?(notify_new_block = fun _ -> ()) ~block_header_timeout ~block_operations_timeout block_validator peer_id net_db locator = - let canceler = Canceler.create () in + let canceler = Lwt_canceler.create () in let fetched_headers = Lwt_pipe.create ~size:(50, fun _ -> 1) () in let fetched_blocks = @@ -205,7 +204,7 @@ let create fetched_headers ; fetched_blocks ; errors = [] ; } in - Canceler.on_cancel pipeline.canceler begin fun () -> + Lwt_canceler.on_cancel pipeline.canceler begin fun () -> Lwt_pipe.close fetched_blocks ; Lwt_pipe.close fetched_headers ; Lwt.return_unit @@ -217,19 +216,19 @@ let create (Format.asprintf "bootstrap_pipeline-headers_fetch.%a.%a" P2p.Peer_id.pp_short peer_id Block_hash.pp_short hash) ~run:(fun () -> headers_fetch_worker_loop pipeline) - ~cancel:(fun () -> Canceler.cancel pipeline.canceler) ; + ~cancel:(fun () -> Lwt_canceler.cancel pipeline.canceler) ; pipeline.operations_fetch_worker <- Lwt_utils.worker (Format.asprintf "bootstrap_pipeline-operations_fetch.%a.%a" P2p.Peer_id.pp_short peer_id Block_hash.pp_short hash) ~run:(fun () -> operations_fetch_worker_loop pipeline) - ~cancel:(fun () -> Canceler.cancel pipeline.canceler) ; + ~cancel:(fun () -> Lwt_canceler.cancel pipeline.canceler) ; pipeline.validation_worker <- Lwt_utils.worker (Format.asprintf "bootstrap_pipeline-validation.%a.%a" P2p.Peer_id.pp_short peer_id Block_hash.pp_short hash) ~run:(fun () -> validation_worker_loop pipeline) - ~cancel:(fun () -> Canceler.cancel pipeline.canceler) ; + ~cancel:(fun () -> Lwt_canceler.cancel pipeline.canceler) ; pipeline let wait_workers pipeline = @@ -245,5 +244,5 @@ let wait pipeline = | errors -> Lwt.return_error errors let cancel pipeline = - Canceler.cancel pipeline.canceler >>= fun () -> + Lwt_canceler.cancel pipeline.canceler >>= fun () -> wait_workers pipeline diff --git a/src/node/shell/distributed_db.ml b/src/node/shell/distributed_db.ml index 6723c7118..5ea27d853 100644 --- a/src/node/shell/distributed_db.ml +++ b/src/node/shell/distributed_db.ml @@ -100,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 ~f:State.Block.header b) + Lwt.return (Option.map ~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) @@ -304,8 +304,8 @@ type db = { disk: State.t ; active_nets: net_db Net_id.Table.t ; protocol_db: Raw_protocol.t ; - block_input: (Block_hash.t * Block_header.t) Watcher.input ; - operation_input: (Operation_hash.t * Operation.t) Watcher.input ; + block_input: (Block_hash.t * Block_header.t) Lwt_watcher.input ; + operation_input: (Operation_hash.t * Operation.t) Lwt_watcher.input ; } and net_db = { @@ -324,7 +324,7 @@ and p2p_reader = { gid: P2p.Peer_id.t ; conn: connection ; peer_active_nets: net_db Net_id.Table.t ; - canceler: Lwt_utils.Canceler.t ; + canceler: Lwt_canceler.t ; mutable worker: unit Lwt.t ; } @@ -644,7 +644,7 @@ module P2p_reader = struct Lwt.return_unit let run db gid conn = - let canceler = Lwt_utils.Canceler.create () in + let canceler = Lwt_canceler.create () in let state = { conn ; gid ; canceler ; peer_active_nets = Net_id.Table.create 17 ; @@ -660,11 +660,11 @@ module P2p_reader = struct (Format.asprintf "db_network_reader.%a" P2p.Peer_id.pp_short gid) ~run:(fun () -> worker_loop db state) - ~cancel:(fun () -> Lwt_utils.Canceler.cancel canceler) ; + ~cancel:(fun () -> Lwt_canceler.cancel canceler) ; P2p.Peer_id.Table.add db.p2p_readers gid state let shutdown s = - Lwt_utils.Canceler.cancel s.canceler >>= fun () -> + Lwt_canceler.cancel s.canceler >>= fun () -> s.worker end @@ -691,8 +691,8 @@ let create disk p2p = let protocol_db = Raw_protocol.create global_request disk in let active_nets = Net_id.Table.create 17 in let p2p_readers = P2p.Peer_id.Table.create 17 in - let block_input = Watcher.create_input () in - let operation_input = Watcher.create_input () in + let block_input = Lwt_watcher.create_input () in + let operation_input = Lwt_watcher.create_input () in let db = { p2p ; p2p_readers ; disk ; active_nets ; protocol_db ; @@ -809,9 +809,9 @@ let commit_protocol db h p = return (res <> None) let watch_block_header { block_input } = - Watcher.create_stream block_input + Lwt_watcher.create_stream block_input let watch_operation { operation_input } = - Watcher.create_stream operation_input + Lwt_watcher.create_stream operation_input module Raw = struct let encoding = P2p.Raw.encoding Message.cfg.encoding @@ -841,7 +841,7 @@ module type DISTRIBUTED_DB = sig key -> param -> unit type error += Canceled of key val clear_or_cancel: t -> key -> unit - val watch: t -> (key * value) Lwt_stream.t * Watcher.stopper + val watch: t -> (key * value) Lwt_stream.t * Lwt_watcher.stopper end module Make diff --git a/src/node/shell/distributed_db.mli b/src/node/shell/distributed_db.mli index 0bf1d35c3..0481ba55e 100644 --- a/src/node/shell/distributed_db.mli +++ b/src/node/shell/distributed_db.mli @@ -166,7 +166,7 @@ module type DISTRIBUTED_DB = sig (** Monitor all the fetched data. A given data will appear only once. *) - val watch: t -> (key * value) Lwt_stream.t * Watcher.stopper + val watch: t -> (key * value) Lwt_stream.t * Lwt_watcher.stopper end @@ -216,7 +216,7 @@ val commit_invalid_block: (** Monitor all the fetched block headers (for all activate networks). *) val watch_block_header: - t -> (Block_hash.t * Block_header.t) Lwt_stream.t * Watcher.stopper + t -> (Block_hash.t * Block_header.t) Lwt_stream.t * Lwt_watcher.stopper (** {2 Operations index} *) @@ -236,7 +236,7 @@ val inject_operation: (** Monitor all the fetched operations (for all activate networks). *) val watch_operation: - t -> (Operation_hash.t * Operation.t) Lwt_stream.t * Watcher.stopper + t -> (Operation_hash.t * Operation.t) Lwt_stream.t * Lwt_watcher.stopper (** {2 Protocol index} *) diff --git a/src/node/shell/distributed_db_functors.ml b/src/node/shell/distributed_db_functors.ml index 66ad441a4..73f02ae53 100644 --- a/src/node/shell/distributed_db_functors.ml +++ b/src/node/shell/distributed_db_functors.ml @@ -7,8 +7,6 @@ (* *) (**************************************************************************) -module Canceler = Lwt_utils.Canceler - module type DISTRIBUTED_DB = sig type t @@ -40,7 +38,7 @@ module type DISTRIBUTED_DB = sig val clear_or_cancel: t -> key -> unit val inject: t -> key -> value -> bool Lwt.t - val watch: t -> (key * value) Lwt_stream.t * Watcher.stopper + val watch: t -> (key * value) Lwt_stream.t * Lwt_watcher.stopper val pending: t -> key -> bool @@ -103,7 +101,7 @@ module Make_table and type value = Disk_table.value and type param = Precheck.param val create: - ?global_input:(key * value) Watcher.input -> + ?global_input:(key * value) Lwt_watcher.input -> Scheduler.t -> Disk_table.store -> t val notify: t -> P2p.Peer_id.t -> key -> Precheck.notified_value -> unit Lwt.t @@ -117,8 +115,8 @@ end = struct scheduler: Scheduler.t ; disk: Disk_table.store ; memory: status Memory_table.t ; - global_input: (key * value) Watcher.input option ; - input: (key * value) Watcher.input ; + global_input: (key * value) Lwt_watcher.input option ; + input: (key * value) Lwt_watcher.input ; } and status = @@ -257,9 +255,9 @@ end = struct Scheduler.notify s.scheduler p k ; Memory_table.replace s.memory k (Found v) ; Lwt.wakeup_later w (Ok v) ; - iter_option s.global_input - ~f:(fun input -> Watcher.notify input (k, v)) ; - Watcher.notify s.input (k, v) ; + Option.iter s.global_input + ~f:(fun input -> Lwt_watcher.notify input (k, v)) ; + Lwt_watcher.notify s.input (k, v) ; Lwt.return_unit end | Found _ -> @@ -289,11 +287,11 @@ end = struct Lwt.wakeup_later w (Error [Canceled k]) | Found _ -> Memory_table.remove s.memory k - let watch s = Watcher.create_stream s.input + let watch s = Lwt_watcher.create_stream s.input let create ?global_input scheduler disk = let memory = Memory_table.create 17 in - let input = Watcher.create_input () in + let input = Lwt_watcher.create_input () in { scheduler ; disk ; memory ; input ; global_input } let pending s k = @@ -339,7 +337,7 @@ end = struct queue: event Lwt_pipe.t ; mutable events: event list Lwt.t ; - canceler: Canceler.t ; + canceler: Lwt_canceler.t ; mutable worker: unit Lwt.t ; } @@ -464,7 +462,7 @@ end = struct Lwt.return_unit let rec worker_loop state = - let shutdown = Canceler.cancelation state.canceler + let shutdown = Lwt_canceler.cancelation state.canceler and timeout = compute_timeout state in Lwt.choose [ (state.events >|= fun _ -> ()) ; timeout ; shutdown ] >>= fun () -> @@ -523,17 +521,17 @@ end = struct queue = Lwt_pipe.create () ; pending = Table.create 17 ; events = Lwt.return [] ; - canceler = Canceler.create () ; + canceler = Lwt_canceler.create () ; worker = Lwt.return_unit ; } in state.worker <- Lwt_utils.worker "db_request_scheduler" ~run:(fun () -> worker_loop state) - ~cancel:(fun () -> Canceler.cancel state.canceler) ; + ~cancel:(fun () -> Lwt_canceler.cancel state.canceler) ; state let shutdown s = - Canceler.cancel s.canceler >>= fun () -> + Lwt_canceler.cancel s.canceler >>= fun () -> s.worker end diff --git a/src/node/shell/distributed_db_functors.mli b/src/node/shell/distributed_db_functors.mli index 612d3e030..ed05dcd24 100644 --- a/src/node/shell/distributed_db_functors.mli +++ b/src/node/shell/distributed_db_functors.mli @@ -41,7 +41,7 @@ module type DISTRIBUTED_DB = sig val clear_or_cancel: t -> key -> unit val inject: t -> key -> value -> bool Lwt.t - val watch: t -> (key * value) Lwt_stream.t * Watcher.stopper + val watch: t -> (key * value) Lwt_stream.t * Lwt_watcher.stopper val pending: t -> key -> bool @@ -105,7 +105,7 @@ module Make_table and type value = Disk_table.value and type param = Precheck.param val create: - ?global_input:(key * value) Watcher.input -> + ?global_input:(key * value) Lwt_watcher.input -> Scheduler.t -> Disk_table.store -> t val notify: t -> P2p.Peer_id.t -> key -> Precheck.notified_value -> unit Lwt.t diff --git a/src/node/shell/jbuild b/src/node/shell/jbuild index 72e107a4a..c7c13a7cb 100644 --- a/src/node/shell/jbuild +++ b/src/node/shell/jbuild @@ -3,11 +3,13 @@ (library ((name node_shell) (public_name tezos.node.shell) - (libraries (node_net node_db node_updater)) + (libraries (tezos-base node_net node_db node_updater)) (flags (:standard -w -9+27-30-32-40@8 -safe-string - -open Error_monad - -open Hash - -open Utils - -open Tezos_data)) + -open Tezos_base__TzPervasives)) (wrapped false))) + +(alias + ((name runtest_indent) + (deps ((glob_files *.ml) (glob_files *.mli))) + (action (run bash ${libexec:tezos-stdlib:test-ocp-indent.sh} ${<})))) diff --git a/src/node/shell/net_validator.ml b/src/node/shell/net_validator.ml index ef285db8b..03c13d287 100644 --- a/src/node/shell/net_validator.ml +++ b/src/node/shell/net_validator.ml @@ -8,7 +8,6 @@ (**************************************************************************) include Logging.Make(struct let name = "node.validator.net" end) -module Canceler = Lwt_utils.Canceler type t = { @@ -21,9 +20,9 @@ type t = { bootstrap_threshold: int ; mutable bootstrapped: bool ; bootstrapped_wakener: unit Lwt.u ; - valid_block_input: State.Block.t Watcher.input ; - global_valid_block_input: State.Block.t Watcher.input ; - new_head_input: State.Block.t Watcher.input ; + valid_block_input: State.Block.t Lwt_watcher.input ; + global_valid_block_input: State.Block.t Lwt_watcher.input ; + new_head_input: State.Block.t Lwt_watcher.input ; parent: t option ; max_child_ttl: int option ; @@ -35,7 +34,7 @@ type t = { mutable worker: unit Lwt.t ; queue: State.Block.t Lwt_pipe.t ; - canceler: Canceler.t ; + canceler: Lwt_canceler.t ; } @@ -49,7 +48,7 @@ and timeout = { let rec shutdown nv = - Canceler.cancel nv.canceler >>= fun () -> + Lwt_canceler.cancel nv.canceler >>= fun () -> Distributed_db.deactivate nv.net_db >>= fun () -> Lwt.join ( nv.worker :: @@ -64,10 +63,10 @@ let shutdown_child nv = Lwt_utils.may ~f:shutdown nv.child let notify_new_block nv block = - iter_option nv.parent - ~f:(fun nv -> Watcher.notify nv.valid_block_input block) ; - Watcher.notify nv.valid_block_input block ; - Watcher.notify nv.global_valid_block_input block ; + Option.iter nv.parent + ~f:(fun nv -> Lwt_watcher.notify nv.valid_block_input block) ; + Lwt_watcher.notify nv.valid_block_input block ; + Lwt_watcher.notify nv.global_valid_block_input block ; assert (Lwt_pipe.push_now nv.queue block) let may_toggle_bootstrapped_network nv = @@ -128,9 +127,9 @@ let rec create Prevalidator.create ~max_operations:2000 (* FIXME temporary constant *) ~operation_timeout:timeout.operation net_db >>= fun prevalidator -> - let valid_block_input = Watcher.create_input () in - let new_head_input = Watcher.create_input () in - let canceler = Canceler.create () in + let valid_block_input = Lwt_watcher.create_input () in + let new_head_input = Lwt_watcher.create_input () in + let canceler = Lwt_canceler.create () in let _, bootstrapped_wakener = Lwt.wait () in let nv = { db ; net_state ; net_db ; block_validator ; @@ -180,7 +179,7 @@ let rec create Lwt_utils.worker (Format.asprintf "net_validator.%a" Net_id.pp (State.Net.id net_state)) ~run:(fun () -> worker_loop nv) - ~cancel:(fun () -> Canceler.cancel nv.canceler) ; + ~cancel:(fun () -> Lwt_canceler.cancel nv.canceler) ; Lwt.return nv (** Current block computation *) @@ -208,7 +207,7 @@ and worker_loop nv = broadcast_head nv ~previous block >>= fun () -> Prevalidator.flush nv.prevalidator block ; (* FIXME *) may_switch_test_network nv block >>= fun () -> - Watcher.notify nv.new_head_input block ; + Lwt_watcher.notify nv.new_head_input block ; lwt_log_notice "update current head %a %a %a(%t)" Block_hash.pp_short block_hash Fitness.pp block_header.shell.fitness @@ -228,7 +227,7 @@ and worker_loop nv = | Error err -> lwt_log_error "@[Unexpected error:@ %a@]" pp_print_error err >>= fun () -> - Canceler.cancel nv.canceler >>= fun () -> + Lwt_canceler.cancel nv.canceler >>= fun () -> Lwt.return_unit and may_switch_test_network nv block = @@ -245,8 +244,8 @@ and may_switch_test_network nv block = State.fork_testnet genesis protocol expiration >>=? fun net_state -> Chain.head net_state >>= fun new_genesis_block -> - Watcher.notify nv.global_valid_block_input new_genesis_block ; - Watcher.notify nv.valid_block_input new_genesis_block ; + Lwt_watcher.notify nv.global_valid_block_input new_genesis_block ; + Lwt_watcher.notify nv.valid_block_input new_genesis_block ; return net_state end >>=? fun net_state -> create @@ -341,7 +340,7 @@ let bootstrapped { bootstrapped_wakener } = Lwt.protected (Lwt.waiter_of_wakener bootstrapped_wakener) let valid_block_watcher { valid_block_input } = - Watcher.create_stream valid_block_input + Lwt_watcher.create_stream valid_block_input let new_head_watcher { new_head_input } = - Watcher.create_stream new_head_input + Lwt_watcher.create_stream new_head_input diff --git a/src/node/shell/net_validator.mli b/src/node/shell/net_validator.mli index ffc9a424e..a25c9fa04 100644 --- a/src/node/shell/net_validator.mli +++ b/src/node/shell/net_validator.mli @@ -22,7 +22,7 @@ val create: ?bootstrap_threshold:int -> timeout -> Block_validator.t -> - State.Block.t Watcher.input -> + State.Block.t Lwt_watcher.input -> Distributed_db.t -> State.Net.t -> t Lwt.t @@ -43,6 +43,6 @@ val validate_block: val shutdown: t -> unit Lwt.t -val valid_block_watcher: t -> State.Block.t Lwt_stream.t * Watcher.stopper -val new_head_watcher: t -> State.Block.t Lwt_stream.t * Watcher.stopper +val valid_block_watcher: t -> State.Block.t Lwt_stream.t * Lwt_watcher.stopper +val new_head_watcher: t -> State.Block.t Lwt_stream.t * Lwt_watcher.stopper diff --git a/src/node/shell/node.ml b/src/node/shell/node.ml index bc57ae52c..aa3373379 100644 --- a/src/node/shell/node.ml +++ b/src/node/shell/node.ml @@ -621,12 +621,12 @@ module RPC = struct end else begin Lwt.pick [ ( Lwt_stream.get block_stream >|= - map_option ~f:(fun b -> + Option.map ~f:(fun b -> (State.Block.hash b, (State.Block.header b).shell.timestamp)) ) ; (Net_validator.bootstrapped node.mainnet_validator >|= fun () -> None) ; ] end in - let shutdown () = Watcher.shutdown stopper in + let shutdown () = Lwt_watcher.shutdown stopper in RPC.Answer.{ next ; shutdown } module Network = struct diff --git a/src/node/shell/node.mli b/src/node/shell/node.mli index 9fa4a90e0..eb504d335 100644 --- a/src/node/shell/node.mli +++ b/src/node/shell/node.mli @@ -53,9 +53,9 @@ module RPC : sig val raw_block_info: t -> Block_hash.t -> block_info Lwt.t val block_header_watcher: - t -> (Block_hash.t * Block_header.t) Lwt_stream.t * Watcher.stopper + t -> (Block_hash.t * Block_header.t) Lwt_stream.t * Lwt_watcher.stopper val block_watcher: - t -> (block_info Lwt_stream.t * Watcher.stopper) + t -> (block_info Lwt_stream.t * Lwt_watcher.stopper) val heads: t -> block_info Block_hash.Map.t Lwt.t val predecessors: @@ -75,7 +75,7 @@ module RPC : sig val operations: t -> block -> Operation.t list list Lwt.t val operation_watcher: - t -> (Operation_hash.t * Operation.t) Lwt_stream.t * Watcher.stopper + t -> (Operation_hash.t * Operation.t) Lwt_stream.t * Lwt_watcher.stopper val pending_operations: t -> block -> (error Prevalidation.preapply_result * Operation.t Operation_hash.Map.t) Lwt.t @@ -85,7 +85,7 @@ module RPC : sig val protocol_content: t -> Protocol_hash.t -> Protocol.t tzresult Lwt.t val protocol_watcher: - t -> (Protocol_hash.t * Protocol.t) Lwt_stream.t * Watcher.stopper + t -> (Protocol_hash.t * Protocol.t) Lwt_stream.t * Lwt_watcher.stopper val context_dir: t -> block -> 'a RPC.directory option Lwt.t @@ -108,7 +108,7 @@ module RPC : sig module Network : sig val stat : t -> P2p.Stat.t - val watch : t -> P2p.RPC.Event.t Lwt_stream.t * Watcher.stopper + val watch : t -> P2p.RPC.Event.t Lwt_stream.t * Lwt_watcher.stopper val connect : t -> P2p.Point.t -> float -> unit tzresult Lwt.t module Connection : sig @@ -124,7 +124,7 @@ module RPC : sig val info : t -> P2p.Peer_id.t -> P2p.RPC.Peer_id.info option val events : t -> P2p.Peer_id.t -> P2p.RPC.Peer_id.Event.t list val watch : t -> P2p.Peer_id.t -> - P2p.RPC.Peer_id.Event.t Lwt_stream.t * Watcher.stopper + P2p.RPC.Peer_id.Event.t Lwt_stream.t * Lwt_watcher.stopper end module Point : sig @@ -133,7 +133,7 @@ module RPC : sig val info : t -> P2p.Point.t -> P2p.RPC.Point.info option val events : t -> P2p.Point.t -> P2p.RPC.Point.Event.t list val watch : t -> P2p.Point.t -> - P2p.RPC.Point.Event.t Lwt_stream.t * Watcher.stopper + P2p.RPC.Point.Event.t Lwt_stream.t * Lwt_watcher.stopper end end diff --git a/src/node/shell/node_rpc.ml b/src/node/shell/node_rpc.ml index 1107ceb3e..d2120e96a 100644 --- a/src/node/shell/node_rpc.ml +++ b/src/node/shell/node_rpc.ml @@ -7,7 +7,6 @@ (* *) (**************************************************************************) -open Utils open Logging.RPC module Services = Node_rpc_services @@ -18,7 +17,7 @@ let filter_bi operations (bi: Services.Blocks.block_info) = let monitor_operations node contents = let stream, stopper = Node.RPC.operation_watcher node in - let shutdown () = Watcher.shutdown stopper in + let shutdown () = Lwt_watcher.shutdown stopper in let first_request = ref true in let next () = if not !first_request then @@ -315,7 +314,7 @@ let list_blocks let filtering = heads <> None in create_delayed_stream ~filtering ~include_ops requested_heads bi_stream delay in - let shutdown () = Watcher.shutdown stopper in + let shutdown () = Lwt_watcher.shutdown stopper in let first_request = ref true in let next () = if not !first_request then begin @@ -350,7 +349,7 @@ let list_protocols node {Services.Protocols.monitor; contents} = RPC.Answer.return protocols else let stream, stopper = Node.RPC.protocol_watcher node in - let shutdown () = Watcher.shutdown stopper in + let shutdown () = Lwt_watcher.shutdown stopper in let first_request = ref true in let next () = if not !first_request then @@ -453,7 +452,7 @@ let build_rpc_directory node = let dir = let implementation () = let stream, stopper = Node.RPC.Network.watch node in - let shutdown () = Watcher.shutdown stopper in + let shutdown () = Lwt_watcher.shutdown stopper in let next () = Lwt_stream.get stream in RPC.Answer.return_stream { next ; shutdown } in RPC.register0 dir Services.Network.events implementation in @@ -491,11 +490,11 @@ let build_rpc_directory node = let implementation peer_id monitor = if monitor then let stream, stopper = Node.RPC.Network.Peer_id.watch node peer_id in - let shutdown () = Watcher.shutdown stopper in + let shutdown () = Lwt_watcher.shutdown stopper in let first_request = ref true in let next () = if not !first_request then begin - Lwt_stream.get stream >|= map_option ~f:(fun i -> [i]) + Lwt_stream.get stream >|= Option.map ~f:(fun i -> [i]) end else begin first_request := false ; Lwt.return_some @@ Node.RPC.Network.Peer_id.events node peer_id @@ -519,11 +518,11 @@ let build_rpc_directory node = let implementation point monitor = if monitor then let stream, stopper = Node.RPC.Network.Point.watch node point in - let shutdown () = Watcher.shutdown stopper in + let shutdown () = Lwt_watcher.shutdown stopper in let first_request = ref true in let next () = if not !first_request then begin - Lwt_stream.get stream >|= map_option ~f:(fun i -> [i]) + Lwt_stream.get stream >|= Option.map ~f:(fun i -> [i]) end else begin first_request := false ; Lwt.return_some @@ Node.RPC.Network.Point.events node point diff --git a/src/node/shell/node_rpc_services.ml b/src/node/shell/node_rpc_services.ml index 74f4574e8..13c52e582 100644 --- a/src/node/shell/node_rpc_services.ml +++ b/src/node/shell/node_rpc_services.ml @@ -109,7 +109,7 @@ module Blocks = struct let parse_block s = try - match Utils.split '~' s with + match String.split '~' s with | ["genesis"] -> Ok `Genesis | ["head"] -> Ok (`Head 0) | ["prevalidation"] -> Ok `Prevalidation diff --git a/src/node/shell/peer_validator.ml b/src/node/shell/peer_validator.ml index e3f495316..0f8015d09 100644 --- a/src/node/shell/peer_validator.ml +++ b/src/node/shell/peer_validator.ml @@ -10,7 +10,6 @@ (* FIXME ignore/postpone fetching/validating of block in the future... *) include Logging.Make(struct let name = "node.validator.peer" end) -module Canceler = Lwt_utils.Canceler type msg = | New_head of Block_hash.t * Block_header.t @@ -37,7 +36,7 @@ type t = { mutable worker: unit Lwt.t ; dropbox: msg Lwt_dropbox.t ; - canceler: Canceler.t ; + canceler: Lwt_canceler.t ; } @@ -198,7 +197,7 @@ let rec worker_loop pv = (* TODO ban the peer_id... *) lwt_log_info "Terminating the validation worker for peer %a (kickban)." P2p.Peer_id.pp_short pv.peer_id >>= fun () -> - Canceler.cancel pv.canceler >>= fun () -> + Lwt_canceler.cancel pv.canceler >>= fun () -> Lwt.return_unit | Error [Block_validator.Unavailable_protocol { protocol } ] -> begin Block_validator.fetch_and_compile_protocol @@ -213,7 +212,7 @@ let rec worker_loop pv = \ (missing protocol %a)." P2p.Peer_id.pp_short pv.peer_id Protocol_hash.pp_short protocol >>= fun () -> - Canceler.cancel pv.canceler >>= fun () -> + Lwt_canceler.cancel pv.canceler >>= fun () -> Lwt.return_unit end | Error [Exn Lwt.Canceled | Lwt_utils.Canceled | Exn Lwt_dropbox.Closed] -> @@ -226,7 +225,7 @@ let rec worker_loop pv = \ %a@]" P2p.Peer_id.pp_short pv.peer_id pp_print_error err >>= fun () -> - Canceler.cancel pv.canceler >>= fun () -> + Lwt_canceler.cancel pv.canceler >>= fun () -> Lwt.return_unit let create @@ -240,7 +239,7 @@ let create block_validator net_db peer_id = lwt_debug "creating validator for peer %a." P2p.Peer_id.pp_short peer_id >>= fun () -> - let canceler = Canceler.create () in + let canceler = Lwt_canceler.create () in let dropbox = Lwt_dropbox.create () in let net_state = Distributed_db.net_state net_db in State.Block.read_exn net_state @@ -265,7 +264,7 @@ let create dropbox ; worker = Lwt.return_unit ; } in - Canceler.on_cancel pv.canceler begin fun () -> + Lwt_canceler.on_cancel pv.canceler begin fun () -> Lwt_dropbox.close pv.dropbox ; Distributed_db.disconnect pv.net_db pv.peer_id >>= fun () -> notify_termination pv ; @@ -276,7 +275,7 @@ let create (Format.asprintf "peer_validator.%a.%a" Net_id.pp (State.Net.id net_state) P2p.Peer_id.pp_short peer_id) ~run:(fun () -> worker_loop pv) - ~cancel:(fun () -> Canceler.cancel pv.canceler) ; + ~cancel:(fun () -> Lwt_canceler.cancel pv.canceler) ; Lwt.return pv let notify_branch pv locator = @@ -298,7 +297,7 @@ let notify_head pv header = with Lwt_dropbox.Closed -> () let shutdown pv = - Canceler.cancel pv.canceler >>= fun () -> + Lwt_canceler.cancel pv.canceler >>= fun () -> pv.worker let peer_id pv = pv.peer_id diff --git a/src/node/shell/prevalidation.ml b/src/node/shell/prevalidation.ml index b31f39142..364d22cda 100644 --- a/src/node/shell/prevalidation.ml +++ b/src/node/shell/prevalidation.ml @@ -211,12 +211,12 @@ let prevalidate (h, op, Proto.parse_operation h op |> record_trace Parse_error)) ops in let invalid_ops = - Utils.filter_map + List.filter_map (fun (h, op, parsed_op) -> match parsed_op with | Ok _ -> None | Error err -> Some (h, op, err)) ops and parsed_ops = - Utils.filter_map + List.filter_map (fun (h, op, parsed_op) -> match parsed_op with | Ok parsed_op -> Some (h, op, parsed_op) | Error _ -> None) ops in diff --git a/src/node/shell/prevalidator.ml b/src/node/shell/prevalidator.ml index d869b1e01..1117cb271 100644 --- a/src/node/shell/prevalidator.ml +++ b/src/node/shell/prevalidator.ml @@ -32,7 +32,7 @@ let list_pendings ?maintain_net_db ~from_block ~to_block old_mempool = in let push_block mempool block = State.Block.all_operation_hashes block >|= fun operations -> - iter_option maintain_net_db + Option.iter maintain_net_db ~f:(fun net_db -> List.iter (List.iter (Distributed_db.Operation.clear_or_cancel net_db)) diff --git a/src/node/shell/protocol_validator.ml b/src/node/shell/protocol_validator.ml index fd2abb575..115bb0775 100644 --- a/src/node/shell/protocol_validator.ml +++ b/src/node/shell/protocol_validator.ml @@ -8,7 +8,6 @@ (**************************************************************************) include Logging.Make(struct let name = "node.validator.block" end) -module Canceler = Lwt_utils.Canceler type 'a request = | Request_validation: { @@ -22,7 +21,7 @@ type t = { db: Distributed_db.t ; mutable worker: unit Lwt.t ; messages: message Lwt_pipe.t ; - canceler: Canceler.t ; + canceler: Lwt_canceler.t ; } (** Block validation *) @@ -122,27 +121,27 @@ let rec worker_loop bv = | Error err -> lwt_log_error "@[Unexpected error (worker):@ %a@]" pp_print_error err >>= fun () -> - Canceler.cancel bv.canceler >>= fun () -> + Lwt_canceler.cancel bv.canceler >>= fun () -> Lwt.return_unit let create db = - let canceler = Canceler.create () in + let canceler = Lwt_canceler.create () in let messages = Lwt_pipe.create () in let bv = { canceler ; messages ; db ; worker = Lwt.return_unit } in - Canceler.on_cancel bv.canceler begin fun () -> + Lwt_canceler.on_cancel bv.canceler begin fun () -> Lwt_pipe.close bv.messages ; Lwt.return_unit end ; bv.worker <- Lwt_utils.worker "block_validator" ~run:(fun () -> worker_loop bv) - ~cancel:(fun () -> Canceler.cancel bv.canceler) ; + ~cancel:(fun () -> Lwt_canceler.cancel bv.canceler) ; bv let shutdown { canceler ; worker } = - Canceler.cancel canceler >>= fun () -> + Lwt_canceler.cancel canceler >>= fun () -> worker let validate { messages } hash protocol = diff --git a/src/node/shell/state.ml b/src/node/shell/state.ml index 8e1fce062..ef055801c 100644 --- a/src/node/shell/state.ml +++ b/src/node/shell/state.ml @@ -70,7 +70,7 @@ and net_state = { allow_forked_network: bool ; block_store: Store.Block.store Shared.t ; context_index: Context.index Shared.t ; - block_watcher: block Watcher.input ; + block_watcher: block Lwt_watcher.input ; chain_state: chain_state Shared.t ; } @@ -210,7 +210,7 @@ module Net = struct allow_forked_network ; block_store = Shared.create block_store ; context_index = Shared.create context_index ; - block_watcher = Watcher.create_input () ; + block_watcher = Lwt_watcher.create_input () ; } in Lwt.return net_state @@ -483,7 +483,7 @@ module Block = struct Store.Chain.Known_heads.store store hash end >>= fun () -> let block = { net_state ; hash ; contents } in - Watcher.notify net_state.block_watcher block ; + Lwt_watcher.notify net_state.block_watcher block ; return (Some block) end end @@ -504,7 +504,7 @@ module Block = struct end let watcher net_state = - Watcher.create_stream net_state.block_watcher + Lwt_watcher.create_stream net_state.block_watcher let operation_hashes { net_state ; hash ; contents } i = if i < 0 || contents.header.shell.validation_passes <= i then @@ -595,6 +595,8 @@ let fork_testnet block protocol expiration = module Protocol = struct + include Protocol + let known global_state hash = Shared.use global_state.protocol_store begin fun store -> Store.Protocol.Contents.known store hash @@ -708,13 +710,13 @@ module Register_embedded_protocol (Proto : Env.Updater.PROTOCOL) (Source : sig val hash: Protocol_hash.t option - val sources: Tezos_data.Protocol.t + val sources: Protocol.t end) = struct let () = let hash = match Source.hash with - | None -> Tezos_data.Protocol.hash Source.sources + | None -> Protocol.hash Source.sources | Some hash -> hash in let module Name = struct let name = Protocol_hash.to_b58check hash diff --git a/src/node/shell/state.mli b/src/node/shell/state.mli index 73b6ee9ec..8e3b47010 100644 --- a/src/node/shell/state.mli +++ b/src/node/shell/state.mli @@ -150,7 +150,7 @@ module Block : sig t -> int -> (Operation.t list * Operation_list_list_hash.path) Lwt.t val all_operations: t -> Operation.t list list Lwt.t - val watcher: Net.t -> block Lwt_stream.t * Watcher.stopper + val watcher: Net.t -> block Lwt_stream.t * Lwt_watcher.stopper end @@ -192,6 +192,8 @@ val update_chain_store: module Protocol : sig + include (module type of (struct include Protocol end)) + (** Is a value stored in the local database ? *) val known: global_state -> Protocol_hash.t -> bool Lwt.t @@ -236,5 +238,5 @@ module Register_embedded_protocol (Proto : Env.Updater.PROTOCOL) (Source : sig val hash: Protocol_hash.t option - val sources: Tezos_data.Protocol.t + val sources: Protocol.t end) : sig end diff --git a/src/node/shell/validator.ml b/src/node/shell/validator.ml index 91de06ef0..9895782b9 100644 --- a/src/node/shell/validator.ml +++ b/src/node/shell/validator.ml @@ -8,7 +8,6 @@ (**************************************************************************) include Logging.Make(struct let name = "node.validator" end) -module Canceler = Lwt_utils.Canceler type t = { @@ -17,7 +16,7 @@ type t = { block_validator: Block_validator.t ; timeout: Net_validator.timeout ; - valid_block_input: State.Block.t Watcher.input ; + valid_block_input: State.Block.t Lwt_watcher.input ; active_nets: Net_validator.t Lwt.t Net_id.Table.t ; } @@ -27,7 +26,7 @@ let create state db timeout = Block_validator.create ~protocol_timeout:timeout.Net_validator.protocol db in - let valid_block_input = Watcher.create_input () in + let valid_block_input = Lwt_watcher.create_input () in { state ; db ; timeout ; block_validator ; valid_block_input ; active_nets = Net_id.Table.create 7 ; @@ -113,7 +112,7 @@ let shutdown { active_nets ; block_validator } = Lwt.return_unit let watcher { valid_block_input } = - Watcher.create_stream valid_block_input + Lwt_watcher.create_stream valid_block_input let inject_operation v ?(force = false) ?net_id op = begin diff --git a/src/node/shell/validator.mli b/src/node/shell/validator.mli index 48fb954b0..94dadb304 100644 --- a/src/node/shell/validator.mli +++ b/src/node/shell/validator.mli @@ -35,7 +35,7 @@ val validate_block: (Block_hash.t * State.Block.t tzresult Lwt.t) tzresult Lwt.t (** Monitor all the valid block (for all activate networks). *) -val watcher: t -> State.Block.t Lwt_stream.t * Watcher.stopper +val watcher: t -> State.Block.t Lwt_stream.t * Lwt_watcher.stopper val inject_operation: t -> diff --git a/src/node/updater/jbuild b/src/node/updater/jbuild index c2992089f..2e69bc396 100644 --- a/src/node/updater/jbuild +++ b/src/node/updater/jbuild @@ -3,11 +3,18 @@ (library ((name node_updater) (public_name tezos.node.updater) - (libraries (utils minutils micheline tezos_protocol_compiler node_db dynlink)) + (libraries (tezos-base + micheline + tezos_protocol_compiler + node_net + node_db + dynlink)) (flags (:standard -w -9+27-30-32-40@8 -safe-string - -open Error_monad - -open Hash - -open Utils - -open Tezos_data)) + -open Tezos_base__TzPervasives)) (wrapped false))) + +(alias + ((name runtest_indent) + (deps ((glob_files *.ml) (glob_files *.mli))) + (action (run bash ${libexec:tezos-stdlib:test-ocp-indent.sh} ${<})))) diff --git a/src/node/updater/tezos_protocol_environment.ml b/src/node/updater/tezos_protocol_environment.ml index 79c7cc532..0d11b1126 100644 --- a/src/node/updater/tezos_protocol_environment.ml +++ b/src/node/updater/tezos_protocol_environment.ml @@ -7,217 +7,6 @@ (* *) (**************************************************************************) -module Ed25519 = struct - - module Public_key_hash = Hash.Make_Blake2B(Base58)(struct - let name = "Ed25519.Public_key_hash" - let title = "An Ed25519 public key ID" - let b58check_prefix = Base58.Prefix.ed25519_public_key_hash - let size = Some 20 - end) - - let () = - Base58.check_encoded_prefix Public_key_hash.b58check_encoding "tz1" 36 - - module Public_key = struct - - type t = Sodium.Sign.public_key - let compare = Sodium.Sign.compare_public_keys - let (=) xs ys = compare xs ys = 0 - let (<>) xs ys = compare xs ys <> 0 - let (<) xs ys = compare xs ys < 0 - let (<=) xs ys = compare xs ys <= 0 - let (>=) xs ys = compare xs ys >= 0 - let (>) xs ys = compare xs ys > 0 - let max x y = if x >= y then x else y - let min x y = if x <= y then x else y - - type Base58.data += - | Public_key of t - - let b58check_encoding = - Base58.register_encoding - ~prefix: Base58.Prefix.ed25519_public_key - ~length:Sodium.Sign.public_key_size - ~to_raw:(fun x -> Bytes.to_string (Sodium.Sign.Bytes.of_public_key x)) - ~of_raw:(fun x -> - try Some (Sodium.Sign.Bytes.to_public_key (Bytes.of_string x)) - with _ -> None) - ~wrap:(fun x -> Public_key x) - - let of_b58check_opt s = Base58.simple_decode b58check_encoding s - let of_b58check_exn s = - match Base58.simple_decode b58check_encoding s with - | Some x -> x - | None -> Pervasives.failwith "Unexpected hash (ed25519 public key)" - let of_b58check s = - match Base58.simple_decode b58check_encoding s with - | Some x -> Ok x - | None -> generic_error "Unexpected hash (ed25519 public key)" - let to_b58check s = Base58.simple_encode b58check_encoding s - - let of_bytes s = Sodium.Sign.Bytes.to_public_key s - - let param ?(name="ed25519-public") ?(desc="Ed25519 public key (b58check-encoded)") t = - Cli_entries.(param ~name ~desc (parameter (fun _ str -> Lwt.return (of_b58check str))) t) - - let () = - Base58.check_encoded_prefix b58check_encoding "edpk" 54 - - let encoding = - let open Data_encoding in - splitted - ~json: - (describe - ~title: "An Ed25519 public key (Base58Check encoded)" @@ - conv - (fun s -> Base58.simple_encode b58check_encoding s) - (fun s -> - match Base58.simple_decode b58check_encoding s with - | Some x -> x - | None -> Data_encoding.Json.cannot_destruct - "Ed25519 public key: unexpected prefix.") - string) - ~binary: - (conv - Sodium.Sign.Bigbytes.of_public_key - Sodium.Sign.Bigbytes.to_public_key - (Fixed.bytes Sodium.Sign.public_key_size)) - - let hash v = - Public_key_hash.hash_bytes - [ Sodium.Sign.Bigbytes.of_public_key v ] - - end - - module Secret_key = struct - - type t = Sodium.Sign.secret_key - - type Base58.data += - | Secret_key of t - - let b58check_encoding = - Base58.register_encoding - ~prefix: Base58.Prefix.ed25519_secret_key - ~length:Sodium.Sign.secret_key_size - ~to_raw:(fun x -> Bytes.to_string (Sodium.Sign.Bytes.of_secret_key x)) - ~of_raw:(fun x -> - try Some (Sodium.Sign.Bytes.to_secret_key (Bytes.of_string x)) - with _ -> None) - ~wrap:(fun x -> Secret_key x) - - let of_b58check_opt s = Base58.simple_decode b58check_encoding s - let of_b58check_exn s = - match Base58.simple_decode b58check_encoding s with - | Some x -> x - | None -> Pervasives.failwith "Unexpected hash (ed25519 secret key)" - let of_b58check s = - match Base58.simple_decode b58check_encoding s with - | Some x -> Ok x - | None -> generic_error "Unexpected hash (ed25519 public key)" - let to_b58check s = Base58.simple_encode b58check_encoding s - - let of_bytes s = Sodium.Sign.Bytes.to_secret_key s - - let param ?(name="ed25519-secret") ?(desc="Ed25519 secret key (b58check-encoded)") t = - Cli_entries.(param ~name ~desc (parameter (fun _ str -> Lwt.return (of_b58check str))) t) - - let () = - Base58.check_encoded_prefix b58check_encoding "edsk" 98 - - let encoding = - let open Data_encoding in - splitted - ~json: - (describe - ~title: "An Ed25519 secret key (Base58Check encoded)" @@ - conv - (fun s -> Base58.simple_encode b58check_encoding s) - (fun s -> - match Base58.simple_decode b58check_encoding s with - | Some x -> x - | None -> Data_encoding.Json.cannot_destruct - "Ed25519 secret key: unexpected prefix.") - string) - ~binary: - (conv - Sodium.Sign.Bigbytes.of_secret_key - Sodium.Sign.Bigbytes.to_secret_key - (Fixed.bytes Sodium.Sign.secret_key_size)) - - end - - let sign key msg = - Sodium.Sign.Bigbytes.(of_signature @@ sign_detached key msg) - - module Signature = struct - - type t = MBytes.t - - type Base58.data += - | Signature of t - - let b58check_encoding = - Base58.register_encoding - ~prefix: Base58.Prefix.ed25519_signature - ~length:Sodium.Sign.signature_size - ~to_raw:MBytes.to_string - ~of_raw:(fun s -> Some (MBytes.of_string s)) - ~wrap:(fun x -> Signature x) - - let of_b58check_opt s = Base58.simple_decode b58check_encoding s - let of_b58check_exn s = - match Base58.simple_decode b58check_encoding s with - | Some x -> x - | None -> Pervasives.failwith "Unexpected hash (ed25519 signature)" - let of_b58check s = - match Base58.simple_decode b58check_encoding s with - | Some x -> Ok x - | None -> generic_error "Unexpected hash (ed25519 public key)" - let to_b58check s = Base58.simple_encode b58check_encoding s - - let of_bytes s = MBytes.of_string (Bytes.to_string s) - - let param ?(name="signature") ?(desc="Signature (b58check-encoded)") t = - Cli_entries.(param ~name ~desc (parameter (fun _ str -> Lwt.return (of_b58check str))) t) - - let () = - Base58.check_encoded_prefix b58check_encoding "edsig" 99 - - let encoding = - let open Data_encoding in - splitted - ~json: - (describe - ~title: "An Ed25519 signature (Base58Check encoded)" @@ - conv - (fun s -> Base58.simple_encode b58check_encoding s) - (fun s -> - match Base58.simple_decode b58check_encoding s with - | Some x -> x - | None -> Data_encoding.Json.cannot_destruct - "Ed25519 signature: unexpected prefix.") - string) - ~binary: (Fixed.bytes Sodium.Sign.signature_size) - - let check public_key signature msg = - try - Sodium.Sign.Bigbytes.(verify public_key (to_signature signature) msg) ; - true - with _ -> false - - let append key msg = - MBytes.concat msg (sign key msg) - - end - - let generate_key () = - let secret, pub = Sodium.Sign.random_keypair () in - (Public_key.hash pub, pub, secret) - -end - module Make(Param : sig val name: string end)() = struct include Pervasives @@ -252,8 +41,21 @@ module Make(Param : sig val name: string end)() = struct module Data_encoding = Data_encoding module Time = Time module Ed25519 = Ed25519 - module Hash = Hash - module Tezos_data = Tezos_data + module Hash = struct + include Tezos_crypto + include Tezos_crypto.S + module Make_minimal_Blake2B = Blake2B.Make_minimal + module Make_Blake2B = Blake2B.Make + end + module Blake2B = Blake2B + module Tezos_data = struct + module type DATA = Tezos_base.S.T + module type HASHABLE_DATA = Tezos_base.S.HASHABLE + module Fitness = Fitness + module Operation = Operation + module Block_header = Block_header + module Protocol = Protocol + end module RPC = RPC module Micheline = Micheline module Fitness = Fitness diff --git a/src/node/updater/updater.ml b/src/node/updater/updater.ml index 57a16543f..82576f75e 100644 --- a/src/node/updater/updater.ml +++ b/src/node/updater/updater.ml @@ -126,17 +126,17 @@ module Node_protocol_environment_sigs = struct and type 'a Data_encoding.t = 'a Data_encoding.t and type 'a Lwt.t = 'a Lwt.t and type ('a, 'b) Pervasives.result = ('a, 'b) result - and type Hash.Net_id.t = Hash.Net_id.t - and type Hash.Block_hash.t = Hash.Block_hash.t - and type Hash.Operation_hash.t = Hash.Operation_hash.t - and type Hash.Operation_list_list_hash.t = Hash.Operation_list_list_hash.t + and type Hash.Net_id.t = Net_id.t + and type Hash.Block_hash.t = Block_hash.t + and type Hash.Operation_hash.t = Operation_hash.t + and type Hash.Operation_list_list_hash.t = Operation_list_list_hash.t and type Context.t = Context.t and type Time.t = Time.t and type MBytes.t = MBytes.t - and type Tezos_data.Operation.shell_header = Tezos_data.Operation.shell_header - and type Tezos_data.Operation.t = Tezos_data.Operation.t - and type Tezos_data.Block_header.shell_header = Tezos_data.Block_header.shell_header - and type Tezos_data.Block_header.t = Tezos_data.Block_header.t + and type Tezos_data.Operation.shell_header = Operation.shell_header + and type Tezos_data.Operation.t = Operation.t + and type Tezos_data.Block_header.shell_header = Block_header.shell_header + and type Tezos_data.Block_header.t = Block_header.t and type 'a RPC.Directory.t = 'a RPC.Directory.t and type Updater.validation_result = validation_result and type Updater.rpc_context = rpc_context diff --git a/src/node/updater/updater.mli b/src/node/updater/updater.mli index 0804d450a..b613e6375 100644 --- a/src/node/updater/updater.mli +++ b/src/node/updater/updater.mli @@ -88,17 +88,17 @@ module Node_protocol_environment_sigs : sig and type 'a Data_encoding.t = 'a Data_encoding.t and type 'a Lwt.t = 'a Lwt.t and type ('a, 'b) Pervasives.result = ('a, 'b) result - and type Hash.Net_id.t = Hash.Net_id.t - and type Hash.Block_hash.t = Hash.Block_hash.t - and type Hash.Operation_hash.t = Hash.Operation_hash.t - and type Hash.Operation_list_list_hash.t = Hash.Operation_list_list_hash.t + and type Hash.Net_id.t = Net_id.t + and type Hash.Block_hash.t = Block_hash.t + and type Hash.Operation_hash.t = Operation_hash.t + and type Hash.Operation_list_list_hash.t = Operation_list_list_hash.t and type Context.t = Context.t and type Time.t = Time.t and type MBytes.t = MBytes.t - and type Tezos_data.Operation.shell_header = Tezos_data.Operation.shell_header - and type Tezos_data.Operation.t = Tezos_data.Operation.t - and type Tezos_data.Block_header.shell_header = Tezos_data.Block_header.shell_header - and type Tezos_data.Block_header.t = Tezos_data.Block_header.t + and type Tezos_data.Operation.shell_header = Operation.shell_header + and type Tezos_data.Operation.t = Operation.t + and type Tezos_data.Block_header.shell_header = Block_header.shell_header + and type Tezos_data.Block_header.t = Block_header.t and type 'a RPC.Directory.t = 'a RPC.Directory.t and type Updater.validation_result = validation_result and type Updater.rpc_context = rpc_context diff --git a/src/proto/alpha/jbuild b/src/proto/alpha/jbuild index 4096c062a..f9c020208 100644 --- a/src/proto/alpha/jbuild +++ b/src/proto/alpha/jbuild @@ -17,9 +17,9 @@ let () = (Tezos_embedded_raw_protocol_alpha.Main) (struct let hash = - Some (Hash.Protocol_hash.of_b58check_exn + Some (Tezos_crypto.Protocol_hash.of_b58check_exn \"ProtoALphaALphaALphaALphaALphaALphaALphaALphaDdp3zK\") - let sources = Tezos_data.Protocol.{ + let sources = Tezos_base.Protocol.{ expected_env = V1 ; components = [(* FIXME ?? *)] ; } end) in ()")))) @@ -59,3 +59,8 @@ let () = TEZOS_PROTOCOL)) (action (chdir ${ROOT} (run ${exe:../../compiler_main.exe} dummy_alpha ${path-no-dep:.}))))) + +(alias + ((name runtest_indent) + (deps ((glob_files *.ml) (glob_files *.mli))) + (action (run bash ${libexec:tezos-stdlib:test-ocp-indent.sh} ${<})))) diff --git a/src/proto/alpha/tezos_hash.ml b/src/proto/alpha/tezos_hash.ml index a15306963..fb163af64 100644 --- a/src/proto/alpha/tezos_hash.ml +++ b/src/proto/alpha/tezos_hash.ml @@ -19,28 +19,28 @@ module Prefix = struct end -module State_hash = Hash.Make_Blake2B(Base58)(struct +module State_hash = Blake2B.Make(Base58)(struct let name = "random" let title = "A random generation state" let b58check_prefix = Prefix.random_state_hash let size = None end) -module Nonce_hash = Hash.Make_Blake2B(Base58)(struct +module Nonce_hash = Blake2B.Make(Base58)(struct let name = "cycle_nonce" let title = "A nonce hash" let b58check_prefix = Prefix.nonce_hash let size = None end) -module Script_expr_hash = Hash.Make_Blake2B(Base58)(struct +module Script_expr_hash = Blake2B.Make(Base58)(struct let name = "script_expr" let title = "A script expression ID" let b58check_prefix = Prefix.script_expr_hash let size = None end) -module Contract_hash = Hash.Make_Blake2B(Base58)(struct +module Contract_hash = Blake2B.Make(Base58)(struct let name = "Contract_hash" let title = "A contract ID" let b58check_prefix = Prefix.contract_hash diff --git a/src/proto/demo/jbuild b/src/proto/demo/jbuild index 55dfb0ffc..362efc343 100644 --- a/src/proto/demo/jbuild +++ b/src/proto/demo/jbuild @@ -16,9 +16,9 @@ (Tezos_embedded_raw_protocol_demo.Main) (struct let hash = - Some (Hash.Protocol_hash.of_b58check_exn + Some (Tezos_crypto.Protocol_hash.of_b58check_exn \"ProtoDemoDemoDemoDemoDemoDemoDemoDemoDemoDemoD3c8k9\") - let sources = Tezos_data.Protocol.{ + let sources = Tezos_base.Protocol.{ expected_env = V1 ; components = [(* FIXME ?? *)] ; } end)")))) @@ -53,3 +53,8 @@ (glob_files *.mli) TEZOS_PROTOCOL)) (action (chdir ${ROOT} (run ${exe:../../compiler_main.exe} dummy_genesis ${path-no-dep:.}))))) + +(alias + ((name runtest_indent) + (deps ((glob_files *.ml) (glob_files *.mli))) + (action (run bash ${libexec:tezos-stdlib:test-ocp-indent.sh} ${<})))) diff --git a/src/proto/genesis/jbuild b/src/proto/genesis/jbuild index 49ca281e3..52d7577ce 100644 --- a/src/proto/genesis/jbuild +++ b/src/proto/genesis/jbuild @@ -16,9 +16,9 @@ (Tezos_embedded_raw_protocol_genesis.Main) (struct let hash = - Some (Hash.Protocol_hash.of_b58check_exn + Some (Tezos_crypto.Protocol_hash.of_b58check_exn \"ProtoGenesisGenesisGenesisGenesisGenesisGenesk612im\") - let sources = Tezos_data.Protocol.{ + let sources = Tezos_base.Protocol.{ expected_env = V1 ; components = [(* FIXME ?? *)] ; } end)")))) @@ -56,3 +56,8 @@ (glob_files *.mli) TEZOS_PROTOCOL)) (action (chdir ${ROOT} (run ${exe:../../compiler_main.exe} dummy_genesis ${path-no-dep:.}))))) + +(alias + ((name runtest_indent) + (deps ((glob_files *.ml) (glob_files *.mli))) + (action (run bash ${libexec:tezos-stdlib:test-ocp-indent.sh} ${<})))) diff --git a/src/utils/IO.ml b/src/utils/IO.ml deleted file mode 100644 index 6771038a1..000000000 --- a/src/utils/IO.ml +++ /dev/null @@ -1,132 +0,0 @@ -(* For this source file only. - * Copyright (c) 2013-2014 Thomas Gazagnaire - * Copyright (c) 2016-2017 Dynamic Ledger Solutions, Inc. - * - * Permission to use, copy, modify, and distribute this software for any - * purpose with or without fee is hereby granted, provided that the above - * copyright notice and this permission notice appear in all copies. - * - * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES - * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF - * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR - * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES - * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN - * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF - * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. -*) - -open Error_monad - -let mkdir dir = - let safe_mkdir dir = - if not (Sys.file_exists dir) then - try Unix.mkdir dir 0o755 - with Unix.Unix_error(Unix.EEXIST,_,_) -> () in - let rec aux dir = - if not (Sys.file_exists dir) then begin - aux (Filename.dirname dir); - safe_mkdir dir; - end in - aux dir - -let check_dir root = - if Sys.file_exists root && not (Sys.is_directory root) then - failwith "%s is not a directory!" root - else begin - let mkdir dir = - if not (Sys.file_exists dir) then mkdir dir in - mkdir root; - return () - end - -let files = Lwt_pool.create 50 (fun () -> Lwt.return_unit) - -let with_file fn = - Lwt_pool.use files fn - -let read_bigstring fd = - Lwt_bytes.map_file ~fd ~shared:false () - -let with_file_in file fn = - with_file - (fun () -> - let fd = Unix.(openfile file [O_RDONLY; O_NONBLOCK] 0o644) in - try - let b = read_bigstring fd in - fn b >>= fun r -> - Unix.close fd; - Lwt.return r - with e -> - Unix.close fd; - Lwt.fail e) - -let write_bigstring fd ba = - let rec rwrite fd buf ofs len = - Lwt_bytes.write fd buf ofs len >>= fun n -> - if n = 0 && len <> 0 then Lwt.fail End_of_file - else if n < len then rwrite fd buf (ofs + n) (len - n) - else Lwt.return_unit in - rwrite fd ba 0 (Bigarray.Array1.dim ba) - -let with_file_out file ba = - mkdir (Filename.dirname file); - with_file - (fun () -> - Lwt_unix.(openfile file - [O_RDWR; O_NONBLOCK; O_CREAT] 0o644) >>= fun fd -> - try - write_bigstring fd ba >>= fun r -> - Lwt_unix.close fd >>= fun () -> - Lwt.return r - with e -> - Lwt_unix.close fd >>= fun () -> - Lwt.fail e) - -let is_directory f = - try Sys.is_directory f with _ -> false - -let is_empty dir = - Lwt_unix.opendir dir >>= fun hdir -> - Lwt_unix.readdir_n hdir 3 >>= fun files -> - let res = Array.length files = 2 in - Lwt_unix.closedir hdir >>= fun () -> - Lwt.return res - -let rec cleanup_dir dir = - Lwt_unix.file_exists dir >>= function - | true -> - is_empty dir >>= fun empty -> - if empty && dir <> "/" then begin - Lwt_unix.rmdir dir >>= fun () -> - cleanup_dir (Filename.dirname dir) - end else - Lwt.return_unit - | false -> - Lwt.return_unit - -let remove_file ?(cleanup = false) file = - Lwt_unix.file_exists file >>= function - | true -> - Lwt_unix.unlink file >>= fun () -> - if cleanup then - Lwt.catch - (fun () -> cleanup_dir (Filename.dirname file)) - (fun _ -> Lwt.return_unit) - else - Lwt.return_unit - | false -> - Lwt.return_unit - -let fold root ~init ~f = - if is_directory root then begin - let files = Lwt_unix.files_of_directory root in - Lwt_stream.fold_s - (fun file acc -> - if file = "." || file = ".." then - Lwt.return acc - else - f file acc) - files init - end else - Lwt.return init - diff --git a/src/utils/jbuild b/src/utils/jbuild deleted file mode 100644 index b317dad7a..000000000 --- a/src/utils/jbuild +++ /dev/null @@ -1,24 +0,0 @@ -(jbuild_version 1) - -(library - ((name utils) - (public_name tezos.utils) - (libraries - ( - ;; External - base64 - calendar - ezjsonm - ipaddr.unix - lwt.unix - mtime.clock.os - nocrypto - sodium - zarith - ;; Internal - minutils - )) - (flags (:standard -w -9+27-30-32-40@8 -safe-string)) - (wrapped false))) - - diff --git a/src/utils/tezos_data.ml b/src/utils/tezos_data.ml deleted file mode 100644 index f82238b9e..000000000 --- a/src/utils/tezos_data.ml +++ /dev/null @@ -1,324 +0,0 @@ -(**************************************************************************) -(* *) -(* Copyright (c) 2014 - 2017. *) -(* Dynamic Ledger Solutions, Inc. *) -(* *) -(* All rights reserved. No warranty, explicit or implicit, provided. *) -(* *) -(**************************************************************************) - -open Hash - -module type DATA = sig - - type t - - val compare: t -> t -> int - val equal: t -> t -> bool - - val (=): t -> t -> bool - val (<>): t -> t -> bool - val (<): t -> t -> bool - val (<=): t -> t -> bool - val (>=): t -> t -> bool - val (>): t -> t -> bool - val min: t -> t -> t - val max: t -> t -> t - - val pp: Format.formatter -> t -> unit - - val encoding: t Data_encoding.t - val to_bytes: t -> MBytes.t - val of_bytes: MBytes.t -> t option - -end - -module type HASHABLE_DATA = sig - - include DATA - - type hash - val hash: t -> hash - val hash_raw: MBytes.t -> hash - -end - -module Fitness = struct - - type t = MBytes.t list - - (* Fitness comparison: - - shortest lists are smaller ; - - lexicographical order for lists of the same length. *) - let compare_bytes b1 b2 = - let len1 = MBytes.length b1 in - let len2 = MBytes.length b2 in - let c = compare len1 len2 in - if c <> 0 - then c - else - let rec compare_byte b1 b2 pos len = - if pos = len - then 0 - else - let c = compare (MBytes.get_char b1 pos) (MBytes.get_char b2 pos) in - if c <> 0 - then c - else compare_byte b1 b2 (pos+1) len - in - compare_byte b1 b2 0 len1 - - let compare f1 f2 = - let rec compare_rec f1 f2 = match f1, f2 with - | [], [] -> 0 - | i1 :: f1, i2 :: f2 -> - let i = compare_bytes i1 i2 in - if i = 0 then compare_rec f1 f2 else i - | _, _ -> assert false in - let len = compare (List.length f1) (List.length f2) in - if len = 0 then compare_rec f1 f2 else len - - let equal f1 f2 = compare f1 f2 = 0 - - let (=) = equal - let (<>) x y = compare x y <> 0 - let (<) x y = compare x y < 0 - let (<=) x y = compare x y <= 0 - let (>=) x y = compare x y >= 0 - let (>) x y = compare x y > 0 - let min x y = if x <= y then x else y - let max x y = if x <= y then y else x - - let rec pp fmt = function - | [] -> () - | [f] -> Format.fprintf fmt "%s" (Hex_encode.hex_of_bytes f) - | f1 :: f -> Format.fprintf fmt "%s::%a" (Hex_encode.hex_of_bytes f1) pp f - - let to_string x = Format.asprintf "%a" pp x - - let encoding = - let open Data_encoding in - describe ~title: "Tezos block fitness" - (list bytes) - - let to_bytes v = Data_encoding.Binary.to_bytes encoding v - let of_bytes b = Data_encoding.Binary.of_bytes encoding b - let of_bytes_exn b = Data_encoding.Binary.of_bytes_exn encoding b - -end - -module Operation = struct - - type shell_header = { - branch: Block_hash.t ; - } - - let shell_header_encoding = - let open Data_encoding in - conv - (fun { branch } -> branch) - (fun branch -> { branch }) - (obj1 (req "branch" Block_hash.encoding)) - - type t = { - shell: shell_header ; - proto: MBytes.t ; - } - let encoding = - let open Data_encoding in - conv - (fun { shell ; proto } -> (shell, proto)) - (fun (shell, proto) -> { shell ; proto }) - (merge_objs - shell_header_encoding - (obj1 (req "data" Variable.bytes))) - - let pp fmt op = - Format.pp_print_string fmt @@ - Data_encoding_ezjsonm.to_string (Data_encoding.Json.construct encoding op) - - let compare o1 o2 = - let (>>) x y = if x = 0 then y () else x in - Block_hash.compare o1.shell.branch o1.shell.branch >> fun () -> - MBytes.compare o1.proto o2.proto - let equal b1 b2 = compare b1 b2 = 0 - - let (=) = equal - let (<>) x y = compare x y <> 0 - let (<) x y = compare x y < 0 - let (<=) x y = compare x y <= 0 - let (>=) x y = compare x y >= 0 - let (>) x y = compare x y > 0 - let min x y = if x <= y then x else y - let max x y = if x <= y then y else x - - let to_bytes v = Data_encoding.Binary.to_bytes encoding v - let of_bytes b = Data_encoding.Binary.of_bytes encoding b - let of_bytes_exn b = Data_encoding.Binary.of_bytes_exn encoding b - - let hash op = Operation_hash.hash_bytes [to_bytes op] - let hash_raw bytes = Operation_hash.hash_bytes [bytes] - -end - -module Block_header = struct - - type shell_header = { - level: Int32.t ; - proto_level: int ; (* uint8 *) - predecessor: Block_hash.t ; - timestamp: Time.t ; - validation_passes: int ; (* uint8 *) - operations_hash: Operation_list_list_hash.t ; - fitness: MBytes.t list ; - } - - let shell_header_encoding = - let open Data_encoding in - conv - (fun { level ; proto_level ; predecessor ; - timestamp ; validation_passes ; operations_hash ; fitness } -> - (level, proto_level, predecessor, - timestamp, validation_passes, operations_hash, fitness)) - (fun (level, proto_level, predecessor, - timestamp, validation_passes, operations_hash, fitness) -> - { level ; proto_level ; predecessor ; - timestamp ; validation_passes ; operations_hash ; fitness }) - (obj7 - (req "level" int32) - (req "proto" uint8) - (req "predecessor" Block_hash.encoding) - (req "timestamp" Time.encoding) - (req "validation_pass" uint8) - (req "operations_hash" Operation_list_list_hash.encoding) - (req "fitness" Fitness.encoding)) - - type t = { - shell: shell_header ; - proto: MBytes.t ; - } - - let encoding = - let open Data_encoding in - conv - (fun { shell ; proto } -> (shell, proto)) - (fun (shell, proto) -> { shell ; proto }) - (merge_objs - shell_header_encoding - (obj1 (req "data" Variable.bytes))) - - let encoding = - let open Data_encoding in - conv - (fun { shell ; proto } -> (shell, proto)) - (fun (shell, proto) -> { shell ; proto }) - (merge_objs - shell_header_encoding - (obj1 (req "data" Variable.bytes))) - - let pp fmt op = - Format.pp_print_string fmt @@ - Data_encoding_ezjsonm.to_string (Data_encoding.Json.construct encoding op) - - let compare b1 b2 = - let (>>) x y = if x = 0 then y () else x in - let rec list compare xs ys = - match xs, ys with - | [], [] -> 0 - | _ :: _, [] -> -1 - | [], _ :: _ -> 1 - | x :: xs, y :: ys -> - compare x y >> fun () -> list compare xs ys in - Block_hash.compare b1.shell.predecessor b2.shell.predecessor >> fun () -> - compare b1.proto b2.proto >> fun () -> - Operation_list_list_hash.compare - b1.shell.operations_hash b2.shell.operations_hash >> fun () -> - Time.compare b1.shell.timestamp b2.shell.timestamp >> fun () -> - list compare b1.shell.fitness b2.shell.fitness - - let equal b1 b2 = compare b1 b2 = 0 - - let (=) = equal - let (<>) x y = compare x y <> 0 - let (<) x y = compare x y < 0 - let (<=) x y = compare x y <= 0 - let (>=) x y = compare x y >= 0 - let (>) x y = compare x y > 0 - let min x y = if x <= y then x else y - let max x y = if x <= y then y else x - - let to_bytes v = Data_encoding.Binary.to_bytes encoding v - let of_bytes b = Data_encoding.Binary.of_bytes encoding b - let of_bytes_exn b = Data_encoding.Binary.of_bytes_exn encoding b - - let hash block = Block_hash.hash_bytes [to_bytes block] - let hash_raw bytes = Block_hash.hash_bytes [bytes] - -end - -module Protocol = struct - - type t = { - expected_env: env_version ; - components: component list ; - } - - and component = { - name: string ; - interface: string option ; - implementation: string ; - } - - and env_version = V1 - - let component_encoding = - let open Data_encoding in - conv - (fun { name ; interface; implementation } -> - (name, interface, implementation)) - (fun (name, interface, implementation) -> - { name ; interface ; implementation }) - (obj3 - (req "name" string) - (opt "interface" string) - (req "implementation" string)) - - let env_version_encoding = - let open Data_encoding in - conv - (function V1 -> 0) - (function 0 -> V1 | _ -> failwith "unexpected environment version") - int16 - - let encoding = - let open Data_encoding in - conv - (fun { expected_env ; components } -> (expected_env, components)) - (fun (expected_env, components) -> { expected_env ; components }) - (obj2 - (req "expected_env_version" env_version_encoding) - (req "components" (list component_encoding))) - - let pp fmt op = - Format.pp_print_string fmt @@ - Data_encoding_ezjsonm.to_string (Data_encoding.Json.construct encoding op) - - let compare = Pervasives.compare - let equal = (=) - - let (=) = equal - let (<>) x y = compare x y <> 0 - let (<) x y = compare x y < 0 - let (<=) x y = compare x y <= 0 - let (>=) x y = compare x y >= 0 - let (>) x y = compare x y > 0 - let min x y = if x <= y then x else y - let max x y = if x <= y then y else x - - let to_bytes v = Data_encoding.Binary.to_bytes encoding v - let of_bytes b = Data_encoding.Binary.of_bytes encoding b - let of_bytes_exn b = Data_encoding.Binary.of_bytes_exn encoding b - let hash proto = Protocol_hash.hash_bytes [to_bytes proto] - let hash_raw proto = Protocol_hash.hash_bytes [proto] - -end diff --git a/src/utils/tezos_data.mli b/src/utils/tezos_data.mli deleted file mode 100644 index 7eed25720..000000000 --- a/src/utils/tezos_data.mli +++ /dev/null @@ -1,113 +0,0 @@ -(**************************************************************************) -(* *) -(* Copyright (c) 2014 - 2017. *) -(* Dynamic Ledger Solutions, Inc. *) -(* *) -(* All rights reserved. No warranty, explicit or implicit, provided. *) -(* *) -(**************************************************************************) - -open Hash - -module type DATA = sig - - type t - - val compare: t -> t -> int - val equal: t -> t -> bool - - val (=): t -> t -> bool - val (<>): t -> t -> bool - val (<): t -> t -> bool - val (<=): t -> t -> bool - val (>=): t -> t -> bool - val (>): t -> t -> bool - val min: t -> t -> t - val max: t -> t -> t - - val pp: Format.formatter -> t -> unit - - val encoding: t Data_encoding.t - val to_bytes: t -> MBytes.t - val of_bytes: MBytes.t -> t option - -end - -module Fitness : DATA with type t = MBytes.t list - -module type HASHABLE_DATA = sig - - include DATA - - type hash - val hash: t -> hash - val hash_raw: MBytes.t -> hash - -end - -module Operation : sig - - type shell_header = { - branch: Block_hash.t ; - } - val shell_header_encoding: shell_header Data_encoding.t - - type t = { - shell: shell_header ; - proto: MBytes.t ; - } - - include HASHABLE_DATA with type t := t - and type hash := Operation_hash.t - val of_bytes_exn: MBytes.t -> t - -end - -module Block_header : sig - - type shell_header = { - level: Int32.t ; - proto_level: int ; (* uint8 *) - predecessor: Block_hash.t ; - timestamp: Time.t ; - validation_passes: int ; (* uint8 *) - operations_hash: Operation_list_list_hash.t ; - fitness: MBytes.t list ; - } - - val shell_header_encoding: shell_header Data_encoding.t - - type t = { - shell: shell_header ; - proto: MBytes.t ; - } - - include HASHABLE_DATA with type t := t - and type hash := Block_hash.t - val of_bytes_exn: MBytes.t -> t - -end - -module Protocol : sig - - type t = { - expected_env: env_version ; - components: component list ; - } - - and component = { - name: string ; - interface: string option ; - implementation: string ; - } - - and env_version = V1 - - val component_encoding: component Data_encoding.t - val env_version_encoding: env_version Data_encoding.t - - include HASHABLE_DATA with type t := t - and type hash := Protocol_hash.t - val of_bytes_exn: MBytes.t -> t - -end diff --git a/test/lib/assert.ml b/test/lib/assert.ml index d19e8b834..696bbe80e 100644 --- a/test/lib/assert.ml +++ b/test/lib/assert.ml @@ -7,9 +7,6 @@ (* *) (**************************************************************************) -open Error_monad -open Hash - include Kaputt.Assertion module Assert = Kaputt.Abbreviations.Assert diff --git a/test/lib/assert.mli b/test/lib/assert.mli index 133748233..a39b70278 100644 --- a/test/lib/assert.mli +++ b/test/lib/assert.mli @@ -7,8 +7,6 @@ (* *) (**************************************************************************) -open Hash -open Error_monad include module type of Kaputt.Assertion val format_msg : string option -> string option diff --git a/test/lib/jbuild b/test/lib/jbuild index 74be2f013..01be577d5 100644 --- a/test/lib/jbuild +++ b/test/lib/jbuild @@ -2,6 +2,12 @@ (library ((name test_lib) - (libraries (kaputt utils minutils)) + (libraries (kaputt tezos-base)) (wrapped false) - (flags (:standard -w -9-32 -safe-string)))) + (flags (:standard -w -9-32 -safe-string + -open Tezos_base__TzPervasives)))) + +(alias + ((name runtest_indent) + (deps ((glob_files *.ml) (glob_files *.mli))) + (action (run bash ${libexec:tezos-stdlib:test-ocp-indent.sh} ${<})))) diff --git a/test/lib/process.ml b/test/lib/process.ml index 586d4e830..b4b242af0 100644 --- a/test/lib/process.ml +++ b/test/lib/process.ml @@ -11,8 +11,6 @@ let () = Lwt_unix.set_default_async_method Async_none include Logging.Make (struct let name = "process" end) -open Error_monad - exception Exited of int let handle_error f = diff --git a/test/p2p/jbuild b/test/p2p/jbuild index bac16d954..bb54e1338 100644 --- a/test/p2p/jbuild +++ b/test/p2p/jbuild @@ -4,14 +4,11 @@ ((names (test_p2p_connection test_p2p_connection_pool test_p2p_io_scheduler)) - (libraries (minutils utils test_lib node_net)) + (libraries (tezos-base test_lib node_net)) (flags (:standard -w -9-32 -linkall -safe-string - -open Error_monad - -open Hash - -open Utils - -open Tezos_data)))) + -open Tezos_base__TzPervasives)))) (alias ((name buildtest) @@ -40,3 +37,8 @@ (deps ((alias runtest_p2p_connection) (alias runtest_p2p_connection_pool) (alias runtest_p2p_io_scheduler))))) + +(alias + ((name runtest_indent) + (deps ((glob_files *.ml) (glob_files *.mli))) + (action (run bash ${libexec:tezos-stdlib:test-ocp-indent.sh} ${<})))) diff --git a/test/p2p/test_p2p_connection.ml b/test/p2p/test_p2p_connection.ml index 64db084ca..3bd809950 100644 --- a/test/p2p/test_p2p_connection.ml +++ b/test/p2p/test_p2p_connection.ml @@ -10,7 +10,6 @@ (* TODO Use Kaputt on the client side and remove `assert` from the server. *) -open Error_monad open P2p_types include Logging.Make (struct let name = "test.p2p.connection" end) diff --git a/test/p2p/test_p2p_connection_pool.ml b/test/p2p/test_p2p_connection_pool.ml index a8c4a725f..97f55c770 100644 --- a/test/p2p/test_p2p_connection_pool.ml +++ b/test/p2p/test_p2p_connection_pool.ml @@ -7,7 +7,6 @@ (* *) (**************************************************************************) -open Error_monad open P2p_types include Logging.Make (struct let name = "test.p2p.connection-pool" end) @@ -58,7 +57,7 @@ let sync_nodes nodes = Lwt.return err let detach_node f points n = - let (addr, port), points = Utils.select n points in + let (addr, port), points = List.select n points in let proof_of_work_target = Crypto_box.make_target 0. in let identity = Identity.generate proof_of_work_target in let nb_points = List.length points in @@ -102,7 +101,6 @@ let detach_node f points n = end let detach_nodes run_node points = - let open Utils in let clients = List.length points in Lwt_list.map_p (detach_node run_node points) (0 -- (clients - 1)) >>= fun nodes -> @@ -267,7 +265,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 ; diff --git a/test/p2p/test_p2p_io_scheduler.ml b/test/p2p/test_p2p_io_scheduler.ml index 843553f4d..42173c753 100644 --- a/test/p2p/test_p2p_io_scheduler.ml +++ b/test/p2p/test_p2p_io_scheduler.ml @@ -7,7 +7,6 @@ (* *) (**************************************************************************) -open Error_monad open P2p_types include Logging.Make (struct let name = "test-p2p-io-scheduler" end) @@ -154,7 +153,7 @@ let run Lwt_utils.safe_close main_socket >>= fun () -> client ?max_upload_speed ?write_queue_size addr port time n end in - Lwt_list.map_p client Utils.(1 -- n) >>= fun client_nodes -> + Lwt_list.map_p client (1 -- n) >>= fun client_nodes -> Process.wait_all (server_node :: client_nodes) let () = Random.self_init () diff --git a/test/proto_alpha/jbuild b/test/proto_alpha/jbuild index c9f42d9f3..bb4e629b4 100644 --- a/test/proto_alpha/jbuild +++ b/test/proto_alpha/jbuild @@ -6,14 +6,13 @@ test_origination test_transaction test_vote)) - (libraries (test_lib + (libraries (tezos-base + test_lib client_lib client_embedded_genesis client_embedded_alpha)) (flags (:standard -w -9-32 -safe-string - -open Error_monad - -open Hash - -open Tezos_data + -open Tezos_base__TzPervasives -open Tezos_protocol_environment_alpha -open Tezos_embedded_raw_protocol_alpha -open Tezos_context @@ -61,3 +60,8 @@ (alias runtest_origination) (alias runtest_transaction) (alias runtest_vote))))) + +(alias + ((name runtest_indent) + (deps ((glob_files *.ml) (glob_files *.mli))) + (action (run bash ${libexec:tezos-stdlib:test-ocp-indent.sh} ${<})))) diff --git a/test/proto_alpha/proto_alpha_helpers.ml b/test/proto_alpha/proto_alpha_helpers.ml index 6898142a3..47f76b58c 100644 --- a/test/proto_alpha/proto_alpha_helpers.ml +++ b/test/proto_alpha/proto_alpha_helpers.ml @@ -88,7 +88,7 @@ module Account = struct let create ?keys alias = let sk, pk = match keys with | Some keys -> keys - | None -> Sodium.Sign.random_keypair () in + | None -> let _, pk, sk = Ed25519.generate_key () in sk, pk in let pkh = Ed25519.Public_key.hash pk in let contract = Contract.default_contract pkh in { alias ; contract ; pkh ; pk ; sk } @@ -266,7 +266,7 @@ module Protocol = struct ~proposals () >>=? fun bytes -> let signed_bytes = Ed25519.Signature.append sk bytes in - return (Tezos_data.Operation.of_bytes_exn signed_bytes) + return (Tezos_base.Operation.of_bytes_exn signed_bytes) let ballot ?(block = `Prevalidation) ~src:({ pk; sk } : Account.t) ~proposal ballot = Client_node_rpcs.Blocks.info !rpc_config block >>=? fun block_info -> @@ -279,7 +279,7 @@ module Protocol = struct ~ballot () >>=? fun bytes -> let signed_bytes = Ed25519.Signature.append sk bytes in - return (Tezos_data.Operation.of_bytes_exn signed_bytes) + return (Tezos_base.Operation.of_bytes_exn signed_bytes) end @@ -323,7 +323,7 @@ module Assert = struct List.exists f errors | _ -> false - let hash op = Tezos_data.Operation.hash op + let hash op = Tezos_base.Operation.hash op let failed_to_preapply ~msg ?op f = Assert.contain_error ~msg ~f:begin function @@ -464,7 +464,7 @@ module Endorse = struct ~slot:slot () >>=? fun bytes -> let signed_bytes = Ed25519.Signature.append src_sk bytes in - return (Tezos_data.Operation.of_bytes_exn signed_bytes) + return (Tezos_base.Operation.of_bytes_exn signed_bytes) let signing_slots ?(max_priority = 1024) diff --git a/test/proto_alpha/proto_alpha_helpers.mli b/test/proto_alpha/proto_alpha_helpers.mli index e7aa3715c..f3b52005d 100644 --- a/test/proto_alpha/proto_alpha_helpers.mli +++ b/test/proto_alpha/proto_alpha_helpers.mli @@ -156,7 +156,7 @@ module Assert : sig val failed_to_preapply: msg:string -> - ?op:Tezos_data.Operation.t -> + ?op:Tezos_base.Operation.t -> (Environment.Error_monad.error -> bool) -> 'a tzresult -> unit diff --git a/test/shell/jbuild b/test/shell/jbuild index ab06ca296..85929ec28 100644 --- a/test/shell/jbuild +++ b/test/shell/jbuild @@ -4,8 +4,7 @@ ((names (test_context test_state test_store)) - (libraries (minutils - utils + (libraries (tezos-base test_lib node_shell tezos_embedded_protocol_demo @@ -13,10 +12,7 @@ tezos_embedded_protocol_genesis)) (flags (:standard -w -9-32 -safe-string - -open Error_monad - -open Hash - -open Utils - -open Tezos_data)))) + -open Tezos_base__TzPervasives)))) (alias ((name buildtest) @@ -41,3 +37,8 @@ (deps ((alias runtest_context) (alias runtest_state) (alias runtest_store))))) + +(alias + ((name runtest_indent) + (deps ((glob_files *.ml) (glob_files *.mli))) + (action (run bash ${libexec:tezos-stdlib:test-ocp-indent.sh} ${<})))) diff --git a/test/shell/test_context.ml b/test/shell/test_context.ml index ba0d3e576..527d1455a 100644 --- a/test/shell/test_context.ml +++ b/test/shell/test_context.ml @@ -7,7 +7,6 @@ (* *) (**************************************************************************) -open Hash open Context let (>>=) = Lwt.bind diff --git a/test/shell/test_state.ml b/test/shell/test_state.ml index 55524eeb0..7874deea5 100644 --- a/test/shell/test_state.ml +++ b/test/shell/test_state.ml @@ -7,9 +7,6 @@ (* *) (**************************************************************************) -open Hash -open Error_monad - let (//) = Filename.concat (** Basic blocks *) @@ -41,7 +38,7 @@ let incr_fitness fitness = | [ fitness ] -> Pervasives.( Data_encoding.Binary.of_bytes Data_encoding.int64 fitness - |> Utils.unopt ~default:0L + |> Option.unopt ~default:0L |> Int64.succ |> Data_encoding.Binary.to_bytes Data_encoding.int64 ) @@ -86,7 +83,7 @@ let equal_operation ?msg op1 op2 = | _ -> false in let prn = function | None -> "none" - | Some op -> Hash.Operation_hash.to_hex (Operation.hash op) in + | Some op -> Operation_hash.to_hex (Operation.hash op) in Assert.equal ?msg ~prn ~eq op1 op2 let equal_block ?msg st1 st2 = @@ -98,8 +95,7 @@ let equal_block ?msg st1 st2 = | _ -> false in let prn = function | None -> "none" - | Some st -> - Hash.Block_hash.to_hex (Block_header.hash st) in + | Some st -> Block_hash.to_hex (Block_header.hash st) in Assert.equal ?msg ~prn ~eq st1 st2 let block _state ?(operations = []) (pred: State.Block.t) name diff --git a/test/shell/test_store.ml b/test/shell/test_store.ml index 3a20bdb97..e19b13afb 100644 --- a/test/shell/test_store.ml +++ b/test/shell/test_store.ml @@ -7,8 +7,6 @@ (* *) (**************************************************************************) -open Error_monad -open Hash open Store let (>>=) = Lwt.bind @@ -62,13 +60,13 @@ let net_id = Net_id.of_block_hash genesis_block (** Operation store *) -let make proto : Tezos_data.Operation.t = +let make proto : Operation.t = { shell = { branch = genesis_block } ; proto } let op1 = make (MBytes.of_string "Capadoce") -let oph1 = Tezos_data.Operation.hash op1 +let oph1 = Operation.hash op1 let op2 = make (MBytes.of_string "Kivu") -let oph2 = Tezos_data.Operation.hash op2 +let oph2 = Operation.hash op2 (** Block store *) diff --git a/test/utils/jbuild b/test/utils/jbuild index 0f6e9b09a..13084d740 100644 --- a/test/utils/jbuild +++ b/test/utils/jbuild @@ -6,13 +6,10 @@ test_merkle test_stream_data_encoding test_utils)) - (libraries (minutils utils test_lib)) + (libraries (tezos-base test_lib)) (flags (:standard -w -9-32 -safe-string - -open Error_monad - -open Hash - -open Utils - -open Tezos_data)))) + -open Tezos_base__TzPervasives)))) (alias ((name buildtest) @@ -49,3 +46,8 @@ (alias runtest_merkle) (alias runtest_stream_data_encoding) (alias runtest_utils))))) + +(alias + ((name runtest_indent) + (deps ((glob_files *.ml) (glob_files *.mli))) + (action (run bash ${libexec:tezos-stdlib:test-ocp-indent.sh} ${<})))) diff --git a/test/utils/test_data_encoding.ml b/test/utils/test_data_encoding.ml index 7e5097791..8d3f0121b 100644 --- a/test/utils/test_data_encoding.ml +++ b/test/utils/test_data_encoding.ml @@ -1,5 +1,4 @@ open Data_encoding -open Error_monad let (>>=) = Lwt.bind let (>|=) = Lwt.(>|=) diff --git a/test/utils/test_merkle.ml b/test/utils/test_merkle.ml index 27a1d6fc7..18b3cbe1c 100644 --- a/test/utils/test_merkle.ml +++ b/test/utils/test_merkle.ml @@ -7,8 +7,6 @@ (* *) (**************************************************************************) -open Error_monad - let rec (--) i j = if j < i then [] else i :: (i+1) -- j @@ -27,7 +25,7 @@ let rec list_of_tree = function assert (sx = sy) ; x @ y, sx + sy -module Merkle = Hash.Generic_Merkle_tree(struct +module Merkle = Blake2B.Generic_Merkle_tree(struct type t = tree type elt = int let empty = Empty diff --git a/test/utils/test_stream_data_encoding.ml b/test/utils/test_stream_data_encoding.ml index 00e768daf..2373eba74 100644 --- a/test/utils/test_stream_data_encoding.ml +++ b/test/utils/test_stream_data_encoding.ml @@ -1,5 +1,4 @@ open Data_encoding -open Error_monad let (>>=) = Lwt.bind let (>|=) = Lwt.(>|=) diff --git a/test/utils/test_utils.ml b/test/utils/test_utils.ml index 800cf67ea..e3122f8ca 100644 --- a/test/utils/test_utils.ml +++ b/test/utils/test_utils.ml @@ -7,12 +7,6 @@ (* *) (**************************************************************************) -open Error_monad - -let rec (--) i j = - if j < i then [] - else i :: (i+1) -- j - let rec permut = function | [] -> [[]] | x :: xs -> @@ -29,25 +23,25 @@ let rec permut = function let test_take_n _ = ListLabels.iter (permut [1;2;3;4;5;6;7;8;9]) ~f:begin fun xs -> - Assert.equal ~msg:__LOC__ (take_n ~compare 1 xs) [9] + Assert.equal ~msg:__LOC__ (List.take_n ~compare 1 xs) [9] end ; ListLabels.iter (permut [1;2;3;4;5;6;7;8;9]) ~f:begin fun xs -> - Assert.equal ~msg:__LOC__ (take_n ~compare 3 xs) [7;8;9] + Assert.equal ~msg:__LOC__ (List.take_n ~compare 3 xs) [7;8;9] end ; let inv_compare x y = compare y x in ListLabels.iter (permut [1;2;3;4;5;6;7;8;9]) ~f:begin fun xs -> - Assert.equal ~msg:__LOC__ (take_n ~compare:inv_compare 3 xs) [3;2;1] + Assert.equal ~msg:__LOC__ (List.take_n ~compare:inv_compare 3 xs) [3;2;1] end ; (* less elements than the bound. *) ListLabels.iter (permut [1;2;3;4;5;6;7;8;9]) ~f:begin fun xs -> - Assert.equal ~msg:__LOC__ (take_n ~compare 12 xs) [1;2;3;4;5;6;7;8;9] + Assert.equal ~msg:__LOC__ (List.take_n ~compare 12 xs) [1;2;3;4;5;6;7;8;9] end ; (* with duplicates. *) ListLabels.iter (permut [1;2;3;3;4;5;5;5;6]) ~f:begin fun xs -> - Assert.equal ~msg:__LOC__ (take_n ~compare 3 xs) [5;5;6] + Assert.equal ~msg:__LOC__ (List.take_n ~compare 3 xs) [5;5;6] end ; ListLabels.iter (permut [1;2;3;3;4;5;5;5;6]) ~f:begin fun xs -> - Assert.equal ~msg:__LOC__ (take_n ~compare 5 xs) [4;5;5;5;6] + Assert.equal ~msg:__LOC__ (List.take_n ~compare 5 xs) [4;5;5;5;6] end ; return ()