From a01f786de42596329fd74a65e38b62aa9ffce289 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Gr=C3=A9goire=20Henry?= Date: Mon, 17 Jul 2017 15:59:09 +0200 Subject: [PATCH] Update to irmin.1.3 --- scripts/install_build_deps.sh | 9 +- src/.merlin | 3 + src/Makefile.files | 16 +- src/node/db/context.ml | 280 ++++++------ src/node/db/context.mli | 27 +- src/node/db/ir_funview.ml | 689 ------------------------------ src/node/db/ir_funview.mli | 26 -- src/node/db/store.ml | 14 +- src/node/db/store.mli | 1 + src/node/shell/state.ml | 96 ++--- src/tezos-deps.opam | 6 +- test/p2p/test_p2p_connection.ml | 2 +- test/p2p/test_p2p_io_scheduler.ml | 2 +- test/shell/test_context.ml | 54 ++- test/shell/test_store.ml | 1 + 15 files changed, 249 insertions(+), 977 deletions(-) delete mode 100644 src/node/db/ir_funview.ml delete mode 100644 src/node/db/ir_funview.mli diff --git a/scripts/install_build_deps.sh b/scripts/install_build_deps.sh index ae9632822..4381bcb37 100755 --- a/scripts/install_build_deps.sh +++ b/scripts/install_build_deps.sh @@ -45,13 +45,10 @@ set -e set -x if "$pin"; then - opam pin --yes remove --no-action --dev-repo ocplib-resto || true opam pin --yes add --no-action --dev-repo sodium opam pin --yes add --no-action --dev-repo ocp-ocamlres opam pin --yes add --no-action --dev-repo ocplib-json-typed opam pin --yes add --no-action --dev-repo ocplib-resto - opam pin --yes add --no-action ocp-build 1.99.18-beta ## TMP fix - opam pin add typerex-build --dev --no-action ## Force opam to take account of the new `tezos-deps.opam` opam pin --yes remove tezos-deps opam pin --yes add --no-action tezos-deps $src_dir/src @@ -63,9 +60,5 @@ if "$depext"; then fi if "$install"; then - if opam list --installed tezos-deps ; then - opam upgrade $(opam list -s --required-by tezos-deps | grep -ve '^ocaml *$') - else - opam install tezos-deps - fi + opam install tezos-deps fi diff --git a/src/.merlin b/src/.merlin index 5cee97c87..4c077bb95 100644 --- a/src/.merlin +++ b/src/.merlin @@ -32,7 +32,10 @@ PKG cstruct PKG dynlink PKG ezjsonm PKG git +PKG git-unix PKG ipv6-multicast +PKG irmin-unix +PKG irmin-git PKG irmin PKG lwt PKG magic-mime diff --git a/src/Makefile.files b/src/Makefile.files index f508dc647..8b97ec41e 100644 --- a/src/Makefile.files +++ b/src/Makefile.files @@ -207,16 +207,15 @@ NODE_LIB_INTFS := \ node/net/p2p.mli \ node/net/RPC_server.mli \ \ + node/db/persist.mli \ + node/db/context.mli \ + \ node/db/store_sigs.mli \ node/db/raw_store.mli \ node/db/store_sigs.mli \ node/db/store_helpers.mli \ node/db/store.mli \ \ - node/db/ir_funview.mli \ - node/db/persist.mli \ - node/db/context.mli \ - \ node/updater/protocol_sigs.mli \ node/updater/updater.mli \ node/updater/proto_environment.mli \ @@ -254,15 +253,14 @@ FULL_NODE_LIB_IMPLS := \ \ node/net/RPC_server.ml \ \ + node/db/persist.ml \ + node/db/context.ml \ + \ node/db/raw_store.ml \ node/db/store_sigs.mli \ node/db/store_helpers.ml \ node/db/store.ml \ \ - node/db/ir_funview.ml \ - node/db/persist.ml \ - node/db/context.ml \ - \ node/updater/protocol_sigs.mli \ node/updater/updater.ml \ node/updater/environment.ml \ @@ -312,7 +310,7 @@ NODE_PACKAGES := \ dynlink \ git \ ipv6-multicast \ - irmin.unix \ + irmin-unix \ ocplib-resto.directory \ ssl \ threads.posix \ diff --git a/src/node/db/context.ml b/src/node/db/context.ml index 8605991c1..7a748b0e5 100644 --- a/src/node/db/context.ml +++ b/src/node/db/context.ml @@ -9,159 +9,105 @@ (** Tezos - Versioned (key x value) store (over Irmin) *) +open Hash open Logging.Db module IrminPath = Irmin.Path.String_list module MBytesContent = struct - module Tc_S0 = - (val Tc.biject Tc.cstruct Cstruct.to_bigarray Cstruct.of_bigarray) - include Tc_S0 - module Path = Irmin.Path.String_list - let merge = - let fn = Irmin.Merge.(option (module Tc_S0) (default (module Tc_S0))) in - fun _path -> fn + type t = MBytes.t + let t = + Irmin.Type.(like cstruct) + (fun x -> Cstruct.to_bigarray x) + (fun x -> Cstruct.of_bigarray x) + let merge = Irmin.Merge.default Irmin.Type.(option t) + let pp ppf b = Format.pp_print_string ppf (MBytes.to_string b) + let of_string s = Ok (MBytes.of_string s) end -module GitStore = struct - - module Store = - Irmin_unix.Irmin_git.FS - (MBytesContent) (Irmin.Ref.String) (Irmin.Hash.SHA1) - - include Store - - module View = Irmin.View (Store) - - module FunView = struct - include Ir_funview.Make (Store) - type v = t * Lwt_utils.Idle_waiter.t - let get (t, w) k = - Lwt_utils.Idle_waiter.task w @@ fun () -> - read t k - let mem (t, w) k = - Lwt_utils.Idle_waiter.task w @@ fun () -> - mem t k - let dir_mem (t, w) k = - Lwt_utils.Idle_waiter.task w @@ fun () -> - dir_mem t k - let del (t, w) k = - Lwt_utils.Idle_waiter.task w @@ fun () -> - remove t k >>= fun t -> - Lwt.return (t, w) - let remove_rec (t, w) k = - Lwt_utils.Idle_waiter.task w @@ fun () -> - remove_rec t k >>= fun t -> - Lwt.return (t, w) - let set (t, w) k v = - Lwt_utils.Idle_waiter.task w @@ fun () -> - update t k v >>= fun t -> - Lwt.return (t, w) - let update_path db k (t, w) = - Lwt_utils.Idle_waiter.task w @@ fun () -> - update_path db k t - let list (t, w) k = - Lwt_utils.Idle_waiter.task w @@ fun () -> - Lwt_list.map_p (list t) k >|= List.flatten - end - -end +module GitStore = + Irmin_unix.Git.FS.Make + (MBytesContent) (Irmin.Path.String_list) (Irmin.Branch.String) type index = { path: string ; repo: GitStore.Repo.t ; patch_context: context -> context Lwt.t ; mutable commits: int ; - repack_scheduler : Lwt_utils.Idle_waiter.t ; + repack_scheduler: Lwt_utils.Idle_waiter.t ; } + and context = { index: index ; - store: GitStore.t ; - view: GitStore.FunView.v ; + parents: GitStore.Commit.t list ; + tree: GitStore.tree ; } type t = context +type commit = GitStore.Commit.Hash.t + +let dummy_commit = + match + GitStore.Commit.Hash.of_string "0000000000000000000000000000000000000000" + with + | Ok c -> c + | Error _ -> assert false + +let commit_encoding : commit Data_encoding.t = + let open Data_encoding in + conv + (fun c -> Cstruct.to_bigarray (Irmin.Type.encode_cstruct GitStore.Commit.Hash.t c)) + (fun c -> + match + Irmin.Type.decode_cstruct + GitStore.Commit.Hash.t + (Cstruct.of_bigarray c) + with + | Ok x -> x + | _ -> assert false + ) + bytes + (*-- Version Access and Update -----------------------------------------------*) let current_protocol_key = ["protocol"] let current_test_network_key = ["test_network"] -let exists { repo } key = - GitStore.of_branch_id - Irmin.Task.none (Block_hash.to_b58check key) repo >>= fun t -> - let store = t () in - GitStore.read store current_protocol_key >>= function - | Some _ -> - Lwt.return true - | None -> - Lwt.return false +let exists index key = + Lwt_utils.Idle_waiter.task index.repack_scheduler @@ fun () -> + GitStore.Commit.of_hash index.repo key >>= function + | None -> Lwt.return_false + | Some _ -> Lwt.return_true let checkout index key = - lwt_debug "-> Context.checkout %a" - Block_hash.pp_short key >>= fun () -> - exists index key >>= fun exists -> - if not exists then - Lwt.return None - else - GitStore.of_branch_id - Irmin.Task.none (Block_hash.to_b58check key) index.repo >>= fun t -> - let store = t () in - GitStore.FunView.of_path store [] >>= fun view -> - let view = (view, index.repack_scheduler) in - let ctxt = { index ; store ; view } in - index.patch_context ctxt >>= fun ctxt -> - lwt_debug "<- Context.checkout %a OK" - Block_hash.pp_short key >>= fun () -> - Lwt.return (Some ctxt) + Lwt_utils.Idle_waiter.task index.repack_scheduler @@ fun () -> + GitStore.Commit.of_hash index.repo key >>= function + | None -> Lwt.return_none + | Some commit -> + GitStore.Commit.tree commit >>= fun tree -> + let ctxt = { index ; tree ; parents = [commit] } in + index.patch_context ctxt >>= fun ctxt -> + Lwt.return (Some ctxt) let checkout_exn index key = checkout index key >>= function | None -> Lwt.fail Not_found | Some p -> Lwt.return p -let exists index key = - lwt_debug "-> Context.exists %a" - Block_hash.pp_short key >>= fun () -> - exists index key >>= fun exists -> - lwt_debug "<- Context.exists %a %B" - Block_hash.pp_short key exists >>= fun () -> - Lwt.return exists exception Preexistent_context of Block_hash.t exception Empty_head of Block_hash.t -let commit key ~time ~message context = - let task = Irmin.Task.create ~date:(Time.to_seconds time) ~owner:"Tezos" in - GitStore.clone task context.store (Block_hash.to_b58check key) >>= function - | `Empty_head -> Lwt.fail (Empty_head key) - | `Duplicated_branch -> Lwt.fail (Preexistent_context key) - | `Ok store -> - GitStore.FunView.update_path - (store message) [] context.view >>= fun () -> - context.index.commits <- context.index.commits + 1 ; - if context.index.commits mod 200 = 0 then - Lwt_utils.Idle_waiter.force_idle - context.index.repack_scheduler - (fun () -> - lwt_debug "begin git repack" >>= fun () -> - let command = - "git", - [| "git" ; "-C" ; context.index.path ; - "repack" ; "-a" ; "-d" |] in - let t0 = Unix.gettimeofday () in - Lwt_process.exec - ~stdout: `Dev_null ~stderr: `Dev_null - command >>= fun res -> - let dt = Unix.gettimeofday () -. t0 in - match res with - | WEXITED 0 -> - lwt_log_notice "git repack complete in %0.2f sec" dt - | WEXITED code | WSTOPPED code | WSIGNALED code -> - lwt_log_error "git repack failed with code %d after %0.2f sec" - code dt) >>= fun () -> - Lwt.return () - else - Lwt.return () +let raw_commit ~time ~message context = + let info = + Irmin.Info.v ~date:(Time.to_seconds time) ~author:"Tezos" message in + GitStore.Commit.v + context.index.repo ~info ~parents:context.parents context.tree + +let commit ~time ~message context = + Lwt_utils.Idle_waiter.task context.index.repack_scheduler @@ fun () -> + raw_commit ~time ~message context >>= fun commit -> + Lwt.return (GitStore.Commit.hash commit) (*-- Generic Store Primitives ------------------------------------------------*) @@ -173,33 +119,44 @@ let undata_key = function | _ -> assert false let mem ctxt key = - GitStore.FunView.mem ctxt.view (data_key key) >>= fun v -> + Lwt_utils.Idle_waiter.task ctxt.index.repack_scheduler @@ fun () -> + GitStore.Tree.mem ctxt.tree (data_key key) >>= fun v -> Lwt.return v let dir_mem ctxt key = - GitStore.FunView.dir_mem ctxt.view (data_key key) >>= fun v -> + Lwt_utils.Idle_waiter.task ctxt.index.repack_scheduler @@ fun () -> + GitStore.Tree.mem_tree ctxt.tree (data_key key) >>= fun v -> Lwt.return v -let raw_get ctxt key = GitStore.FunView.get ctxt.view key +let raw_get ctxt key = + Lwt_utils.Idle_waiter.task ctxt.index.repack_scheduler @@ fun () -> + GitStore.Tree.find ctxt.tree key let get t key = raw_get t (data_key key) let raw_set ctxt key data = - GitStore.FunView.set ctxt.view key data >>= fun view -> - Lwt.return { ctxt with view } + Lwt_utils.Idle_waiter.task ctxt.index.repack_scheduler @@ fun () -> + GitStore.Tree.add ctxt.tree key data >>= fun tree -> + Lwt.return { ctxt with tree } let set t key data = raw_set t (data_key key) data let raw_del ctxt key = - GitStore.FunView.del ctxt.view key >>= fun view -> - Lwt.return { ctxt with view } + Lwt_utils.Idle_waiter.task ctxt.index.repack_scheduler @@ fun () -> + GitStore.Tree.remove ctxt.tree key >>= fun tree -> + Lwt.return { ctxt with tree } let del t key = raw_del t (data_key key) +let list_one ctxt key = + Lwt_utils.Idle_waiter.task ctxt.index.repack_scheduler @@ fun () -> + GitStore.Tree.list ctxt.tree (data_key key) >>= fun keys -> + Lwt.return (List.map (fun (k,_) -> key @ [k]) keys) + let list ctxt keys = - GitStore.FunView.list ctxt.view (List.map data_key keys) >>= fun keys -> - Lwt.return (List.map undata_key keys) + Lwt_list.map_p (list_one ctxt) keys >|= List.flatten let remove_rec ctxt key = - GitStore.FunView.remove_rec ctxt.view (data_key key) >>= fun view -> - Lwt.return { ctxt with view } + Lwt_utils.Idle_waiter.task ctxt.index.repack_scheduler @@ fun () -> + GitStore.Tree.remove ctxt.tree (data_key key) >>= fun tree -> + Lwt.return { ctxt with tree } (*-- Predefined Fields -------------------------------------------------------*) @@ -275,50 +232,46 @@ let fork_test_network v ~protocol ~expiration = (*-- Initialisation ----------------------------------------------------------*) let init ?patch_context ~root = - GitStore.Repo.create - (Irmin_unix.Irmin_git.config ~root ~bare:true ()) >>= fun repo -> + GitStore.Repo.v + (Irmin_git.config ~bare:true root) >>= fun repo -> Lwt.return { commits = 0 ; - repack_scheduler = Lwt_utils.Idle_waiter.create () ; path = root ; repo ; + repack_scheduler = Lwt_utils.Idle_waiter.create () ; patch_context = match patch_context with | None -> (fun ctxt -> Lwt.return ctxt) | Some patch_context -> patch_context } -let commit_genesis index ~id:block ~time ~protocol = - let task = Irmin.Task.create ~date:(Time.to_seconds time) ~owner:"Tezos" in - GitStore.of_branch_id - task (Block_hash.to_b58check block) - index.repo >>= fun t -> - let store = t "Genesis" in - GitStore.FunView.of_path store [] >>= fun view -> - let view = (view, index.repack_scheduler) in - let ctxt = { index ; store ; view } in +let get_branch net_id = Format.asprintf "%a" Net_id.pp net_id + + +let commit_genesis index ~net_id ~time ~protocol = + Lwt_utils.Idle_waiter.task index.repack_scheduler @@ fun () -> + let tree = GitStore.Tree.empty in + let ctxt = { index ; tree ; parents = [] } in + index.patch_context ctxt >>= fun ctxt -> set_protocol ctxt protocol >>= fun ctxt -> set_test_network ctxt Not_running >>= fun ctxt -> - index.patch_context ctxt >>= fun ctxt -> - GitStore.FunView.update_path ctxt.store [] ctxt.view >>= fun () -> - Lwt.return ctxt + raw_commit ~time ~message:"Genesis" ctxt >>= fun commit -> + GitStore.Branch.set index.repo (get_branch net_id) commit >>= fun () -> + Lwt.return (GitStore.Commit.hash commit) let compute_testnet_genesis forked_block = let genesis = Block_hash.hash_bytes [Block_hash.to_bytes forked_block] in let net_id = Net_id.of_block_hash genesis in net_id, genesis -let commit_test_network_genesis forked_block time ctxt = +let commit_test_network_genesis index forked_block time ctxt = + Lwt_utils.Idle_waiter.task index.repack_scheduler @@ fun () -> let net_id, genesis = compute_testnet_genesis forked_block in - let task = Irmin.Task.create ~date:(Time.to_seconds time) ~owner:"Tezos" in - GitStore.clone task ctxt.store (Block_hash.to_b58check genesis) >>= function - | `Empty_head -> fail (Exn (Empty_head genesis)) - | `Duplicated_branch -> fail (Exn (Preexistent_context genesis)) - | `Ok store -> - let msg = - Format.asprintf "Forking testnet: %a." Net_id.pp_short net_id in - GitStore.FunView.update_path (store msg) [] ctxt.view >>= fun () -> - return (net_id, genesis) + let branch = get_branch net_id in + let message = Format.asprintf "Forking testnet: %s." branch in + raw_commit ~time ~message ctxt >>= fun commit -> + GitStore.Branch.set index.repo branch commit >>= fun () -> + return (net_id, genesis, GitStore.Commit.hash commit) let reset_test_network ctxt forked_block timestamp = get_test_network ctxt >>= function @@ -333,3 +286,24 @@ let reset_test_network ctxt forked_block timestamp = set_test_network ctxt (Running { net_id ; genesis ; protocol ; expiration }) + +let clear_test_network index net_id = + (* TODO remove commits... ??? *) + Lwt_utils.Idle_waiter.task index.repack_scheduler @@ fun () -> + let branch = get_branch net_id in + GitStore.Branch.remove index.repo branch + +let set_head index net_id commit = + Lwt_utils.Idle_waiter.task index.repack_scheduler @@ fun () -> + let branch = get_branch net_id in + GitStore.Commit.of_hash index.repo commit >>= function + | None -> assert false + | Some commit -> + GitStore.Branch.set index.repo branch commit + +let set_master index commit = + Lwt_utils.Idle_waiter.task index.repack_scheduler @@ fun () -> + GitStore.Commit.of_hash index.repo commit >>= function + | None -> assert false + | Some commit -> + GitStore.Branch.set index.repo GitStore.Branch.master commit diff --git a/src/node/db/context.mli b/src/node/db/context.mli index 9d94f9c69..554234f40 100644 --- a/src/node/db/context.mli +++ b/src/node/db/context.mli @@ -16,6 +16,11 @@ type index type t type context = t +type commit + +val dummy_commit: commit +val commit_encoding: commit Data_encoding.t + (** Open or initialize a versioned store at a given path. *) val init: ?patch_context:(context -> context Lwt.t) -> @@ -24,14 +29,14 @@ val init: val commit_genesis: index -> - id:Block_hash.t -> + net_id:Net_id.t -> time:Time.t -> protocol:Protocol_hash.t -> - context Lwt.t + commit Lwt.t val commit_test_network_genesis: - Block_hash.t -> Time.t -> context -> - (Net_id.t * Block_hash.t) tzresult Lwt.t + index -> Block_hash.t -> Time.t -> context -> + (Net_id.t * Block_hash.t * commit) tzresult Lwt.t (** {2 Generic interface} ****************************************************) @@ -39,15 +44,16 @@ include Persist.STORE with type t := context (** {2 Accessing and Updating Versions} **************************************) -exception Preexistent_context of Block_hash.t -val exists: index -> Block_hash.t -> bool Lwt.t -val checkout: index -> Block_hash.t -> context option Lwt.t -val checkout_exn: index -> Block_hash.t -> context Lwt.t +val exists: index -> commit -> bool Lwt.t +val checkout: index -> commit -> context option Lwt.t +val checkout_exn: index -> commit -> context Lwt.t val commit: - Block_hash.t -> time:Time.t -> message:string -> - context -> unit Lwt.t + context -> + commit Lwt.t +val set_head: index -> Net_id.t -> commit -> unit Lwt.t +val set_master: index -> commit -> unit Lwt.t (** {2 Predefined Fields} ****************************************************) @@ -77,3 +83,4 @@ val reset_test_network: context -> Block_hash.t -> Time.t -> context Lwt.t val fork_test_network: context -> protocol:Protocol_hash.t -> expiration:Time.t -> context Lwt.t +val clear_test_network: index -> Net_id.t -> unit Lwt.t diff --git a/src/node/db/ir_funview.ml b/src/node/db/ir_funview.ml deleted file mode 100644 index 2f9c24530..000000000 --- a/src/node/db/ir_funview.ml +++ /dev/null @@ -1,689 +0,0 @@ -(**************************************************************************) -(* *) -(* Copyright (c) 2014 - 2016. *) -(* Dynamic Ledger Solutions, Inc. *) -(* *) -(* All rights reserved. No warranty, explicit or implicit, provided. *) -(* *) -(**************************************************************************) - -(* - * Copyright (c) 2013-2015 Thomas Gazagnaire - * Copyright (c) 2016 Grégoire Henry - * - * Permission to use, copy, modify, and distribute this software for any - * purpose with or without fee is hereby granted, provided that the above - * copyright notice and this permission notice appear in all copies. - * - * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES - * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF - * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR - * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES - * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN - * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF - * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. - *) - -open Lwt.Infix - -(* Import Ir_hum.S *) -module type Hum = sig - include Tc.S0 - val to_hum: t -> string - val of_hum: string -> t -end - - -(***** views *) - -module type NODE = sig - type t - type node - type contents - module Contents: Tc.S0 with type t = contents - module Path : sig - (* Import Ir_S.PATH *) - include Hum - type step - val empty: t - val create: step list -> t - val is_empty: t -> bool - val cons: step -> t -> t - val rcons: t -> step -> t - val decons: t -> (step * t) option - val rdecons: t -> (t * step) option - val map: t -> (step -> 'a) -> 'a list - module Step: Hum with type t = step - end - - val empty: unit -> t - val is_empty: t -> bool Lwt.t - - val read: t -> node option Lwt.t - - val read_contents: t -> Path.step -> contents option Lwt.t - - val with_contents: t -> Path.step -> contents option -> t option Lwt.t - (* Return [true] iff the contents has actually changed. Used for - invalidating the view cache if needed. *) - - val read_succ: node -> Path.step -> t option - - val with_succ: t -> Path.step -> t option -> t option Lwt.t - (* Return [true] iff the successors has actually changes. Used for - invalidating the view cache if needed. *) - - val steps: t -> Path.step list Lwt.t -end - -module Ir_misc = struct - module Set (K: Tc.S0) = struct - - include Set.Make(K) - - let of_list l = - List.fold_left (fun set elt -> add elt set) empty l - - let to_list = elements - - include Tc.As_L0(struct - type u = t - type t = u - module K = K - let to_list = to_list - let of_list = of_list - end) - end - (* assume l1 and l2 are key-sorted *) - let alist_iter2 compare_k f l1 l2 = - let rec aux l1 l2 = match l1, l2 with - | [], t -> List.iter (fun (key, v) -> f key (`Right v)) t - | t, [] -> List.iter (fun (key, v) -> f key (`Left v)) t - | (k1,v1)::t1, (k2,v2)::t2 -> - match compare_k k1 k2 with - | 0 -> - f k1 (`Both (v1, v2)); - aux t1 t2 - | x -> if x < 0 then ( - f k1 (`Left v1); - aux t1 l2 - ) else ( - f k2 (`Right v2); - aux l1 t2 - ) - in - aux l1 l2 - module Map_ext (M: Map.S) (K: Tc.S0 with type t = M.key) = struct - - include M - - let keys m = - List.map fst (bindings m) - - let of_alist l = - List.fold_left (fun map (k, v) -> add k v map) empty l - - let to_alist = bindings - - let add_multi key data t = - try - let l = find key t in - add key (data :: l) t - with Not_found -> - add key [data] t - - let iter2 f t1 t2 = - alist_iter2 K.compare f (bindings t1) (bindings t2) - - module Lwt = struct - open Lwt - - let iter2 f m1 m2 = - let m3 = ref [] in - iter2 (fun key data -> - m3 := f key data :: !m3 - ) m1 m2; - Lwt_list.iter_p - (fun b -> b >>= fun () -> return_unit) (List.rev !m3) - - let merge f m1 m2 = - let l3 = ref [] in - let f key data = - f key data >>= function - | None -> return_unit - | Some v -> l3 := (key, v) :: !l3; return_unit - in - iter2 f m1 m2 >>= fun () -> - let m3 = of_alist !l3 in - return m3 - - end - - include Tc.As_AL1(struct - type 'a r = 'a t - type 'a t = 'a r - module K = K - let of_alist = of_alist - let to_alist = to_alist - end) - end - module Map (S: Tc.S0) = Map_ext (Map.Make(S))(S) - -end - -module Make (S: Irmin.S) = struct - - module P = S.Private - module Path = S.Key - module PathSet = Ir_misc.Set(Path) - - module Step = Path.Step - module StepMap = Ir_misc.Map(Path.Step) - module StepSet = Ir_misc.Set(Path.Step) - - module Contents = struct - - type key = S.Repo.t * S.Private.Contents.key - - type contents_or_key = - | Key of key - | Contents of S.value - | Both of key * S.value - - type t = contents_or_key ref - (* Same as [Contents.t] but can either be a raw contents or a key - that will be fetched lazily. *) - - let create c = - ref (Contents c) - - let export c = - match !c with - | Both ((_, k), _) - | Key (_, k) -> k - | Contents _ -> Pervasives.failwith "Contents.export" - - let key db k = - ref (Key (db, k)) - - let read t = - match !t with - | Both (_, c) - | Contents c -> Lwt.return (Some c) - | Key (db, k as key) -> - P.Contents.read (P.Repo.contents_t db) k >>= function - | None -> Lwt.return_none - | Some c -> - t := Both (key, c); - Lwt.return (Some c) - - let equal (x:t) (y:t) = - x == y - || - match !x, !y with - | (Key (_,x) | Both ((_,x),_)), (Key (_,y) | Both ((_,y),_)) -> - P.Contents.Key.equal x y - | (Contents x | Both (_, x)), (Contents y | Both (_, y)) -> - P.Contents.Val.equal x y - | _ -> false - - end - - module Node = struct - - type contents = S.value - type key = S.Repo.t * P.Node.key - - type node = { - contents: Contents.t StepMap.t; - succ : t StepMap.t; - alist : (Path.step * [`Contents of Contents.t | `Node of t ]) list Lazy.t; - } - - and t = { - mutable node: node option ; - mutable key: key option ; - } - - let rec equal (x:t) (y:t) = - match x, y with - | { key = Some (_,x) ; _ }, { key = Some (_,y) ; _ } -> - P.Node.Key.equal x y - | { node = Some x ; _ }, { node = Some y ; _ } -> - List.length (Lazy.force x.alist) = List.length (Lazy.force y.alist) - && List.for_all2 (fun (s1, n1) (s2, n2) -> - Step.equal s1 s2 - && match n1, n2 with - | `Contents n1, `Contents n2 -> Contents.equal n1 n2 - | `Node n1, `Node n2 -> equal n1 n2 - | _ -> false) (Lazy.force x.alist) (Lazy.force y.alist) - | _ -> false - - let mk_alist contents succ = - lazy ( - StepMap.fold - (fun step c acc -> (step, `Contents c) :: acc) - contents @@ - StepMap.fold - (fun step c acc -> (step, `Node c) :: acc) - succ - []) - let mk_index alist = - List.fold_left (fun (contents, succ) (l, x) -> - match x with - | `Contents c -> StepMap.add l c contents, succ - | `Node n -> contents, StepMap.add l n succ - ) (StepMap.empty, StepMap.empty) alist - - let create_node contents succ = - let alist = mk_alist contents succ in - { contents; succ; alist } - - let create contents succ = - { key = None ; node = Some (create_node contents succ) } - - let key db k = - { key = Some (db, k) ; node = None } - - let both db k v = - { key = Some (db, k) ; node = Some v } - - let empty () = create StepMap.empty StepMap.empty - - let import t n = - let alist = P.Node.Val.alist n in - let alist = List.map (fun (l, x) -> - match x with - | `Contents (c, _meta) -> (l, `Contents (Contents.key t c)) - | `Node n -> (l, `Node (key t n)) - ) alist in - let contents, succ = mk_index alist in - create_node contents succ - - let export n = - match n.key with - | Some (_, k) -> k - | None -> Pervasives.failwith "Node.export" - - let export_node n = - let alist = List.map (fun (l, x) -> - match x with - | `Contents c -> (l, `Contents (Contents.export c, - P.Node.Val.Metadata.default)) - | `Node n -> (l, `Node (export n)) - ) (Lazy.force n.alist) - in - P.Node.Val.create alist - - let read t = - match t with - | { key = None ; node = None } -> assert false - | { node = Some n ; _ } -> Lwt.return (Some n) - | { key = Some (db, k) ; _ } -> - P.Node.read (P.Repo.node_t db) k >>= function - | None -> Lwt.return_none - | Some n -> - let n = import db n in - t.node <- Some n; - Lwt.return (Some n) - - let is_empty t = - read t >>= function - | None -> Lwt.return false - | Some n -> Lwt.return (Lazy.force n.alist = []) - - let steps t = - read t >>= function - | None -> Lwt.return_nil - | Some n -> - let steps = ref StepSet.empty in - List.iter - (fun (l, _) -> steps := StepSet.add l !steps) - (Lazy.force n.alist); - Lwt.return (StepSet.to_list !steps) - - let read_contents t step = - read t >>= function - | None -> Lwt.return_none - | Some t -> - try - StepMap.find step t.contents - |> Contents.read - with Not_found -> - Lwt.return_none - - let read_succ t step = - try Some (StepMap.find step t.succ) - with Not_found -> None - - let with_contents t step contents = - read t >>= function - | None -> begin - match contents with - | None -> Lwt.return_none - | Some c -> - let contents = StepMap.singleton step (Contents.create c) in - Lwt.return (Some (create contents StepMap.empty)) - end - | Some n -> begin - match contents with - | None -> - if StepMap.mem step n.contents then - let contents = StepMap.remove step n.contents in - Lwt.return (Some (create contents n.succ)) - else - Lwt.return_none - | Some c -> - try - let previous = StepMap.find step n.contents in - if not (Contents.equal (Contents.create c) previous) then - raise Not_found; - Lwt.return_none - with Not_found -> - let contents = - StepMap.add step (Contents.create c) n.contents in - Lwt.return (Some (create contents n.succ)) - end - - let with_succ t step succ = - read t >>= function - | None -> begin - match succ with - | None -> Lwt.return_none - | Some c -> - let succ = StepMap.singleton step c in - Lwt.return (Some (create StepMap.empty succ)) - end - | Some n -> begin - match succ with - | None -> - if StepMap.mem step n.succ then - let succ = StepMap.remove step n.succ in - Lwt.return (Some (create n.contents succ)) - else - Lwt.return_none - | Some c -> - try - let previous = StepMap.find step n.succ in - if c != previous then raise Not_found; - Lwt.return_none - with Not_found -> - let succ = StepMap.add step c n.succ in - Lwt.return (Some (create n.contents succ)) - end - - end - - type key = Path.t - type value = Node.contents - - type t = [`Empty | `Node of Node.t | `Contents of Node.contents] - - module CO = Tc.Option(P.Contents.Val) - module PL = Tc.List(Path) - - let empty = `Empty - - let sub t path = - let rec aux node path = - match Path.decons path with - | None -> Lwt.return (Some node) - | Some (h, p) -> - Node.read node >>= function - | None -> Lwt.return_none - | Some t -> - match Node.read_succ t h with - | None -> Lwt.return_none - | Some v -> aux v p - in - match t with - | `Empty -> Lwt.return_none - | `Node n -> aux n path - | `Contents _ -> Lwt.return_none - - let read_contents t path = - match t, Path.rdecons path with - | `Contents c, None -> Lwt.return (Some c) - | _ , None -> Lwt.return_none - | _ , Some (path, file) -> - sub t path >>= function - | None -> Lwt.return_none - | Some n -> Node.read_contents n file - - let read t k = read_contents t k - - let err_not_found n k = - Printf.ksprintf - invalid_arg "Irmin.View.%s: %s not found" n (Path.to_hum k) - - let read_exn t k = - read t k >>= function - | None -> err_not_found "read" k - | Some v -> Lwt.return v - - let mem t k = - read t k >>= function - | None -> Lwt.return false - | _ -> Lwt.return true - - let dir_mem t k = - sub t k >>= function - | Some _ -> Lwt.return true - | None -> Lwt.return false - - let list_aux t path = - sub t path >>= function - | None -> Lwt.return [] - | Some n -> - Node.steps n >>= fun steps -> - let paths = - List.fold_left (fun set p -> - PathSet.add (Path.rcons path p) set - ) PathSet.empty steps - in - Lwt.return (PathSet.to_list paths) - - let list t path = - list_aux t path - - let iter t fn = - let rec aux = function - | [] -> Lwt.return_unit - | path::tl -> - list t path >>= fun childs -> - let todo = childs @ tl in - mem t path >>= fun exists -> - begin - if not exists then Lwt.return_unit - else fn path (fun () -> read_exn t path) - end >>= fun () -> - aux todo - in - list t Path.empty >>= aux - - let update_contents_aux t k v = - match Path.rdecons k with - | None -> begin - match t, v with - | `Empty, None -> Lwt.return t - | `Contents c, Some v when P.Contents.Val.equal c v -> Lwt.return t - | _, None -> Lwt.return `Empty - | _, Some c -> Lwt.return (`Contents c) - end - | Some (path, file) -> - let rec aux view path = - match Path.decons path with - | None -> Node.with_contents view file v - | Some (h, p) -> - Node.read view >>= function - | None -> - if v = None then Lwt.return_none - else err_not_found "update_contents" k (* XXX ?*) - | Some n -> - match Node.read_succ n h with - | Some child -> begin - aux child p >>= function - | None -> Lwt.return_none - | Some child -> begin - if v = None then - (* remove empty dirs *) - Node.is_empty child >>= function - | true -> Lwt.return_none - | false -> Lwt.return (Some child) - else - Lwt.return (Some child) - end >>= fun child -> - Node.with_succ view h child - end - | None -> - if v = None then - Lwt.return_none - else - aux (Node.empty ()) p >>= function - | None -> assert false - | Some _ as child -> Node.with_succ view h child - in - let n = match t with `Node n -> n | _ -> Node.empty () in - aux n path >>= function - | None -> Lwt.return t - | Some node -> - Node.is_empty node >>= function - | true -> Lwt.return `Empty - | false -> Lwt.return (`Node node) - - let update_contents t k v = - update_contents_aux t k v - - let update t k v = update_contents t k (Some v) - - let remove t k = update_contents t k None - - let remove_rec t k = - match Path.decons k with - | None -> Lwt.return t - | _ -> - match t with - | `Contents _ -> Lwt.return `Empty - | `Empty -> Lwt.return t - | `Node n -> - let rec aux view path = - match Path.decons path with - | None -> assert false - | Some (h,p) -> - if Path.is_empty p then - Node.with_succ view h None - else - Node.read view >>= function - | None -> Lwt.return_none - | Some n -> - match Node.read_succ n h with - | None -> - Lwt.return_none - | Some child -> - aux child p >>= function - | None -> Lwt.return_none - | Some child -> begin - (* remove empty dirs *) - Node.is_empty child >>= function - | true -> Lwt.return_none - | false -> Lwt.return (Some child) - end >>= fun child -> - Node.with_succ view h child - in - aux n k >>= function - | None -> Lwt.return t - | Some node -> - Node.is_empty node >>= function - | true -> Lwt.return `Empty - | false -> Lwt.return (`Node node) - - type db = S.t - - let import db key = - let repo = S.repo db in - begin P.Node.read (P.Repo.node_t repo) key >|= function - | None -> `Empty - | Some n -> `Node (Node.both repo key (Node.import repo n)) - end - - let export repo t = - let node n = P.Node.add (P.Repo.node_t repo) (Node.export_node n) in - let todo = Stack.create () in - let rec add_to_todo n = - match n with - | { Node.key = Some _ ; _ } -> () - | { Node.key = None ; node = None } -> assert false - | { Node.key = None ; node = Some x } -> - (* 1. we push the current node job on the stack. *) - Stack.push (fun () -> - node x >>= fun k -> - n.Node.key <- Some (repo, k); - n.Node.node <- None; (* Clear cache ?? *) - Lwt.return_unit - ) todo; - (* 2. we push the contents job on the stack. *) - List.iter (fun (_, x) -> - match x with - | `Node _ -> () - | `Contents c -> - match !c with - | Contents.Both _ - | Contents.Key _ -> () - | Contents.Contents x -> - Stack.push (fun () -> - P.Contents.add (P.Repo.contents_t repo) x >>= fun k -> - c := Contents.Key (repo, k); - Lwt.return_unit - ) todo - ) (Lazy.force x.Node.alist); - (* 3. we push the children jobs on the stack. *) - List.iter (fun (_, x) -> - match x with - | `Contents _ -> () - | `Node n -> - Stack.push (fun () -> add_to_todo n; Lwt.return_unit) todo - ) (Lazy.force x.Node.alist); - in - let rec loop () = - let task = - try Some (Stack.pop todo) - with Stack.Empty -> None - in - match task with - | None -> Lwt.return_unit - | Some t -> t () >>= loop - in - match t with - | `Empty -> Lwt.return `Empty - | `Contents c -> Lwt.return (`Contents c) - | `Node n -> - add_to_todo n; - loop () >|= fun () -> - `Node (Node.export n) - - let of_path db path = - P.read_node db path >>= function - | None -> Lwt.return `Empty - | Some n -> import db n - - let update_path db path view = - let repo = S.repo db in - export repo view >>= function - | `Empty -> P.remove_node db path - | `Contents c -> S.update db path c - | `Node node -> P.update_node db path node - -end - -module type S = sig - include Irmin.RO - val dir_mem: t -> key -> bool Lwt.t - val update: t -> key -> value -> t Lwt.t - val remove: t -> key -> t Lwt.t - val list: t -> key -> key list Lwt.t - val remove_rec: t -> key -> t Lwt.t - val empty: t - type db - val of_path: db -> key -> t Lwt.t - val update_path: db -> key -> t -> unit Lwt.t -end diff --git a/src/node/db/ir_funview.mli b/src/node/db/ir_funview.mli deleted file mode 100644 index b72dca5c2..000000000 --- a/src/node/db/ir_funview.mli +++ /dev/null @@ -1,26 +0,0 @@ -(**************************************************************************) -(* *) -(* Copyright (c) 2014 - 2016. *) -(* Dynamic Ledger Solutions, Inc. *) -(* *) -(* All rights reserved. No warranty, explicit or implicit, provided. *) -(* *) -(**************************************************************************) - -module type S = sig - include Irmin.RO - val dir_mem: t -> key -> bool Lwt.t - val update: t -> key -> value -> t Lwt.t - val remove: t -> key -> t Lwt.t - val list: t -> key -> key list Lwt.t - val remove_rec: t -> key -> t Lwt.t - val empty: t - type db - val of_path: db -> key -> t Lwt.t - val update_path: db -> key -> t -> unit Lwt.t -end - -module Make (S: Irmin.S): - S with type db = S.t - and type key = S.key - and type value = S.value diff --git a/src/node/db/store.ml b/src/node/db/store.ml index e4ebb4a3b..f1dd7a5a4 100644 --- a/src/node/db/store.ml +++ b/src/node/db/store.ml @@ -87,6 +87,7 @@ module Block = struct message: string ; operation_list_count: int ; max_operations_ttl: int ; + context: Context.commit ; } module Contents = @@ -99,15 +100,18 @@ module Block = struct let open Data_encoding in conv (fun { header ; message ; operation_list_count ; - max_operations_ttl } -> - (message, operation_list_count, max_operations_ttl, header)) + max_operations_ttl ; context } -> + (message, operation_list_count, max_operations_ttl, + context, header)) (fun (message, operation_list_count, - max_operations_ttl, header) -> - { header ; message ; max_operations_ttl ; operation_list_count }) - (obj4 + max_operations_ttl, context, header) -> + { header ; message ; max_operations_ttl ; + operation_list_count ; context }) + (obj5 (req "message" string) (req "operation_list_count" uint8) (req "max_operations_ttl" uint16) + (req "context" Context.commit_encoding) (req "header" Block_header.encoding)) end)) diff --git a/src/node/db/store.mli b/src/node/db/store.mli index 13d915bc8..fcb326384 100644 --- a/src/node/db/store.mli +++ b/src/node/db/store.mli @@ -90,6 +90,7 @@ module Block : sig message: string ; operation_list_count: int ; max_operations_ttl: int ; + context: Context.commit ; } module Contents : SINGLE_STORE diff --git a/src/node/shell/state.ml b/src/node/shell/state.ml index 246ad677b..bdef798ea 100644 --- a/src/node/shell/state.ml +++ b/src/node/shell/state.ml @@ -95,9 +95,10 @@ type t = global_state module Locked_block = struct - let store_genesis context_index store genesis = + let store_genesis store genesis commit = + let net_id = Net_id.of_block_hash genesis.block in let shell : Block_header.shell_header = { - net_id = Net_id.of_block_hash genesis.block; + net_id ; level = 0l ; proto_level = 0 ; predecessor = genesis.block ; @@ -108,12 +109,8 @@ module Locked_block = struct let header : Block_header.t = { shell ; proto = MBytes.create 0 } in Store.Block.Contents.store (store, genesis.block) { Store.Block.header ; message = "Genesis" ; - operation_list_count = 0 ; max_operations_ttl = 0 } >>= fun () -> - Context.commit_genesis - context_index - ~id:genesis.block - ~time:genesis.time - ~protocol:genesis.protocol >>= fun _context -> + operation_list_count = 0 ; max_operations_ttl = 0 ; + context = commit } >>= fun () -> Lwt.return header end @@ -168,7 +165,7 @@ module Net = struct let locked_create data ?expiration ?(allow_forked_network = false) - net_id genesis = + net_id genesis commit = let net_store = Store.Net.get data.global_store net_id in let block_store = Store.Block.get net_store and chain_store = Store.Chain.get net_store in @@ -189,7 +186,7 @@ module Net = struct Lwt.return_unit end >>= fun () -> Locked_block.store_genesis - data.context_index block_store genesis >>= fun _genesis_header -> + block_store genesis commit >>= fun _genesis_header -> allocate ~genesis ~current_head:genesis.block @@ -205,8 +202,13 @@ module Net = struct if Net_id.Table.mem data.nets net_id then Pervasives.failwith "State.Net.create" else + Context.commit_genesis + data.context_index + ~net_id + ~time:genesis.time + ~protocol:genesis.protocol >>= fun commit -> locked_create - data ?allow_forked_network net_id genesis >>= fun net -> + data ?allow_forked_network net_id genesis commit >>= fun net -> Net_id.Table.add data.nets net_id net ; Lwt.return net end @@ -356,19 +358,22 @@ module Block = struct Block_hash.pp_short hash block_header.shell.level Fitness.pp fitness in - let contents = { - Store.Block.header = block_header ; - message ; - operation_list_count = List.length operations ; - max_operations_ttl ; - } in Shared.use net_state.block_store begin fun store -> Store.Block.Invalid_block.known store hash >>= fun known_invalid -> fail_when known_invalid (failure "Known invalid") >>=? fun () -> Store.Block.Contents.known (store, hash) >>= fun known -> if known then - return false + return None else begin + Context.commit + ~time:block_header.shell.timestamp ~message context >>= fun commit -> + let contents = { + Store.Block.header = block_header ; + message ; + operation_list_count = List.length operations ; + max_operations_ttl ; + context = commit ; + } in Store.Block.Contents.store (store, hash) contents >>= fun () -> let hashes = List.map (List.map Operation.hash) operations in let list_hashes = List.map Operation_list_hash.compute hashes in @@ -382,24 +387,18 @@ module Block = struct Lwt_list.iteri_p (fun i ops -> Store.Block.Operations.store (store, hash) i ops) operations >>= fun () -> - Context.commit - hash block_header.shell.timestamp message context >>= fun () -> - return true + (* Update the chain state. *) + Shared.use net_state.chain_state begin fun chain_state -> + let store = chain_state.chain_store in + let predecessor = block_header.shell.predecessor in + Store.Chain.Known_heads.remove store predecessor >>= fun () -> + Store.Chain.Known_heads.store store hash + end >>= fun () -> + let block = { net_state ; hash ; contents } in + Watcher.notify net_state.block_watcher block ; + return (Some block) end - end >>=? fun commited -> - if not commited then - return None - else - (* Update the chain state. *) - Shared.use net_state.chain_state begin fun chain_state -> - let store = chain_state.chain_store in - let predecessor = block_header.shell.predecessor in - Store.Chain.Known_heads.remove store predecessor >>= fun () -> - Store.Chain.Known_heads.store store hash - end >>= fun () -> - let block = { net_state ; hash ; contents } in - Watcher.notify net_state.block_watcher block ; - return (Some block) + end let store_invalid net_state block_header = let bytes = Block_header.to_bytes block_header in @@ -452,21 +451,20 @@ module Block = struct end let context { net_state ; hash } = + Shared.use net_state.block_store begin fun block_store -> + Store.Block.Contents.read_exn (block_store, hash) + end >>= fun { context = commit } -> Shared.use net_state.context_index begin fun context_index -> - Context.checkout_exn context_index hash + Context.checkout_exn context_index commit end - let protocol_hash { net_state ; hash } = - Shared.use net_state.context_index begin fun context_index -> - Context.checkout_exn context_index hash >>= fun context -> - Context.get_protocol context - end + let protocol_hash block = + context block >>= fun context -> + Context.get_protocol context - let test_network { net_state ; hash } = - Shared.use net_state.context_index begin fun context_index -> - Context.checkout_exn context_index hash >>= fun context -> - Context.get_test_network context - end + let test_network block = + context block >>= fun context -> + Context.get_test_network context end @@ -495,15 +493,15 @@ let fork_testnet state block protocol expiration = Context.set_test_network context Not_running >>= fun context -> Context.set_protocol context protocol >>= fun context -> Context.commit_test_network_genesis - block.hash block.contents.header.shell.timestamp - context >>=? fun (net_id, genesis) -> + data.context_index block.hash block.contents.header.shell.timestamp + context >>=? fun (net_id, genesis, commit) -> let genesis = { block = genesis ; time = Time.add block.contents.header.shell.timestamp 1L ; protocol ; } in Net.locked_create data - net_id ~expiration genesis >>= fun net -> + net_id ~expiration genesis commit >>= fun net -> return net end diff --git a/src/tezos-deps.opam b/src/tezos-deps.opam index 37d4af965..2e95d6963 100644 --- a/src/tezos-deps.opam +++ b/src/tezos-deps.opam @@ -19,12 +19,12 @@ depends: [ "calendar" "cohttp" {>= "0.21" } "conduit" - "ezjsonm" {= "0.4.3" } + "ezjsonm" {>= "0.5.0" } "git" "git-unix" "ipv6-multicast" - "irmin-watcher" (* for `irmin.unix` *) - "irmin" {>= "0.12" & < "1.0" } + "irmin" {>= "1.3" } + "irmin-unix" "lwt" {>= "3.0.0" } "lwt_ssl" "menhir" diff --git a/test/p2p/test_p2p_connection.ml b/test/p2p/test_p2p_connection.ml index 7e541022a..55267bebc 100644 --- a/test/p2p/test_p2p_connection.ml +++ b/test/p2p/test_p2p_connection.ml @@ -35,7 +35,7 @@ let rec listen ?port addr = let main_socket = Lwt_unix.(socket PF_INET6 SOCK_STREAM 0) in Lwt_unix.(setsockopt main_socket SO_REUSEADDR true) ; Lwt.catch begin fun () -> - Lwt_unix.Versioned.bind_2 main_socket + Lwt_unix.bind main_socket (ADDR_INET (uaddr, tentative_port)) >>= fun () -> Lwt_unix.listen main_socket 1 ; Lwt.return (main_socket, tentative_port) diff --git a/test/p2p/test_p2p_io_scheduler.ml b/test/p2p/test_p2p_io_scheduler.ml index 78114e673..88cd0e0a2 100644 --- a/test/p2p/test_p2p_io_scheduler.ml +++ b/test/p2p/test_p2p_io_scheduler.ml @@ -22,7 +22,7 @@ let rec listen ?port addr = let main_socket = Lwt_unix.(socket PF_INET6 SOCK_STREAM 0) in Lwt_unix.(setsockopt main_socket SO_REUSEADDR true) ; Lwt.catch begin fun () -> - Lwt_unix.Versioned.bind_2 main_socket + Lwt_unix.bind main_socket (ADDR_INET (uaddr, tentative_port)) >>= fun () -> Lwt_unix.listen main_socket 50 ; Lwt.return (main_socket, tentative_port) diff --git a/test/shell/test_context.ml b/test/shell/test_context.ml index 8329dce20..bd8f1ae36 100644 --- a/test/shell/test_context.ml +++ b/test/shell/test_context.ml @@ -43,28 +43,28 @@ let block2 = Block_hash.of_hex_exn "2222222222222222222222222222222222222222222222222222222222222222" -let create_block2 idx = - checkout idx genesis_block >>= function +let create_block2 idx genesis_commit = + checkout idx genesis_commit >>= function | None -> Assert.fail_msg "checkout genesis_block" | Some ctxt -> set ctxt ["a"; "b"] (MBytes.of_string "Novembre") >>= fun ctxt -> set ctxt ["a"; "c"] (MBytes.of_string "Juin") >>= fun ctxt -> set ctxt ["version";] (MBytes.of_string "0.0") >>= fun ctxt -> - commit block2 ctxt + commit ctxt let block3a = Block_hash.of_hex_exn "3a3a3a3a3a3a3a3a3a3a3a3a3a3a3a3a3a3a3a3a3a3a3a3a3a3a3a3a3a3a3a3a" -let create_block3a idx = - checkout idx block2 >>= function +let create_block3a idx block2_commit = + checkout idx block2_commit >>= function | None -> Assert.fail_msg "checkout block2" | Some ctxt -> del ctxt ["a"; "b"] >>= fun ctxt -> set ctxt ["a"; "d"] (MBytes.of_string "Mars") >>= fun ctxt -> - commit block3a ctxt + commit ctxt let block3b = Block_hash.of_hex_exn @@ -74,26 +74,34 @@ let block3c = Block_hash.of_hex_exn "3c3c3c3c3c3c3c3c3c3c3c3c3c3c3c3c3c3c3c3c3c3c3c3c3c3c3c3c3c3c3c3c" -let create_block3b idx = - checkout idx block2 >>= function +let create_block3b idx block2_commit = + checkout idx block2_commit >>= function | None -> Assert.fail_msg "checkout block3b" | Some ctxt -> del ctxt ["a"; "c"] >>= fun ctxt -> set ctxt ["a"; "d"] (MBytes.of_string "Février") >>= fun ctxt -> - commit block3b ctxt + commit ctxt + +type t = { + idx: Context.index ; + genesis: Context.commit ; + block2: Context.commit ; + block3a: Context.commit ; + block3b: Context.commit ; +} let wrap_context_init f base_dir = let root = base_dir // "context" in Context.init root >>= fun idx -> Context.commit_genesis idx - ~id:genesis.block + ~net_id ~time:genesis.time - ~protocol:genesis.protocol >>= fun _ -> - create_block2 idx >>= fun () -> - create_block3a idx >>= fun () -> - create_block3b idx >>= fun () -> - f idx >>= fun result -> + ~protocol:genesis.protocol >>= fun genesis -> + create_block2 idx genesis >>= fun block2 -> + create_block3a idx block2 >>= fun block3a -> + create_block3b idx block2 >>= fun block3b -> + f { idx; genesis; block2 ; block3a; block3b } >>= fun result -> Error_monad.return result (** Simple test *) @@ -102,7 +110,7 @@ let c = function | None -> None | Some s -> Some (MBytes.to_string s) -let test_simple idx = +let test_simple { idx ; block2 } = checkout idx block2 >>= function | None -> Assert.fail_msg "checkout block2" @@ -115,7 +123,7 @@ let test_simple idx = Assert.equal_string_option ~msg:__LOC__ (Some "Juin") (c juin) ; Lwt.return () -let test_continuation idx = +let test_continuation { idx ; block3a } = checkout idx block3a >>= function | None -> Assert.fail_msg "checkout block3a" @@ -130,7 +138,7 @@ let test_continuation idx = Assert.equal_string_option ~msg:__LOC__ (Some "Mars") (c mars) ; Lwt.return () -let test_fork idx = +let test_fork { idx ; block3b } = checkout idx block3b >>= function | None -> Assert.fail_msg "checkout block3b" @@ -145,8 +153,8 @@ let test_fork idx = Assert.equal_string_option ~msg:__LOC__ (Some "Février") (c mars) ; Lwt.return () -let test_replay idx = - checkout idx genesis_block >>= function +let test_replay { idx ; genesis } = + checkout idx genesis >>= function | None -> Assert.fail_msg "checkout genesis_block" | Some ctxt0 -> @@ -168,8 +176,8 @@ let test_replay idx = Assert.equal_string_option ~msg:__LOC__ (Some "Juillet") (c juillet) ; Lwt.return () -let test_list idx = - checkout idx genesis_block >>= function +let test_list { idx ; genesis } = + checkout idx genesis >>= function | None -> Assert.fail_msg "checkout genesis_block" | Some ctxt -> @@ -197,7 +205,7 @@ let test_list idx = (******************************************************************************) -let tests : (string * (index -> unit Lwt.t)) list = [ +let tests : (string * (t -> unit Lwt.t)) list = [ "simple", test_simple ; "continuation", test_continuation ; "fork", test_fork ; diff --git a/test/shell/test_store.ml b/test/shell/test_store.ml index 03ca3e09d..ee3e987b7 100644 --- a/test/shell/test_store.ml +++ b/test/shell/test_store.ml @@ -91,6 +91,7 @@ let lolblock ?(operations = []) header = operation_list_count = Random.int 32 ; max_operations_ttl = 0 ; message = "" ; + context = Context.dummy_commit ; } let b1 = lolblock "Blop !"