From 9097809589d817bf800a86b3461486bad15eb41e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Gr=C3=A9goire=20Henry?= Date: Thu, 16 Mar 2017 17:17:06 +0100 Subject: [PATCH 1/5] Shell: Merkle tree of operations --- src/minutils/utils.ml | 5 + src/minutils/utils.mli | 1 + src/proto/environment/hash.mli | 21 ++++ src/utils/base58.ml | 2 + src/utils/base58.mli | 2 + src/utils/hash.ml | 212 ++++++++++++++++++++++++++++----- src/utils/hash.mli | 35 ++++++ 7 files changed, 251 insertions(+), 27 deletions(-) diff --git a/src/minutils/utils.ml b/src/minutils/utils.ml index 9a195791d..189aede0f 100644 --- a/src/minutils/utils.ml +++ b/src/minutils/utils.ml @@ -90,6 +90,11 @@ 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) diff --git a/src/minutils/utils.mli b/src/minutils/utils.mli index ea27466e0..2ba60cd35 100644 --- a/src/minutils/utils.mli +++ b/src/minutils/utils.mli @@ -44,6 +44,7 @@ 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 val list_hd_opt: 'a list -> 'a option +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 diff --git a/src/proto/environment/hash.mli b/src/proto/environment/hash.mli index 32812e829..bc33d1081 100644 --- a/src/proto/environment/hash.mli +++ b/src/proto/environment/hash.mli @@ -71,6 +71,20 @@ module type HASH = sig 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 + (** {2 Building Hashes} *******************************************************) (** The parameters for creating a new Hash type using @@ -111,5 +125,12 @@ module Block_hash : HASH (** Operations hashes / IDs. *) module Operation_hash : HASH +(** List of operations hashes / IDs. *) +module Operation_list_hash : + MERKLE_TREE with type elt = Operation_hash.t + +module Operation_list_list_hash : + MERKLE_TREE with type elt = Operation_list_hash.t + (** Protocol versions / source hashes. *) module Protocol_hash : HASH diff --git a/src/utils/base58.ml b/src/utils/base58.ml index 17bf69494..08e65fefe 100644 --- a/src/utils/base58.ml +++ b/src/utils/base58.ml @@ -292,6 +292,8 @@ module Prefix = struct (* 32 *) let block_hash = "\001\052" (* B(51) *) let operation_hash = "\005\116" (* o(51) *) + let operation_list_hash = "\133\233" (* Lo(52) *) + let operation_list_list_hash = "\029\159\109" (* LLo(53) *) let protocol_hash = "\002\170" (* P(51) *) (* 20 *) diff --git a/src/utils/base58.mli b/src/utils/base58.mli index 99895b910..990efe81b 100644 --- a/src/utils/base58.mli +++ b/src/utils/base58.mli @@ -13,6 +13,8 @@ module Prefix : sig val block_hash: string val operation_hash: string + val operation_list_hash: string + val operation_list_list_hash: string val protocol_hash: string val ed25519_public_key_hash: string val cryptobox_public_key_hash: string diff --git a/src/utils/hash.ml b/src/utils/hash.ml index 60fd8923e..73e7c8e13 100644 --- a/src/utils/hash.ml +++ b/src/utils/hash.ml @@ -98,6 +98,34 @@ module type INTERNAL_HASH = sig 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 @@ -297,36 +325,148 @@ module Make_Blake2B (R : sig end -(*-- Hash sets and maps -----------------------------------------------------*) +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) = struct + + let rec step a n = + let m = (n+1) / 2 in + for i = 0 to m - 1 do + a.(i) <- H.node a.(2*i) a.(2*i+1) + done ; + a.(m) <- H.node a.(n) a.(n) ; + if m = 1 then + a.(0) + else if m mod 2 = 0 then + step a m + else begin + a.(m+1) <- a.(m) ; + step a (m+1) + end + + let empty = H.empty + + let compute xs = + match xs with + | [] -> H.empty + | [x] -> H.leaf x + | _ :: _ :: _ -> + let last = Utils.list_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 ; + step a n + + type path = + | Left of path * H.t + | Right of H.t * path + | Op + + let rec step_path a n p j = + let m = (n+1) / 2 in + let p = if j mod 2 = 0 then Left (p, a.(j+1)) else Right (a.(j-1), p) in + for i = 0 to m - 1 do + a.(i) <- H.node a.(2*i) a.(2*i+1) + done ; + a.(m) <- H.node a.(n) a.(n) ; + if m = 1 then + p + else if m mod 2 = 0 then + step_path a m p (j/2) + else begin + a.(m+1) <- a.(m) ; + step_path a (m+1) p (j/2) + end + + let compute_path xs i = + match xs with + | [] -> invalid_arg "compute_path" + | [_] -> Op + | _ :: _ :: _ -> + let last = Utils.list_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 + List.iteri (fun i x -> a.(i) <- H.leaf x) xs ; + step_path a n Op i + + let rec check_path p h = + match p with + | Op -> + H.leaf h, 1, 0 + | Left (p, r) -> + let l, s, pos = check_path p h in + H.node l r, s * 2, pos + | Right (l, p) -> + let r, s, pos = check_path p h in + H.node l r, s * 2, pos + s + + let check_path p h = + let h, _, pos = check_path p h in + h, pos + + let path_encoding = + let open Data_encoding in + mu "path" + (fun path_encoding -> + union [ + case ~tag:240 + (obj2 + (req "path" path_encoding) + (req "right" H.encoding)) + (function Left (p, r) -> Some (p, r) | _ -> None) + (fun (p, r) -> Left (p, r)) ; + case ~tag:15 + (obj2 + (req "left" H.encoding) + (req "path" path_encoding)) + (function Right (r, p) -> Some (r, p) | _ -> None) + (fun (r, p) -> Right (r, p)) ; + case ~tag:0 + unit + (function Op -> Some () | _ -> None) + (fun () -> Op) + ]) -module Hash_set (Hash : HASH) = struct - include Set.Make (Hash) - let encoding = - Data_encoding.conv - elements - (fun l -> List.fold_left (fun m x -> add x m) empty l) - Data_encoding.(list Hash.encoding) end -module Hash_map (Hash : HASH) = struct - include Map.Make (Hash) - 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 Hash.encoding arg_encoding)) -end +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 : PrefixedName) + (Contents: sig + type t + val to_bytes: t -> MBytes.t + end) = struct -module Hash_table (Hash : MINIMAL_HASH) - : Hashtbl.S with type key = Hash.t - = Hashtbl.Make (struct - type t = Hash.t - let equal = Hash.equal - let hash v = - let raw_hash = Hash.to_string v in - let int64_hash = EndianString.BigEndian.get_int64 raw_hash 0 in - Int64.to_int int64_hash - end) + include Make_Blake2B (R) (K) + + type elt = Contents.t + + let empty = hash_bytes [] + + include Generic_Merkle_tree(struct + type nonrec t = t + type nonrec elt = elt + let encoding = encoding + let empty = empty + let leaf x = hash_bytes [Contents.to_bytes x] + let node x y = hash_bytes [to_bytes x; to_bytes y] + end) + +end (*-- Pre-instanciated hashes ------------------------------------------------*) @@ -344,7 +484,23 @@ module Operation_hash = let title = "A Tezos operation ID" let b58check_prefix = Base58.Prefix.operation_hash let size = None - end) + 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 @@ -364,4 +520,6 @@ module Generic_hash = 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 diff --git a/src/utils/hash.mli b/src/utils/hash.mli index a45d4b9c4..c9e2dd5ce 100644 --- a/src/utils/hash.mli +++ b/src/utils/hash.mli @@ -90,6 +90,34 @@ module type INTERNAL_HASH = sig 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 + (** {2 Building Hashes} *******************************************************) (** The parameters for creating a new Hash type using @@ -136,6 +164,13 @@ end (** 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 From a6307c40cf05b999fa35cfeaa00dcd527d6b6a51 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Gr=C3=A9goire=20Henry?= Date: Fri, 31 Mar 2017 01:17:25 +0200 Subject: [PATCH 2/5] Shell: add unit tests for Merkle tree --- .gitignore | 1 + .gitlab-ci.yml | 9 +++++ src/utils/hash.mli | 19 ++++++++++ test/Makefile | 24 +++++++++++++ test/test_merkle.ml | 86 +++++++++++++++++++++++++++++++++++++++++++++ 5 files changed, 139 insertions(+) create mode 100644 test/test_merkle.ml diff --git a/.gitignore b/.gitignore index a27ff1458..33c57dea5 100644 --- a/.gitignore +++ b/.gitignore @@ -42,6 +42,7 @@ /test/test-context /test/test-basic /test/test-data-encoding +/test/test-merkle /test/test-p2p-io-scheduler /test/test-p2p-connection /test/test-p2p-connection-pool diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index fdc02559e..8b68dff2d 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -86,6 +86,15 @@ test:data-encoding: dependencies: - build +test:merkle: + stage: test + tags: + - tezos_builder + script: + - make -C test run-test-merkle + dependencies: + - build + test:p2p-io-scheduler: stage: test tags: diff --git a/src/utils/hash.mli b/src/utils/hash.mli index c9e2dd5ce..d33218bc0 100644 --- a/src/utils/hash.mli +++ b/src/utils/hash.mli @@ -175,3 +175,22 @@ module Operation_list_list_hash : module Protocol_hash : INTERNAL_HASH 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/test/Makefile b/test/Makefile index 3fe7cb102..ad1e869b5 100644 --- a/test/Makefile +++ b/test/Makefile @@ -1,5 +1,6 @@ TESTS := \ + merkle \ data-encoding \ store context state \ basic basic.sh \ @@ -246,6 +247,29 @@ test-lwt-pipe: ${NODELIB} ${TEST_PIPE_IMPLS:.ml=.cmx} clean:: rm -f test-p2p +############################################################################ +## Merkle test program + +.PHONY:build-test-merkle run-test-merkle +build-test-merkle: test-merkle +run-test-merkle: + ./test-merkle + +TEST_MERKLE_INTFS = + +TEST_MERKLE_IMPLS = \ + lib/assert.ml \ + lib/test.ml \ + test_merkle.ml + +${TEST_MERKLE_IMPLS:.ml=.cmx}: ${NODELIB} +test-merkle: ${NODELIB} ${TEST_MERKLE_IMPLS:.ml=.cmx} + ocamlfind ocamlopt -linkall -linkpkg ${OCAMLFLAGS} -o $@ $^ + +clean:: + rm -f test-merkle + + ############################################################################ ## data encoding test program diff --git a/test/test_merkle.ml b/test/test_merkle.ml new file mode 100644 index 000000000..a30a1685c --- /dev/null +++ b/test/test_merkle.ml @@ -0,0 +1,86 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +open Error_monad +open Hash + +let rec (--) i j = + if j < i then [] + else i :: (i+1) -- j + +type tree = + | Empty + | Leaf of int + | Node of tree * tree + +let rec list_of_tree = function + | Empty -> [], 0 + | Leaf x -> [x], 1 + | Node (x, y) -> + let x, sx = list_of_tree x + and y, sy = list_of_tree y in + assert (sx = sy) ; + x @ y, sx + sy + +module Merkle = Hash.Generic_Merkle_tree(struct + type t = tree + type elt = int + let empty = Empty + let leaf i = Leaf i + let node x y = Node (x, y) + let encoding = + (* Fake... *) + Data_encoding.conv (fun _ -> 0) (fun _ -> Empty) Data_encoding.int31 + end) + +let rec compare_list xs ys = + match xs, ys with + | [], [] -> true + | [x], y :: ys when x = y -> ys = [] || compare_list xs ys + | x :: xs, y :: ys when x = y -> compare_list xs ys + | _, _ -> false + +let check_size i = + let l = 0 -- i in + let l2, _ = list_of_tree (Merkle.compute l) in + if compare_list l l2 then + return () + else + failwith "Failed for %d: %a" + i + (Format.pp_print_list + ~pp_sep:(fun ppf () -> Format.pp_print_string ppf ";") + Format.pp_print_int) + l2 + +let test_compute _ = + iter_s check_size (0--99) + +let check_path i = + let l = 0 -- i in + let orig = Merkle.compute l in + iter_s (fun j -> + let path = Merkle.compute_path l j in + let found, pos = Merkle.check_path path j in + if found = orig && j = pos then + return () + else + failwith "Failed for %d in %d." j i) + l + +let test_path _ = + iter_s check_path (0--128) + +let tests : (string * (string -> unit tzresult Lwt.t)) list = [ + "compute", test_compute ; + "path", test_path ; +] + +let () = + Test.run "merkel." tests From e273cfa07ff436a4214b602794538b19cb390d5b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Gr=C3=A9goire=20Henry?= Date: Tue, 28 Mar 2017 13:31:41 +0200 Subject: [PATCH 3/5] Shell/Distributed_db: allow to `precheck` data. --- src/node/shell/distributed_db.ml | 76 ++++++++++---- src/node/shell/distributed_db.mli | 4 +- src/node/shell/distributed_db_functors.ml | 115 ++++++++++++++++----- src/node/shell/distributed_db_functors.mli | 79 ++++++++++++-- src/node/shell/node.ml | 2 +- src/node/shell/state.ml | 34 +++--- src/node/shell/state.mli | 2 +- 7 files changed, 234 insertions(+), 78 deletions(-) diff --git a/src/node/shell/distributed_db.ml b/src/node/shell/distributed_db.ml index 34fcf1f1e..1d6cafca3 100644 --- a/src/node/shell/distributed_db.ml +++ b/src/node/shell/distributed_db.ml @@ -21,13 +21,18 @@ type 'a request_param = { } module Make_raw - (Hash : HASH) - (Disk_table : State.DATA_STORE with type key := Hash.t) - (Memory_table : Hashtbl.S with type key := Hash.t) + (Hash : sig type t end) + (Disk_table : + Distributed_db_functors.DISK_TABLE with type key := Hash.t) + (Memory_table : + Distributed_db_functors.MEMORY_TABLE with type key := Hash.t) (Request_message : sig type param val forge : param -> Hash.t list -> Message.t - end) = struct + end) + (Precheck : Distributed_db_functors.PRECHECK + with type key := Hash.t + and type value := Disk_table.value) = struct type key = Hash.t type value = Disk_table.value @@ -45,7 +50,7 @@ module Make_raw (Hash) (Memory_table) (Request) module Table = Distributed_db_functors.Make_table - (Hash) (Disk_table) (Memory_table) (Scheduler) + (Hash) (Disk_table) (Memory_table) (Scheduler) (Precheck) type t = { scheduler: Scheduler.t ; @@ -62,23 +67,51 @@ module Make_raw end +module No_precheck = struct + type param = unit + let precheck _ _ _ = true +end + module Raw_operation = - Make_raw (Operation_hash) (State.Operation) (Operation_hash.Table) (struct - type param = Net_id.t - let forge net_id keys = Message.Get_operations (net_id, keys) - end) + Make_raw + (Operation_hash) + (State.Operation) + (Operation_hash.Table) + (struct + type param = Net_id.t + let forge net_id keys = Message.Get_operations (net_id, keys) + end) + (No_precheck) module Raw_block_header = - Make_raw (Block_hash) (State.Block_header) (Block_hash.Table) (struct - type param = Net_id.t - let forge net_id keys = Message.Get_block_headers (net_id, keys) + Make_raw + (Block_hash) + (State.Block_header) + (Block_hash.Table) + (struct + type param = Net_id.t + let forge net_id keys = Message.Get_block_headers (net_id, keys) + end) + (No_precheck) + +module Operation_list_table = + Hashtbl.Make(struct + type t = Block_hash.t * int + let hash = Hashtbl.hash + let equal (b1, i1) (b2, i2) = + Block_hash.equal b1 b2 && i1 = i2 end) module Raw_protocol = - Make_raw (Protocol_hash) (State.Protocol) (Protocol_hash.Table) (struct - type param = unit - let forge () keys = Message.Get_protocols keys - end) + Make_raw + (Protocol_hash) + (State.Protocol) + (Protocol_hash.Table) + (struct + type param = unit + let forge () keys = Message.Get_protocols keys + end) + (No_precheck) type callback = { notify_branch: P2p.Peer_id.t -> Block_hash.t list -> unit ; @@ -403,10 +436,13 @@ let shutdown { p2p ; p2p_readers ; active_nets } = P2p.shutdown p2p >>= fun () -> Lwt.return_unit -module type DISTRIBUTED_DB = Distributed_db_functors.DISTRIBUTED_DB +module type PARAMETRIZED_DISTRIBUTED_DB = + Distributed_db_functors.PARAMETRIZED_DISTRIBUTED_DB +module type DISTRIBUTED_DB = + Distributed_db_functors.DISTRIBUTED_DB module Make - (Table : DISTRIBUTED_DB) + (Table : PARAMETRIZED_DISTRIBUTED_DB with type param := unit) (Kind : sig type t val proj: t -> Table.t @@ -417,8 +453,8 @@ module Make let known t k = Table.known (Kind.proj t) k let read t k = Table.read (Kind.proj t) k let read_exn t k = Table.read_exn (Kind.proj t) k - let prefetch t ?peer k = Table.prefetch (Kind.proj t) ?peer k - let fetch t ?peer k = Table.fetch (Kind.proj t) ?peer k + let prefetch t ?peer k = Table.prefetch (Kind.proj t) ?peer k () + let fetch t ?peer k = Table.fetch (Kind.proj t) ?peer k () let commit t k = Table.commit (Kind.proj t) k let inject t k v = Table.inject (Kind.proj t) k v let watch t = Table.watch (Kind.proj t) diff --git a/src/node/shell/distributed_db.mli b/src/node/shell/distributed_db.mli index e3d21c687..6efeb5a30 100644 --- a/src/node/shell/distributed_db.mli +++ b/src/node/shell/distributed_db.mli @@ -40,11 +40,11 @@ module type DISTRIBUTED_DB = sig val known: t -> key -> bool Lwt.t val read: t -> key -> value option Lwt.t val read_exn: t -> key -> value Lwt.t - val prefetch: t -> ?peer:P2p.Peer_id.t -> key -> unit - val fetch: t -> ?peer:P2p.Peer_id.t -> key -> value Lwt.t val commit: t -> key -> unit Lwt.t val inject: t -> key -> value -> bool Lwt.t val watch: t -> (key * value) Lwt_stream.t * Watcher.stopper + val prefetch: t -> ?peer:P2p.Peer_id.t -> key -> unit + val fetch: t -> ?peer:P2p.Peer_id.t -> key -> value Lwt.t end module Operation : diff --git a/src/node/shell/distributed_db_functors.ml b/src/node/shell/distributed_db_functors.ml index f1d6f7b89..df4a1e960 100644 --- a/src/node/shell/distributed_db_functors.ml +++ b/src/node/shell/distributed_db_functors.ml @@ -7,19 +7,63 @@ (* *) (**************************************************************************) -module type DISTRIBUTED_DB = sig +module type PARAMETRIZED_RO_DISTRIBUTED_DB = sig + type t type key type value + type param + val known: t -> key -> bool Lwt.t val read: t -> key -> value option Lwt.t val read_exn: t -> key -> value Lwt.t - val prefetch: t -> ?peer:P2p.Peer_id.t -> key -> unit - val fetch: t -> ?peer:P2p.Peer_id.t -> key -> value Lwt.t + + val prefetch: t -> ?peer:P2p.Peer_id.t -> key -> param -> unit + val fetch: t -> ?peer:P2p.Peer_id.t -> key -> param -> value Lwt.t + +end + +module type PARAMETRIZED_DISTRIBUTED_DB = sig + + include PARAMETRIZED_RO_DISTRIBUTED_DB + val commit: t -> key -> unit Lwt.t (* val commit_invalid: t -> key -> unit Lwt.t *) (* TODO *) val inject: t -> key -> value -> bool Lwt.t val watch: t -> (key * value) Lwt_stream.t * Watcher.stopper + +end + +module type DISTRIBUTED_DB = sig + + include PARAMETRIZED_DISTRIBUTED_DB with type param := unit + + val prefetch: t -> ?peer:P2p.Peer_id.t -> key -> unit + val fetch: t -> ?peer:P2p.Peer_id.t -> key -> value Lwt.t + +end + +module type DISK_TABLE = sig + type store + type key + type value + val known: store -> key -> bool Lwt.t + val read: store -> key -> value tzresult Lwt.t + val read_opt: store -> key -> value option Lwt.t + val read_exn: store -> key -> value Lwt.t + val store: store -> key -> value -> bool Lwt.t + val remove: store -> key -> bool Lwt.t +end + +module type MEMORY_TABLE = sig + type 'a t + type key + val create: int -> 'a t + val find: 'a t -> key -> 'a + val add: 'a t -> key -> 'a -> unit + val replace: 'a t -> key -> 'a -> unit + val remove: 'a t -> key -> unit + val fold: (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b end module type SCHEDULER_EVENTS = sig @@ -29,16 +73,27 @@ module type SCHEDULER_EVENTS = sig val notify: t -> P2p.Peer_id.t -> key -> unit val notify_unrequested: t -> P2p.Peer_id.t -> key -> unit val notify_duplicate: t -> P2p.Peer_id.t -> key -> unit + val notify_invalid: t -> P2p.Peer_id.t -> key -> unit +end + +module type PRECHECK = sig + type key + type param + type value + val precheck: key -> param -> value -> bool end module Make_table - (Hash : HASH) - (Disk_table : State.DATA_STORE with type key := Hash.t) - (Memory_table : Hashtbl.S with type key := Hash.t) - (Scheduler : SCHEDULER_EVENTS with type key := Hash.t) : sig + (Hash : sig type t end) + (Disk_table : DISK_TABLE with type key := Hash.t) + (Memory_table : MEMORY_TABLE with type key := Hash.t) + (Scheduler : SCHEDULER_EVENTS with type key := Hash.t) + (Precheck : PRECHECK with type key := Hash.t + and type value := Disk_table.value) : sig - include DISTRIBUTED_DB with type key = Hash.t - and type value = Disk_table.value + include PARAMETRIZED_DISTRIBUTED_DB with type key = Hash.t + and type value = Disk_table.value + and type param = Precheck.param val create: ?global_input:(key * value) Watcher.input -> Scheduler.t -> Disk_table.store -> t @@ -48,6 +103,7 @@ end = struct type key = Hash.t type value = Disk_table.value + type param = Precheck.param type t = { scheduler: Scheduler.t ; @@ -58,7 +114,7 @@ end = struct } and status = - | Pending of value Lwt.u + | Pending of value Lwt.u * param | Found of value let known s k = @@ -79,24 +135,23 @@ end = struct | Found v -> Lwt.return v | Pending _ -> Lwt.fail Not_found - let fetch s ?peer k = + let fetch s ?peer k param = match Memory_table.find s.memory k with | exception Not_found -> begin Disk_table.read_opt s.disk k >>= function | None -> let waiter, wakener = Lwt.wait () in - Memory_table.add s.memory k (Pending wakener) ; + Memory_table.add s.memory k (Pending (wakener, param)) ; Scheduler.request s.scheduler peer k ; waiter | Some v -> Lwt.return v end - | Pending w -> Lwt.waiter_of_wakener w + | Pending (w, _) -> Lwt.waiter_of_wakener w | Found v -> Lwt.return v - let prefetch s ?peer k = Lwt.ignore_result (fetch s ?peer k) + let prefetch s ?peer k param = Lwt.ignore_result (fetch s ?peer k param) let notify s p k v = - Scheduler.notify s.scheduler p k ; match Memory_table.find s.memory k with | exception Not_found -> begin Disk_table.known s.disk k >>= function @@ -107,13 +162,19 @@ end = struct Scheduler.notify_unrequested s.scheduler p k ; Lwt.return_unit end - | Pending w -> - Memory_table.replace s.memory k (Found v) ; - Lwt.wakeup w v ; - iter_option s.global_input - ~f:(fun input -> Watcher.notify input (k, v)) ; - Watcher.notify s.input (k, v) ; - Lwt.return_unit + | Pending (w, param) -> + if not (Precheck.precheck k param v) then begin + Scheduler.notify_invalid s.scheduler p k ; + Lwt.return_unit + end else begin + Scheduler.notify s.scheduler p k ; + Memory_table.replace s.memory k (Found v) ; + Lwt.wakeup w v ; + iter_option s.global_input + ~f:(fun input -> Watcher.notify input (k, v)) ; + Watcher.notify s.input (k, v) ; + Lwt.return_unit + end | Found _ -> Scheduler.notify_duplicate s.scheduler p k ; Lwt.return_unit @@ -137,7 +198,7 @@ end = struct | exception Not_found -> Lwt.return_unit | Pending _ -> assert false | Found v -> - Disk_table.store s.disk v >>= fun _ -> + Disk_table.store s.disk k v >>= fun _ -> Memory_table.remove s.memory k ; Lwt.return_unit @@ -158,8 +219,8 @@ module type REQUEST = sig end module Make_request_scheduler - (Hash : HASH) - (Table : Hashtbl.S with type key := Hash.t) + (Hash : sig type t end) + (Table : MEMORY_TABLE with type key := Hash.t) (Request : REQUEST with type key := Hash.t) : sig type t @@ -181,6 +242,7 @@ end = struct and event = | Request of P2p.Peer_id.t option * key | Notify of P2p.Peer_id.t * key + | Notify_invalid of P2p.Peer_id.t * key | Notify_duplicate of P2p.Peer_id.t * key | Notify_unrequested of P2p.Peer_id.t * key @@ -188,6 +250,8 @@ end = struct t.push_to_worker (Request (p, k)) let notify t p k = t.push_to_worker (Notify (p, k)) + let notify_invalid t p k = + t.push_to_worker (Notify_invalid (p, k)) let notify_duplicate t p k = t.push_to_worker (Notify_duplicate (p, k)) let notify_unrequested t p k = @@ -240,6 +304,7 @@ end = struct | Notify (_gid, key) -> Table.remove state.pending key ; Lwt.return_unit + | Notify_invalid _ | Notify_unrequested _ | Notify_duplicate _ -> (* TODO *) diff --git a/src/node/shell/distributed_db_functors.mli b/src/node/shell/distributed_db_functors.mli index e16e5cd05..1a57848f6 100644 --- a/src/node/shell/distributed_db_functors.mli +++ b/src/node/shell/distributed_db_functors.mli @@ -7,19 +7,65 @@ (* *) (**************************************************************************) -module type DISTRIBUTED_DB = sig +module type PARAMETRIZED_RO_DISTRIBUTED_DB = sig + type t type key type value + type param + val known: t -> key -> bool Lwt.t val read: t -> key -> value option Lwt.t val read_exn: t -> key -> value Lwt.t - val prefetch: t -> ?peer:P2p.Peer_id.t -> key -> unit - val fetch: t -> ?peer:P2p.Peer_id.t -> key -> value Lwt.t + + val prefetch: t -> ?peer:P2p.Peer_id.t -> key -> param -> unit + val fetch: t -> ?peer:P2p.Peer_id.t -> key -> param -> value Lwt.t + +end + +module type PARAMETRIZED_DISTRIBUTED_DB = sig + + include PARAMETRIZED_RO_DISTRIBUTED_DB + val commit: t -> key -> unit Lwt.t (* val commit_invalid: t -> key -> unit Lwt.t *) (* TODO *) val inject: t -> key -> value -> bool Lwt.t val watch: t -> (key * value) Lwt_stream.t * Watcher.stopper + +end + +module type DISTRIBUTED_DB = sig + + include PARAMETRIZED_DISTRIBUTED_DB with type param := unit + + val prefetch: t -> ?peer:P2p.Peer_id.t -> key -> unit + val fetch: t -> ?peer:P2p.Peer_id.t -> key -> value Lwt.t + +end + +module type DISK_TABLE = sig + (* A subtype of State.DATA_STORE *) + type store + type key + type value + val known: store -> key -> bool Lwt.t + val read: store -> key -> value tzresult Lwt.t + val read_opt: store -> key -> value option Lwt.t + val read_exn: store -> key -> value Lwt.t + val store: store -> key -> value -> bool Lwt.t + val remove: store -> key -> bool Lwt.t +end + +module type MEMORY_TABLE = sig + (* A subtype of Hashtbl.S *) + type 'a t + type key + val create: int -> 'a t + val find: 'a t -> key -> 'a + val add: 'a t -> key -> 'a -> unit + val replace: 'a t -> key -> 'a -> unit + val remove: 'a t -> key -> unit + val fold: (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b end module type SCHEDULER_EVENTS = sig @@ -29,16 +75,27 @@ module type SCHEDULER_EVENTS = sig val notify: t -> P2p.Peer_id.t -> key -> unit val notify_unrequested: t -> P2p.Peer_id.t -> key -> unit val notify_duplicate: t -> P2p.Peer_id.t -> key -> unit + val notify_invalid: t -> P2p.Peer_id.t -> key -> unit +end + +module type PRECHECK = sig + type key + type param + type value + val precheck: key -> param -> value -> bool end module Make_table - (Hash : HASH) - (Disk_table : State.DATA_STORE with type key := Hash.t) - (Memory_table : Hashtbl.S with type key := Hash.t) - (Scheduler : SCHEDULER_EVENTS with type key := Hash.t) : sig + (Hash : sig type t end) + (Disk_table : DISK_TABLE with type key := Hash.t) + (Memory_table : MEMORY_TABLE with type key := Hash.t) + (Scheduler : SCHEDULER_EVENTS with type key := Hash.t) + (Precheck : PRECHECK with type key := Hash.t + and type value := Disk_table.value) : sig - include DISTRIBUTED_DB with type key = Hash.t - and type value = Disk_table.value + include PARAMETRIZED_DISTRIBUTED_DB with type key = Hash.t + and type value = Disk_table.value + and type param := Precheck.param val create: ?global_input:(key * value) Watcher.input -> Scheduler.t -> Disk_table.store -> t @@ -54,8 +111,8 @@ module type REQUEST = sig end module Make_request_scheduler - (Hash : HASH) - (Table : Hashtbl.S with type key := Hash.t) + (Hash : sig type t end) + (Table : MEMORY_TABLE with type key := Hash.t) (Request : REQUEST with type key := Hash.t) : sig type t diff --git a/src/node/shell/node.ml b/src/node/shell/node.ml index d2f6f3ad5..f2f5d5c5c 100644 --- a/src/node/shell/node.ml +++ b/src/node/shell/node.ml @@ -33,7 +33,7 @@ let inject_protocol state ?force:_ proto = "Compilation failed (%a)" Protocol_hash.pp_short hash | true -> - State.Protocol.store state proto >>= function + State.Protocol.store state hash proto >>= function | false -> failwith "Previously registred protocol (%a)" diff --git a/src/node/shell/state.ml b/src/node/shell/state.ml index 343f650e1..71757001d 100644 --- a/src/node/shell/state.ml +++ b/src/node/shell/state.ml @@ -176,7 +176,7 @@ module type DATA_STORE = sig val read_discovery_time_opt: store -> key -> Time.t option Lwt.t val read_discovery_time_exn: store -> key -> Time.t Lwt.t - val store: store -> value -> bool Lwt.t + val store: store -> key -> value -> bool Lwt.t val store_raw: store -> key -> MBytes.t -> value option tzresult Lwt.t val remove: store -> key -> bool Lwt.t @@ -263,14 +263,12 @@ end = struct S.Contents.read_opt (s, k) >>= function | None -> Lwt.return_none | Some v -> Lwt.return (Some { Time.data = Ok v ; time }) - let store s v = - let bytes = Data_encoding.Binary.to_bytes S.encoding v in - let k = S.hash_raw bytes in + let store s k v = S.Discovery_time.known s k >>= function | true -> Lwt.return_false | false -> let time = Time.now () in - S.RawContents.store (s, k) bytes >>= fun () -> + S.Contents.store (s, k) v >>= fun () -> S.Discovery_time.store s k time >>= fun () -> S.Pending.store s k >>= fun () -> Lwt.return_true @@ -366,7 +364,7 @@ end = struct let read_discovery_time = atomic2 Locked.read_discovery_time let read_discovery_time_opt = atomic2 Locked.read_discovery_time_opt let read_discovery_time_exn = atomic2 Locked.read_discovery_time_exn - let store = atomic2 Locked.store + let store = atomic3 Locked.store let store_raw = atomic3 Locked.store_raw let remove = atomic2 Locked.remove let mark_valid = atomic2 Locked.mark_valid @@ -443,7 +441,7 @@ module Raw_block_header = struct } in Locked.store_raw store genesis.block bytes >>= fun _created -> Lwt.return shell - + end module Raw_helpers = struct @@ -901,17 +899,17 @@ module Valid_block = struct let store net hash context = Shared.use net.state begin fun net_state -> Shared.use net.block_header_store begin fun block_header_store -> - Context.exists net_state.context_index hash >>= function - | true -> return None (* Previously stored context. *) - | false -> - Raw_block_header.Locked.invalid - block_header_store hash >>= function - | Some _ -> return None (* Previously invalidated block. *) - | None -> - Locked.store - block_header_store net_state net.valid_block_watcher - hash context net.forked_network_ttl >>=? fun valid_block -> - return (Some valid_block) + Context.exists net_state.context_index hash >>= function + | true -> return None (* Previously stored context. *) + | false -> + Raw_block_header.Locked.invalid + block_header_store hash >>= function + | Some _ -> return None (* Previously invalidated block. *) + | None -> + Locked.store + block_header_store net_state net.valid_block_watcher + hash context net.forked_network_ttl >>=? fun valid_block -> + return (Some valid_block) end end diff --git a/src/node/shell/state.mli b/src/node/shell/state.mli index 8e2c314e9..4f325e61e 100644 --- a/src/node/shell/state.mli +++ b/src/node/shell/state.mli @@ -119,7 +119,7 @@ module type DATA_STORE = sig returns [false] when the value is already stored, or [true] otherwise. For a given value, only one call to `store` (or an equivalent call to `store_raw`) might return [true]. *) - val store: store -> value -> bool Lwt.t + val store: store -> key -> value -> bool Lwt.t (** Store a value in the local database (unparsed data). It returns [Ok None] when the data is already stored, or [Ok (Some (hash, From 618fb641293314ac46b762ef67974317867e8c63 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Gr=C3=A9goire=20Henry?= Date: Thu, 30 Mar 2017 13:08:33 +0200 Subject: [PATCH 4/5] Client/RPC: rename `wait` into `async` --- src/client/client_node_rpcs.ml | 12 ++++++------ src/client/client_node_rpcs.mli | 10 +++++----- .../alpha/baker/client_mining_endorsement.ml | 8 ++++---- .../embedded/alpha/baker/client_mining_forge.ml | 2 +- .../embedded/alpha/baker/client_mining_revelation.ml | 7 +++---- .../alpha/baker/client_mining_revelation.mli | 2 +- src/client/embedded/alpha/client_proto_context.ml | 6 +++--- src/client/embedded/demo/client_proto_main.ml | 2 +- src/client/embedded/genesis/client_proto_main.ml | 2 +- 9 files changed, 25 insertions(+), 26 deletions(-) diff --git a/src/client/client_node_rpcs.ml b/src/client/client_node_rpcs.ml index 3df77846d..e10889294 100644 --- a/src/client/client_node_rpcs.ml +++ b/src/client/client_node_rpcs.ml @@ -135,12 +135,12 @@ let forge_block cctxt ?net ?predecessor ?timestamp fitness ops header = (net, predecessor, timestamp, fitness, ops, header) let validate_block cctxt net block = call_service0 cctxt Services.validate_block (net, block) -let inject_block cctxt ?(wait = true) ?force block = - call_service0 cctxt Services.inject_block (block, wait, force) -let inject_operation cctxt ?(wait = true) ?force operation = - call_service0 cctxt Services.inject_operation (operation, wait, force) -let inject_protocol cctxt ?(wait = true) ?force protocol = - call_service0 cctxt Services.inject_protocol (protocol, wait, force) +let inject_block cctxt ?(async = false) ?force block = + call_service0 cctxt Services.inject_block (block, not async, force) +let inject_operation cctxt ?(async = false) ?force operation = + call_service0 cctxt Services.inject_operation (operation, not async, force) +let inject_protocol cctxt ?(async = false) ?force protocol = + call_service0 cctxt Services.inject_protocol (protocol, not async, force) let bootstrapped cctxt = call_streamed_service0 cctxt Services.bootstrapped () let complete cctxt ?block prefix = diff --git a/src/client/client_node_rpcs.mli b/src/client/client_node_rpcs.mli index cca41fb19..daa331e01 100644 --- a/src/client/client_node_rpcs.mli +++ b/src/client/client_node_rpcs.mli @@ -33,24 +33,24 @@ val validate_block: val inject_block: Client_commands.context -> - ?wait:bool -> ?force:bool -> + ?async:bool -> ?force:bool -> MBytes.t -> Block_hash.t tzresult Lwt.t -(** [inject_block cctxt ?wait ?force raw_block] tries to inject - [raw_block] inside the node. If [?wait] is [true], [raw_block] +(** [inject_block cctxt ?async ?force raw_block] tries to inject + [raw_block] inside the node. If [?async] is [true], [raw_block] will be validated before the result is returned. If [?force] is true, the block will be injected even on non strictly increasing fitness. *) val inject_operation: Client_commands.context -> - ?wait:bool -> ?force:bool -> + ?async:bool -> ?force:bool -> MBytes.t -> Operation_hash.t tzresult Lwt.t val inject_protocol: Client_commands.context -> - ?wait:bool -> ?force:bool -> + ?async:bool -> ?force:bool -> Tezos_compiler.Protocol.t -> Protocol_hash.t tzresult Lwt.t diff --git a/src/client/embedded/alpha/baker/client_mining_endorsement.ml b/src/client/embedded/alpha/baker/client_mining_endorsement.ml index 5f580858f..a057c6264 100644 --- a/src/client/embedded/alpha/baker/client_mining_endorsement.ml +++ b/src/client/embedded/alpha/baker/client_mining_endorsement.ml @@ -116,7 +116,7 @@ let get_signing_slots cctxt ?max_priority block delegate level = return slots let inject_endorsement cctxt - block level ?wait ?force + block level ?async ?force src_sk source slot = Client_blocks.get_block_hash cctxt block >>= fun block_hash -> Client_node_rpcs.Blocks.net cctxt block >>= fun net -> @@ -129,7 +129,7 @@ let inject_endorsement cctxt () >>=? fun bytes -> let signed_bytes = Ed25519.Signature.append src_sk bytes in Client_node_rpcs.inject_operation - cctxt ?force ?wait signed_bytes >>=? fun oph -> + cctxt ?force ?async signed_bytes >>=? fun oph -> State.record_endorsement cctxt level block_hash slot oph >>=? fun () -> return oph @@ -173,7 +173,7 @@ let forge_endorsement cctxt else check_endorsement cctxt level slot end >>=? fun () -> inject_endorsement cctxt - block level ~wait:true ~force + block level ~force src_sk src_pk slot @@ -316,7 +316,7 @@ let endorse cctxt state = lwt_debug "Endorsing %a for %s (slot %d)!" Block_hash.pp_short hash name slot >>= fun () -> inject_endorsement cctxt - b level ~wait:false ~force:true + b level ~async:true ~force:true sk pk slot >>=? fun oph -> cctxt.message "Injected endorsement for block '%a' \ diff --git a/src/client/embedded/alpha/baker/client_mining_forge.ml b/src/client/embedded/alpha/baker/client_mining_forge.ml index 1ea1d87c6..23e67ee19 100644 --- a/src/client/embedded/alpha/baker/client_mining_forge.ml +++ b/src/client/embedded/alpha/baker/client_mining_forge.ml @@ -65,7 +65,7 @@ let inject_block cctxt block () >>=? fun unsigned_header -> let signed_header = Ed25519.Signature.append src_sk unsigned_header in Client_node_rpcs.inject_block cctxt - ~wait:true ?force signed_header >>=? fun block_hash -> + ?force signed_header >>=? fun block_hash -> return block_hash let forge_block cctxt block diff --git a/src/client/embedded/alpha/baker/client_mining_revelation.ml b/src/client/embedded/alpha/baker/client_mining_revelation.ml index a2fd5cc9b..03cec8468 100644 --- a/src/client/embedded/alpha/baker/client_mining_revelation.ml +++ b/src/client/embedded/alpha/baker/client_mining_revelation.ml @@ -11,7 +11,7 @@ open Cli_entries open Tezos_context open Logging.Client.Revelation -let inject_seed_nonce_revelation cctxt block ?force ?wait nonces = +let inject_seed_nonce_revelation cctxt block ?force ?async nonces = let operations = List.map (fun (level, nonce) -> @@ -19,7 +19,7 @@ let inject_seed_nonce_revelation cctxt block ?force ?wait nonces = Client_node_rpcs.Blocks.net cctxt block >>= fun net -> Client_proto_rpcs.Helpers.Forge.Anonymous.operations cctxt block ~net operations >>=? fun bytes -> - Client_node_rpcs.inject_operation cctxt ?force ?wait bytes >>=? fun oph -> + Client_node_rpcs.inject_operation cctxt ?force ?async bytes >>=? fun oph -> return oph type Error_monad.error += Bad_revelation @@ -34,8 +34,7 @@ let forge_seed_nonce_revelation Block_hash.pp_short hash >>= fun () -> return () | _ -> - inject_seed_nonce_revelation cctxt - block ~force ~wait:true nonces >>=? fun oph -> + inject_seed_nonce_revelation cctxt block ~force nonces >>=? fun oph -> cctxt.answer "Operation successfully injected %d revelation(s) for %a." (List.length nonces) diff --git a/src/client/embedded/alpha/baker/client_mining_revelation.mli b/src/client/embedded/alpha/baker/client_mining_revelation.mli index 06b52b91a..8f6642bb6 100644 --- a/src/client/embedded/alpha/baker/client_mining_revelation.mli +++ b/src/client/embedded/alpha/baker/client_mining_revelation.mli @@ -11,7 +11,7 @@ val inject_seed_nonce_revelation: Client_commands.context -> Client_proto_rpcs.block -> ?force:bool -> - ?wait:bool -> + ?async:bool -> (Raw_level.t * Nonce.t) list -> Operation_hash.t tzresult Lwt.t diff --git a/src/client/embedded/alpha/client_proto_context.ml b/src/client/embedded/alpha/client_proto_context.ml index a66cb1487..6a36fbf23 100644 --- a/src/client/embedded/alpha/client_proto_context.ml +++ b/src/client/embedded/alpha/client_proto_context.ml @@ -104,7 +104,7 @@ let transfer cctxt let oph = Operation_hash.hash_bytes [ signed_bytes ] in Client_proto_rpcs.Helpers.apply_operation cctxt block predecessor oph bytes (Some signature) >>=? fun contracts -> - Client_node_rpcs.inject_operation cctxt ?force ~wait:true signed_bytes >>=? fun injected_oph -> + Client_node_rpcs.inject_operation cctxt ?force signed_bytes >>=? fun injected_oph -> assert (Operation_hash.equal oph injected_oph) ; cctxt.message "Operation successfully injected in the node." >>= fun () -> cctxt.message "Operation hash is '%a'." Operation_hash.pp oph >>= fun () -> @@ -121,7 +121,7 @@ let originate cctxt ?force ~block ?signature bytes = Client_proto_rpcs.Helpers.apply_operation cctxt block predecessor oph bytes signature >>=? function | [ contract ] -> - Client_node_rpcs.inject_operation cctxt ?force ~wait:true signed_bytes >>=? fun injected_oph -> + Client_node_rpcs.inject_operation cctxt ?force signed_bytes >>=? fun injected_oph -> assert (Operation_hash.equal oph injected_oph) ; cctxt.message "Operation successfully injected in the node." >>= fun () -> cctxt.message "Operation hash is '%a'." Operation_hash.pp oph >>= fun () -> @@ -176,7 +176,7 @@ let dictate cctxt block command seckey = let signature = Ed25519.sign seckey bytes in let signed_bytes = MBytes.concat bytes signature in let oph = Operation_hash.hash_bytes [ signed_bytes ] in - Client_node_rpcs.inject_operation cctxt ~wait:true signed_bytes >>=? fun injected_oph -> + Client_node_rpcs.inject_operation cctxt signed_bytes >>=? fun injected_oph -> assert (Operation_hash.equal oph injected_oph) ; cctxt.message "Operation successfully injected in the node." >>= fun () -> cctxt.message "Operation hash is '%a'." Operation_hash.pp oph >>= fun () -> diff --git a/src/client/embedded/demo/client_proto_main.ml b/src/client/embedded/demo/client_proto_main.ml index 8e71da3b0..6be920d84 100644 --- a/src/client/embedded/demo/client_proto_main.ml +++ b/src/client/embedded/demo/client_proto_main.ml @@ -53,7 +53,7 @@ let mine cctxt = Client_node_rpcs.forge_block cctxt ~net:bi.net ~predecessor:bi.hash fitness [] (MBytes.create 0) >>= fun bytes -> - Client_node_rpcs.inject_block cctxt ~wait:true bytes >>=? fun hash -> + Client_node_rpcs.inject_block cctxt bytes >>=? fun hash -> cctxt.answer "Injected %a" Block_hash.pp_short hash >>= fun () -> return () diff --git a/src/client/embedded/genesis/client_proto_main.ml b/src/client/embedded/genesis/client_proto_main.ml index 8ffda3707..e8dea57da 100644 --- a/src/client/embedded/genesis/client_proto_main.ml +++ b/src/client/embedded/genesis/client_proto_main.ml @@ -29,7 +29,7 @@ let mine cctxt ?timestamp block command fitness seckey = Client_blocks.get_block_info cctxt block >>= fun bi -> forge_block cctxt ?timestamp block bi.net command fitness >>= fun blk -> let signed_blk = Environment.Ed25519.Signature.append seckey blk in - Client_node_rpcs.inject_block cctxt ~wait:true signed_blk >>=? fun hash -> + Client_node_rpcs.inject_block cctxt signed_blk >>=? fun hash -> cctxt.answer "Injected %a" Block_hash.pp_short hash >>= fun () -> return () From 245fa66140f7d4ecd738481f9820110703de6e66 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Gr=C3=A9goire=20Henry?= Date: Thu, 30 Mar 2017 13:16:21 +0200 Subject: [PATCH 5/5] Shell: Split the operations list out of the (minimal) block header. The minimal header now (classically) contains the root of a Merkle tree, wrapping a list of lists of operations. Currently, the validator only accept a single list of operations, but the 3+pass validator will requires at least two lists. --- src/client/client_node_rpcs.ml | 8 +- src/client/client_node_rpcs.mli | 11 +- .../alpha/baker/client_mining_forge.ml | 15 +- .../alpha/baker/client_mining_forge.mli | 2 +- .../alpha/baker/client_mining_operations.ml | 2 +- .../embedded/alpha/client_proto_rpcs.mli | 2 +- src/client/embedded/demo/client_proto_main.ml | 4 +- .../embedded/genesis/client_proto_main.ml | 34 +-- src/node/db/raw_store.ml | 14 ++ src/node/db/store.ml | 48 +++- src/node/db/store.mli | 16 +- src/node/db/store_helpers.ml | 9 + src/node/db/store_helpers.mli | 2 + src/node/shell/distributed_db.ml | 162 +++++++++++- src/node/shell/distributed_db.mli | 32 ++- src/node/shell/distributed_db_message.ml | 26 +- src/node/shell/distributed_db_message.mli | 4 + src/node/shell/node.ml | 18 +- src/node/shell/node.mli | 5 +- src/node/shell/node_rpc.ml | 24 +- src/node/shell/node_rpc_services.ml | 120 +++++---- src/node/shell/node_rpc_services.mli | 20 +- src/node/shell/prevalidator.ml | 16 +- src/node/shell/state.ml | 233 ++++++++++++++++-- src/node/shell/state.mli | 39 ++- src/node/shell/validator.ml | 44 +++- src/node/shell/validator.mli | 3 +- src/node/updater/protocol.mli | 4 +- src/node/updater/updater.ml | 4 +- src/node/updater/updater.mli | 4 +- src/proto/alpha/services.ml | 2 +- src/proto/environment/updater.mli | 4 +- src/proto/genesis/services.ml | 7 +- test/lib/assert.ml | 4 +- test/test_state.ml | 21 +- test/test_store.ml | 5 +- 36 files changed, 781 insertions(+), 187 deletions(-) diff --git a/src/client/client_node_rpcs.ml b/src/client/client_node_rpcs.ml index e10889294..d1ef7f894 100644 --- a/src/client/client_node_rpcs.ml +++ b/src/client/client_node_rpcs.ml @@ -135,8 +135,9 @@ let forge_block cctxt ?net ?predecessor ?timestamp fitness ops header = (net, predecessor, timestamp, fitness, ops, header) let validate_block cctxt net block = call_service0 cctxt Services.validate_block (net, block) -let inject_block cctxt ?(async = false) ?force block = - call_service0 cctxt Services.inject_block (block, not async, force) +let inject_block cctxt ?(async = false) ?(force = false) raw operations = + call_service0 cctxt Services.inject_block + { raw ; blocking = not async ; force ; operations } let inject_operation cctxt ?(async = false) ?force operation = call_service0 cctxt Services.inject_operation (operation, not async, force) let inject_protocol cctxt ?(async = false) ?force protocol = @@ -163,7 +164,8 @@ module Blocks = struct fitness: MBytes.t list ; timestamp: Time.t ; protocol: Protocol_hash.t option ; - operations: Operation_hash.t list option ; + operations_hash: Operation_list_list_hash.t ; + operations: Operation_hash.t list list option ; data: MBytes.t option ; net: Updater.Net_id.t ; test_protocol: Protocol_hash.t option ; diff --git a/src/client/client_node_rpcs.mli b/src/client/client_node_rpcs.mli index daa331e01..80660d008 100644 --- a/src/client/client_node_rpcs.mli +++ b/src/client/client_node_rpcs.mli @@ -17,7 +17,7 @@ val forge_block: ?predecessor:Block_hash.t -> ?timestamp:Time.t -> Fitness.fitness -> - Operation_hash.t list -> + Operation_list_list_hash.t -> MBytes.t -> MBytes.t Lwt.t (** [forge_block cctxt ?net ?predecessor ?timestamp fitness ops @@ -34,7 +34,7 @@ val validate_block: val inject_block: Client_commands.context -> ?async:bool -> ?force:bool -> - MBytes.t -> + MBytes.t -> Operation_hash.t list list -> Block_hash.t tzresult Lwt.t (** [inject_block cctxt ?async ?force raw_block] tries to inject [raw_block] inside the node. If [?async] is [true], [raw_block] @@ -83,7 +83,7 @@ module Blocks : sig block -> MBytes.t list Lwt.t val operations: Client_commands.context -> - block -> Operation_hash.t list Lwt.t + block -> Operation_hash.t list list Lwt.t val protocol: Client_commands.context -> block -> Protocol_hash.t Lwt.t @@ -104,7 +104,8 @@ module Blocks : sig fitness: MBytes.t list ; timestamp: Time.t ; protocol: Protocol_hash.t option ; - operations: Operation_hash.t list option ; + operations_hash: Operation_list_list_hash.t ; + operations: Operation_hash.t list list option ; data: MBytes.t option ; net: Updater.Net_id.t ; test_protocol: Protocol_hash.t option ; @@ -146,7 +147,7 @@ module Operations : sig val monitor: Client_commands.context -> ?contents:bool -> unit -> - (Operation_hash.t * Store.Operation.t option) list Lwt_stream.t Lwt.t + (Operation_hash.t * Store.Operation.t option) list list Lwt_stream.t Lwt.t end module Protocols : sig diff --git a/src/client/embedded/alpha/baker/client_mining_forge.ml b/src/client/embedded/alpha/baker/client_mining_forge.ml index 23e67ee19..a276f787d 100644 --- a/src/client/embedded/alpha/baker/client_mining_forge.ml +++ b/src/client/embedded/alpha/baker/client_mining_forge.ml @@ -40,11 +40,14 @@ let rec compute_stamp let inject_block cctxt block ?force ~priority ~timestamp ~fitness ~seed_nonce - ~src_sk operations = + ~src_sk operation_list = let block = match block with `Prevalidation -> `Head 0 | block -> block in Client_node_rpcs.Blocks.info cctxt block >>= fun bi -> let seed_nonce_hash = Nonce.hash seed_nonce in Client_proto_rpcs.Context.next_level cctxt block >>=? fun level -> + let operations = + Operation_list_list_hash.compute + (List.map Operation_list_hash.compute operation_list) in let shell = { Store.Block_header.net_id = bi.net ; predecessor = bi.hash ; timestamp ; fitness ; operations } in @@ -65,7 +68,7 @@ let inject_block cctxt block () >>=? fun unsigned_header -> let signed_header = Ed25519.Signature.append src_sk unsigned_header in Client_node_rpcs.inject_block cctxt - ?force signed_header >>=? fun block_hash -> + ?force signed_header operation_list >>=? fun block_hash -> return block_hash let forge_block cctxt block @@ -138,7 +141,8 @@ let forge_block cctxt block && Operation_hash.Map.is_empty operations.branch_refused && Operation_hash.Map.is_empty operations.branch_delayed ) then inject_block cctxt ?force ~src_sk - ~priority ~timestamp ~fitness ~seed_nonce block operations.applied + ~priority ~timestamp ~fitness ~seed_nonce block + [operations.applied] else failwith "Cannot (fully) validate the given operations." @@ -436,8 +440,9 @@ let mine cctxt state = Fitness.pp fitness >>= fun () -> let seed_nonce = generate_seed_nonce () in Client_keys.get_key cctxt delegate >>=? fun (_,_,src_sk) -> - inject_block cctxt ~force:true ~src_sk ~priority ~timestamp ~fitness ~seed_nonce - (`Hash bi.hash) operations.applied + inject_block cctxt + ~force:true ~src_sk ~priority ~timestamp ~fitness ~seed_nonce + (`Hash bi.hash) [operations.applied] |> trace_exn (Failure "Error while injecting block") >>=? fun block_hash -> State.record_block cctxt level block_hash seed_nonce |> trace_exn (Failure "Error while recording block") >>=? fun () -> diff --git a/src/client/embedded/alpha/baker/client_mining_forge.mli b/src/client/embedded/alpha/baker/client_mining_forge.mli index 97c36c6cb..3d9e907ab 100644 --- a/src/client/embedded/alpha/baker/client_mining_forge.mli +++ b/src/client/embedded/alpha/baker/client_mining_forge.mli @@ -22,7 +22,7 @@ val inject_block: fitness:Fitness.t -> seed_nonce:Nonce.t -> src_sk:secret_key -> - Operation_hash.t list -> + Operation_hash.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 diff --git a/src/client/embedded/alpha/baker/client_mining_operations.ml b/src/client/embedded/alpha/baker/client_mining_operations.ml index d7815f78b..13e6969bd 100644 --- a/src/client/embedded/alpha/baker/client_mining_operations.ml +++ b/src/client/embedded/alpha/baker/client_mining_operations.ml @@ -34,7 +34,7 @@ let monitor cctxt ?contents ?check () = "@[Error while parsing operations@,%a@[" pp_print_error err >>= fun () -> Lwt.return None) - ops + (List.concat ops) in Lwt.return (Lwt_stream.map_s convert ops_stream) diff --git a/src/client/embedded/alpha/client_proto_rpcs.mli b/src/client/embedded/alpha/client_proto_rpcs.mli index 90dcedae8..f405333a2 100644 --- a/src/client/embedded/alpha/client_proto_rpcs.mli +++ b/src/client/embedded/alpha/client_proto_rpcs.mli @@ -314,7 +314,7 @@ module Helpers : sig predecessor:Block_hash.t -> timestamp:Time.t -> fitness:Fitness.t -> - operations:Operation_hash.t list -> + operations:Operation_list_list_hash.t -> level:Raw_level.t -> priority:int -> seed_nonce_hash:Nonce_hash.t -> diff --git a/src/client/embedded/demo/client_proto_main.ml b/src/client/embedded/demo/client_proto_main.ml index 6be920d84..2a057ad1d 100644 --- a/src/client/embedded/demo/client_proto_main.ml +++ b/src/client/embedded/demo/client_proto_main.ml @@ -52,8 +52,8 @@ let mine cctxt = exit 2 in Client_node_rpcs.forge_block cctxt ~net:bi.net ~predecessor:bi.hash - fitness [] (MBytes.create 0) >>= fun bytes -> - Client_node_rpcs.inject_block cctxt bytes >>=? fun hash -> + fitness Operation_list_list_hash.empty (MBytes.create 0) >>= fun bytes -> + Client_node_rpcs.inject_block cctxt bytes [] >>=? fun hash -> cctxt.answer "Injected %a" Block_hash.pp_short hash >>= fun () -> return () diff --git a/src/client/embedded/genesis/client_proto_main.ml b/src/client/embedded/genesis/client_proto_main.ml index e8dea57da..c4b0c441a 100644 --- a/src/client/embedded/genesis/client_proto_main.ml +++ b/src/client/embedded/genesis/client_proto_main.ml @@ -29,7 +29,7 @@ let mine cctxt ?timestamp block command fitness seckey = Client_blocks.get_block_info cctxt block >>= fun bi -> forge_block cctxt ?timestamp block bi.net command fitness >>= fun blk -> let signed_blk = Environment.Ed25519.Signature.append seckey blk in - Client_node_rpcs.inject_block cctxt signed_blk >>=? fun hash -> + Client_node_rpcs.inject_block cctxt signed_blk [[]] >>=? fun hash -> cctxt.answer "Injected %a" Block_hash.pp_short hash >>= fun () -> return () @@ -48,6 +48,7 @@ let commands () = "Set the timestamp of the block (and initial time of the chain)" ] in let open Cli_entries in [ + command ~args ~desc: "Activate a protocol" begin prefixes [ "activate" ; "protocol" ] @@ param ~name:"version" ~desc:"Protocol version (b58check)" @@ -60,16 +61,16 @@ let commands () = Client_keys.Secret_key.source_param ~name:"password" ~desc:"Dictator's key" @@ stop - end - (fun hash fitness seckey cctxt -> + end begin fun hash fitness seckey cctxt -> let timestamp = !timestamp in let fitness = Client_embedded_proto_alpha.Fitness_repr.from_int64 fitness in mine cctxt ?timestamp cctxt.config.block (Activate hash) fitness seckey >>= - handle_error cctxt) - ; - command ~args ~desc: "Fork a test protocol" begin + handle_error cctxt + end ; + + command ~args ~desc: "Fork a test protocol" begin prefixes [ "fork" ; "test" ; "protocol" ] @@ param ~name:"version" ~desc:"Protocol version (b58check)" (fun _ p -> Lwt.return (Protocol_hash.of_b58check p)) @@ @@ -80,16 +81,17 @@ let commands () = prefixes [ "and" ; "key" ] @@ param ~name:"password" ~desc:"Dictator's key" (fun _ key -> - Lwt.return (Environment.Ed25519.Secret_key.of_b58check key)) - stop - end - (fun hash fitness seckey cctxt -> - let timestamp = !timestamp in - let fitness = - Client_embedded_proto_alpha.Fitness_repr.from_int64 fitness in - mine cctxt ?timestamp cctxt.config.block - (Activate_testnet hash) fitness seckey >>= - handle_error cctxt) ; + Lwt.return (Environment.Ed25519.Secret_key.of_b58check key)) @@ + stop + end begin fun hash fitness seckey cctxt -> + let timestamp = !timestamp in + let fitness = + Client_embedded_proto_alpha.Fitness_repr.from_int64 fitness in + mine cctxt ?timestamp cctxt.config.block + (Activate_testnet hash) fitness seckey >>= + handle_error cctxt + end ; + ] let () = diff --git a/src/node/db/raw_store.ml b/src/node/db/raw_store.ml index 55b337676..e5210daad 100644 --- a/src/node/db/raw_store.ml +++ b/src/node/db/raw_store.ml @@ -49,6 +49,20 @@ let read_opt s k = type error += Unknown of string list +let () = + Error_monad.register_error_kind + `Permanent + ~id:"store.unkown_key" + ~title:"Unknown key in store" + ~description: "" + ~pp:(fun ppf key -> + Format.fprintf ppf + "@[Unknown key %s@]" + (String.concat "/" key)) + Data_encoding.(obj1 (req "key" (list string))) + (function Unknown key -> Some key | _ -> None) + (fun key -> Unknown key) + let read t key = read_opt t key >>= function | None -> fail (Unknown key) diff --git a/src/node/db/store.ml b/src/node/db/store.ml index 60d9e757d..7b4293263 100644 --- a/src/node/db/store.ml +++ b/src/node/db/store.ml @@ -283,23 +283,23 @@ module Block_header = struct net_id: Net_id.t ; predecessor: Block_hash.t ; timestamp: Time.t ; + operations: Operation_list_list_hash.t ; fitness: MBytes.t list ; - operations: Operation_hash.t list ; } let shell_header_encoding = let open Data_encoding in conv - (fun { net_id ; predecessor ; timestamp ; fitness ; operations } -> - (net_id, predecessor, timestamp, fitness, operations)) - (fun (net_id, predecessor, timestamp, fitness, operations) -> - { net_id ; predecessor ; timestamp ; fitness ; operations }) + (fun { net_id ; predecessor ; timestamp ; operations ; fitness } -> + (net_id, predecessor, timestamp, operations, fitness)) + (fun (net_id, predecessor, timestamp, operations, fitness) -> + { net_id ; predecessor ; timestamp ; operations ; fitness }) (obj5 (req "net_id" Net_id.encoding) (req "predecessor" Block_hash.encoding) (req "timestamp" Time.encoding) - (req "fitness" Fitness.encoding) - (req "operations" (list Operation_hash.encoding))) + (req "operations" Operation_list_list_hash.encoding) + (req "fitness" Fitness.encoding)) module Encoding = struct type t = { @@ -329,7 +329,7 @@ module Block_header = struct 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 () -> - list Operation_hash.compare + Operation_list_list_hash.compare b1.shell.operations b2.shell.operations >> fun () -> Time.compare b1.shell.timestamp b2.shell.timestamp >> fun () -> list compare b1.shell.fitness b2.shell.fitness @@ -349,6 +349,38 @@ module Block_header = struct (Value) (Block_hash.Set) + module Operation_list_count = + Store_helpers.Make_single_store + (Indexed_store.Store) + (struct let name = ["operation_list_count"] end) + (Store_helpers.Make_value(struct + type t = int + let encoding = Data_encoding.int8 + end)) + + module Operations_index = + Store_helpers.Make_indexed_substore + (Store_helpers.Make_substore + (Indexed_store.Store) + (struct let name = ["operations"] end)) + (Store_helpers.Integer_index) + + module Operation_list = + Operations_index.Make_map + (struct let name = ["list"] end) + (Store_helpers.Make_value(struct + type t = Operation_hash.t list + let encoding = Data_encoding.list Operation_hash.encoding + end)) + + module Operation_list_path = + Operations_index.Make_map + (struct let name = ["path"] end) + (Store_helpers.Make_value(struct + type t = Operation_list_list_hash.path + let encoding = Operation_list_list_hash.path_encoding + end)) + end diff --git a/src/node/db/store.mli b/src/node/db/store.mli index b5c3d1223..0bfc19d33 100644 --- a/src/node/db/store.mli +++ b/src/node/db/store.mli @@ -187,8 +187,8 @@ module Block_header : sig net_id: Net_id.t ; predecessor: Block_hash.t ; timestamp: Time.t ; + operations: Operation_list_list_hash.t ; fitness: MBytes.t list ; - operations: Operation_hash.t list ; } val shell_header_encoding: shell_header Data_encoding.t @@ -206,6 +206,20 @@ module Block_header : sig and type value = t and type key_set = Block_hash.Set.t + module Operation_list_count : SINGLE_STORE + with type t = store * Block_hash.t + and type value = int + + module Operation_list : MAP_STORE + with type t = store * Block_hash.t + and type key = int + and type value = Operation_hash.t list + + module Operation_list_path : MAP_STORE + with type t = store * Block_hash.t + and type key = int + and type value = Operation_list_list_hash.path + end diff --git a/src/node/db/store_helpers.ml b/src/node/db/store_helpers.ml index c0699789a..5105dc68c 100644 --- a/src/node/db/store_helpers.ml +++ b/src/node/db/store_helpers.ml @@ -360,3 +360,12 @@ module Make_buffered_map (fun k v acc -> let res = store s k v in acc >>= fun () -> res) map Lwt.return_unit end + +module Integer_index = struct + type t = int + let path_length = 1 + let to_path x = [string_of_int x] + let of_path = function + | [x] -> begin try Some (int_of_string x) with _ -> None end + | _ -> None +end diff --git a/src/node/db/store_helpers.mli b/src/node/db/store_helpers.mli index f65007611..0e831f46a 100644 --- a/src/node/db/store_helpers.mli +++ b/src/node/db/store_helpers.mli @@ -43,3 +43,5 @@ module Make_buffered_map module Make_indexed_substore (S : STORE) (I : INDEX) : INDEXED_STORE with type t = S.t and type key = I.t + +module Integer_index : INDEX with type t = int diff --git a/src/node/shell/distributed_db.ml b/src/node/shell/distributed_db.ml index 1d6cafca3..d2b56e8b3 100644 --- a/src/node/shell/distributed_db.ml +++ b/src/node/shell/distributed_db.ml @@ -102,6 +102,26 @@ module Operation_list_table = Block_hash.equal b1 b2 && i1 = i2 end) +module Raw_operation_list = + Make_raw + (struct type t = Block_hash.t * int end) + (State.Operation_list) + (Operation_list_table) + (struct + type param = Net_id.t + let forge net_id keys = + Message.Get_operation_list (net_id, keys) + end) + (struct + type param = Operation_list_list_hash.t + let precheck (_block, expected_ofs) expected_hash (ops, path) = + let received_hash, received_ofs = + Operation_list_list_hash.check_path path + (Operation_list_hash.compute ops) in + received_ofs = expected_ofs && + Operation_list_list_hash.compare expected_hash received_hash = 0 + end) + module Raw_protocol = Make_raw (Protocol_hash) @@ -136,6 +156,7 @@ and net = { global_db: db ; operation_db: Raw_operation.t ; block_header_db: Raw_block_header.t ; + operation_list_db: Raw_operation_list.t ; callback: callback ; active_peers: P2p.Peer_id.Set.t ref ; active_connections: p2p_reader P2p.Peer_id.Table.t ; @@ -299,6 +320,43 @@ module P2p_reader = struct global_db.protocol_db.table state.gid hash protocol >>= fun () -> Lwt.return_unit + | Get_operation_list (net_id, hashes) -> + may_handle state net_id @@ fun net_db -> + Lwt_list.iter_p + (fun (block, ofs as key) -> + Raw_operation_list.Table.read + net_db.operation_list_db.table key >>= function + | None -> Lwt.return_unit + | Some (ops, path) -> + ignore @@ + P2p.try_send + global_db.p2p state.conn + (Operation_list (net_id, block, ofs, ops, path)) ; + Lwt.return_unit) + hashes + + | Operation_list (net_id, block, ofs, ops, path) -> + may_handle state net_id @@ fun net_db -> + (* TODO early detection of non-requested list. *) + let found_hash, found_ofs = + Operation_list_list_hash.check_path + path (Operation_list_hash.compute ops) in + if found_ofs <> ofs then + Lwt.return_unit + else + Raw_block_header.Table.read + net_db.block_header_db.table block >>= function + | None -> Lwt.return_unit + | Some bh -> + if Operation_list_list_hash.compare + found_hash bh.shell.operations <> 0 then + Lwt.return_unit + else + Raw_operation_list.Table.notify + net_db.operation_list_db.table state.gid + (block, ofs) (ops, path) >>= fun () -> + Lwt.return_unit + let rec worker_loop global_db state = Lwt_utils.protect ~canceler:state.canceler begin fun () -> P2p.recv global_db.p2p state.conn @@ -386,8 +444,10 @@ let activate ~callback ({ p2p ; active_nets } as global_db) net = let block_header_db = Raw_block_header.create ~global_input:global_db.block_input p2p_request net in + let operation_list_db = + Raw_operation_list.create p2p_request net in let net = { - global_db ; operation_db ; block_header_db ; + global_db ; operation_db ; block_header_db ; operation_list_db ; net ; callback ; active_peers ; active_connections = P2p.Peer_id.Table.create 53 ; } in @@ -478,7 +538,73 @@ module Protocol = let proj db = db.protocol_db.table end) -let inject_block t bytes = +module Operation_list = struct + + type t = net + type key = Block_hash.t * int + type value = Operation_hash.t list + type param = Operation_list_list_hash.t + + let proj net = net.operation_list_db.table + + module Table = Raw_operation_list.Table + + let known t k = Table.known (proj t) k + let read t k = + Table.read (proj t) k >>= function + | None -> Lwt.return_none + | Some (op, _) -> Lwt.return (Some op) + let read_exn t k = Table.read_exn (proj t) k >|= fst + let prefetch t ?peer k p = Table.prefetch (proj t) ?peer k p + let fetch t ?peer k p = Table.fetch (proj t) ?peer k p >|= fst + + let rec do_read net block acc i = + if i <= 0 then + Lwt.return [] + else + read_exn net (block, i-1) >>= fun ops -> + do_read net block (ops :: acc) (i-1) + + let read_all_opt net block = + State.Operation_list.read_count_opt + net.net block >>= function + | None -> Lwt.return_none + | Some len -> do_read net block [] len >>= fun ops -> Lwt.return (Some ops) + + let read_all_exn net block = + State.Operation_list.read_count_exn + net.net block >>= fun len -> + do_read net block [] len + + let rec do_commit net block i = + if i <= 0 then + Lwt.return_unit + else + Raw_operation_list.Table.commit + net.operation_list_db.table (block, i-1) >>= fun () -> + do_commit net block (i-1) + + let commit_all net block len = + State.Operation_list.store_count net.net block len >>= fun () -> + do_commit net block len + + let inject_all net block opss = + State.Operation_list.read_count_opt net.net block >>= function + | Some _ -> Lwt.return_false + | None -> + let hashes = List.map Operation_list_hash.compute opss in + Lwt_list.mapi_p + (fun i ops -> + let path = Operation_list_list_hash.compute_path hashes i in + Raw_operation_list.Table.inject + net.operation_list_db.table + (block, i) (ops, path)) + opss >>= fun injected -> + Lwt.return (List.for_all (fun x -> x) injected) + +end + +let inject_block t bytes operations = let hash = Block_hash.hash_bytes [bytes] in match Data_encoding.Binary.of_bytes Store.Block_header.encoding bytes @@ -494,13 +620,45 @@ let inject_block t bytes = | true -> failwith "Previously injected block." | false -> + let computed_hash = + Operation_list_list_hash.compute + (List.map Operation_list_hash.compute operations) in + fail_unless + (Operation_list_list_hash.compare + computed_hash block.shell.operations = 0) + (Exn (Failure "Incoherent operation list")) >>=? fun () -> Raw_block_header.Table.inject net_db.block_header_db.table hash block >>= function | false -> failwith "Previously injected block." | true -> + Operation_list.inject_all + net_db hash operations >>= fun _ -> return (hash, block) +(* +let inject_operation t bytes = + let hash = Operation_hash.hash_bytes [bytes] in + match Data_encoding.Binary.of_bytes Store.Operation.encoding bytes with + | None -> + failwith "Cannot parse operations." + | Some op -> + match get_net t op.shell.net_id with + | None -> + failwith "Unknown network." + | Some net_db -> + Operation.known net_db hash >>= function + | true -> + failwith "Previously injected block." + | false -> + Raw_operation.Table.inject + net_db.operation_db.table hash op >>= function + | false -> + failwith "Previously injected block." + | true -> + return (hash, op) +*) + let broadcast_head net head mempool = let msg : Message.t = Current_head (State.Net.id net.net, head, mempool) in diff --git a/src/node/shell/distributed_db.mli b/src/node/shell/distributed_db.mli index 6efeb5a30..c2bec0389 100644 --- a/src/node/shell/distributed_db.mli +++ b/src/node/shell/distributed_db.mli @@ -62,11 +62,41 @@ module Protocol : and type key := Protocol_hash.t and type value := Tezos_compiler.Protocol.t +module Operation_list : sig + + type t = net + type key = Block_hash.t * int + type value = Operation_hash.t list + type param = Operation_list_list_hash.t + + val known: t -> key -> bool Lwt.t + val read: t -> key -> value option Lwt.t + val read_exn: t -> key -> value Lwt.t + val prefetch: t -> ?peer:P2p.Peer_id.t -> key -> param -> unit + val fetch: t -> ?peer:P2p.Peer_id.t -> key -> param -> value Lwt.t + + val read_all_opt: + net -> Block_hash.t -> Operation_hash.t list list option Lwt.t + val read_all_exn: + net -> Block_hash.t -> Operation_hash.t list list Lwt.t + + val commit_all: + net -> Block_hash.t -> int -> unit Lwt.t + val inject_all: + net -> Block_hash.t -> Operation_hash.t list list -> bool Lwt.t + +end + val broadcast_head: net -> Block_hash.t -> Operation_hash.t list -> unit val inject_block: - t -> MBytes.t -> (Block_hash.t * Store.Block_header.t) tzresult Lwt.t + t -> MBytes.t -> Operation_hash.t list list -> + (Block_hash.t * Store.Block_header.t) tzresult Lwt.t + +(* val inject_operation: *) + (* t -> MBytes.t -> *) + (* (Block_hash.t * Store.Operation.t) tzresult Lwt.t *) val read_block: t -> Block_hash.t -> (net * Store.Block_header.t) option Lwt.t diff --git a/src/node/shell/distributed_db_message.ml b/src/node/shell/distributed_db_message.ml index d960bd50e..45c86ec14 100644 --- a/src/node/shell/distributed_db_message.ml +++ b/src/node/shell/distributed_db_message.ml @@ -27,6 +27,10 @@ type t = | Get_protocols of Protocol_hash.t list | Protocol of Tezos_compiler.Protocol.t + | Get_operation_list of Net_id.t * (Block_hash.t * int) list + | Operation_list of Net_id.t * Block_hash.t * int * + Operation_hash.t list * Operation_list_list_hash.path + let encoding = let open Data_encoding in let case ?max_length ~tag encoding unwrap wrap = @@ -34,7 +38,7 @@ let encoding = [ case ~tag:0x10 (obj1 - (req "get_current_branch" Net_id.encoding)) + (req "get_current_branch" Store.Net_id.encoding)) (function | Get_current_branch net_id -> Some net_id | _ -> None) @@ -118,6 +122,26 @@ let encoding = (function Protocol proto -> Some proto | _ -> None) (fun proto -> Protocol proto); + case ~tag:0x50 + (obj2 + (req "net_id" Net_id.encoding) + (req "get_operation_list" (list (tup2 Block_hash.encoding int8)))) + (function + | Get_operation_list (net_id, keys) -> Some (net_id, keys) + | _ -> None) + (fun (net_id, keys) -> Get_operation_list (net_id, keys)); + + case ~tag:0x51 + (obj4 + (req "net_id" Net_id.encoding) + (req "operation_list" (tup2 Block_hash.encoding int8)) + (req "operations" (list Operation_hash.encoding)) + (req "operation_list_path" Operation_list_list_hash.path_encoding)) + (function Operation_list (net_id, block, ofs, ops, path) -> + Some (net_id, (block, ofs), ops, path) | _ -> None) + (fun (net_id, (block, ofs), ops, path) -> + Operation_list (net_id, block, ofs, ops, path)) ; + ] let versions = diff --git a/src/node/shell/distributed_db_message.mli b/src/node/shell/distributed_db_message.mli index 6b39d8d0a..0161acf58 100644 --- a/src/node/shell/distributed_db_message.mli +++ b/src/node/shell/distributed_db_message.mli @@ -27,6 +27,10 @@ type t = | Get_protocols of Protocol_hash.t list | Protocol of Tezos_compiler.Protocol.t + | Get_operation_list of Net_id.t * (Block_hash.t * int) list + | Operation_list of Net_id.t * Block_hash.t * int * + Operation_hash.t list * Operation_list_list_hash.path + val cfg : t P2p.message_config val pp_json : Format.formatter -> t -> unit diff --git a/src/node/shell/node.ml b/src/node/shell/node.ml index f2f5d5c5c..5cf95f3d1 100644 --- a/src/node/shell/node.ml +++ b/src/node/shell/node.ml @@ -42,8 +42,10 @@ let inject_protocol state ?force:_ proto = in Lwt.return (hash, validation) -let inject_block validator ?force bytes = - Validator.inject_block validator ?force bytes >>=? fun (hash, block) -> +let inject_block validator ?force bytes operations = + Validator.inject_block + validator ?force + bytes operations >>=? fun (hash, block) -> return (hash, (block >>=? fun _ -> return ())) type t = { @@ -54,7 +56,8 @@ type t = { mainnet_net: State.Net.t ; mainnet_validator: Validator.t ; inject_block: - ?force:bool -> MBytes.t -> + ?force:bool -> + MBytes.t -> Operation_hash.t list list -> (Block_hash.t * unit tzresult Lwt.t) tzresult Lwt.t ; inject_operation: ?force:bool -> MBytes.t -> @@ -139,7 +142,8 @@ module RPC = struct fitness: MBytes.t list ; timestamp: Time.t ; protocol: Protocol_hash.t option ; - operations: Operation_hash.t list option ; + operations_hash: Operation_list_list_hash.t ; + operations: Operation_hash.t list list option ; data: MBytes.t option ; net: Node_rpc_services.Blocks.net ; test_protocol: Protocol_hash.t option ; @@ -152,6 +156,7 @@ module RPC = struct fitness = block.fitness ; timestamp = block.timestamp ; protocol = Some block.protocol_hash ; + operations_hash = block.operations_hash ; operations = Some block.operations ; data = Some block.proto_header ; net = block.net_id ; @@ -166,7 +171,8 @@ module RPC = struct fitness = shell.fitness ; timestamp = shell.timestamp ; protocol = None ; - operations = Some shell.operations ; + operations_hash = shell.operations ; + operations = None ; data = Some proto ; test_protocol = None ; test_network = None ; @@ -316,7 +322,7 @@ module RPC = struct let validator, _net = get_net node block in let pv = Validator.prevalidator validator in let { Updater.applied }, _ = Prevalidator.operations pv in - Lwt.return applied + Lwt.return [applied] | `Hash hash-> read_valid_block node hash >|= function | None -> [] diff --git a/src/node/shell/node.mli b/src/node/shell/node.mli index fbd9173ca..e5b26bb9c 100644 --- a/src/node/shell/node.mli +++ b/src/node/shell/node.mli @@ -26,7 +26,8 @@ module RPC : sig type block_info = Node_rpc_services.Blocks.block_info val inject_block: - t -> ?force:bool -> MBytes.t -> + t -> ?force:bool -> + MBytes.t -> Operation_hash.t list list -> (Block_hash.t * unit tzresult Lwt.t) tzresult Lwt.t (** [inject_block node ?force bytes] tries to insert [bytes] (supposedly the serialization of a block header) inside @@ -58,7 +59,7 @@ module RPC : sig t -> block -> block_info Lwt.t val operations: - t -> block -> Operation_hash.t list Lwt.t + t -> block -> Operation_hash.t list list Lwt.t val operation_content: t -> Operation_hash.t -> Store.Operation.t option Lwt.t val operation_watcher: diff --git a/src/node/shell/node_rpc.ml b/src/node/shell/node_rpc.ml index b42b1de09..f94c39e41 100644 --- a/src/node/shell/node_rpc.ml +++ b/src/node/shell/node_rpc.ml @@ -307,12 +307,13 @@ let list_operations node {Services.Operations.monitor; contents} = let include_ops = match contents with None -> false | Some x -> x in Node.RPC.operations node `Prevalidation >>= fun operations -> Lwt_list.map_p - (fun hash -> - if include_ops then - Node.RPC.operation_content node hash >>= fun op -> - Lwt.return (hash, op) - else - Lwt.return (hash, None)) + (Lwt_list.map_p + (fun hash -> + if include_ops then + Node.RPC.operation_content node hash >>= fun op -> + Lwt.return (hash, op) + else + Lwt.return (hash, None))) operations >>= fun operations -> if not monitor then RPC.Answer.return operations @@ -324,8 +325,8 @@ let list_operations node {Services.Operations.monitor; contents} = if not !first_request then Lwt_stream.get stream >>= function | None -> Lwt.return_none - | Some (h, op) when include_ops -> Lwt.return (Some [h, Some op]) - | Some (h, _) -> Lwt.return (Some [h, None]) + | Some (h, op) when include_ops -> Lwt.return (Some [[h, Some op]]) + | Some (h, _) -> Lwt.return (Some [[h, None]]) else begin first_request := false ; Lwt.return (Some operations) @@ -416,9 +417,12 @@ let build_rpc_directory node = RPC.Answer.return res in RPC.register0 dir Services.validate_block implementation in let dir = - let implementation (block, blocking, force) = + let implementation + { Node_rpc_services.raw ; blocking ; force ; operations } = begin - Node.RPC.inject_block node ?force block >>=? fun (hash, wait) -> + Node.RPC.inject_block + node ~force + raw operations >>=? fun (hash, wait) -> (if blocking then wait else return ()) >>=? fun () -> return hash end >>= RPC.Answer.return in RPC.register0 dir Services.inject_block implementation in diff --git a/src/node/shell/node_rpc_services.ml b/src/node/shell/node_rpc_services.ml index 140337a0b..27f79e75f 100644 --- a/src/node/shell/node_rpc_services.ml +++ b/src/node/shell/node_rpc_services.ml @@ -66,7 +66,8 @@ module Blocks = struct fitness: MBytes.t list ; timestamp: Time.t ; protocol: Protocol_hash.t option ; - operations: Operation_hash.t list option ; + operations_hash: Operation_list_list_hash.t ; + operations: Operation_hash.t list list option ; data: MBytes.t option ; net: net ; test_protocol: Protocol_hash.t option ; @@ -75,25 +76,32 @@ module Blocks = struct let block_info_encoding = conv - (fun { hash ; predecessor ; fitness ; timestamp ; protocol ; operations ; - net ; test_protocol ; test_network ; data } -> - (hash, predecessor, fitness, timestamp, protocol, operations, - net, test_protocol, test_network, data)) - (fun (hash, predecessor, fitness, timestamp, protocol, operations, - net, test_protocol, test_network, data) -> - { hash ; predecessor ; fitness ; timestamp ; protocol ; operations ; - net ; test_protocol ; test_network ; data }) - (obj10 - (req "hash" Block_hash.encoding) - (req "predecessor" Block_hash.encoding) - (req "fitness" Fitness.encoding) - (req "timestamp" Time.encoding) - (opt "protocol" Protocol_hash.encoding) - (opt "operations" (list Operation_hash.encoding)) - (req "net_id" net_encoding) - (opt "test_protocol" Protocol_hash.encoding) - (opt "test_network" (tup2 net_encoding Time.encoding)) - (opt "data" bytes)) + (fun { hash ; predecessor ; fitness ; timestamp ; protocol ; + operations_hash ; operations ; data ; net ; + test_protocol ; test_network } -> + ((hash, predecessor, fitness, timestamp, protocol), + (operations_hash, operations, data, + net, test_protocol, test_network))) + (fun ((hash, predecessor, fitness, timestamp, protocol), + (operations_hash, operations, data, + net, test_protocol, test_network)) -> + { hash ; predecessor ; fitness ; timestamp ; protocol ; + operations_hash ; operations ; data ; net ; + test_protocol ; test_network }) + (merge_objs + (obj5 + (req "hash" Block_hash.encoding) + (req "predecessor" Block_hash.encoding) + (req "fitness" Fitness.encoding) + (req "timestamp" Time.encoding) + (opt "protocol" Protocol_hash.encoding)) + (obj6 + (req "operations_hash" Operation_list_list_hash.encoding) + (opt "operations" (list (list Operation_hash.encoding))) + (opt "data" bytes) + (req "net" net_encoding) + (opt "test_protocol" Protocol_hash.encoding) + (opt "test_network" (tup2 net_encoding Time.encoding)))) let parse_block s = try @@ -231,7 +239,7 @@ module Blocks = struct RPC.service ~description:"List the block operations." ~input: empty - ~output: (obj1 (req "operations" (list Operation_hash.encoding))) + ~output: (obj1 (req "operations" (list (list Operation_hash.encoding)))) RPC.Path.(block_path / "operations") let protocol = @@ -437,11 +445,12 @@ module Operations = struct (obj1 (req "operations" (list - (obj2 - (req "hash" Operation_hash.encoding) - (opt "contents" - (dynamic_size Updater.raw_operation_encoding))) - ))) + (list + (obj2 + (req "hash" Operation_hash.encoding) + (opt "contents" + (dynamic_size Updater.raw_operation_encoding))) + )))) RPC.Path.(root / "operations") end @@ -637,7 +646,7 @@ let forge_block = (opt "predecessor" Block_hash.encoding) (opt "timestamp" Time.encoding) (req "fitness" Fitness.encoding) - (req "operations" (list Operation_hash.encoding)) + (req "operations" Operation_list_list_hash.encoding) (req "header" bytes)) ~output: (obj1 (req "block" bytes)) RPC.Path.(root / "forge_block") @@ -654,35 +663,50 @@ let validate_block = (Error.wrap @@ empty) RPC.Path.(root / "validate_block") +type inject_block_param = { + raw: MBytes.t ; + blocking: bool ; + force: bool ; + operations: Operation_hash.t list list ; +} + +let inject_block_param = + conv + (fun { raw ; blocking ; force ; operations } -> + (raw, blocking, force, operations)) + (fun (raw, blocking, force, operations) -> + { raw ; blocking ; force ; operations }) + (obj4 + (req "data" bytes) + (dft "blocking" + (describe + ~description: + "Should the RPC wait for the block to be \ + validated before answering. (default: true)" + bool) + true) + (dft "force" + (describe + ~description: + "Should we inject the block when its fitness is below \ + the current head. (default: false)" + bool) + false) + (req "operations" + (describe + ~description:"..." + (list (list Operation_hash.encoding))))) + let inject_block = RPC.service ~description: "Inject a block in the node and broadcast it. The `operations` \ - embedded in `blockHeader` might pre-validated using a \ + embedded in `blockHeader` might be pre-validated using a \ contextual RPCs from the latest block \ (e.g. '/blocks/head/context/preapply'). Returns the ID of the \ block. By default, the RPC will wait for the block to be \ validated before answering." - ~input: - (conv - (fun (block, blocking, force) -> - (block, Some blocking, force)) - (fun (block, blocking, force) -> - (block, Utils.unopt ~default:true blocking, force)) - (obj3 - (req "data" bytes) - (opt "blocking" - (describe - ~description: - "Should the RPC wait for the block to be \ - validated before answering. (default: true)" - bool)) - (opt "force" - (describe - ~description: - "Should we inject the block when its fitness is below \ - the current head. (default: false)" - bool)))) + ~input: inject_block_param ~output: (Error.wrap @@ (obj1 (req "block_hash" Block_hash.encoding))) diff --git a/src/node/shell/node_rpc_services.mli b/src/node/shell/node_rpc_services.mli index 663e661eb..d06337209 100644 --- a/src/node/shell/node_rpc_services.mli +++ b/src/node/shell/node_rpc_services.mli @@ -34,7 +34,8 @@ module Blocks : sig fitness: MBytes.t list ; timestamp: Time.t ; protocol: Protocol_hash.t option ; - operations: Operation_hash.t list option ; + operations_hash: Operation_list_list_hash.t ; + operations: Operation_hash.t list list option ; data: MBytes.t option ; net: net ; test_protocol: Protocol_hash.t option ; @@ -56,7 +57,7 @@ module Blocks : sig val fitness: (unit, unit * block, unit, MBytes.t list) RPC.service val operations: - (unit, unit * block, unit, Operation_hash.t list) RPC.service + (unit, unit * block, unit, Operation_hash.t list list) RPC.service val protocol: (unit, unit * block, unit, Protocol_hash.t) RPC.service val test_protocol: @@ -108,7 +109,7 @@ module Operations : sig } val list: (unit, unit, - list_param, (Operation_hash.t * Store.Operation.t option) list) RPC.service + list_param, (Operation_hash.t * Store.Operation.t option) list list) RPC.service end module Protocols : sig @@ -170,16 +171,21 @@ end val forge_block: (unit, unit, Updater.Net_id.t option * Block_hash.t option * Time.t option * - Fitness.fitness * Operation_hash.t list * MBytes.t, + Fitness.fitness * Operation_list_list_hash.t * MBytes.t, MBytes.t) RPC.service val validate_block: (unit, unit, Blocks.net * Block_hash.t, unit tzresult) RPC.service +type inject_block_param = { + raw: MBytes.t ; + blocking: bool ; + force: bool ; + operations: Operation_hash.t list list ; +} + val inject_block: - (unit, unit, - (MBytes.t * bool * bool option), - Block_hash.t tzresult) RPC.service + (unit, unit, inject_block_param, Block_hash.t tzresult) RPC.service val inject_operation: (unit, unit, diff --git a/src/node/shell/prevalidator.ml b/src/node/shell/prevalidator.ml index 50a9d2833..a2ae79087 100644 --- a/src/node/shell/prevalidator.ml +++ b/src/node/shell/prevalidator.ml @@ -48,22 +48,26 @@ let list_pendings net_db ~from_block ~to_block old_mempool = Lwt.return mempool else Distributed_db.Block_header.read_exn net_db hash >>= fun { shell } -> + Distributed_db.Operation_list.read_all_exn + net_db hash >>= fun operations -> let mempool = List.fold_left - (fun mempool h -> Operation_hash.Set.add h mempool) - mempool shell.operations in + (List.fold_left (fun mempool h -> Operation_hash.Set.add h mempool)) + mempool operations in pop_blocks ancestor shell.predecessor mempool in - let push_block mempool (_hash, shell) = + let push_block mempool (hash, _shell) = + Distributed_db.Operation_list.read_all_exn + net_db hash >|= fun operations -> List.fold_left - (fun mempool h -> Operation_hash.Set.remove h mempool) - mempool shell.Store.Block_header.operations + (List.fold_left (fun mempool h -> Operation_hash.Set.remove h mempool)) + mempool operations in let net_state = Distributed_db.state net_db in State.Valid_block.Current.new_blocks net_state ~from_block ~to_block >>= fun (ancestor, path) -> pop_blocks ancestor from_block.hash old_mempool >>= fun mempool -> - let new_mempool = List.fold_left push_block mempool path in + Lwt_list.fold_left_s push_block mempool path >>= fun new_mempool -> Lwt.return new_mempool diff --git a/src/node/shell/state.ml b/src/node/shell/state.ml index 71757001d..7ef793bb3 100644 --- a/src/node/shell/state.ml +++ b/src/node/shell/state.ml @@ -12,7 +12,12 @@ open Logging.Node.State module Net_id = Store.Net_id type error += - | Invalid_fitness of Fitness.fitness * Fitness.fitness + | Invalid_fitness of { block: Block_hash.t ; + expected: Fitness.fitness ; + found: Fitness.fitness } + | Invalid_operations of { block: Block_hash.t ; + expected: Operation_list_list_hash.t ; + found: Operation_hash.t list list } | Unknown_network of Net_id.t | Unknown_operation of Operation_hash.t | Unknown_block of Block_hash.t @@ -27,18 +32,22 @@ let () = ~title:"Invalid fitness" ~description:"The computed fitness differs from the fitness found \ \ in the block header." - ~pp:(fun ppf (expected, found) -> + ~pp:(fun ppf (block, expected, found) -> Format.fprintf ppf - "@[Invalid fitness@ \ + "@[Invalid fitness for block %a@ \ \ expected %a@ \ \ found %a" + Block_hash.pp_short block Fitness.pp expected Fitness.pp found) - Data_encoding.(obj2 + Data_encoding.(obj3 + (req "block" Block_hash.encoding) (req "expected" Fitness.encoding) (req "found" Fitness.encoding)) - (function Invalid_fitness (e, f) -> Some (e, f) | _ -> None) - (fun (e, f) -> Invalid_fitness (e, f)) ; + (function Invalid_fitness { block ; expected ; found } -> + Some (block, expected, found) | _ -> None) + (fun (block, expected, found) -> + Invalid_fitness { block ; expected ; found }) ; Error_monad.register_error_kind `Temporary ~id:"state.unknown_network" @@ -105,7 +114,8 @@ and valid_block = { pred: Block_hash.t ; timestamp: Time.t ; fitness: Protocol.fitness ; - operations: Operation_hash.t list ; + operations_hash: Operation_list_list_hash.t ; + operations: Operation_hash.t list list ; discovery_time: Time.t ; protocol_hash: Protocol_hash.t ; protocol: (module Updater.REGISTRED_PROTOCOL) option ; @@ -119,7 +129,8 @@ and valid_block = { } let build_valid_block - hash header context discovery_time successors invalid_successors = + hash header operations + context discovery_time successors invalid_successors = Context.get_protocol context >>= fun protocol_hash -> Context.get_test_protocol context >>= fun test_protocol_hash -> Context.get_test_network context >>= fun test_network -> @@ -137,7 +148,8 @@ let build_valid_block pred = header.shell.predecessor ; timestamp = header.shell.timestamp ; discovery_time ; - operations = header.shell.operations ; + operations_hash = header.shell.operations ; + operations ; fitness = header.shell.fitness ; protocol_hash ; protocol ; @@ -389,6 +401,121 @@ module Raw_operation = end) (Operation_hash.Set) +module Raw_operation_list = struct + + module Locked = struct + + let known store (hash, ofs) = + Store.Block_header.Operation_list.known (store, hash) ofs + let read store (hash, ofs) = + Store.Block_header.Operation_list.read + (store, hash) ofs >>=? fun ops -> + Store.Block_header.Operation_list_path.read + (store, hash) ofs >>=? fun path -> + return (ops, path) + let read_opt store (hash, ofs) = + Store.Block_header.Operation_list.read_opt + (store, hash) ofs >>= function + | None -> Lwt.return_none + | Some ops -> + Store.Block_header.Operation_list_path.read_exn + (store, hash) ofs >>= fun path -> + Lwt.return (Some (ops, path)) + let read_exn store (hash, ofs) = + read_opt store (hash, ofs) >>= function + | None -> Lwt.fail Not_found + | Some (ops, path) -> Lwt.return (ops, path) + let store store (hash, ofs) (ops, path) = + Store.Block_header.Operation_list.known + (store, hash) ofs >>= function + | false -> + Store.Block_header.Operation_list.store + (store, hash) ofs ops >>= fun () -> + Store.Block_header.Operation_list_path.store + (store, hash) ofs path >>= fun () -> + Lwt.return_true + | true -> + Lwt.return_false + + let remove store (hash, ofs) = + Store.Block_header.Operation_list.known + (store, hash) ofs >>= function + | false -> + Lwt.return_false + | true -> + Store.Block_header.Operation_list.remove + (store, hash) ofs >>= fun () -> + Store.Block_header.Operation_list_path.remove + (store, hash) ofs >>= fun () -> + Lwt.return_true + + let read_count store hash = + Store.Block_header.Operation_list_count.read (store, hash) + + let read_count_opt store hash = + read_count store hash >>= function + | Ok cpt -> Lwt.return (Some cpt) + | Error _ -> Lwt.return_none + + let read_count_exn store hash = + read_count store hash >>= function + | Ok cpt -> Lwt.return cpt + | Error _ -> Lwt.fail Not_found + + let store_count store hash count = + Store.Block_header.Operation_list_count.store (store, hash) count + + let read_all store hash = + Store.Block_header.Operation_list_count.read (store, hash) + >>=? fun operation_list_count -> + let rec read acc i = + if i <= 0 then return acc + else + Store.Block_header.Operation_list.read + (store, hash) (i-1) >>=? fun ops -> + read (ops :: acc) (i-1) in + read [] operation_list_count + + let read_all_exn store hash = + read_all store hash >>= function + | Error _ -> Lwt.fail Not_found + | Ok ops -> Lwt.return ops + + let store_all store hash op_hashes operations = + Store.Block_header.Operation_list_count.store (store, hash) + (List.length operations) >>= fun () -> + Lwt_list.iteri_p + (fun i ops -> + Store.Block_header.Operation_list.store + (store, hash) i ops >>= fun () -> + Store.Block_header.Operation_list_path.store + (store, hash) i + (Operation_list_list_hash.compute_path op_hashes i) + >>= fun () -> + Lwt.return_unit) + operations >>= fun () -> + Lwt.return_unit + + end + + let atomic1 f s = Shared.use s f + let atomic2 f s k = Shared.use s (fun s -> f s k) + let atomic3 f s k v = Shared.use s (fun s -> f s k v) + let atomic4 f s k v1 v2 = Shared.use s (fun s -> f s k v1 v2) + + let known = atomic2 Locked.known + let read = atomic2 Locked.read + let read_opt = atomic2 Locked.read_opt + let read_exn = atomic2 Locked.read_exn + let store = atomic3 Locked.store + let remove = atomic2 Locked.remove + + let store_all = atomic4 Locked.store_all + let read_all = atomic2 Locked.read_all + let read_all_exn = atomic2 Locked.read_all_exn + +end + module Raw_block_header = struct include @@ -417,13 +544,14 @@ module Raw_block_header = struct predecessor = genesis.block ; timestamp = genesis.time ; fitness = [] ; - operations = [] ; + operations = Operation_list_list_hash.empty ; } in let header = { Store.Block_header.shell ; proto = MBytes.create 0 } in let bytes = Data_encoding.Binary.to_bytes Store.Block_header.encoding header in Locked.store_raw store genesis.block bytes >>= fun _created -> + Raw_operation_list.Locked.store_all store genesis.block [] [] >>= fun () -> Lwt.return header let store_testnet_genesis store genesis = @@ -432,7 +560,7 @@ module Raw_block_header = struct predecessor = genesis.block ; timestamp = genesis.time ; fitness = [] ; - operations = [] ; + operations = Operation_list_list_hash.empty ; } in let bytes = Data_encoding.Binary.to_bytes Store.Block_header.encoding { @@ -440,6 +568,7 @@ module Raw_block_header = struct proto = MBytes.create 0 ; } in Locked.store_raw store genesis.block bytes >>= fun _created -> + Raw_operation_list.Locked.store_all store genesis.block [] [] >>= fun () -> Lwt.return shell end @@ -567,8 +696,8 @@ module Block_header = struct net_id: Net_id.t ; predecessor: Block_hash.t ; timestamp: Time.t ; + operations: Operation_list_list_hash.t ; fitness: MBytes.t list ; - operations: Operation_hash.t list ; } type t = Store.Block_header.t = { @@ -596,6 +725,9 @@ module Block_header = struct | Some _ | None -> Lwt.return_none let read_pred_exn = wrap_not_found read_pred_opt + let read_operations s k = + Raw_operation_list.read_all s.block_header_store k + let mark_invalid net hash errors = mark_invalid net hash errors >>= fun marked -> if not marked then @@ -676,6 +808,45 @@ module Block_header = struct end +module Operation_list = struct + + type store = net + type key = Block_hash.t * int + type value = Operation_hash.t list * Operation_list_list_hash.path + + module Locked = Raw_operation_list.Locked + + let atomic1 f s = + Shared.use s.block_header_store f + let atomic2 f s k = + Shared.use s.block_header_store (fun s -> f s k) + let atomic3 f s k v = + Shared.use s.block_header_store (fun s -> f s k v) + let atomic4 f s k v1 v2 = + Shared.use s.block_header_store (fun s -> f s k v1 v2) + + let known = atomic2 Locked.known + let read = atomic2 Locked.read + let read_opt = atomic2 Locked.read_opt + let read_exn = atomic2 Locked.read_exn + let store = atomic3 Locked.store + let remove = atomic2 Locked.remove + + let store_all s k v = + Shared.use s.block_header_store begin fun s -> + let h = List.map Operation_list_hash.compute v in + Locked.store_all s k h v + end + let read_all = atomic2 Locked.read_all + let read_all_exn = atomic2 Locked.read_all_exn + + let read_count = atomic2 Locked.read_count + let read_count_opt = atomic2 Locked.read_count_opt + let read_count_exn = atomic2 Locked.read_count_exn + let store_count = atomic3 Locked.store_count + +end + module Raw_net = struct let build @@ -739,7 +910,7 @@ module Raw_net = struct Lwt.return context end >>= fun context -> build_valid_block - genesis.block header context genesis.time + genesis.block header [] context genesis.time Block_hash.Set.empty Block_hash.Set.empty >>= fun genesis_block -> Lwt.return @@ build @@ -763,7 +934,8 @@ module Valid_block = struct pred: Block_hash.t ; timestamp: Time.t ; fitness: Fitness.fitness ; - operations: Operation_hash.t list ; + operations_hash: Operation_list_list_hash.t ; + operations: Operation_hash.t list list ; discovery_time: Time.t ; protocol_hash: Protocol_hash.t ; protocol: (module Updater.REGISTRED_PROTOCOL) option ; @@ -782,7 +954,7 @@ module Valid_block = struct let known { context_index } hash = Context.exists context_index hash - let raw_read block time chain_store context_index hash = + let raw_read block operations time chain_store context_index hash = Context.checkout context_index hash >>= function | None -> fail (Unknown_context hash) @@ -791,11 +963,12 @@ module Valid_block = struct >>= fun successors -> Store.Chain.Invalid_successors.read_all (chain_store, hash) >>= fun invalid_successors -> - build_valid_block hash block context time successors invalid_successors >>= fun block -> + build_valid_block hash block operations + context time successors invalid_successors >>= fun block -> return block - let raw_read_exn block time chain_store context_index hash = - raw_read block time chain_store context_index hash >>= function + let raw_read_exn block operations time chain_store context_index hash = + raw_read block operations time chain_store context_index hash >>= function | Error _ -> Lwt.fail Not_found | Ok data -> Lwt.return data @@ -804,7 +977,8 @@ module Valid_block = struct | None | Some { Time.data = Error _ } -> fail (Unknown_block hash) | Some { Time.data = Ok block ; time } -> - raw_read block + Block_header.read_operations net hash >>=? fun operations -> + raw_read block operations time net_state.chain_store net_state.context_index hash let read_opt net net_state hash = @@ -832,7 +1006,10 @@ module Valid_block = struct fail_unless (Fitness.equal fitness block.Store.Block_header.shell.fitness) (Invalid_fitness - (block.Store.Block_header.shell.fitness, fitness)) >>=? fun () -> + { block = hash ; + expected = block.Store.Block_header.shell.fitness ; + found = fitness ; + }) >>=? fun () -> begin (* Patch context about the associated test network. *) Context.read_and_reset_fork_test_network context >>= fun (fork, context) -> @@ -860,6 +1037,8 @@ module Valid_block = struct Raw_block_header.Locked.mark_valid block_header_store hash >>= fun _marked -> (* TODO fail if the block was previsouly stored ... ??? *) + Operation_list.Locked.read_all + block_header_store hash >>=? fun operations -> (* Let's commit the context. *) Context.commit hash context >>= fun () -> (* Update the chain state. *) @@ -871,7 +1050,7 @@ module Valid_block = struct (store, predecessor) hash >>= fun () -> (* Build the `valid_block` value. *) raw_read_exn - block discovery_time + block operations discovery_time net_state.chain_store net_state.context_index hash >>= fun valid_block -> Watcher.notify valid_block_watcher valid_block ; Lwt.return (Ok valid_block) @@ -1056,11 +1235,14 @@ module Valid_block = struct lwt_debug "pop_block %a" Block_hash.pp_short hash >>= fun () -> Raw_block_header.read_exn block_header_store hash >>= fun { shell } -> + Raw_operation_list.read_all_exn + block_header_store hash >>= fun operations -> + let operations = List.concat operations in Lwt_list.iter_p (fun h -> Raw_operation.Locked.unmark operation_store h >>= fun _ -> Lwt.return_unit) - shell.operations >>= fun () -> + operations >>= fun () -> Store.Chain.In_chain_insertion_time.remove (state.chain_store, hash) >>= fun () -> Store.Chain.Successor_in_chain.remove @@ -1074,11 +1256,14 @@ module Valid_block = struct Store.Chain.Successor_in_chain.store (state.chain_store, shell.Store.Block_header.predecessor) hash >>= fun () -> + Raw_operation_list.read_all_exn + block_header_store hash >>= fun operations -> + let operations = List.concat operations in Lwt_list.iter_p (fun h -> Raw_operation.Locked.mark_valid operation_store h >>= fun _ -> Lwt.return_unit) - shell.operations + operations in let time = Time.now () in new_blocks @@ -1163,7 +1348,7 @@ module Net = struct Block_header.Locked.read_discovery_time block_header_store genesis_hash >>=? fun genesis_discovery_time -> Valid_block.Locked.raw_read - genesis_shell_header genesis_discovery_time + genesis_shell_header [] genesis_discovery_time chain_store context_index genesis_hash >>=? fun genesis_block -> return @@ Raw_net.build diff --git a/src/node/shell/state.mli b/src/node/shell/state.mli index 4f325e61e..9facb9aad 100644 --- a/src/node/shell/state.mli +++ b/src/node/shell/state.mli @@ -36,7 +36,12 @@ val read: (** {2 Errors} **************************************************************) type error += - | Invalid_fitness of Fitness.fitness * Fitness.fitness + | Invalid_fitness of { block: Block_hash.t ; + expected: Fitness.fitness ; + found: Fitness.fitness } + | Invalid_operations of { block: Block_hash.t ; + expected: Operation_list_list_hash.t ; + found: Operation_hash.t list list } | Unknown_network of Store.Net_id.t | Unknown_operation of Operation_hash.t | Unknown_block of Block_hash.t @@ -143,8 +148,8 @@ module Block_header : sig net_id: Net_id.t ; predecessor: Block_hash.t ; timestamp: Time.t ; + operations: Operation_list_list_hash.t ; fitness: MBytes.t list ; - operations: Operation_hash.t list ; } type t = Store.Block_header.t = { @@ -205,6 +210,31 @@ module Block_header : sig end +module Operation_list : sig + + type store = Net.t + type key = Block_hash.t * int + type value = Operation_hash.t list * Operation_list_list_hash.path + + val known: store -> key -> bool Lwt.t + val read: store -> key -> value tzresult Lwt.t + val read_opt: store -> key -> value option Lwt.t + val read_exn: store -> key -> value Lwt.t + val store: store -> key -> value -> bool Lwt.t + val remove: store -> key -> bool Lwt.t + + val read_count: store -> Block_hash.t -> int tzresult Lwt.t + val read_count_opt: store -> Block_hash.t -> int option Lwt.t + val read_count_exn: store -> Block_hash.t -> int Lwt.t + val store_count: store -> Block_hash.t -> int -> unit Lwt.t + + val read_all: + store -> Block_hash.t -> Operation_hash.t list list tzresult Lwt.t + val store_all: + store -> Block_hash.t -> Operation_hash.t list list -> unit Lwt.t + +end + (** {2 Valid block} ***********************************************************) @@ -223,8 +253,9 @@ module Valid_block : sig (** The date at which this block has been forged. *) fitness: Protocol.fitness ; (** The (validated) score of the block. *) - operations: Operation_hash.t list ; - (** The sequence of operations. *) + operations_hash: Operation_list_list_hash.t ; + operations: Operation_hash.t list list ; + (** The sequence of operations ans its (Merkle-)hash. *) discovery_time: Time.t ; (** The data at which the block was discorevered on the P2P network. *) protocol_hash: Protocol_hash.t ; diff --git a/src/node/shell/validator.ml b/src/node/shell/validator.ml index 63358e0f9..c6f9358ed 100644 --- a/src/node/shell/validator.ml +++ b/src/node/shell/validator.ml @@ -15,7 +15,8 @@ type worker = { get_exn: State.Net_id.t -> t Lwt.t ; deactivate: t -> unit Lwt.t ; inject_block: - ?force:bool -> MBytes.t -> + ?force:bool -> + MBytes.t -> Operation_hash.t list list -> (Block_hash.t * State.Valid_block.t tzresult Lwt.t) tzresult Lwt.t ; notify_block: Block_hash.t -> Store.Block_header.t -> unit Lwt.t ; shutdown: unit -> unit Lwt.t ; @@ -152,9 +153,11 @@ let apply_block net db >>= fun () -> lwt_log_info "validation of %a: looking for dependencies..." Block_hash.pp_short hash >>= fun () -> + Distributed_db.Operation_list.fetch + db (hash, 0) block.shell.operations >>= fun operation_hashes -> Lwt_list.map_p (fun op -> Distributed_db.Operation.fetch db op) - block.shell.operations >>= fun operations -> + operation_hashes >>= fun operations -> lwt_debug "validation of %a: found operations" Block_hash.pp_short hash >>= fun () -> begin (* Are we validating a block in an expired test network ? *) @@ -194,7 +197,7 @@ let apply_block net db (fun op_hash raw -> Lwt.return (Proto.parse_operation op_hash raw) |> trace (Invalid_operation op_hash)) - block.Store.Block_header.shell.operations + operation_hashes operations >>=? fun parsed_operations -> lwt_debug "validation of %a: applying block..." Block_hash.pp_short hash >>= fun () -> @@ -290,22 +293,27 @@ module Context_db = struct match data with | Ok data -> Distributed_db.Block_header.commit net_db hash >>= fun () -> + Distributed_db.Operation_list.commit_all + net_db hash 1 >>= fun () -> begin State.Valid_block.store net_state hash data >>=? function | None -> State.Valid_block.read net_state hash >>=? fun block -> - Lwt_list.iter_p (fun hash -> - Distributed_db.Operation.commit net_db hash) + Lwt_list.iter_p + (Lwt_list.iter_p (fun hash -> + Distributed_db.Operation.commit net_db hash)) block.operations >>= fun () -> return (Ok block, false) | Some block -> - Lwt_list.iter_p (fun hash -> - Distributed_db.Operation.commit net_db hash) + Lwt_list.iter_p + (Lwt_list.iter_p (fun hash -> + Distributed_db.Operation.commit net_db hash)) block.operations >>= fun () -> return (Ok block, true) end | Error err -> - State.Block_header.mark_invalid net_state hash err >>= fun changed -> + State.Block_header.mark_invalid + net_state hash err >>= fun changed -> return (Error err, changed) end >>= function | Ok (block, changed) -> @@ -704,9 +712,25 @@ let create_worker state db = validators [] in Lwt.join (maintenance_worker :: validators) in - let inject_block ?(force = false) bytes = - Distributed_db.inject_block db bytes >>=? fun (hash, block) -> + let inject_block ?(force = false) bytes operations = + Distributed_db.inject_block db bytes operations >>=? fun (hash, block) -> get block.shell.net_id >>=? fun net -> +(* + Lwt_list.filter_map_s + (fun bytes -> + let hash = Operation_hash.hash_bytes [bytes] in + match Data_encoding. + Distributed_db.Operation.inject net.net_db hash bytes >>= function + | false -> Lwt.return_none + | true -> + if List.exists + (List.exists (Operation_hash.equal hash)) + operations then + Lwt.return (Some hash) + else + Lwt.return_none) + injected_operations >>= fun injected_operations -> +*) let validation = State.Valid_block.Current.head net.net >>= fun head -> if force diff --git a/src/node/shell/validator.mli b/src/node/shell/validator.mli index 3148ff2ac..96d4d5b9b 100644 --- a/src/node/shell/validator.mli +++ b/src/node/shell/validator.mli @@ -32,7 +32,8 @@ val fetch_block: t -> Block_hash.t -> State.Valid_block.t tzresult Lwt.t val inject_block: - worker -> ?force:bool -> MBytes.t -> + worker -> ?force:bool -> + MBytes.t -> Operation_hash.t list list -> (Block_hash.t * State.Valid_block.t tzresult Lwt.t) tzresult Lwt.t val prevalidator: t -> Prevalidator.t diff --git a/src/node/updater/protocol.mli b/src/node/updater/protocol.mli index 903465cd5..01c1a98c0 100644 --- a/src/node/updater/protocol.mli +++ b/src/node/updater/protocol.mli @@ -33,12 +33,12 @@ type shell_block = Store.Block_header.shell_header = (** The preceding block in the chain. *) timestamp: Time.t ; (** The date at which this block has been forged. *) + operations: Operation_list_list_hash.t ; + (** The sequence of operations. *) fitness: MBytes.t list ; (** The announced score of the block. As a sequence of sequences of unsigned bytes. Ordered by length and then by contents lexicographically. *) - operations: Operation_hash.t list ; - (** The sequence of operations. *) } type raw_block = Store.Block_header.t = { diff --git a/src/node/updater/updater.ml b/src/node/updater/updater.ml index 625940d0b..9b2611727 100644 --- a/src/node/updater/updater.ml +++ b/src/node/updater/updater.ml @@ -40,12 +40,12 @@ type shell_block = Store.Block_header.shell_header = { (** The preceding block in the chain. *) timestamp: Time.t ; (** The date at which this block has been forged. *) + operations: Operation_list_list_hash.t ; + (** The sequence of operations. *) fitness: MBytes.t list ; (** The announced score of the block. As a sequence of sequences of unsigned bytes. Ordered by length and then by contents lexicographically. *) - operations: Operation_hash.t list ; - (** The sequence of operations. *) } let shell_block_encoding = Store.Block_header.shell_header_encoding diff --git a/src/node/updater/updater.mli b/src/node/updater/updater.mli index e33a873be..fd8872f80 100644 --- a/src/node/updater/updater.mli +++ b/src/node/updater/updater.mli @@ -31,12 +31,12 @@ type shell_block = Store.Block_header.shell_header = { (** The preceding block in the chain. *) timestamp: Time.t ; (** The date at which this block has been forged. *) + operations: Operation_list_list_hash.t ; + (** The sequence of operations. *) fitness: MBytes.t list ; (** The announced score of the block. As a sequence of sequences of unsigned bytes. Ordered by length and then by contents lexicographically. *) - operations: Operation_hash.t list ; - (** The sequence of operations. *) } val shell_block_encoding: shell_block Data_encoding.t diff --git a/src/proto/alpha/services.ml b/src/proto/alpha/services.ml index 1dcd2d7f5..b39e16604 100644 --- a/src/proto/alpha/services.ml +++ b/src/proto/alpha/services.ml @@ -570,7 +570,7 @@ module Helpers = struct (req "predecessor" Block_hash.encoding) (req "timestamp" Timestamp.encoding) (req "fitness" Fitness.encoding) - (req "operations" (list Operation_hash.encoding)) + (req "operations" Operation_list_list_hash.encoding) (req "level" Raw_level.encoding) (req "priority" int31) (req "nonce_hash" Nonce_hash.encoding) diff --git a/src/proto/environment/updater.mli b/src/proto/environment/updater.mli index bdbabd5d7..9e4891bd0 100644 --- a/src/proto/environment/updater.mli +++ b/src/proto/environment/updater.mli @@ -27,12 +27,12 @@ type shell_block = { (** The preceding block in the chain. *) timestamp: Time.t ; (** The date at which this block has been forged. *) + operations: Operation_list_list_hash.t ; + (** The sequence of operations. *) fitness: MBytes.t list ; (** The announced score of the block. As a sequence of sequences of unsigned bytes. Ordered by length and then by contents lexicographically. *) - operations: Operation_hash.t list ; - (** The sequence of operations. *) } val shell_block_encoding: shell_block Data_encoding.t diff --git a/src/proto/genesis/services.ml b/src/proto/genesis/services.ml index 1d60480be..82eb7ab1e 100644 --- a/src/proto/genesis/services.ml +++ b/src/proto/genesis/services.ml @@ -53,6 +53,9 @@ let int64_to_bytes i = MBytes.set_int64 b 0 i; b +let operations = + Operation_list_list_hash.compute [Operation_list_hash.empty] + let rpc_services : Context.t RPC.directory = let dir = RPC.empty in let dir = @@ -60,8 +63,8 @@ let rpc_services : Context.t RPC.directory = dir (Forge.block RPC.Path.root) (fun _ctxt ((net_id, predecessor, timestamp, fitness), command) -> - let shell = { Updater.net_id ; predecessor ; timestamp ; - fitness ; operations = [] } in + let shell = { Updater.net_id ; predecessor ; timestamp ; fitness ; + operations } in let bytes = Data.Command.forge shell command in RPC.Answer.return bytes) in dir diff --git a/test/lib/assert.ml b/test/lib/assert.ml index 946c13a85..0e459a5d5 100644 --- a/test/lib/assert.ml +++ b/test/lib/assert.ml @@ -50,9 +50,7 @@ let equal_string_option ?msg o1 o2 = let equal_error_monad ?msg exn1 exn2 = let msg = format_msg msg in - let prn exn = match exn with - | Error_monad.Exn err -> Printexc.to_string err - | Error_monad.Unclassified err -> err in + let prn err = Format.asprintf "%a" Error_monad.pp_print_error [err] in Assert.equal ?msg ~prn exn1 exn2 let equal_block_set ?msg set1 set2 = diff --git a/test/test_state.ml b/test/test_state.ml index 290781ce5..6484bcfa7 100644 --- a/test/test_state.ml +++ b/test/test_state.ml @@ -62,6 +62,9 @@ let operation op = Data_encoding.Binary.to_bytes Store.Operation.encoding op let block state ?(operations = []) pred_hash pred name : Store.Block_header.t = + let operations = + Operation_list_list_hash.compute + [Operation_list_hash.compute operations] in let fitness = incr_fitness pred.Store.Block_header.shell.fitness in let timestamp = incr_timestamp pred.shell.timestamp in { shell = { @@ -76,7 +79,7 @@ let build_chain state tbl otbl pred names = (fun (pred_hash, pred) name -> begin let oph, op, bytes = operation name in - State.Operation.store state op >>= fun created -> + State.Operation.store state oph op >>= fun created -> Assert.is_true ~msg:__LOC__ created ; State.Operation.read_opt state oph >>= fun op' -> Assert.equal_operation ~msg:__LOC__ (Some op) op' ; @@ -84,9 +87,9 @@ let build_chain state tbl otbl pred names = Assert.is_true ~msg:__LOC__ store_invalid ; Hashtbl.add otbl name (oph, Error []) ; let block = block ~operations:[oph] state pred_hash pred name in - State.Block_header.store state block >>= fun created -> - Assert.is_true ~msg:__LOC__ created ; let hash = Store.Block_header.hash block in + State.Block_header.store state hash block >>= fun created -> + Assert.is_true ~msg:__LOC__ created ; State.Block_header.read_opt state hash >>= fun block' -> Assert.equal_block ~msg:__LOC__ (Some block) block' ; State.Block_header.mark_invalid state hash [] >>= fun store_invalid -> @@ -104,6 +107,9 @@ let build_chain state tbl otbl pred names = let block state ?(operations = []) (pred: State.Valid_block.t) name : State.Block_header.t = + let operations = + Operation_list_list_hash.compute + [Operation_list_hash.compute operations] in let fitness = incr_fitness pred.fitness in let timestamp = incr_timestamp pred.timestamp in { shell = { net_id = pred.net_id ; @@ -117,15 +123,16 @@ let build_valid_chain state tbl vtbl otbl pred names = (fun pred name -> begin let oph, op, bytes = operation name in - State.Operation.store state op >>= fun created -> + State.Operation.store state oph op >>= fun created -> Assert.is_true ~msg:__LOC__ created ; State.Operation.read_opt state oph >>= fun op' -> Assert.equal_operation ~msg:__LOC__ (Some op) op' ; Hashtbl.add otbl name (oph, Ok op) ; let block = block state ~operations:[oph] pred name in - State.Block_header.store state block >>= fun created -> - Assert.is_true ~msg:__LOC__ created ; let hash = Store.Block_header.hash block in + State.Block_header.store state hash block >>= fun created -> + Assert.is_true ~msg:__LOC__ created ; + State.Operation_list.store_all state hash [[oph]] >>= fun () -> State.Block_header.read_opt state hash >>= fun block' -> Assert.equal_block ~msg:__LOC__ (Some block) block' ; Hashtbl.add tbl name (hash, block) ; @@ -162,7 +169,7 @@ let build_example_tree net = build_chain net tbl otbl b7 chain >>= fun () -> let pending_op = "PP" in let oph, op, bytes = operation pending_op in - State.Operation.store net op >>= fun _ -> + State.Operation.store net oph op >>= fun _ -> State.Operation.read_opt net oph >>= fun op' -> Assert.equal_operation ~msg:__LOC__ (Some op) op' ; Hashtbl.add otbl pending_op (oph, Ok op) ; diff --git a/test/test_store.ml b/test/test_store.ml index ae8a9685d..c96fb3b4e 100644 --- a/test/test_store.ml +++ b/test/test_store.ml @@ -89,10 +89,13 @@ let test_operation s = (** Block store *) let lolblock ?(operations = []) header = + let operations = + Operation_list_list_hash.compute + [Operation_list_hash.compute operations] in { Store.Block_header.shell = { timestamp = Time.of_seconds (Random.int64 1500L) ; net_id ; - predecessor = genesis_block ; operations; + predecessor = genesis_block ; operations ; fitness = [MBytes.of_string @@ string_of_int @@ String.length header; MBytes.of_string @@ string_of_int @@ 12] } ; proto = MBytes.of_string header ;