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

Update to irmin.1.3

Browse Source
This commit is contained in:
Grégoire Henry 2017-07-17 15:59:09 +02:00
parent 571e87dacb
commit a01f786de4
15 changed files with 249 additions and 977 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
scripts/install_build_deps.sh
View File

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

3
src/.merlin
View File

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

16
src/Makefile.files
View File

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

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

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

27
src/node/db/context.mli
View File

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

689
src/node/db/ir_funview.ml
View File

@ -1,689 +0,0 @@
(**************************************************************************)
(* *)
(* Copyright (c) 2014 - 2016. *)
(* Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* All rights reserved. No warranty, explicit or implicit, provided. *)
(* *)
(**************************************************************************)
(*
* Copyright (c) 2013-2015 Thomas Gazagnaire <thomas@gazagnaire.org>
* Copyright (c) 2016 Grégoire Henry <gregoire.henry@ocamlpro.com>
*
* 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

26
src/node/db/ir_funview.mli
View File

@ -1,26 +0,0 @@
(**************************************************************************)
(* *)
(* Copyright (c) 2014 - 2016. *)
(* Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* 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

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

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

1
src/node/db/store.mli
View File

@ -90,6 +90,7 @@ module Block : sig
message: string ;
operation_list_count: int ;
max_operations_ttl: int ;
context: Context.commit ;
}
module Contents : SINGLE_STORE

96
src/node/shell/state.ml
View File

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

6
src/tezos-deps.opam
View File

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

2
test/p2p/test_p2p_connection.ml
View File

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

2
test/p2p/test_p2p_io_scheduler.ml
View File

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

54
test/shell/test_context.ml
View File

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

1
test/shell/test_store.ml
View File

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