Proto: reimplements Storage_functors with iterable indexes

The new `Storage_functors` is now a "functional" equivalent of the
"imperative" `Store_helpers` used in the shell.

src/environment/v1/context.mli

@@ -20,8 +20,11 @@ type value = MBytes.t
 
 val mem: t -> key -> bool Lwt.t
 val dir_mem: t -> key -> bool Lwt.t
+
 val get: t -> key -> value option Lwt.t
+
 val set: t -> key -> value -> t Lwt.t
+
 val del: t -> key -> t Lwt.t
 val remove_rec: t -> key -> t Lwt.t
 

src/environment/v1/hash.mli

@@ -45,7 +45,7 @@ module type MINIMAL_HASH = sig
   val read: MBytes.t -> int -> t
   val write: MBytes.t -> int -> t -> unit
 
-  val to_path: t -> string list
+  val to_path: t -> string list -> string list
   val of_path: string list -> t option
   val of_path_exn: string list -> t
 

src/node/db/store_helpers.ml

@@ -84,8 +84,8 @@ module Make_indexed_substore (S : STORE) (I : INDEX) = struct
     type key = string list
     type value = MBytes.t
     let to_key i k =
-      assert (List.length (I.to_path i) = I.path_length) ;
+      assert (List.length (I.to_path i []) = I.path_length) ;
-      I.to_path i @ k
+      I.to_path i k
     let of_key k = Utils.remove_elem_from_list I.path_length k
     let known (t,i) k = S.known t (to_key i k)
     let known_dir (t,i) k = S.known_dir t (to_key i k)
@@ -250,9 +250,9 @@ module Make_set (S : STORE) (I : INDEX) = struct
   type t = S.t
   type elt = I.t
   let inited = MBytes.of_string "inited"
-  let known s i = S.known s (I.to_path i)
+  let known s i = S.known s (I.to_path i [])
-  let store s i = S.store s (I.to_path i) inited
+  let store s i = S.store s (I.to_path i []) inited
-  let remove s i = S.remove s (I.to_path i)
+  let remove s i = S.remove s (I.to_path i [])
   let remove_all s = S.remove_dir s []
 
   let fold s ~init ~f =
@@ -298,9 +298,9 @@ module Make_map (S : STORE) (I : INDEX) (V : VALUE) = struct
   type t = S.t
   type key = I.t
   type value = V.t
-  let known s i = S.known s (I.to_path i)
+  let known s i = S.known s (I.to_path i [])
   let read s i =
-    S.read s (I.to_path i) >>=? fun b -> Lwt.return (V.of_bytes b)
+    S.read s (I.to_path i []) >>=? fun b -> Lwt.return (V.of_bytes b)
   let read_opt s i =
     read s i >>= function
     | Error _ -> Lwt.return_none
@@ -309,8 +309,8 @@ module Make_map (S : STORE) (I : INDEX) (V : VALUE) = struct
     read s i >>= function
     | Error _ -> Lwt.fail Not_found
     | Ok v -> Lwt.return v
-  let store s i v = S.store s (I.to_path i) (V.to_bytes v)
+  let store s i v = S.store s (I.to_path i []) (V.to_bytes v)
-  let remove s i = S.remove s (I.to_path i)
+  let remove s i = S.remove s (I.to_path i [])
   let remove_all s = S.remove_dir s []
   let fold s ~init ~f =
     let rec dig i path acc =
@@ -375,7 +375,7 @@ end
 module Integer_index = struct
   type t = int
   let path_length = 1
-  let to_path x = [string_of_int x]
+  let to_path x l = string_of_int x :: l
   let of_path = function
     | [x] -> begin try Some (int_of_string x) with _ -> None end
     | _ -> None

src/node/db/store_sigs.ml

@@ -25,7 +25,7 @@ end
 module type INDEX = sig
   type t
   val path_length: int
-  val to_path: t -> string list
+  val to_path: t -> string list -> string list
   val of_path: string list -> t option
 end
 

src/proto/alpha/TEZOS_PROTOCOL

@@ -26,7 +26,7 @@
         "Manager_repr",
         "Block_header_repr",
 
-        "Persist",
+        "Raw_context",
         "Storage_sigs",
         "Storage_functors",
         "Storage",

src/proto/alpha/amendment.ml

@@ -49,8 +49,8 @@ let check_approval_and_update_quorum ctxt =
 let start_new_voting_cycle ctxt =
   Vote.get_current_period_kind ctxt >>=? function
   | Proposal -> begin
-      Vote.get_proposals ctxt >>=? fun proposals ->
+      Vote.get_proposals ctxt >>= fun proposals ->
-      Vote.clear_proposals ctxt >>=? fun ctxt ->
+      Vote.clear_proposals ctxt >>= fun ctxt ->
       Vote.clear_listings ctxt >>=? fun ctxt ->
       match select_winning_proposal proposals with
       | None ->
@@ -111,10 +111,10 @@ let record_proposals ctxt delegate proposals =
   | Proposal ->
       Vote.in_listings ctxt delegate >>= fun in_listings ->
       if in_listings then
-        fold_left_s
+        Lwt_list.fold_left_s
           (fun ctxt proposal ->
              Vote.record_proposal ctxt proposal delegate)
-          ctxt proposals
+          ctxt proposals >>= return
       else
         fail Unauthorized_proposal
   | Testing_vote | Testing | Promotion_vote ->
@@ -128,7 +128,7 @@ let record_ballot ctxt delegate proposal ballot =
         Invalid_proposal >>=? fun () ->
       Vote.in_listings ctxt delegate >>= fun in_listings ->
       if in_listings then
-        Vote.record_ballot ctxt delegate ballot
+        Vote.record_ballot ctxt delegate ballot >>= return
       else
         fail Unauthorized_ballot
   | Testing | Proposal ->

src/proto/alpha/bootstrap_storage.ml

@@ -29,7 +29,7 @@ let make public_key =
   { public_key ; public_key_hash = Ed25519.Public_key.hash public_key }
 
 let accounts ctxt =
-  let { Constants_repr.bootstrap_keys } = Storage.constants ctxt in
+  let { Constants_repr.bootstrap_keys } = Raw_context.constants ctxt in
   List.map make bootstrap_keys
 
 let init ctxt =
@@ -49,7 +49,7 @@ let account_encoding =
 
 let refill ctxt =
   (* Unefficient HACK for the alphanet only... *)
-  Contract_storage.list ctxt >>=? fun contracts ->
+  Contract_storage.list ctxt >>= fun contracts ->
   List.fold_left
     (fun total contract ->
        Contract_storage.get_balance ctxt contract >>=? fun balance ->

src/proto/alpha/bootstrap_storage.mli

@@ -14,8 +14,8 @@ type account = {
 
 val account_encoding: account Data_encoding.t
 
-val accounts: Storage.t -> account list
+val accounts: Raw_context.t -> account list
 
-val init: Storage.t -> Storage.t tzresult Lwt.t
+val init: Raw_context.t -> Raw_context.t tzresult Lwt.t
 
-val refill: Storage.t -> Storage.t tzresult Lwt.t
+val refill: Raw_context.t -> Raw_context.t tzresult Lwt.t

src/proto/alpha/contract_repr.ml

@@ -148,3 +148,33 @@ let (<=) l1 l2 = Compare.Int.(<=) (compare l1 l2) 0
 let (<) l1 l2 = Compare.Int.(<) (compare l1 l2) 0
 let min l1 l2 = if l1 <= l2 then l1 else l2
 let max l1 l2 = if l1 >= l2 then l1 else l2
+
+module Index = struct
+  type t = contract
+  let path_length =
+    assert Compare.Int.(Ed25519.Public_key_hash.path_length =
+                        Contract_hash.path_length) ;
+    Ed25519.Public_key_hash.path_length + 1
+  let to_path c l =
+    match c with
+    | Default k ->
+        "pubkey" :: Ed25519.Public_key_hash.to_path k l
+    | Originated h ->
+        "originated" :: Contract_hash.to_path h l
+  let of_path = function
+    | "pubkey" :: key -> begin
+        match Ed25519.Public_key_hash.of_path key with
+        | None -> None
+        | Some h -> Some (Default h)
+      end
+    | "originated" :: key -> begin
+        match Contract_hash.of_path key with
+        | None -> None
+        | Some h -> Some (Originated h)
+      end
+    | _ -> None
+  let contract_prefix s =
+    "originated" :: Contract_hash.prefix_path s
+  let pkh_prefix s =
+    "pubkey" :: Ed25519.Public_key_hash.prefix_path s
+end

src/proto/alpha/contract_repr.mli

@@ -59,3 +59,12 @@ val encoding : contract Data_encoding.t
 val origination_nonce_encoding : origination_nonce Data_encoding.t
 
 val arg : contract RPC.Arg.arg
+
+module Index : sig
+  type t = contract
+  val path_length: int
+  val to_path: t -> string list -> string list
+  val of_path: string list -> t option
+  val contract_prefix: string -> string list
+  val pkh_prefix: string -> string list
+end

src/proto/alpha/contract_storage.ml

@@ -210,8 +210,7 @@ let create_base c contract ~balance ~manager ~delegate ?script ~spendable ~deleg
        return c) >>=? fun c ->
   Roll_storage.Contract.init c contract >>=? fun c ->
   Roll_storage.Contract.add_amount c contract balance >>=? fun c ->
-  Storage.Contract.Set.add c contract >>=? fun c ->
+  return (c, contract)
-  Lwt.return (Ok (c, contract))
 
 let create c nonce ~balance ~manager ~delegate ?script ~spendable ~delegatable =
   let contract = Contract_repr.originated_contract nonce in
@@ -238,7 +237,7 @@ let delete c contract =
   Storage.Contract.Storage.remove c contract >>= fun c ->
   Storage.Contract.Code_fees.remove c contract >>= fun c ->
   Storage.Contract.Storage_fees.remove c contract >>= fun c ->
-  Storage.Contract.Set.del c contract
+  return c
 
 let exists c contract =
   match Contract_repr.is_default contract with
@@ -253,8 +252,7 @@ let must_exist c contract =
   | true -> return ()
   | false -> fail (Non_existing_contract contract)
 
-let list c =
+let list c = Storage.Contract.list c
-  Storage.Contract.Set.elements c
 
 let check_counter_increment c contract counter =
   Storage.Contract.Counter.get c contract >>=? fun contract_counter ->
@@ -360,7 +358,8 @@ let set_delegate c contract delegate =
           Storage.Contract.Delegate.remove c contract >>= fun c ->
           return c
       | Some delegate ->
-          Storage.Contract.Delegate.init_set c contract delegate
+          Storage.Contract.Delegate.init_set c contract delegate >>= fun c ->
+          return c
 
 let contract_fee c contract =
   Storage.Contract.Code_fees.get_option c contract >>=? fun code_fees ->

src/proto/alpha/contract_storage.mli

@@ -21,46 +21,46 @@ type error +=
   | Missing_public_key of Ed25519.Public_key_hash.t (* `Permanent *)
   | Failure of string (* `Permanent *)
 
-val delete : Storage.t -> Contract_repr.t -> Storage.t tzresult Lwt.t
+val delete : Raw_context.t -> Contract_repr.t -> Raw_context.t tzresult Lwt.t
 
-val exists: Storage.t -> Contract_repr.t -> bool tzresult Lwt.t
+val exists: Raw_context.t -> Contract_repr.t -> bool tzresult Lwt.t
-val must_exist: Storage.t -> Contract_repr.t -> unit tzresult Lwt.t
+val must_exist: Raw_context.t -> Contract_repr.t -> unit tzresult Lwt.t
 
-val list: Storage.t -> Contract_repr.t list tzresult Lwt.t
+val list: Raw_context.t -> Contract_repr.t list Lwt.t
 
-val check_counter_increment: Storage.t -> Contract_repr.t -> int32 -> unit tzresult Lwt.t
+val check_counter_increment: Raw_context.t -> Contract_repr.t -> int32 -> unit tzresult Lwt.t
-val increment_counter: Storage.t -> Contract_repr.t -> Storage.t tzresult Lwt.t
+val increment_counter: Raw_context.t -> Contract_repr.t -> Raw_context.t tzresult Lwt.t
 
-val is_delegatable : Storage.t -> Contract_repr.t -> bool tzresult Lwt.t
+val is_delegatable : Raw_context.t -> Contract_repr.t -> bool tzresult Lwt.t
-val is_spendable : Storage.t -> Contract_repr.t -> bool tzresult Lwt.t
+val is_spendable : Raw_context.t -> Contract_repr.t -> bool tzresult Lwt.t
 
-val get_manager: Storage.t -> Contract_repr.t -> Ed25519.Public_key_hash.t tzresult Lwt.t
+val get_manager: Raw_context.t -> Contract_repr.t -> Ed25519.Public_key_hash.t tzresult Lwt.t
 val update_manager_key:
-  Storage.t -> Contract_repr.t -> Ed25519.Public_key.t option ->
+  Raw_context.t -> Contract_repr.t -> Ed25519.Public_key.t option ->
-  (Storage.t * Ed25519.Public_key.t) tzresult Lwt.t
+  (Raw_context.t * Ed25519.Public_key.t) tzresult Lwt.t
 
-val get_delegate_opt: Storage.t -> Contract_repr.t -> Ed25519.Public_key_hash.t option tzresult Lwt.t
+val get_delegate_opt: Raw_context.t -> Contract_repr.t -> Ed25519.Public_key_hash.t option tzresult Lwt.t
-val get_balance: Storage.t -> Contract_repr.t -> Tez_repr.t tzresult Lwt.t
+val get_balance: Raw_context.t -> Contract_repr.t -> Tez_repr.t tzresult Lwt.t
-val get_counter: Storage.t -> Contract_repr.t -> int32 tzresult Lwt.t
+val get_counter: Raw_context.t -> Contract_repr.t -> int32 tzresult Lwt.t
 
-val get_script: Storage.t -> Contract_repr.t -> Script_repr.t option tzresult Lwt.t
+val get_script: Raw_context.t -> Contract_repr.t -> Script_repr.t option tzresult Lwt.t
-val get_storage: Storage.t -> Contract_repr.t -> Script_repr.expr option tzresult Lwt.t
+val get_storage: Raw_context.t -> Contract_repr.t -> Script_repr.expr option tzresult Lwt.t
 
-val update_script_storage_and_fees: Storage.t -> Contract_repr.t -> Tez_repr.t -> Script_repr.expr -> Storage.t tzresult Lwt.t
+val update_script_storage_and_fees: Raw_context.t -> Contract_repr.t -> Tez_repr.t -> Script_repr.expr -> Raw_context.t tzresult Lwt.t
 
 (** fails if the contract is not delegatable *)
-val set_delegate : Storage.t -> Contract_repr.t -> Ed25519.Public_key_hash.t option -> Storage.t tzresult Lwt.t
+val set_delegate : Raw_context.t -> Contract_repr.t -> Ed25519.Public_key_hash.t option -> Raw_context.t tzresult Lwt.t
 
-val credit : Storage.t -> Contract_repr.t -> Tez_repr.t -> Storage.t tzresult Lwt.t
+val credit : Raw_context.t -> Contract_repr.t -> Tez_repr.t -> Raw_context.t tzresult Lwt.t
 
 (** checks that the contract is spendable and decrease_balance *)
-val spend : Storage.t -> Contract_repr.t -> Tez_repr.t -> Storage.t tzresult Lwt.t
+val spend : Raw_context.t -> Contract_repr.t -> Tez_repr.t -> Raw_context.t tzresult Lwt.t
 
 (** decrease_balance even if the contract is not spendable *)
-val spend_from_script : Storage.t -> Contract_repr.t -> Tez_repr.t -> Storage.t tzresult Lwt.t
+val spend_from_script : Raw_context.t -> Contract_repr.t -> Tez_repr.t -> Raw_context.t tzresult Lwt.t
 
 val originate :
-  Storage.t ->
+  Raw_context.t ->
   Contract_repr.origination_nonce ->
   balance:Tez_repr.t ->
   manager:Ed25519.Public_key_hash.t ->
@@ -68,7 +68,7 @@ val originate :
   delegate:Ed25519.Public_key_hash.t option ->
   spendable:bool ->
   delegatable:bool ->
-  (Storage.t * Contract_repr.t * Contract_repr.origination_nonce) tzresult Lwt.t
+  (Raw_context.t * Contract_repr.t * Contract_repr.origination_nonce) tzresult Lwt.t
 
 val init :
-  Storage.t -> Storage.t tzresult Lwt.t
+  Raw_context.t -> Raw_context.t tzresult Lwt.t

src/proto/alpha/cycle_repr.ml

@@ -40,3 +40,16 @@ let of_int32_exn l =
   if Compare.Int32.(l >= 0l)
   then l
   else invalid_arg "Level_repr.Cycle.of_int32"
+
+module Index = struct
+  type t = cycle
+  let path_length = 1
+  let to_path c l =
+    Int32.to_string (to_int32 c) :: l
+  let of_path = function
+    | [s] -> begin
+        try Some (Int32.of_string s)
+        with _ -> None
+      end
+    | _ -> None
+end

src/proto/alpha/cycle_repr.mli

@@ -20,3 +20,11 @@ val succ: cycle -> cycle
 
 val to_int32: cycle -> int32
 val of_int32_exn: int32 -> cycle
+
+module Index : sig
+  (* Storage_functors.INDEX with type t = cycle *)
+  type t = cycle
+  val path_length: int
+  val to_path: t -> string list -> string list
+  val of_path: string list -> t option
+end

src/proto/alpha/fitness_storage.ml

@@ -7,7 +7,7 @@
 (*                                                                        *)
 (**************************************************************************)
 
-let current = Storage.current_fitness
+let current = Raw_context.current_fitness
 let increase ctxt =
   let fitness = current ctxt in
-  Storage.set_current_fitness ctxt (Int64.succ fitness)
+  Raw_context.set_current_fitness ctxt (Int64.succ fitness)

src/proto/alpha/init_storage.ml

@@ -21,30 +21,10 @@ let initialize store =
   Vote_storage.init store >>=? fun store ->
   return store
 
-type error +=
-  | Unimplemented_sandbox_migration
-
 let may_initialize ctxt ~level ~timestamp ~fitness =
-  Storage.prepare ~level ~timestamp ~fitness ctxt >>=? fun (ctxt, first_block) ->
+  Raw_context.prepare
+    ~level ~timestamp ~fitness ctxt >>=? fun (ctxt, first_block) ->
   if first_block then
     initialize ctxt
   else
     return ctxt
-
-let configure_sandbox ctxt json =
-  let json =
-    match json with
-    | None -> `O []
-    | Some json -> json in
-  Storage.is_first_block ctxt >>=? function
-  | true ->
-      Storage.set_sandboxed ctxt json >>= fun ctxt ->
-      return ctxt
-  | false ->
-      Storage.get_sandboxed ctxt >>=? function
-      | None ->
-          fail Unimplemented_sandbox_migration
-      | Some _ ->
-          (* FIXME GRGR fail if parameter changed! *)
-          (* failwith "Changing sandbox parameter is not yet implemented" *)
-          return ctxt

src/proto/alpha/level_repr.ml

@@ -89,3 +89,4 @@ let (<=) { level = l1 } { level = l2 } = Raw_level_repr.(<=) l1 l2
 let (<) { level = l1 } { level = l2 } = Raw_level_repr.(<) l1 l2
 let min l1 l2 = if l1 <= l2 then l1 else l2
 let max l1 l2 = if l1 >= l2 then l1 else l2
+

src/proto/alpha/level_storage.ml

@@ -14,8 +14,8 @@ let from_raw c ?offset l =
     match offset with
     | None -> l
     | Some o -> Raw_level_repr.(of_int32_exn (Int32.add (to_int32 l) o)) in
-  let constants = Storage.constants c in
+  let constants = Raw_context.constants c in
-  let first_level = Storage.first_level c in
+  let first_level = Raw_context.first_level c in
   Level_repr.from_raw
     ~first_level
     ~cycle_length:constants.Constants_repr.cycle_length
@@ -23,7 +23,7 @@ let from_raw c ?offset l =
     l
 
 let root c =
-  Level_repr.root (Storage.first_level c)
+  Level_repr.root (Raw_context.first_level c)
 
 let succ c l = from_raw c (Raw_level_repr.succ l.level)
 let pred c l =
@@ -31,7 +31,7 @@ let pred c l =
   | None -> None
   | Some l -> Some (from_raw c l)
 
-let current ctxt = Storage.current_level ctxt
+let current ctxt = Raw_context.current_level ctxt
 
 let previous ctxt =
   let l = current ctxt in
@@ -40,8 +40,8 @@ let previous ctxt =
   | Some p -> p
 
 let first_level_in_cycle ctxt c =
-  let constants = Storage.constants ctxt in
+  let constants = Raw_context.constants ctxt in
-  let first_level = Storage.first_level ctxt in
+  let first_level = Raw_context.first_level ctxt in
   from_raw ctxt
     (Raw_level_repr.of_int32_exn
        (Int32.add

src/proto/alpha/level_storage.mli

@@ -7,14 +7,14 @@
 (*                                                                        *)
 (**************************************************************************)
 
-val current: Storage.t -> Level_repr.t
+val current: Raw_context.t -> Level_repr.t
-val previous: Storage.t -> Level_repr.t
+val previous: Raw_context.t -> Level_repr.t
 
-val root: Storage.t -> Level_repr.t
+val root: Raw_context.t -> Level_repr.t
 
-val from_raw: Storage.t -> ?offset:int32 -> Raw_level_repr.t -> Level_repr.t
+val from_raw: Raw_context.t -> ?offset:int32 -> Raw_level_repr.t -> Level_repr.t
-val pred: Storage.t -> Level_repr.t -> Level_repr.t option
+val pred: Raw_context.t -> Level_repr.t -> Level_repr.t option
-val succ: Storage.t -> Level_repr.t -> Level_repr.t
+val succ: Raw_context.t -> Level_repr.t -> Level_repr.t
 
-val last_level_in_cycle: Storage.t -> Cycle_repr.t -> Level_repr.t
+val last_level_in_cycle: Raw_context.t -> Cycle_repr.t -> Level_repr.t
-val levels_in_cycle: Storage.t -> Cycle_repr.t -> Level_repr.t list
+val levels_in_cycle: Raw_context.t -> Cycle_repr.t -> Level_repr.t list

src/proto/alpha/nonce_storage.mli

@@ -20,13 +20,13 @@ type nonce = t
 val encoding: nonce Data_encoding.t
 
 val record_hash:
-  Storage.t ->
+  Raw_context.t ->
   Ed25519.Public_key_hash.t -> Tez_repr.t ->
-  Nonce_hash.t -> Storage.t tzresult Lwt.t
+  Nonce_hash.t -> Raw_context.t tzresult Lwt.t
 
 val reveal:
-  Storage.t -> Level_repr.t -> nonce ->
+  Raw_context.t -> Level_repr.t -> nonce ->
-  (Storage.t * Ed25519.Public_key_hash.t * Tez_repr.t) tzresult Lwt.t
+  (Raw_context.t * Ed25519.Public_key_hash.t * Tez_repr.t) tzresult Lwt.t
 
 type status =
   | Unrevealed of {
@@ -36,7 +36,7 @@ type status =
     }
   | Revealed of nonce
 
-val get: Storage.t -> Level_repr.t -> status tzresult Lwt.t
+val get: Raw_context.t -> Level_repr.t -> status tzresult Lwt.t
 
 val of_bytes: MBytes.t -> nonce tzresult
 val hash: nonce -> Nonce_hash.t

src/proto/alpha/persist.ml

@@ -1,422 +0,0 @@
-(**************************************************************************)
-(*                                                                        *)
-(*    Copyright (c) 2014 - 2017.                                          *)
-(*    Dynamic Ledger Solutions, Inc. <contact@tezos.com>                  *)
-(*                                                                        *)
-(*    All rights reserved. No warranty, explicit or implicit, provided.   *)
-(*                                                                        *)
-(**************************************************************************)
-
-(*  Tezos - Persistent structures on top of {!Store} or {!Context} *)
-
-(*-- Signatures --------------------------------------------------------------*)
-
-type key = string list
-type value = MBytes.t
-
-module type STORE = sig
-  type t
-  val mem: t -> key -> bool Lwt.t
-  val dir_mem: t -> key -> bool Lwt.t
-  val get: t -> key -> value option Lwt.t
-  val set: t -> key -> value -> t Lwt.t
-  val del: t -> key -> t Lwt.t
-  val remove_rec: t -> key -> t Lwt.t
-  val fold:
-    t -> key -> init:'a ->
-    f:([ `Key of key | `Dir of key ] -> 'a -> 'a Lwt.t) ->
-    'a Lwt.t
-  val keys: t -> key -> key list Lwt.t
-  val fold_keys:
-    t -> key -> init:'a -> f:(key -> 'a -> 'a Lwt.t) -> 'a Lwt.t
-end
-
-module type BYTES_STORE = sig
-  type t
-  type key
-  val mem: t -> key -> bool Lwt.t
-  val get: t -> key -> value option Lwt.t
-  val set: t -> key -> value -> t Lwt.t
-  val del: t -> key -> t Lwt.t
-  val remove_rec: t -> key -> t Lwt.t
-end
-
-module type TYPED_STORE = sig
-  type t
-  type key
-  type value
-  val mem: t -> key -> bool Lwt.t
-  val get: t -> key -> value option Lwt.t
-  val set: t -> key -> value -> t Lwt.t
-  val del: t -> key -> t Lwt.t
-end
-
-module type KEY = sig
-  type t
-  val prefix: key
-  val length: int
-  val to_path: t -> key
-  val of_path: key -> t
-  val compare: t -> t -> int
-end
-
-module type VALUE = sig
-  type t
-  val of_bytes: value -> t option
-  val to_bytes: t -> value
-end
-
-module type PERSISTENT_SET = sig
-  type t and key
-  val mem : t -> key -> bool Lwt.t
-  val set : t -> key -> t Lwt.t
-  val del : t -> key -> t Lwt.t
-  val elements : t -> key list Lwt.t
-  val clear : t -> t Lwt.t
-  val iter : t -> f:(key -> unit Lwt.t) -> unit Lwt.t
-  val fold : t -> init:'a -> f:(key -> 'a -> 'a Lwt.t) -> 'a Lwt.t
-end
-
-module type BUFFERED_PERSISTENT_SET = sig
-  include PERSISTENT_SET
-  module Set : Set.S with type elt = key
-  val read : t -> Set.t Lwt.t
-  val write : t -> Set.t -> t Lwt.t
-end
-
-module type PERSISTENT_MAP = sig
-  type t and key and value
-  val mem : t -> key -> bool Lwt.t
-  val get : t -> key -> value option Lwt.t
-  val set : t -> key -> value -> t Lwt.t
-  val del : t -> key -> t Lwt.t
-  val bindings : t -> (key * value) list Lwt.t
-  val clear : t -> t Lwt.t
-  val iter : t -> f:(key -> value -> unit Lwt.t) -> unit Lwt.t
-  val fold : t -> init:'a -> f:(key -> value -> 'a -> 'a Lwt.t) -> 'a Lwt.t
-end
-
-module type BUFFERED_PERSISTENT_MAP = sig
-  include PERSISTENT_MAP
-  module Map : Map.S with type key = key
-  val read : t -> value Map.t Lwt.t
-  val write : t -> value Map.t -> t Lwt.t
-end
-
-(*-- Utils -------------------------------------------------------------------*)
-
-let prefix prf key =
-  prf @ key
-
-let unprefix prf key =
-  let rec eat = function
-    | k :: key, p :: prefix ->
-        assert Compare.String.(k = p) ;
-        eat (key, prefix)
-    | key, [] -> key
-    | _ -> assert false in
-  eat (key, prf)
-
-(*-- Typed Store Overlays ----------------------------------------------------*)
-
-module MakeBytesStore
-    (S : STORE) (K : KEY) = struct
-
-  type t = S.t
-  type key = K.t
-
-  let to_path k =
-    let suffix = K.to_path k in
-    prefix K.prefix suffix
-
-  let mem s k =
-    S.mem s (to_path k)
-
-  let get s k =
-    S.get s (to_path k)
-
-  let set s k v =
-    S.set s (to_path k) v
-
-  let del s k =
-    S.del s (to_path k)
-
-  let remove_rec s k =
-    S.remove_rec s (to_path k)
-
-end
-
-module MakeTypedStore
-    (S : STORE) (K : KEY) (C : VALUE) = struct
-
-  type t = S.t
-  type key = K.t
-  type value = C.t
-
-  module S = MakeBytesStore (S) (K)
-
-  let mem = S.mem
-  let get s k =
-    S.get s k >>= function
-    | None -> Lwt.return None
-    | Some v -> Lwt.return (C.of_bytes v)
-  let set s k v = S.set s k (C.to_bytes v)
-  let del = S.del
-
-end
-
-module CompareStringList = Compare.List(Compare.String)
-
-module RawKey = struct
-  type t = key
-  let prefix = []
-  let length = 0
-  let to_path p = p
-  let of_path p = p
-  let compare = CompareStringList.compare
-end
-module RawValue = struct
-  type t = value
-  let to_bytes b = b
-  let of_bytes b = Some b
-end
-
-(*-- Set Builders ------------------------------------------------------------*)
-
-module MakePersistentSet
-    (S : STORE) (K : KEY) = struct
-
-  let to_path k =
-    let suffix = K.to_path k in
-    assert Compare.Int.(List.length suffix = K.length) ;
-    prefix K.prefix suffix
-
-  let of_path p = K.of_path (unprefix K.prefix p)
-
-  let empty =
-    MBytes.of_string ""
-
-  let inited_key =
-    prefix K.prefix [ "inited" ]
-
-  let mem c k =
-    S.mem c (to_path k)
-
-  let set c k =
-    S.set c inited_key empty >>= fun c ->
-    S.set c (to_path k) empty
-
-  let del c k =
-    S.del c (to_path k)
-
-  let clear c =
-    S.remove_rec c K.prefix
-
-  let fold s ~init ~f =
-    let rec dig i path acc =
-      if Compare.Int.(i <= 1) then
-        S.fold s path ~init:acc ~f:begin fun k acc ->
-          match k with
-          | `Dir _ -> Lwt.return acc
-          | `Key file -> f (of_path file) acc
-        end
-      else
-        S.fold s path ~init:acc ~f:begin fun k acc ->
-          match k with
-          | `Dir k ->
-              dig (i-1) k acc
-          | `Key _ ->
-              Lwt.return acc
-        end in
-    dig K.length K.prefix init
-
-  let iter c ~f = fold c ~init:() ~f:(fun x () -> f x)
-  let elements c = fold c ~init:[] ~f:(fun p xs -> Lwt.return (p :: xs))
-
-end
-
-module MakeBufferedPersistentSet
-    (S : STORE) (K : KEY) (Set : Set.S with type elt = K.t) = struct
-
-  include MakePersistentSet(S)(K)
-
-  let read c =
-    fold c ~init:Set.empty ~f:(fun p set -> Lwt.return (Set.add p set))
-
-  let write c set =
-    S.set c inited_key empty >>= fun c ->
-    read c >>= fun old_set ->
-    Lwt_list.fold_left_s
-      (fun c h -> S.del c (to_path h))
-      c Set.(elements (diff old_set set)) >>= fun c ->
-    Lwt_list.fold_left_s
-      (fun c h -> S.set c (to_path h) empty)
-      c Set.(elements (diff set old_set))
-
-end
-
-(*-- Map Builders ------------------------------------------------------------*)
-
-module MakePersistentMap
-    (S : STORE) (K : KEY) (C : VALUE) = struct
-
-  let to_path k =
-    let suffix = K.to_path k in
-    assert Compare.Int.(List.length suffix = K.length) ;
-    prefix K.prefix suffix
-
-  let of_path p = K.of_path (unprefix K.prefix p)
-
-  let empty =
-    MBytes.of_string ""
-
-  let inited_key =
-    prefix K.prefix [ "inited" ]
-
-  let mem c k =
-    S.mem c (to_path k)
-
-  let get c k =
-    S.get c (to_path k) >|= function
-    | None -> None
-    | Some b -> C.of_bytes b
-
-  let set c k b =
-    S.set c inited_key empty >>= fun c ->
-    S.set c (to_path k) (C.to_bytes b)
-
-  let del c k =
-    S.del c (to_path k)
-
-  let clear c =
-    S.remove_rec c K.prefix
-
-  let fold s ~init ~f =
-    let rec dig i path acc =
-      if Compare.Int.(i <= 1) then
-        S.fold s path ~init:acc ~f:begin fun k acc ->
-          match k with
-          | `Dir _ -> Lwt.return acc
-          | `Key file ->
-              S.get s file >>= function
-              | None -> Lwt.return acc
-              | Some b ->
-                  match C.of_bytes b with
-                  | None ->
-                      (* Silently ignore unparsable data *)
-                      Lwt.return acc
-                  | Some v -> f (of_path file) v acc
-        end
-      else
-        S.fold s path ~init:acc ~f:begin fun k acc ->
-          match k with
-          | `Dir k -> dig (i-1) k acc
-          | `Key _ -> Lwt.return acc
-        end in
-    dig K.length K.prefix init
-
-  let iter c ~f = fold c ~init:() ~f:(fun k v () -> f k v)
-  let bindings c = fold c ~init:[] ~f:(fun k v acc -> Lwt.return ((k, v) :: acc))
-
-end
-
-module MakeBufferedPersistentMap
-    (S : STORE) (K : KEY) (C : VALUE) (Map : Map.S with type key = K.t) = struct
-
-  include MakePersistentMap(S)(K)(C)
-
-  let read c = fold c ~init:Map.empty ~f:(fun k v m -> Lwt.return (Map.add k v m))
-
-  let write c m =
-    clear c >>= fun c ->
-    S.set c inited_key empty >>= fun c ->
-    Lwt_list.fold_left_s
-      (fun c (k, b) -> S.set c (to_path k) (C.to_bytes b))
-      c (Map.bindings m)
-
-end
-
-(*-- Predefined Instances ----------------------------------------------------*)
-
-module MBytesValue = struct
-  type t = MBytes.t
-  let of_bytes x = Some x
-  let to_bytes x = x
-end
-
-module MakePersistentBytesMap
-    (S : STORE) (K : KEY) =
-  MakePersistentMap(S)(K)(MBytesValue)
-
-module MakeBufferedPersistentBytesMap
-    (S : STORE) (K : KEY) (Map : Map.S with type key = K.t) =
-  MakeBufferedPersistentMap(S)(K)(MBytesValue)(Map)
-
-module type TYPED_VALUE_REPR = sig
-  type value
-  val encoding: value Data_encoding.t
-end
-
-module TypedValue (T : TYPED_VALUE_REPR) = struct
-  type t = T.value
-  let of_bytes x = Data_encoding.Binary.of_bytes T.encoding x
-  let to_bytes x = Data_encoding.Binary.to_bytes T.encoding x
-end
-
-module MakePersistentTypedMap
-    (S : STORE)    (K : KEY)
-    (T : TYPED_VALUE_REPR) =
-  MakePersistentMap(S)(K)(TypedValue(T))
-
-module MakeBufferedPersistentTypedMap
-    (S : STORE)
-    (K : KEY)
-    (T : TYPED_VALUE_REPR)
-    (Map : Map.S with type key = K.t)
-  =
-  MakeBufferedPersistentMap(S)(K)(TypedValue(T))(Map)
-
-module MakeHashResolver
-    (Store : sig
-       type t
-       val dir_mem: t -> string list -> bool Lwt.t
-       val fold:
-         t -> key -> init:'a ->
-         f:([ `Key of key | `Dir of key ] -> 'a -> 'a Lwt.t) ->
-         'a Lwt.t
-       val prefix: string list
-     end)
-    (H: HASH) = struct
-  let plen = List.length Store.prefix
-  let build path =
-    H.of_path_exn @@
-    Misc.remove_elem_from_list plen path
-  let list t k =
-    Store.fold t k ~init:[] ~f:(fun k acc -> Lwt.return (k :: acc))
-  let resolve t p =
-    let rec loop prefix = function
-      | [] ->
-          list t prefix >>= fun prefixes ->
-          Lwt_list.map_p (function
-              | `Key prefix | `Dir prefix -> loop prefix []) prefixes
-          >|= List.flatten
-      | "" :: ds ->
-          list t prefix >>= fun prefixes ->
-          Lwt_list.map_p (function
-              | `Key prefix | `Dir prefix -> loop prefix ds) prefixes
-          >|= List.flatten
-      | [d] ->
-          list t prefix >>= fun prefixes ->
-          Lwt_list.filter_map_p (function
-              | `Dir _ -> Lwt.return_none
-              | `Key prefix ->
-                  match Misc.remove_prefix ~prefix:d (List.hd (List.rev prefix)) with
-                  | None -> Lwt.return_none
-                  | Some _ -> Lwt.return (Some (build prefix))
-            ) prefixes
-      | d :: ds ->
-          Store.dir_mem t (prefix @ [d]) >>= function
-          | true -> loop (prefix @ [d]) ds
-          | false -> Lwt.return_nil in
-    loop Store.prefix (H.prefix_path p)
-end

src/proto/alpha/persist.mli

@@ -1,218 +0,0 @@
-(**************************************************************************)
-(*                                                                        *)
-(*    Copyright (c) 2014 - 2017.                                          *)
-(*    Dynamic Ledger Solutions, Inc. <contact@tezos.com>                  *)
-(*                                                                        *)
-(*    All rights reserved. No warranty, explicit or implicit, provided.   *)
-(*                                                                        *)
-(**************************************************************************)
-
-(**  Tezos - Persistent structures on top of {!Store} or {!Context} *)
-
-(** Keys in (kex x value) database implementations *)
-type key = string list
-
-(** Values in (kex x value) database implementations *)
-type value = MBytes.t
-
-(** Low level view over a (key x value) database implementation. *)
-module type STORE = sig
-  type t
-  val mem: t -> key -> bool Lwt.t
-  val dir_mem: t -> key -> bool Lwt.t
-  val get: t -> key -> value option Lwt.t
-  val set: t -> key -> value -> t Lwt.t
-  val del: t -> key -> t Lwt.t
-  val remove_rec: t -> key -> t Lwt.t
-  val fold:
-    t -> key -> init:'a ->
-    f:([ `Key of key | `Dir of key ] -> 'a -> 'a Lwt.t) ->
-    'a Lwt.t
-  val keys: t -> key -> key list Lwt.t
-  val fold_keys:
-    t -> key -> init:'a -> f:(key -> 'a -> 'a Lwt.t) -> 'a Lwt.t
-end
-
-(** Projection of OCaml keys of some abstract type to concrete storage
-    keys. For practical reasons, all such keys must fall under a same
-    {!prefix} and have the same relative {!length}. Functions
-    {!to_path} and {!of_path} only take the relative part into account
-    (the prefix is added and removed when needed). *)
-module type KEY = sig
-  type t
-  val prefix: key
-  val length: int
-  val to_path: t -> key
-  val of_path: key -> t
-  val compare: t -> t -> int
-end
-
-(** A KEY instance for using raw implementation paths as keys *)
-module RawKey : KEY with type t = key
-
-(** Projection of OCaml values of some abstract type to concrete
-    storage data. *)
-module type VALUE = sig
-  type t
-  val of_bytes: value -> t option
-  val to_bytes: t -> value
-end
-
-(** A VALUE instance for using the raw bytes values *)
-module RawValue : VALUE with type t = value
-
-module type BYTES_STORE = sig
-  type t
-  type key
-  val mem: t -> key -> bool Lwt.t
-  val get: t -> key -> value option Lwt.t
-  val set: t -> key -> value -> t Lwt.t
-  val del: t -> key -> t Lwt.t
-  val remove_rec: t -> key -> t Lwt.t
-end
-
-module MakeBytesStore (S : STORE) (K : KEY) :
-  BYTES_STORE with type t = S.t and type key = K.t
-
-(** {2 Typed Store Overlays} *************************************************)
-
-(** Signature of a typed store as returned by {!MakecoTypedStore} *)
-module type TYPED_STORE = sig
-  type t
-  type key
-  type value
-  val mem: t -> key -> bool Lwt.t
-  val get: t -> key -> value option Lwt.t
-  val set: t -> key -> value -> t Lwt.t
-  val del: t -> key -> t Lwt.t
-end
-
-(** Gives a typed view of a store (values of a given type stored under
-    keys of a given type). The view is also restricted to a prefix,
-    (which can be empty). For all primitives to work as expected, all
-    keys under this prefix must be homogeneously typed. *)
-module MakeTypedStore (S : STORE) (K : KEY) (C : VALUE) :
-  TYPED_STORE with type t = S.t and type key = K.t and type value = C.t
-
-(** {2 Persistent Sets} ******************************************************)
-
-(** Signature of a set as returned by {!MakePersistentSet} *)
-module type PERSISTENT_SET = sig
-  type t and key
-  val mem : t -> key -> bool Lwt.t
-  val set : t -> key -> t Lwt.t
-  val del : t -> key -> t Lwt.t
-  val elements : t -> key list Lwt.t
-  val clear : t -> t Lwt.t
-  val iter : t -> f:(key -> unit Lwt.t) -> unit Lwt.t
-  val fold : t -> init:'a -> f:(key -> 'a -> 'a Lwt.t) -> 'a Lwt.t
-end
-
-(** Signature of a buffered set as returned by {!MakeBufferedPersistentSet} *)
-module type BUFFERED_PERSISTENT_SET = sig
-  include PERSISTENT_SET
-  module Set : Set.S with type elt = key
-  val read : t -> Set.t Lwt.t
-  val write : t -> Set.t -> t Lwt.t
-end
-
-(** Build a set in the (key x value) storage by encoding elements as
-    keys and using the association of (any) data to these keys as
-    membership. For this to work, the prefix passed must be reserved
-    for the set (every key under it is considered a member). *)
-module MakePersistentSet (S : STORE) (K : KEY)
-  : PERSISTENT_SET with type t := S.t and type key := K.t
-
-(** Same as {!MakePersistentSet} but also provides a way to use an
-    OCaml set as an explicitly synchronized in-memory buffer. *)
-module MakeBufferedPersistentSet
-    (S : STORE) (K : KEY) (Set : Set.S with type elt = K.t)
-  : BUFFERED_PERSISTENT_SET
-    with type t := S.t
-     and type key := K.t
-     and module Set := Set
-
-(** {2 Persistent Maps} ******************************************************)
-
-(** Signature of a map as returned by {!MakePersistentMap} *)
-module type PERSISTENT_MAP = sig
-  type t and key and value
-  val mem : t -> key -> bool Lwt.t
-  val get : t -> key -> value option Lwt.t
-  val set : t -> key -> value -> t Lwt.t
-  val del : t -> key -> t Lwt.t
-  val bindings : t -> (key * value) list Lwt.t
-  val clear : t -> t Lwt.t
-  val iter : t -> f:(key -> value -> unit Lwt.t) -> unit Lwt.t
-  val fold : t -> init:'a -> f:(key -> value -> 'a -> 'a Lwt.t) -> 'a Lwt.t
-end
-
-(** Signature of a buffered map as returned by {!MakeBufferedPersistentMap} *)
-module type BUFFERED_PERSISTENT_MAP = sig
-  include PERSISTENT_MAP
-  module Map : Map.S with type key = key
-  val read : t -> value Map.t Lwt.t
-  val write : t -> value Map.t -> t Lwt.t
-end
-
-(** Build a map in the (key x value) storage. For this to work, the
-    prefix passed must be reserved for the map (every key under it is
-    considered the key of a binding). *)
-module MakePersistentMap (S : STORE) (K : KEY) (C : VALUE)
-  : PERSISTENT_MAP
-    with type t := S.t and type key := K.t and type value := C.t
-
-(** Same as {!MakePersistentMap} but also provides a way to use an
-    OCaml map as an explicitly synchronized in-memory buffer. *)
-module MakeBufferedPersistentMap
-    (S : STORE) (K : KEY) (C : VALUE) (Map : Map.S with type key = K.t)
-  : BUFFERED_PERSISTENT_MAP
-    with type t := S.t
-     and type key := K.t
-     and type value := C.t
-     and module Map := Map
-
-(** {2 Predefined Instances} *************************************************)
-
-module MakePersistentBytesMap (S : STORE) (K : KEY)
-  : PERSISTENT_MAP
-    with type t := S.t and type key := K.t and type value := MBytes.t
-
-module MakeBufferedPersistentBytesMap
-    (S : STORE) (K : KEY) (Map : Map.S with type key = K.t)
-  : BUFFERED_PERSISTENT_MAP
-    with type t := S.t
-     and type key := K.t
-     and type value := MBytes.t
-     and module Map := Map
-
-module type TYPED_VALUE_REPR = sig
-  type value
-  val encoding: value Data_encoding.t
-end
-
-module MakePersistentTypedMap (S : STORE) (K : KEY) (T : TYPED_VALUE_REPR)
-  : PERSISTENT_MAP
-    with type t := S.t and type key := K.t and type value := T.value
-
-module MakeBufferedPersistentTypedMap
-    (S : STORE) (K : KEY) (T : TYPED_VALUE_REPR) (Map : Map.S with type key = K.t)
-  : BUFFERED_PERSISTENT_MAP
-    with type t := S.t
-     and type key := K.t
-     and type value := T.value
-     and module Map := Map
-
-module MakeHashResolver
-    (Store : sig
-       type t
-       val dir_mem: t -> key -> bool Lwt.t
-       val fold:
-         t -> key -> init:'a ->
-         f:([ `Key of key | `Dir of key ] -> 'a -> 'a Lwt.t) ->
-         'a Lwt.t
-       val prefix: string list
-     end)
-    (H: Hash.HASH) : sig
-  val resolve : Store.t -> string -> H.t list Lwt.t
-end

src/proto/alpha/public_key_storage.ml

@@ -36,13 +36,15 @@ let get_option = Storage.Public_key.get_option
 let reveal c hash key =
   let actual_hash = Ed25519.Public_key.hash key in
   if Ed25519.Public_key_hash.equal hash actual_hash then
-    Storage.Public_key.init_set c hash key
+    Storage.Public_key.init_set c hash key >>= return
   else
     fail (Inconsistent_hash (key, actual_hash, hash))
 
 let remove = Storage.Public_key.remove
 
 let list ctxt =
-  Storage.Public_key.fold ctxt [] ~f:(fun pk_h pk acc ->
+  Storage.Public_key.fold ctxt
-      Lwt.return @@ (pk_h, pk) :: acc) >>= fun res ->
+    ~init:[]
-  return res
+    ~f:begin fun pk_h pk acc ->
+      Lwt.return @@ (pk_h, pk) :: acc
+    end

src/proto/alpha/public_key_storage.mli

@@ -12,13 +12,13 @@ open Ed25519
 type error += Inconsistent_hash of Public_key.t * Public_key_hash.t * Public_key_hash.t
 
 val get:
-  Storage.t -> Public_key_hash.t -> Public_key.t tzresult Lwt.t
+  Raw_context.t -> Public_key_hash.t -> Public_key.t tzresult Lwt.t
 val get_option:
-  Storage.t -> Public_key_hash.t -> Public_key.t option tzresult Lwt.t
+  Raw_context.t -> Public_key_hash.t -> Public_key.t option tzresult Lwt.t
 val reveal:
-  Storage.t -> Public_key_hash.t -> Public_key.t -> Storage.t tzresult Lwt.t
+  Raw_context.t -> Public_key_hash.t -> Public_key.t -> Raw_context.t tzresult Lwt.t
 val remove:
-  Storage.t -> Public_key_hash.t -> Storage.t Lwt.t
+  Raw_context.t -> Public_key_hash.t -> Raw_context.t Lwt.t
 
 val list:
-  Storage.t -> (Public_key_hash.t * Public_key.t) list tzresult Lwt.t
+  Raw_context.t -> (Public_key_hash.t * Public_key.t) list Lwt.t

src/proto/alpha/raw_context.ml

@@ -0,0 +1,339 @@
+(**************************************************************************)
+(*                                                                        *)
+(*    Copyright (c) 2014 - 2017.                                          *)
+(*    Dynamic Ledger Solutions, Inc. <contact@tezos.com>                  *)
+(*                                                                        *)
+(*    All rights reserved. No warranty, explicit or implicit, provided.   *)
+(*                                                                        *)
+(**************************************************************************)
+
+type t = {
+  context: Context.t ;
+  constants: Constants_repr.constants ;
+  first_level: Raw_level_repr.t ;
+  level: Level_repr.t ;
+  timestamp: Time.t ;
+  fitness: Int64.t ;
+}
+type context = t
+type root_context = t
+
+let current_level ctxt = ctxt.level
+let current_timestamp ctxt = ctxt.timestamp
+let current_fitness ctxt = ctxt.fitness
+let first_level ctxt = ctxt.first_level
+let constants ctxt = ctxt.constants
+let recover ctxt = ctxt.context
+
+let set_current_fitness ctxt fitness = { ctxt with fitness }
+
+type storage_error =
+  | Incompatible_protocol_version of string
+  | Missing_key of string list * [`Get | `Set | `Del]
+  | Existing_key of string list
+  | Corrupted_data of string list
+
+let storage_error_encoding =
+  let open Data_encoding in
+  union [
+    case ~tag:0
+      (obj1 (req "incompatible_protocol_version" string))
+      (function Incompatible_protocol_version arg -> Some arg | _ -> None)
+      (fun arg -> Incompatible_protocol_version arg) ;
+    case ~tag:1
+      (obj2
+         (req "missing_key" (list string))
+         (req "function" (string_enum ["get", `Get ; "set", `Set])))
+      (function Missing_key (key, f) -> Some (key, f) | _ -> None)
+      (fun (key, f) -> Missing_key (key, f)) ;
+    case ~tag:2
+      (obj1 (req "existing_key" (list string)))
+      (function Existing_key key -> Some key | _ -> None)
+      (fun key -> Existing_key key) ;
+    case ~tag:3
+      (obj1 (req "corrupted_data" (list string)))
+      (function Corrupted_data key -> Some key | _ -> None)
+      (fun key -> Corrupted_data key) ;
+  ]
+
+let pp_storage_error ppf = function
+  | Incompatible_protocol_version version ->
+      Format.fprintf ppf
+        "Found a context with an unexpected version '%s'."
+        version
+  | Missing_key (key, `Get) ->
+      Format.fprintf ppf
+        "Missing key '%s'."
+        (String.concat "/" key)
+  | Missing_key (key, `Set) ->
+      Format.fprintf ppf
+        "Cannot set undefined key '%s'."
+        (String.concat "/" key)
+  | Missing_key (key, `Del) ->
+      Format.fprintf ppf
+        "Cannot delete undefined key '%s'."
+        (String.concat "/" key)
+  | Existing_key key ->
+      Format.fprintf ppf
+        "Cannot initialize defined key '%s'."
+        (String.concat "/" key)
+  | Corrupted_data key ->
+      Format.fprintf ppf
+        "Failed to parse the data at '%s'."
+        (String.concat "/" key)
+
+type error += Storage_error of storage_error
+
+let () =
+  register_error_kind
+    `Permanent
+    ~id:"context.storage_error"
+    ~title: "Storage error (fatal internal error)"
+    ~description:
+      "An error that should never happen unless something \
+       has been deleted or corrupted in the database."
+    ~pp:(fun ppf err ->
+        Format.fprintf ppf
+          "@[<v 2>Storage error:@ %a@]"
+          pp_storage_error err)
+    storage_error_encoding
+    (function Storage_error err -> Some err | _ -> None)
+    (fun err -> Storage_error err)
+
+let storage_error err = fail (Storage_error err)
+
+(* Initialization *********************************************************)
+
+(* This key should always be populated for every version of the
+   protocol.  It's absence meaning that the context is empty. *)
+let version_key = ["version"]
+let version_value = "alpha"
+
+let is_first_block ctxt =
+  Context.get ctxt version_key >>= function
+  | None ->
+      return true
+  | Some bytes ->
+      let s = MBytes.to_string bytes in
+      if Compare.String.(s = version_value) then
+        return false
+      else if Compare.String.(s = "genesis") then
+        return true
+      else
+        storage_error (Incompatible_protocol_version s)
+
+let version = "v1"
+let first_level_key = [ version ; "first_level" ]
+let sandboxed_key = [ version ; "sandboxed" ]
+
+let get_first_level ctxt =
+  Context.get ctxt first_level_key >>= function
+  | None -> storage_error (Missing_key (first_level_key, `Get))
+  | Some bytes ->
+      match
+        Data_encoding.Binary.of_bytes Raw_level_repr.encoding bytes
+      with
+      | None -> storage_error (Corrupted_data first_level_key)
+      | Some level -> return level
+
+let set_first_level ctxt level =
+  let bytes =
+    Data_encoding.Binary.to_bytes Raw_level_repr.encoding level in
+  Context.set ctxt first_level_key bytes >>= fun ctxt ->
+  return ctxt
+
+type error += Failed_to_parse_sandbox_parameter of MBytes.t
+
+let () =
+  register_error_kind
+    `Temporary
+    ~id:"context.failed_to_parse_sandbox_parameter"
+    ~title: "Failed to parse sandbox parameter"
+    ~description:
+      "The sandbox paramater is not a valid JSON string."
+    ~pp:begin fun ppf bytes ->
+      Format.fprintf ppf
+        "@[<v 2>Cannot parse the sandbox parameter:@ %s@]"
+        (MBytes.to_string bytes)
+    end
+    Data_encoding.(obj1 (req "contents" bytes))
+    (function Failed_to_parse_sandbox_parameter data -> Some data | _ -> None)
+    (fun data -> Failed_to_parse_sandbox_parameter data)
+
+let get_sandboxed c =
+  Context.get c sandboxed_key >>= function
+  | None -> return None
+  | Some bytes ->
+      match Data_encoding.Binary.of_bytes Data_encoding.json bytes with
+      | None -> fail (Failed_to_parse_sandbox_parameter bytes)
+      | Some json -> return (Some json)
+
+let set_sandboxed c json =
+  Context.set c sandboxed_key
+    (Data_encoding.Binary.to_bytes Data_encoding.json json)
+
+let may_tag_first_block ctxt level =
+  is_first_block ctxt >>=? function
+  | false ->
+      get_first_level ctxt >>=? fun level ->
+      return (ctxt, false, level)
+  | true ->
+      Context.set ctxt version_key
+        (MBytes.of_string version_value) >>= fun ctxt ->
+      set_first_level ctxt level >>=? fun ctxt ->
+      return (ctxt, true, level)
+
+let prepare ~level ~timestamp ~fitness ctxt =
+  Lwt.return (Raw_level_repr.of_int32 level ) >>=? fun level ->
+  Lwt.return (Fitness_repr.to_int64 fitness) >>=? fun fitness ->
+  may_tag_first_block ctxt level >>=? fun (ctxt, first_block, first_level) ->
+  get_sandboxed ctxt >>=? fun sandbox ->
+  Constants_repr.read sandbox >>=? function constants ->
+    let level =
+      Level_repr.from_raw
+        ~first_level
+        ~cycle_length:constants.Constants_repr.cycle_length
+        ~voting_period_length:constants.Constants_repr.voting_period_length
+        level in
+    return ({ context = ctxt ; constants ; level ;
+              timestamp ; fitness ; first_level},
+            first_block)
+
+let activate ({ context = c } as s) h =
+  Updater.activate c h >>= fun c -> Lwt.return { s with context = c }
+let fork_test_network ({ context = c } as s) protocol expiration =
+  Updater.fork_test_network c ~protocol ~expiration >>= fun c ->
+  Lwt.return { s with context = c }
+
+let register_resolvers enc resolve =
+  let resolve context str =
+    let faked_context = {
+      context ;
+      constants = Constants_repr.default ;
+      first_level = Raw_level_repr.root ;
+      level =  Level_repr.root Raw_level_repr.root ;
+      timestamp = Time.of_seconds 0L ;
+      fitness = 0L ;
+    } in
+    resolve faked_context str in
+  Context.register_resolver enc  resolve
+
+type error += Unimplemented_sandbox_migration
+
+let configure_sandbox ctxt json =
+  let json =
+    match json with
+    | None -> `O []
+    | Some json -> json in
+  is_first_block ctxt >>=? function
+  | true ->
+      set_sandboxed ctxt json >>= fun ctxt ->
+      return ctxt
+  | false ->
+      get_sandboxed ctxt >>=? function
+      | None ->
+          fail Unimplemented_sandbox_migration
+      | Some _ ->
+          (* FIXME GRGR fail if parameter changed! *)
+          (* failwith "Changing sandbox parameter is not yet implemented" *)
+          return ctxt
+
+(* Generic context ********************************************************)
+
+type key = string list
+
+type value = MBytes.t
+
+module type T = sig
+
+  type t
+  type context = t
+
+  val mem: context -> key -> bool Lwt.t
+  val dir_mem: context -> key -> bool Lwt.t
+  val get: context -> key -> value tzresult Lwt.t
+  val get_option: context -> key -> value option Lwt.t
+  val init: context -> key -> value -> context tzresult Lwt.t
+  val set: context -> key -> value -> context tzresult Lwt.t
+  val init_set: context -> key -> value -> context Lwt.t
+  val set_option: context -> key -> value option -> context Lwt.t
+  val delete: context -> key -> context tzresult Lwt.t
+  val remove: context -> key -> context Lwt.t
+  val remove_rec: context -> key -> context Lwt.t
+
+  val fold:
+    context -> key -> init:'a ->
+    f:([ `Key of key | `Dir of key ] -> 'a -> 'a Lwt.t) ->
+    'a Lwt.t
+
+  val keys: context -> key -> key list Lwt.t
+
+  val fold_keys:
+    context -> key -> init:'a -> f:(key -> 'a -> 'a Lwt.t) -> 'a Lwt.t
+
+  val project: context -> root_context
+end
+
+let mem ctxt k = Context.mem ctxt.context k
+let dir_mem ctxt k = Context.dir_mem ctxt.context k
+
+let get ctxt k =
+  Context.get ctxt.context k >>= function
+  | None -> storage_error (Missing_key (k, `Get))
+  | Some v -> return v
+
+let get_option ctxt k =
+  Context.get ctxt.context k
+
+(* Verify that the k is present before modifying *)
+let set ctxt k v =
+  Context.mem ctxt.context k >>= function
+  | false -> storage_error (Missing_key (k, `Set))
+  | true ->
+      Context.set ctxt.context k v >>= fun context ->
+      return { ctxt with context }
+
+(* Verify that the k is not present before inserting *)
+let init ctxt k v =
+  Context.mem ctxt.context k >>= function
+  | true -> storage_error (Existing_key k)
+  | false ->
+      Context.set ctxt.context k v >>= fun context ->
+      return { ctxt with context }
+
+(* Does not verify that the key is present or not *)
+let init_set ctxt k v =
+  Context.set ctxt.context k v >>= fun context ->
+  Lwt.return { ctxt with context }
+
+(* Verify that the key is present before deleting *)
+let delete ctxt k =
+  Context.mem ctxt.context k >>= function
+  | false -> storage_error (Missing_key (k, `Del))
+  | true ->
+      Context.del ctxt.context k >>= fun context ->
+      return { ctxt with context }
+
+(* Do not verify before deleting *)
+let remove ctxt k =
+  Context.del ctxt.context k >>= fun context ->
+  Lwt.return { ctxt with context }
+
+let set_option ctxt k = function
+  | None -> remove ctxt k
+  | Some v -> init_set ctxt k v
+
+let remove_rec ctxt k =
+  Context.remove_rec ctxt.context k >>= fun context ->
+  Lwt.return { ctxt with context }
+
+let fold ctxt k ~init ~f =
+  Context.fold ctxt.context k ~init ~f
+
+let keys ctxt k =
+  Context.keys ctxt.context k
+
+let fold_keys ctxt k ~init ~f =
+  Context.fold_keys ctxt.context k ~init ~f
+
+let project x = x

src/proto/alpha/raw_context.mli

@@ -0,0 +1,134 @@
+(**************************************************************************)
+(*                                                                        *)
+(*    Copyright (c) 2014 - 2017.                                          *)
+(*    Dynamic Ledger Solutions, Inc. <contact@tezos.com>                  *)
+(*                                                                        *)
+(*    All rights reserved. No warranty, explicit or implicit, provided.   *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** {1 Errors} ****************************************************************)
+
+(** An internal storage error that should not happen *)
+type storage_error =
+  | Incompatible_protocol_version of string
+  | Missing_key of string list * [`Get | `Set | `Del]
+  | Existing_key of string list
+  | Corrupted_data of string list
+
+type error += Storage_error of storage_error
+type error += Failed_to_parse_sandbox_parameter of MBytes.t
+
+val storage_error: storage_error -> 'a tzresult Lwt.t
+
+(** {1 Abstract Context} **************************************************)
+
+(** Abstract view of the context *)
+type t
+type context = t
+type root_context = t
+
+(** Retrieves the state of the database and gives its abstract view.
+    It also returns wether this is the first block validated
+    with this version of the protocol. *)
+val prepare:
+  level: Int32.t ->
+  timestamp: Time.t ->
+  fitness: Fitness.t ->
+  Context.t -> (context * bool) tzresult Lwt.t
+
+val activate: context -> Protocol_hash.t -> t Lwt.t
+val fork_test_network: context -> Protocol_hash.t -> Time.t -> t Lwt.t
+
+val register_resolvers:
+  'a Base58.encoding -> (context -> string -> 'a list Lwt.t) -> unit
+
+val configure_sandbox:
+  Context.t -> Data_encoding.json option -> Context.t tzresult Lwt.t
+
+(** Returns the state of the database resulting of operations on its
+    abstract view *)
+val recover: context -> Context.t
+
+val current_level: context -> Level_repr.t
+val current_timestamp: context -> Time.t
+
+val current_fitness: context -> Int64.t
+val set_current_fitness: context -> Int64.t -> t
+
+val constants: context -> Constants_repr.constants
+val first_level: context -> Raw_level_repr.t
+
+(** {1 Generic accessors} *************************************************)
+
+type key = string list
+
+type value = MBytes.t
+
+module type T = sig
+
+  type t
+  type context = t
+
+  (** Tells if the key is already defined as a value. *)
+  val mem: context -> key -> bool Lwt.t
+
+  (** Tells if the key is already defined as a directory. *)
+  val dir_mem: context -> key -> bool Lwt.t
+
+  (** Retrieve the value from the storage bucket ; returns a
+      {!Storage_error Missing_key} if the key is not set. *)
+  val get: context -> key -> value tzresult Lwt.t
+
+  (** Retrieves the value from the storage bucket ; returns [None] if
+      the data is not initialized. *)
+  val get_option: context -> key -> value option Lwt.t
+
+  (** Allocates the storage bucket and initializes it ; returns a
+      {!Storage_error Existing_key} if the bucket exists. *)
+  val init: context -> key -> value -> context tzresult Lwt.t
+
+  (** Updates the content of the bucket ; returns a {!Storage_error
+      Missing_key} if the value does not exists. *)
+  val set: context -> key -> value -> context tzresult Lwt.t
+
+  (** Allocates the data and initializes it with a value ; just
+      updates it if the bucket exists. *)
+  val init_set: context -> key -> value -> context Lwt.t
+
+  (** When the value is [Some v], allocates the data and initializes
+      it with [v] ; just updates it if the bucket exists. When the
+      valus is [None], delete the storage bucket when the value ; does
+      nothing if the bucket does not exists. *)
+  val set_option: context -> key -> value option -> context Lwt.t
+
+  (** Delete the storage bucket ; returns a {!Storage_error
+      Missing_key} if the bucket does not exists. *)
+  val delete: context -> key -> context tzresult Lwt.t
+
+  (** Removes the storage bucket and its contents ; does nothing if the
+      bucket does not exists. *)
+  val remove: context -> key -> context Lwt.t
+
+  (** Recursively removes all the storage buckets and contents ; does
+      nothing if no bucket exists. *)
+  val remove_rec: context -> key -> context Lwt.t
+
+  (** Iterator on all the items of a given directory. *)
+  val fold:
+    context -> key -> init:'a ->
+    f:([ `Key of key | `Dir of key ] -> 'a -> 'a Lwt.t) ->
+    'a Lwt.t
+
+  (** Recursively list all subkeys of a given key. *)
+  val keys: context -> key -> key list Lwt.t
+
+  (** Recursive iterator on all the subkeys of a given key. *)
+  val fold_keys:
+    context -> key -> init:'a -> f:(key -> 'a -> 'a Lwt.t) -> 'a Lwt.t
+
+  val project: context -> root_context
+
+end
+
+include T with type t := t and type context := context

src/proto/alpha/raw_level_repr.ml

@@ -45,3 +45,15 @@ type error += Unexpected_level of Int32.t
 let of_int32 l =
   try Ok (of_int32_exn l)
   with _ -> Error [Unexpected_level l]
+
+module Index = struct
+  type t = raw_level
+  let path_length = 1
+  let to_path level l = Int32.to_string level :: l
+  let of_path = function
+    | [s] -> begin
+        try Some (Int32.of_string s)
+        with _ -> None
+      end
+    | _ -> None
+end

src/proto/alpha/raw_level_repr.mli

@@ -24,3 +24,10 @@ val root: raw_level
 
 val succ: raw_level -> raw_level
 val pred: raw_level -> raw_level option
+
+module Index : sig
+  type t = raw_level
+  val path_length: int
+  val to_path: t -> string list -> string list
+  val of_path: string list -> t option
+end

src/proto/alpha/reward_storage.ml

@@ -16,47 +16,44 @@ let record c delegate cycle amount =
   Storage.Rewards.Next.get c >>=? fun min_cycle ->
   fail_unless Cycle_repr.(min_cycle <= cycle)
     Too_late_reward_recording >>=? fun () ->
-  Storage.Rewards.Amount.get_option c (delegate, cycle) >>=? function
+  Storage.Rewards.Amount.get_option (c, cycle) delegate >>=? function
   | None ->
-      Storage.Rewards.Amount.init c (delegate, cycle) amount
+      Storage.Rewards.Amount.init (c, cycle) delegate amount
   | Some previous_amount ->
       Lwt.return Tez_repr.(previous_amount +? amount) >>=? fun amount ->
-      Storage.Rewards.Amount.set c (delegate, cycle) amount
+      Storage.Rewards.Amount.set (c, cycle) delegate amount
 
 let discard c delegate cycle amount =
   Storage.Rewards.Next.get c >>=? fun min_cycle ->
   fail_unless Cycle_repr.(min_cycle <= cycle)
     Too_late_reward_discarding >>=? fun () ->
-  Storage.Rewards.Amount.get_option c (delegate, cycle) >>=? function
+  Storage.Rewards.Amount.get_option (c, cycle) delegate >>=? function
   | None ->
       fail Incorrect_discard
   | Some previous_amount ->
       match Tez_repr.(previous_amount -? amount) with
       | Ok amount ->
           if Tez_repr.(amount = zero) then
-            Storage.Rewards.Amount.remove c (delegate, cycle) >>= fun ctxt ->
+            Storage.Rewards.Amount.remove (c, cycle) delegate >>= fun ctxt ->
             return ctxt
           else
-            Storage.Rewards.Amount.set c (delegate, cycle) amount
+            Storage.Rewards.Amount.set (c, cycle) delegate amount
       | Error _ ->
           fail Incorrect_discard
 
 let pay_rewards_for_cycle c cycle =
-  Storage.Rewards.Amount.fold c (Ok c)
+  Storage.Rewards.Amount.fold (c, cycle) ~init:(Ok c)
-    ~f:(fun (delegate, reward_cycle) amount c ->
+    ~f:(fun delegate amount c ->
         match c with
         | Error _ -> Lwt.return c
         | Ok c ->
-            if not Cycle_repr.(cycle = reward_cycle)
+            Storage.Rewards.Amount.remove (c, cycle) delegate >>= fun c ->
-            then return c
+            Contract_storage.credit c
-            else
+              (Contract_repr.default_contract delegate)
-              Storage.Rewards.Amount.remove c (delegate, reward_cycle) >>= fun c ->
+              amount)
-              Contract_storage.credit c
-                (Contract_repr.default_contract delegate)
-                amount)
 
 let pay_due_rewards c =
-  let timestamp = Storage.current_timestamp c in
+  let timestamp = Raw_context.current_timestamp c in
   let rec loop c cycle =
     Storage.Rewards.Date.get_option c cycle >>=? function
     | None ->

src/proto/alpha/reward_storage.mli

@@ -8,14 +8,14 @@
 (**************************************************************************)
 
 val record:
-  Storage.t -> Ed25519.Public_key_hash.t -> Cycle_repr.t -> Tez_repr.t -> Storage.t tzresult Lwt.t
+  Raw_context.t -> Ed25519.Public_key_hash.t -> Cycle_repr.t -> Tez_repr.t -> Raw_context.t tzresult Lwt.t
 
 val discard:
-  Storage.t -> Ed25519.Public_key_hash.t -> Cycle_repr.t -> Tez_repr.t -> Storage.t tzresult Lwt.t
+  Raw_context.t -> Ed25519.Public_key_hash.t -> Cycle_repr.t -> Tez_repr.t -> Raw_context.t tzresult Lwt.t
 
-val pay_due_rewards: Storage.t -> Storage.t tzresult Lwt.t
+val pay_due_rewards: Raw_context.t -> Raw_context.t tzresult Lwt.t
 
 val set_reward_time_for_cycle:
-  Storage.t -> Cycle_repr.t -> Time.t -> Storage.t tzresult Lwt.t
+  Raw_context.t -> Cycle_repr.t -> Time.t -> Raw_context.t tzresult Lwt.t
 
-val init: Storage.t -> Storage.t tzresult Lwt.t
+val init: Raw_context.t -> Raw_context.t tzresult Lwt.t

src/proto/alpha/roll_repr.ml

@@ -21,3 +21,19 @@ let random sequence ~bound =
 let to_int32 v = v
 
 let (=) = Compare.Int32.(=)
+
+module Index = struct
+  type t = roll
+  let path_length = 3
+  let nbyte_of_int32 i n =
+    Int32.to_string @@
+    Int32.logand (Int32.shift_right i (8 * n)) (Int32.of_int 0xff)
+  let to_path roll l =
+    nbyte_of_int32 roll 0 :: nbyte_of_int32 roll 1 :: Int32.to_string roll :: l
+  let of_path = function
+    | _ :: _ :: s :: _ -> begin
+        try Some (Int32.of_string s)
+        with _ -> None
+      end
+    | _ -> None
+end

src/proto/alpha/roll_repr.mli

@@ -21,3 +21,10 @@ val succ: roll -> roll
 val to_int32: roll -> Int32.t
 
 val (=): roll -> roll -> bool
+
+module Index : sig
+  type t = roll
+  val path_length: int
+  val to_path: t -> string list -> string list
+  val of_path: string list -> t option
+end

src/proto/alpha/roll_storage.ml

@@ -24,7 +24,7 @@ let clear_cycle c cycle =
     if Roll_repr.(roll = last) then
       return c
     else
-      Storage.Roll.Owner_for_cycle.delete c (cycle, roll) >>=? fun c ->
+      Storage.Roll.Owner_for_cycle.delete (c, cycle) roll >>=? fun c ->
       loop c (Roll_repr.succ roll) in
   loop c Roll_repr.first
 
@@ -49,7 +49,7 @@ let freeze_rolls_for_cycle ctxt cycle =
         | None -> return acc
         | Some delegate ->
             Storage.Roll.Owner_for_cycle.init
-              ctxt (cycle, promoted_roll) delegate >>=? fun ctxt ->
+              (ctxt, cycle) promoted_roll delegate >>=? fun ctxt ->
             return (ctxt, Roll_repr.succ promoted_roll))
   >>=? fun (ctxt, last_promoted_roll) ->
   Storage.Roll.Last_for_cycle.init ctxt cycle last_promoted_roll
@@ -75,8 +75,8 @@ module Random = struct
     let rd = level_random random_seed kind level in
     let sequence = Seed_repr.sequence rd (Int32.of_int offset) in
     Storage.Roll.Last_for_cycle.get c cycle >>=? fun bound ->
-    let roll, _ = Roll_repr.random sequence bound in
+    let roll, _ = Roll_repr.random sequence ~bound in
-    Storage.Roll.Owner_for_cycle.get c (cycle, roll)
+    Storage.Roll.Owner_for_cycle.get (c, cycle) roll
 
 end
 
@@ -94,10 +94,10 @@ module Contract = struct
     return (roll, c)
 
   let get_limbo_roll c =
-    Storage.Roll.Limbo.get c >>=? function
+    Storage.Roll.Limbo.get_option c >>=? function
     | None ->
         fresh_roll c >>=? fun (roll, c) ->
-        Storage.Roll.Limbo.set c (Some roll) >>=? fun c ->
+        Storage.Roll.Limbo.init c roll >>=? fun c ->
         return (roll, c)
     | Some roll ->
         return (roll, c)
@@ -119,24 +119,24 @@ module Contract = struct
        contract : roll -> successor_roll -> ...
        limbo : limbo_head -> ...
     *)
-    Storage.Roll.Limbo.get c >>=? fun limbo_head ->
+    Storage.Roll.Limbo.get_option c >>=? fun limbo_head ->
-    Storage.Roll.Contract_roll_list.get c contract >>=? function
+    Storage.Roll.Contract_roll_list.get_option c contract >>=? function
     | None -> fail No_roll_in_contract
     | Some roll ->
         Storage.Roll.Owner.delete c roll >>=? fun c ->
-        Storage.Roll.Successor.get c roll >>=? fun successor_roll ->
+        Storage.Roll.Successor.get_option c roll >>=? fun successor_roll ->
-        Storage.Roll.Contract_roll_list.set c contract successor_roll >>=? fun c ->
+        Storage.Roll.Contract_roll_list.set_option c contract successor_roll >>= fun c ->
         (* contract : successor_roll -> ...
            roll ------^
            limbo : limbo_head -> ... *)
-        Storage.Roll.Successor.set c roll limbo_head >>=? fun c ->
+        Storage.Roll.Successor.set_option c roll limbo_head >>= fun c ->
         (* contract : successor_roll -> ...
            roll ------v
            limbo : limbo_head -> ... *)
-        Storage.Roll.Limbo.set c (Some roll) >>=? fun c ->
+        Storage.Roll.Limbo.init_set c roll >>= fun c ->
         (* contract : successor_roll -> ...
            limbo : roll -> limbo_head -> ... *)
-        Lwt.return (Ok (roll, c))
+        return (roll, c)
 
   let create_roll_in_contract c contract =
     consume_roll_change c contract >>=? fun c ->
@@ -145,21 +145,22 @@ module Contract = struct
        contract : contract_head -> ...
        limbo : roll -> limbo_successor -> ...
     *)
-    Storage.Roll.Contract_roll_list.get c contract >>=? fun contract_head ->
+    Storage.Roll.Contract_roll_list.get_option c contract >>=? fun contract_head ->
     get_limbo_roll c >>=? fun (roll, c) ->
     Storage.Roll.Owner.init c roll contract >>=? fun c ->
-    Storage.Roll.Successor.get c roll >>=? fun limbo_successor ->
+    Storage.Roll.Successor.get_option c roll >>=? fun limbo_successor ->
-    Storage.Roll.Limbo.set c limbo_successor >>=? fun c ->
+    Storage.Roll.Limbo.set_option c limbo_successor >>= fun c ->
     (* contract : contract_head -> ...
        roll ------v
        limbo : limbo_successor -> ... *)
-    Storage.Roll.Successor.set c roll contract_head >>=? fun c ->
+    Storage.Roll.Successor.set_option c roll contract_head >>= fun c ->
     (* contract : contract_head -> ...
        roll ------^
        limbo : limbo_successor -> ... *)
-    Storage.Roll.Contract_roll_list.set c contract (Some roll)
+    Storage.Roll.Contract_roll_list.init_set c contract roll >>= fun c ->
-  (* contract : roll -> contract_head -> ...
+    (* contract : roll -> contract_head -> ...
-     limbo : limbo_successor -> ... *)
+       limbo : limbo_successor -> ... *)
+    return c
 
   let init c contract =
     Storage.Roll.Contract_change.init c contract Tez_repr.zero

src/proto/alpha/roll_storage.mli

@@ -21,43 +21,43 @@ type error +=
   | Consume_roll_change
   | No_roll_in_contract
 
-val init : Storage.t -> Storage.t tzresult Lwt.t
+val init : Raw_context.t -> Raw_context.t tzresult Lwt.t
 
 val fold :
-  Storage.t ->
+  Raw_context.t ->
   f:(Roll_repr.roll -> Contract_repr.t -> 'a -> 'a tzresult Lwt.t) ->
   'a -> 'a tzresult Lwt.t
 
 val freeze_rolls_for_cycle :
-  Storage.t -> Cycle_repr.t -> Storage.t tzresult Lwt.t
+  Raw_context.t -> Cycle_repr.t -> Raw_context.t tzresult Lwt.t
 
 val clear_cycle :
-  Storage.t -> Cycle_repr.t -> Storage.t tzresult Lwt.t
+  Raw_context.t -> Cycle_repr.t -> Raw_context.t tzresult Lwt.t
 
 val baking_rights_owner :
-  Storage.t -> Level_repr.t -> priority:int ->
+  Raw_context.t -> Level_repr.t -> priority:int ->
   Ed25519.Public_key_hash.t tzresult Lwt.t
 
 val endorsement_rights_owner :
-  Storage.t -> Level_repr.t -> slot:int ->
+  Raw_context.t -> Level_repr.t -> slot:int ->
   Ed25519.Public_key_hash.t tzresult Lwt.t
 
 module Contract : sig
 
   val init :
-    Storage.t -> Contract_repr.t -> Storage.t tzresult Lwt.t
+    Raw_context.t -> Contract_repr.t -> Raw_context.t tzresult Lwt.t
 
   val add_amount :
-    Storage.t -> Contract_repr.t -> Tez_repr.t -> Storage.t tzresult Lwt.t
+    Raw_context.t -> Contract_repr.t -> Tez_repr.t -> Raw_context.t tzresult Lwt.t
 
   val remove_amount :
-    Storage.t -> Contract_repr.t -> Tez_repr.t -> Storage.t tzresult Lwt.t
+    Raw_context.t -> Contract_repr.t -> Tez_repr.t -> Raw_context.t tzresult Lwt.t
 
-  val assert_empty : Storage.t -> Contract_repr.t -> unit tzresult Lwt.t
+  val assert_empty : Raw_context.t -> Contract_repr.t -> unit tzresult Lwt.t
 
 end
 
 (**/**)
 
 val get_contract_delegate:
-  Storage.t -> Contract_repr.t -> Ed25519.Public_key_hash.t option tzresult Lwt.t
+  Raw_context.t -> Contract_repr.t -> Ed25519.Public_key_hash.t option tzresult Lwt.t

src/proto/alpha/seed_repr.mli

@@ -67,7 +67,7 @@ val hash : nonce -> Nonce_hash.t
 val check_hash : nonce -> Nonce_hash.t -> bool
 
 (** For using nonce hashes as keys in the hierarchical database *)
-val nonce_hash_key_part : Nonce_hash.t -> string list
+val nonce_hash_key_part : Nonce_hash.t -> string list -> string list
 
 (** {2 Predefined nonce} *****************************************************)
 

src/proto/alpha/seed_storage.mli

@@ -12,12 +12,12 @@ type error +=
   | Invalid_cycle
 
 val init:
-  Storage.t -> Storage.t tzresult Lwt.t
+  Raw_context.t -> Raw_context.t tzresult Lwt.t
 
 val compute_for_cycle:
-  Storage.t -> Cycle_repr.t -> Storage.t tzresult Lwt.t
+  Raw_context.t -> Cycle_repr.t -> Raw_context.t tzresult Lwt.t
 
-val for_cycle: Storage.t -> Cycle_repr.t -> Seed_repr.seed tzresult Lwt.t
+val for_cycle: Raw_context.t -> Cycle_repr.t -> Seed_repr.seed tzresult Lwt.t
 
 val clear_cycle:
-  Storage.t -> Cycle_repr.t -> Storage.t tzresult Lwt.t
+  Raw_context.t -> Cycle_repr.t -> Raw_context.t tzresult Lwt.t

src/proto/alpha/services_registration.ml

@@ -189,12 +189,15 @@ let get_key ctxt hash () =
   return (hash, pk)
 
 let () = register2 Services.Context.Key.get get_key
-let () = register0 Services.Context.Key.list Delegates_pubkey.list
+let () =
+  register0 Services.Context.Key.list
+    (fun t -> Delegates_pubkey.list t >>= return)
 
 (*-- Context.Contract --------------------------------------------------------*)
 
 let () =
-  register0 Services.Context.Contract.list Contract.list
+  register0 Services.Context.Contract.list
+    (fun ctxt -> Contract.list ctxt >>= return)
 
 let () =
   let register2 s f =

src/proto/alpha/storage.ml

@@ -10,368 +10,233 @@
 open Tezos_hash
 open Storage_functors
 
-(* This key should always be populated for every version of the
+module Int32 = struct
-   protocol.  It's absence meaning that the context is empty. *)
+  type t = Int32.t
-let version_key = ["version"]
+  let encoding = Data_encoding.int32
-let version_value = "alpha"
-
-type error += Incompatiple_protocol_version
-
-let is_first_block ctxt =
-  Context.get ctxt version_key >>= function
-  | None ->
-      return true
-  | Some bytes ->
-      let s = MBytes.to_string bytes in
-      if Compare.String.(s = version_value) then
-        return false
-      else if Compare.String.(s = "genesis") then
-        return true
-      else
-        fail Incompatiple_protocol_version
-
-let version = "v1"
-let first_level_key = [ version ; "first_level" ]
-let sandboxed_key = [ version ; "sandboxed" ]
-
-type t = Storage_functors.context
-
-type error += Invalid_sandbox_parameter
-
-let current_level { level } = level
-let current_timestamp { timestamp } = timestamp
-let current_fitness { fitness } = fitness
-let set_current_fitness c fitness = { c with fitness }
-
-let get_first_level ctxt =
-  Context.get ctxt first_level_key >>= function
-  | None -> failwith "Invalid context"
-  | Some bytes ->
-      match
-        Data_encoding.Binary.of_bytes Raw_level_repr.encoding bytes
-      with
-      | None -> failwith "Invalid context"
-      | Some level -> return level
-
-let set_first_level ctxt level =
-  let bytes =
-    Data_encoding.Binary.to_bytes Raw_level_repr.encoding level in
-  Context.set ctxt first_level_key bytes >>= fun ctxt ->
-  return ctxt
-
-let get_sandboxed c =
-  Context.get c sandboxed_key >>= function
-  | None -> return None
-  | Some bytes ->
-      match Data_encoding.Binary.of_bytes Data_encoding.json bytes with
-      | None -> fail Invalid_sandbox_parameter
-      | Some json -> return (Some json)
-
-let set_sandboxed c json =
-  Context.set c sandboxed_key
-    (Data_encoding.Binary.to_bytes Data_encoding.json json)
-
-let may_tag_first_block ctxt level =
-  is_first_block ctxt >>=? function
-  | false ->
-      get_first_level ctxt >>=? fun level ->
-      return (ctxt, false, level)
-  | true ->
-      Context.set ctxt version_key
-        (MBytes.of_string version_value) >>= fun ctxt ->
-      set_first_level ctxt level >>=? fun ctxt ->
-      return (ctxt, true, level)
-
-let prepare ~level ~timestamp ~fitness ctxt =
-  Lwt.return (Raw_level_repr.of_int32 level ) >>=? fun level ->
-  Lwt.return (Fitness_repr.to_int64 fitness) >>=? fun fitness ->
-  may_tag_first_block ctxt level >>=? fun (ctxt, first_block, first_level) ->
-  get_sandboxed ctxt >>=? fun sandbox ->
-  Constants_repr.read sandbox >>=? function constants ->
-    let level =
-      Level_repr.from_raw
-        ~first_level
-        ~cycle_length:constants.Constants_repr.cycle_length
-        ~voting_period_length:constants.Constants_repr.voting_period_length
-        level in
-    return ({ context = ctxt ; constants ; level ;
-              timestamp ; fitness ; first_level},
-            first_block)
-let recover { context } : Context.t = context
-
-let first_level { first_level } = first_level
-let constants { constants } = constants
-
-module Key = struct
-
-  let store_root tail = version :: "store" :: tail
-
-  let global_counter = store_root ["global_counter"]
-
-  let next_cycle_to_be_rewarded = store_root ["next_cycle_to_be_rewarded"]
-  let rewards = store_root ["rewards"]
-
-  let public_keys = ["public_keys" ; "ed25519"]
-
-  let nbyte_of_int32 i n =
-    Int32.to_string @@
-    Int32.logand (Int32.shift_left i (8 * n)) (Int32.of_int 0xff)
-
-  let roll_path roll l =
-    let i = Roll_repr.to_int32 roll in
-    nbyte_of_int32 i 0 :: nbyte_of_int32 i 1 :: Int32.to_string i :: l
-
-  module Roll = struct
-    let store_root l = store_root ("rolls" :: l)
-    let next = store_root [ "next" ]
-    let limbo = store_root [ "limbo" ]
-    let roll_store roll l =
-      store_root @@ roll_path roll @@ l
-    let successor r = roll_store r ["successor"]
-    let owner r = roll_store r ["owner"]
-  end
-
-  module Cycle = struct
-    let store_root l = store_root ("cycles" :: l)
-    let cycle_store c l =
-      store_root @@ Int32.to_string (Cycle_repr.to_int32 c) :: l
-    let last_roll c = cycle_store c [ "last_roll" ]
-    let random_seed c = cycle_store c [ "random_seed" ]
-    let reward_date c = cycle_store c [ "reward_date" ]
-    let roll_owner (c, r) =
-      cycle_store c @@ "roll_owners" :: roll_path r []
-    let unrevealed_nonce_hash l =
-      let c = l.Level_repr.cycle in
-      cycle_store c [ "unrevealed_nonce_hash" ;
-                      Int32.to_string l.Level_repr.cycle_position ]
-  end
-
-  module Contract = struct
-
-    let store_root l = store_root ("contracts" :: l)
-    let set = store_root ["set"]
-    let pubkey_contract l = store_root ("pubkey" :: l)
-    let generic_contract l = store_root ("generic" :: l)
-    let contract_store c l =
-      match c with
-      | Contract_repr.Default k ->
-          pubkey_contract @@ Ed25519.Public_key_hash.to_path k @ l
-      | Contract_repr.Originated h ->
-          generic_contract @@ Contract_hash.to_path h @ l
-    let roll_list c = contract_store c ["roll_list"]
-    let change c = contract_store c ["change"]
-    let balance c = contract_store c ["balance"]
-    let manager c = contract_store c ["manager"]
-    let spendable c = contract_store c ["spendable"]
-    let delegatable c = contract_store c ["delegatable"]
-    let delegate c = contract_store c ["delegate"]
-    let counter c = contract_store c ["counter"]
-    let code c = contract_store c ["code"]
-    let storage c = contract_store c ["storage"]
-    let code_fees c = contract_store c ["code_fees"]
-    let storage_fees c = contract_store c ["storage_fees"]
-  end
-
-  module Vote = struct
-    let store_root l = store_root ("votes" :: l)
-    let period_kind = store_root ["current_period_kind"]
-    let quorum = store_root ["current_quorum"]
-    let proposition = store_root ["current_proposition"]
-    let proposals = store_root ["proposals"]
-    let ballots = store_root ["ballots"]
-    let listings_size = store_root ["listings_size"]
-    let listings = store_root ["listings"]
-  end
-
 end
 
-(** Rolls *)
+module Bool = struct
-
+  type t = bool
-module Roll = struct
+  let encoding = Data_encoding.bool
-
-  module Next =
-    Make_single_data_storage(struct
-      type value = Roll_repr.t
-      let name = "next fresh roll"
-      let key = Key.Roll.next
-      let encoding = Roll_repr.encoding
-    end)
-
-  module Limbo =
-    Make_single_optional_data_storage(struct
-      type value = Roll_repr.t
-      let name = "limbo"
-      let key = Key.Roll.limbo
-      let encoding = Roll_repr.encoding
-    end)
-
-  module Last_for_cycle =
-    Make_indexed_data_storage(struct
-      type key = Cycle_repr.t
-      type value = Roll_repr.t
-      let name = "last roll for current cycle"
-      let key = Key.Cycle.last_roll
-      let encoding = Roll_repr.encoding
-    end)
-
-  module Successor =
-    Make_indexed_optional_data_storage(struct
-      type key = Roll_repr.t
-      type value = Roll_repr.t
-      let name = "roll successor"
-      let key = Key.Roll.successor
-      let encoding = Roll_repr.encoding
-    end)
-
-  module Owner =
-    Make_indexed_data_storage(struct
-      type key = Roll_repr.t
-      type value = Contract_repr.t
-      let name = "roll owner"
-      let key = Key.Roll.owner
-      let encoding = Contract_repr.encoding
-    end)
-
-  module Owner_for_cycle =
-    Make_indexed_data_storage(struct
-      type key = Cycle_repr.t * Roll_repr.t
-      type value = Ed25519.Public_key_hash.t
-      let name = "roll owner for current cycle"
-      let key = Key.Cycle.roll_owner
-      let encoding = Ed25519.Public_key_hash.encoding
-    end)
-
-  module Contract_roll_list =
-    Make_indexed_optional_data_storage(struct
-      type key = Contract_repr.t
-      type value = Roll_repr.t
-      let name = "contract roll list"
-      let key = Key.Contract.roll_list
-      let encoding = Roll_repr.encoding
-    end)
-
-  module Contract_change =
-    Make_indexed_data_storage(struct
-      type key = Contract_repr.t
-      type value = Tez_repr.t
-      let name = "contract change"
-      let key = Key.Contract.change
-      let encoding = Tez_repr.encoding
-    end)
-
 end
 
 (** Contracts handling *)
 
 module Contract = struct
 
-  module Global_counter =
+  module Raw_context =
-    Make_single_data_storage(struct
+    Make_subcontext(Raw_context)(struct let name = ["contracts"] end)
-      type value = int32
-      let name = "global counter"
-      let key = Key.global_counter
-      let encoding = Data_encoding.int32
-    end)
 
-  (** FIXME REMOVE : use 'list' *)
+  module Global_counter =
-  module Set =
+    Make_single_data_storage
-    Make_data_set_storage(struct
+      (Raw_context)
-      type value = Contract_repr.t
+      (struct let name = ["global_counter"] end)
-      let name = "contract set"
+      (Make_value(Int32))
-      let key = Key.Contract.set
+
-      let encoding = Contract_repr.encoding
+  (* module Set = *)
-    end)
+  (* Make_data_set_storage *)
+  (* (Make_subcontext(Raw_context)(struct let name = ["set"] end)) *)
+  (* (Contract_repr.Index) *)
+
+  module Indexed_context =
+    Make_indexed_subcontext
+      (Make_subcontext(Raw_context)(struct let name = ["index"] end))
+      (Contract_repr.Index)
+
+  let list = Indexed_context.keys
 
   module Balance =
-    Make_indexed_data_storage(
+    Indexed_context.Make_map
-    struct
+      (struct let name = ["balance"] end)
-      type key = Contract_repr.t
+      (Make_value(Tez_repr))
-      type value = Tez_repr.t
-      let name = "contract balance"
-      let key = Key.Contract.balance
-      let encoding = Tez_repr.encoding
-    end)
 
   module Manager =
-    Make_indexed_data_storage(struct
+    Indexed_context.Make_map
-      type key = Contract_repr.t
+      (struct let name = ["manager"] end)
-      type value = Manager_repr.t
+      (Make_value(Manager_repr))
-      let name = "contract manager"
-      let key = Key.Contract.manager
-      let encoding = Manager_repr.encoding
-    end)
 
   module Spendable =
-    Make_indexed_data_storage(struct
+    Indexed_context.Make_map
-      type key = Contract_repr.t
+      (struct let name = ["spendable"] end)
-      type value = bool
+      (Make_value(Bool))
-      let name = "contract spendable"
-      let key = Key.Contract.spendable
-      let encoding = Data_encoding.bool
-    end)
 
   module Delegatable =
-    Make_indexed_data_storage(struct
+    Indexed_context.Make_map
-      type key = Contract_repr.t
+      (struct let name = ["delegatable"] end)
-      type value = bool
+      (Make_value(Bool))
-      let name = "contract delegatable"
-      let key = Key.Contract.delegatable
-      let encoding = Data_encoding.bool
-    end)
 
   module Delegate =
-    Make_indexed_data_storage(struct
+    Indexed_context.Make_map
-      type key = Contract_repr.t
+      (struct let name = ["delegate"] end)
-      type value = Ed25519.Public_key_hash.t
+      (Make_value(Ed25519.Public_key_hash))
-      let name = "contract delegate"
-      let key = Key.Contract.delegate
-      let encoding = Ed25519.Public_key_hash.encoding
-    end)
 
   module Counter =
-    Make_indexed_data_storage(struct
+    Indexed_context.Make_map
-      type key = Contract_repr.t
+      (struct let name = ["counter"] end)
-      type value = Int32.t
+      (Make_value(Int32))
-      let name = "contract counter"
-      let key = Key.Contract.counter
-      let encoding = Data_encoding.int32
-    end)
 
   module Code =
-    Make_indexed_data_storage(struct
+    Indexed_context.Make_map
-      type key = Contract_repr.t
+      (struct let name = ["code"] end)
-      type value = Script_repr.expr
+      (Make_value(struct
-      let name = "contract code"
+         type t = Script_repr.expr
-      let key = Key.Contract.code
+         let encoding = Script_repr.expr_encoding
-      let encoding = Script_repr.expr_encoding
+       end))
-    end)
 
   module Storage =
-    Make_indexed_data_storage(struct
+    Indexed_context.Make_map
-      type key = Contract_repr.t
+      (struct let name = ["storage"] end)
-      type value = Script_repr.expr
+      (Make_value(struct
-      let name = "contract storage"
+         type t = Script_repr.expr
-      let key = Key.Contract.storage
+         let encoding = Script_repr.expr_encoding
-      let encoding = Script_repr.expr_encoding
+       end))
-    end)
 
   module Code_fees =
-    Make_indexed_data_storage(struct
+    Indexed_context.Make_map
-      type key = Contract_repr.t
+      (struct let name = ["code_fees"] end)
-      type value = Tez_repr.t
+      (Make_value(Tez_repr))
-      let name = "contract code fees"
-      let key = Key.Contract.code_fees
-      let encoding = Tez_repr.encoding
-    end)
 
   module Storage_fees =
-    Make_indexed_data_storage(struct
+    Indexed_context.Make_map
-      type key = Contract_repr.t
+      (struct let name = ["storage_fees"] end)
-      type value = Tez_repr.t
+      (Make_value(Tez_repr))
-      let name = "contract storage fees"
+
-      let key = Key.Contract.storage_fees
+  module Roll_list =
-      let encoding = Tez_repr.encoding
+    Indexed_context.Make_map
-    end)
+      (struct let name = ["roll_list"] end)
+      (Make_value(Roll_repr))
+
+  module Change =
+    Indexed_context.Make_map
+      (struct let name = ["change"] end)
+      (Make_value(Tez_repr))
+
+end
+
+(** Rolls *)
+
+module Cycle = struct
+
+  module Indexed_context =
+    Make_indexed_subcontext
+      (Make_subcontext(Raw_context)(struct let name = ["cycle"] end))
+      (Cycle_repr.Index)
+
+  module Last_roll =
+    Indexed_context.Make_map
+      (struct let name = ["last_roll"] end)
+      (Make_value(Roll_repr))
+
+  module Roll_owner =
+    Make_indexed_data_storage
+      (Make_subcontext
+         (Indexed_context.Raw_context)
+         (struct let name = ["roll_owners"] end))
+      (Roll_repr.Index)
+      (Make_value(Ed25519.Public_key_hash))
+
+  type nonce_status =
+    | Unrevealed of {
+        nonce_hash: Nonce_hash.t ;
+        delegate_to_reward: Ed25519.Public_key_hash.t ;
+        reward_amount: Tez_repr.t ;
+      }
+    | Revealed of Seed_repr.nonce
+
+  let nonce_status_encoding =
+    let open Data_encoding in
+    union [
+      case ~tag:0
+        (tup3
+           Nonce_hash.encoding
+           Ed25519.Public_key_hash.encoding
+           Tez_repr.encoding)
+        (function
+          | Unrevealed { nonce_hash ; delegate_to_reward ; reward_amount } ->
+              Some (nonce_hash, delegate_to_reward, reward_amount)
+          | _ -> None)
+        (fun (nonce_hash, delegate_to_reward, reward_amount) ->
+           Unrevealed { nonce_hash ; delegate_to_reward ; reward_amount }) ;
+      case ~tag:1
+        Seed_repr.nonce_encoding
+        (function
+          | Revealed nonce -> Some nonce
+          | _ -> None)
+        (fun nonce -> Revealed nonce)
+    ]
+
+  module Nonce =
+    Make_indexed_data_storage
+      (Make_subcontext
+         (Indexed_context.Raw_context)
+         (struct let name = ["nonces"] end))
+      (Raw_level_repr.Index)
+      (Make_value(struct
+         type t = nonce_status
+         let encoding = nonce_status_encoding
+       end))
+
+  module Seed =
+    Indexed_context.Make_map
+      (struct let name = ["random_seed"] end)
+      (Make_value(struct
+         type t = Seed_repr.seed
+         let encoding = Seed_repr.seed_encoding
+       end))
+
+  module Reward_date =
+    Indexed_context.Make_map
+      (struct let name = [ "reward_date" ] end)
+      (Make_value(Time_repr))
+
+  module Reward_amount =
+    Make_indexed_data_storage
+      (Make_subcontext
+         (Indexed_context.Raw_context)
+         (struct let name = [ "rewards" ] end))
+      (Ed25519.Public_key_hash)
+      (Make_value(Tez_repr))
+
+end
+
+module Roll = struct
+
+  module Raw_context =
+    Make_subcontext(Raw_context)(struct let name = ["rolls"] end)
+
+  module Indexed_context =
+    Make_indexed_subcontext
+      (Make_subcontext(Raw_context)(struct let name = ["index"] end))
+      (Roll_repr.Index)
+
+  module Next =
+    Make_single_data_storage
+      (Raw_context)
+      (struct let name = ["next"] end)
+      (Make_value(Roll_repr))
+
+  module Limbo =
+    Make_single_data_storage
+      (Raw_context)
+      (struct let name = ["limbo"] end)
+      (Make_value(Roll_repr))
+
+  module Contract_roll_list = Contract.Roll_list
+
+  module Successor =
+    Indexed_context.Make_map
+      (struct let name = ["successor"] end)
+      (Make_value(Roll_repr))
+
+  module Contract_change = Contract.Change
+
+  module Owner =
+    Indexed_context.Make_map
+      (struct let name = ["owner"] end)
+      (Make_value(Contract_repr))
+
+  module Last_for_cycle = Cycle.Last_roll
+  module Owner_for_cycle = Cycle.Roll_owner
 
 end
 
@@ -379,130 +244,101 @@ end
 
 module Vote = struct
 
+  module Raw_context =
+    Make_subcontext(Raw_context)(struct let name = ["votes"] end)
+
   module Current_period_kind =
-    Make_single_data_storage(struct
+    Make_single_data_storage
-      type value = Voting_period_repr.kind
+      (Raw_context)
-      let name = "current period kind"
+      (struct let name = ["current_period_kind"] end)
-      let key = Key.Vote.period_kind
+      (Make_value(struct
-      let encoding = Voting_period_repr.kind_encoding
+         type t = Voting_period_repr.kind
-    end)
+         let encoding = Voting_period_repr.kind_encoding
+       end))
 
   module Current_quorum =
-    Make_single_data_storage(struct
+    Make_single_data_storage
-      type value = int32
+      (Raw_context)
-      let name = "current quorum"
+      (struct let name = ["current_quorum"] end)
-      let key = Key.Vote.quorum
+      (Make_value(Int32))
-      let encoding = Data_encoding.int32
-    end)
 
   module Current_proposal =
-    Make_single_data_storage(struct
+    Make_single_data_storage
-      type value = Protocol_hash.t
+      (Raw_context)
-      let name = "current proposal"
+      (struct let name = ["current_proposal"] end)
-      let key = Key.Vote.proposition
+      (Make_value(Protocol_hash))
-      let encoding = Protocol_hash.encoding
-    end)
 
   module Listings_size =
-    Make_single_data_storage(struct
+    Make_single_data_storage
-      type value = int32
+      (Raw_context)
-      let name = "listing size"
+      (struct let name = ["listings_size"] end)
-      let key = Key.Vote.listings_size
+      (Make_value(Int32))
-      let encoding = Data_encoding.int32
-    end)
 
   module Listings =
-    Make_iterable_data_storage (Ed25519.Public_key_hash)
+    Make_indexed_data_storage
-      (struct
+      (Make_subcontext(Raw_context)(struct let name = ["listings"] end))
-        type value = int32
+      (Ed25519.Public_key_hash)
-        let key = Key.Vote.listings
+      (Make_value(Int32))
-        let name = "listings"
-        let encoding = Data_encoding.int32
-      end)
 
   module Proposals =
     Make_data_set_storage
-      (struct
+      (Make_subcontext(Raw_context)(struct let name = ["proposals"] end))
-        type value = Protocol_hash.t * Ed25519.Public_key_hash.t
+      (Pair(Protocol_hash)(Ed25519.Public_key_hash))
-        let name = "proposals"
-        let encoding =
-          Data_encoding.tup2
-            Protocol_hash.encoding Ed25519.Public_key_hash.encoding
-        let key = Key.Vote.proposals
-      end)
 
   module Ballots =
-    Make_iterable_data_storage (Ed25519.Public_key_hash)
+    Make_indexed_data_storage
-      (struct
+      (Make_subcontext(Raw_context)(struct let name = ["ballots"] end))
-        type value = Vote_repr.ballot
+      (Ed25519.Public_key_hash)
-        let key = Key.Vote.ballots
+      (Make_value(struct
-        let name = "ballot"
+         type t = Vote_repr.ballot
-        let encoding = Vote_repr.ballot_encoding
+         let encoding = Vote_repr.ballot_encoding
-      end)
+       end))
 
 end
 
 (** Keys *)
 
 module Public_key =
-  Make_iterable_data_storage (Ed25519.Public_key_hash)
+  Make_indexed_data_storage
-    (struct
+    (Make_subcontext
-      type value = Ed25519.Public_key.t
+       (Raw_context)
-      let key = Key.public_keys
+       (struct let name = ["public_keys"; "ed25519"] end))
-      let name = "public keys"
+    (Ed25519.Public_key_hash)
-      let encoding = Ed25519.Public_key.encoding
+    (Make_value(Ed25519.Public_key))
-    end)
 
 (** Seed *)
 
 module Seed = struct
 
-  type nonce_status =
+  type nonce_status = Cycle.nonce_status =
     | Unrevealed of {
-        nonce_hash: Tezos_hash.Nonce_hash.t ;
+        nonce_hash: Nonce_hash.t ;
         delegate_to_reward: Ed25519.Public_key_hash.t ;
         reward_amount: Tez_repr.t ;
       }
     | Revealed of Seed_repr.nonce
 
-  module Nonce =
+  module Nonce = struct
-    Make_indexed_data_storage(struct
+    open Level_repr
-      type key = Level_repr.level
+    type context = Raw_context.t
-      type value = nonce_status
+    let mem ctxt l = Cycle.Nonce.mem (ctxt, l.cycle) l.level
-      let name = "unrevealed nonce hash"
+    let get ctxt l = Cycle.Nonce.get (ctxt, l.cycle) l.level
-      let key = Key.Cycle.unrevealed_nonce_hash
+    let get_option ctxt l = Cycle.Nonce.get_option (ctxt, l.cycle) l.level
-      let encoding =
+    let set ctxt l v = Cycle.Nonce.set (ctxt, l.cycle) l.level v
-        let open Data_encoding in
+    let init ctxt l v = Cycle.Nonce.init (ctxt, l.cycle) l.level v
-        union [
+    let init_set ctxt l v = Cycle.Nonce.init_set (ctxt, l.cycle) l.level v
-          case ~tag:0
+    let set_option ctxt l v = Cycle.Nonce.set_option (ctxt, l.cycle) l.level v
-            (tup3
+    let delete ctxt l = Cycle.Nonce.delete (ctxt, l.cycle) l.level
-               Nonce_hash.encoding
+    let remove ctxt l = Cycle.Nonce.remove (ctxt, l.cycle) l.level
-               Ed25519.Public_key_hash.encoding
+    (* We don't need the follwing iterators and I am kind of busy
-               Tez_repr.encoding
+       defining a signature "Non_iterable_indexed_data_storage" *)
-            )
+    let clear _ctxt = assert false
-            (function
+    let keys _ctxt = assert false
-              | Unrevealed { nonce_hash ; delegate_to_reward ; reward_amount } ->
+    let bindings _ctxt = assert false
-                  Some (nonce_hash, delegate_to_reward, reward_amount)
+    let fold _ctxt = assert false
-              | _ -> None)
+    let fold_keys _ctxt = assert false
-            (fun (nonce_hash, delegate_to_reward, reward_amount) ->
+  end
-               Unrevealed { nonce_hash ; delegate_to_reward ; reward_amount }) ;
+  module For_cycle = Cycle.Seed
-          case ~tag:1
-            Seed_repr.nonce_encoding
-            (function
-              | Revealed nonce -> Some nonce
-              | _ -> None)
-            (fun nonce -> Revealed nonce)
-        ]
-    end)
-
-  module For_cycle =
-    Make_indexed_data_storage(struct
-      type key = Cycle_repr.t
-      type value = Seed_repr.seed
-      let name = "cycle random seed"
-      let key = Key.Cycle.random_seed
-      let encoding = Seed_repr.seed_encoding
-    end)
 
 end
 
@@ -511,61 +347,36 @@ end
 module Rewards = struct
 
   module Next =
-    Make_single_data_storage(struct
+    Make_single_data_storage
-      type value = Cycle_repr.t
+      (Raw_context)
-      let name = "reward cycle"
+      (struct let name = ["next_cycle_to_be_rewarded"] end)
-      let key = Key.next_cycle_to_be_rewarded
+      (Make_value(Cycle_repr))
-      let encoding = Cycle_repr.encoding
-    end)
 
-  module Date =
+  module Date = Cycle.Reward_date
-    Make_indexed_data_storage(struct
+  module Amount = Cycle.Reward_amount
-      type key = Cycle_repr.t
-      type value = Time_repr.t
-      let name = "reward timestamp"
-      let key = Key.Cycle.reward_date
-      let encoding = Time_repr.encoding
-    end)
-
-  module Amount =
-    Raw_make_iterable_data_storage(struct
-      type t = Ed25519.Public_key_hash.t * Cycle_repr.t
-      let prefix = Key.rewards
-      let length = Ed25519.Public_key_hash.path_length + 1
-      let to_path (pkh, c) =
-        Ed25519.Public_key_hash.to_path pkh @
-        [Int32.to_string (Cycle_repr.to_int32 c)]
-      let of_path p =
-        match List.rev p with
-        | [] -> assert false
-        | cycle :: rev_pkh ->
-            (Ed25519.Public_key_hash.of_path_exn (List.rev rev_pkh),
-             Cycle_repr.of_int32_exn @@ Int32.of_string cycle)
-      let compare (pkh1, c1) (pkh2, c2) =
-        let cmp1 = Ed25519.Public_key_hash.compare pkh1 pkh2 in
-        if Compare.Int.(cmp1 = 0) then Cycle_repr.compare c1 c2
-        else cmp1
-    end)(struct
-      type value = Tez_repr.t
-      let name = "level baker contract"
-      let encoding = Tez_repr.encoding
-    end)
 
 end
 
-let activate ({ context = c } as s) h =
-  Updater.activate c h >>= fun c -> Lwt.return { s with context = c }
-let fork_test_network ({ context = c } as s) protocol expiration =
-  Updater.fork_test_network c ~protocol ~expiration >>= fun c ->
-  Lwt.return { s with context = c }
-
 (** Resolver *)
 
 let () =
-  Storage_functors.register_resolvers
+  Raw_context.register_resolvers
-    (module Contract_hash)
+    Contract_hash.b58check_encoding
-    [ Key.Contract.generic_contract [] ] ;
+    (fun ctxt p ->
-  Storage_functors.register_resolvers
+       let p = Contract_repr.Index.contract_prefix p in
-    (module Ed25519.Public_key_hash)
+       Contract.Indexed_context.resolve ctxt p >|= fun l ->
-    [ Key.Contract.pubkey_contract [] ;
+       List.map
-      Key.public_keys ]
+         (function
+           | Contract_repr.Default _ -> assert false
+           | Contract_repr.Originated s -> s)
+         l) ;
+  Raw_context.register_resolvers
+    Ed25519.Public_key_hash.b58check_encoding
+    (fun ctxt p ->
+       let p = Contract_repr.Index.pkh_prefix p in
+       Contract.Indexed_context.resolve ctxt p >|= fun l ->
+       List.map
+         (function
+           | Contract_repr.Default s -> s
+           | Contract_repr.Originated _ -> assert false)
+         l)

src/proto/alpha/storage.mli

@@ -7,7 +7,7 @@
 (*                                                                        *)
 (**************************************************************************)
 
-(** Tezos Protocol Implementation - Typed storage accessors
+(** Tezos Protocol Implementation - Typed storage
 
     This module hides the hierarchical (key x value) database under
     pre-allocated typed accessors for all persistent entities of the
@@ -18,42 +18,6 @@
     a complete view over the database contents and avoid key
     collisions. *)
 
-
-(** {1 Abstract Context} *****************************************************)
-
-(** Abstract view of the database *)
-type t
-
-(** Is first block validated with this version of the protocol ? *)
-val is_first_block: Context.t -> bool tzresult Lwt.t
-
-(** Retrieves the state of the database and gives its abstract view.
-    It also returns wether this is the first block validated
-    with this version of the protocol. *)
-val prepare :
-  level: Int32.t ->
-  timestamp: Time.t ->
-  fitness: Fitness.t ->
-  Context.t -> (t * bool) tzresult Lwt.t
-
-(** Returns the state of the database resulting of operations on its
-    abstract view *)
-val recover : t -> Context.t
-
-val get_sandboxed : Context.t -> Data_encoding.json option tzresult Lwt.t
-val set_sandboxed : Context.t -> Data_encoding.json -> Context.t Lwt.t
-
-val current_level : t -> Level_repr.t
-val current_timestamp : t -> Time.t
-
-val current_fitness : t -> Int64.t
-val set_current_fitness : t -> Int64.t -> t
-
-val constants : t -> Constants_repr.constants
-val first_level : t -> Raw_level_repr.t
-
-(** {1 Entity Accessors} *****************************************************)
-
 open Storage_sigs
 
 module Roll : sig
@@ -64,50 +28,50 @@ module Roll : sig
   module Owner : Indexed_data_storage
     with type key = Roll_repr.t
      and type value = Contract_repr.t
-     and type context := t
+     and type t := Raw_context.t
 
   (** The next roll to be allocated. *)
   module Next : Single_data_storage
     with type value = Roll_repr.t
-     and type context := t
+     and type t := Raw_context.t
 
   (** Rolls linked lists represent both account owned and free rolls.
       All rolls belongs either to the limbo list or to an owned list. *)
 
   (** Head of the linked list of rolls in limbo *)
-  module Limbo : Single_optional_data_storage
+  module Limbo : Single_data_storage
     with type value = Roll_repr.t
-     and type context := t
+     and type t := Raw_context.t
 
   (** Rolls associated to contracts, a linked list per contract *)
-  module Contract_roll_list : Indexed_optional_data_storage
+  module Contract_roll_list : Indexed_data_storage
     with type key = Contract_repr.t
      and type value = Roll_repr.t
-     and type context := t
+     and type t := Raw_context.t
 
   (** Use this to iter on a linked list of rolls *)
-  module Successor : Indexed_optional_data_storage
+  module Successor : Indexed_data_storage
     with type key = Roll_repr.t
      and type value = Roll_repr.t
-     and type context := t
+     and type t := Raw_context.t
 
   (** The tez of a contract that are not assigned to rolls *)
   module Contract_change : Indexed_data_storage
     with type key = Contract_repr.t
      and type value = Tez_repr.t
-     and type context := t
+     and type t := Raw_context.t
 
   (** Frozen rolls per cycle *)
 
   module Last_for_cycle : Indexed_data_storage
     with type key = Cycle_repr.t
      and type value = Roll_repr.t
-     and type context := t
+     and type t := Raw_context.t
 
   module Owner_for_cycle : Indexed_data_storage
-    with type key = Cycle_repr.t * Roll_repr.t
+    with type key = Roll_repr.t
      and type value = Ed25519.Public_key_hash.t
-     and type context := t
+     and type t = Raw_context.t * Cycle_repr.t
 
 end
 
@@ -117,68 +81,66 @@ module Contract : sig
       module `Contract`. *)
 
   module Global_counter : sig
-    val get : t -> int32 tzresult Lwt.t
+    val get : Raw_context.t -> int32 tzresult Lwt.t
-    val set : t -> int32 -> t tzresult Lwt.t
+    val set : Raw_context.t -> int32 -> Raw_context.t tzresult Lwt.t
-    val init : t -> int32 -> t tzresult Lwt.t
+    val init : Raw_context.t -> int32 -> Raw_context.t tzresult Lwt.t
   end
 
   (** The domain of alive contracts *)
-  module Set : Data_set_storage
+  val list : Raw_context.t -> Contract_repr.t list Lwt.t
-    with type value = Contract_repr.t
-     and type context := t
 
   (** All the tez possesed by a contract, including rolls and change *)
   module Balance : Indexed_data_storage
     with type key = Contract_repr.t
      and type value = Tez_repr.t
-     and type context := t
+     and type t := Raw_context.t
 
   (** The manager of a contract *)
   module Manager : Indexed_data_storage
     with type key = Contract_repr.t
      and type value = Manager_repr.t
-     and type context := t
+     and type t := Raw_context.t
 
   (** The delegate of a contract, if any. *)
   module Delegate : Indexed_data_storage
     with type key = Contract_repr.t
      and type value = Ed25519.Public_key_hash.t
-     and type context := t
+     and type t := Raw_context.t
 
   module Spendable : Indexed_data_storage
     with type key = Contract_repr.t
      and type value = bool
-     and type context := t
+     and type t := Raw_context.t
 
   module Delegatable : Indexed_data_storage
     with type key = Contract_repr.t
      and type value = bool
-     and type context := t
+     and type t := Raw_context.t
 
   module Counter : Indexed_data_storage
     with type key = Contract_repr.t
      and type value = int32
-     and type context := t
+     and type t := Raw_context.t
 
   module Code : Indexed_data_storage
     with type key = Contract_repr.t
      and type value = Script_repr.expr
-     and type context := t
+     and type t := Raw_context.t
 
   module Storage : Indexed_data_storage
     with type key = Contract_repr.t
      and type value = Script_repr.expr
-     and type context := t
+     and type t := Raw_context.t
 
   module Code_fees : Indexed_data_storage
     with type key = Contract_repr.t
      and type value = Tez_repr.t
-     and type context := t
+     and type t := Raw_context.t
 
   module Storage_fees : Indexed_data_storage
     with type key = Contract_repr.t
      and type value = Tez_repr.t
-     and type context := t
+     and type t := Raw_context.t
 
 end
 
@@ -188,43 +150,43 @@ module Vote : sig
 
   module Current_period_kind : Single_data_storage
     with type value = Voting_period_repr.kind
-     and type context := t
+     and type t := Raw_context.t
 
   module Current_quorum : Single_data_storage
     with type value = int32 (* in centile of percentage *)
-     and type context := t
+     and type t := Raw_context.t
 
   module Current_proposal : Single_data_storage
     with type value = Protocol_hash.t
-     and type context := t
+     and type t := Raw_context.t
 
   module Listings_size : Single_data_storage
     with type value = int32 (* total number of rolls in the listing. *)
-     and type context := t
+     and type t := Raw_context.t
 
-  module Listings : Iterable_data_storage
+  module Listings : Indexed_data_storage
     with type key = Ed25519.Public_key_hash.t
      and type value = int32 (* number of rolls for the key. *)
-     and type context := t
+     and type t := Raw_context.t
 
   module Proposals : Data_set_storage
-    with type value = Protocol_hash.t * Ed25519.Public_key_hash.t
+    with type elt = Protocol_hash.t * Ed25519.Public_key_hash.t
-     and type context := t
+     and type t := Raw_context.t
 
-  module Ballots : Iterable_data_storage
+  module Ballots : Indexed_data_storage
     with type key = Ed25519.Public_key_hash.t
      and type value = Vote_repr.ballot
-     and type context := t
+     and type t := Raw_context.t
 
 end
 
 
 (** Keys *)
 
-module Public_key : Iterable_data_storage
+module Public_key : Indexed_data_storage
   with type key = Ed25519.Public_key_hash.t
    and type value = Ed25519.Public_key.t
-   and type context := t
+   and type t := Raw_context.t
 
 (** Seed *)
 
@@ -242,14 +204,14 @@ module Seed : sig
     | Revealed of Seed_repr.nonce
 
   module Nonce : Indexed_data_storage
-    with type key = Level_repr.t
+    with type key := Level_repr.t
-     and type value = nonce_status
+     and type value := nonce_status
-     and type context := t
+     and type t := Raw_context.t
 
   module For_cycle : sig
-    val init : t -> Cycle_repr.t -> Seed_repr.seed -> t tzresult Lwt.t
+    val init : Raw_context.t -> Cycle_repr.t -> Seed_repr.seed -> Raw_context.t tzresult Lwt.t
-    val get : t -> Cycle_repr.t -> Seed_repr.seed tzresult Lwt.t
+    val get : Raw_context.t -> Cycle_repr.t -> Seed_repr.seed tzresult Lwt.t
-    val delete : t -> Cycle_repr.t -> t tzresult Lwt.t
+    val delete : Raw_context.t -> Cycle_repr.t -> Raw_context.t tzresult Lwt.t
   end
 
 end
@@ -260,19 +222,16 @@ module Rewards : sig
 
   module Next : Single_data_storage
     with type value = Cycle_repr.t
-     and type context := t
+     and type t := Raw_context.t
 
   module Date : Indexed_data_storage
     with type key = Cycle_repr.t
      and type value = Time.t
-     and type context := t
+     and type t := Raw_context.t
 
-  module Amount : Iterable_data_storage
+  module Amount : Indexed_data_storage
-    with type key = Ed25519.Public_key_hash.t * Cycle_repr.t
+    with type key = Ed25519.Public_key_hash.t
      and type value = Tez_repr.t
-     and type context := t
+     and type t = Raw_context.t * Cycle_repr.t
 
 end
-
-val activate: t -> Protocol_hash.t -> t Lwt.t
-val fork_test_network: t -> Protocol_hash.t -> Time.t -> t Lwt.t

src/proto/alpha/storage_functors.ml

@@ -7,399 +7,441 @@
 (*                                                                        *)
 (**************************************************************************)
 
-(* Tezos Protocol Implementation - Typed storage accessor builders *)
+open Storage_sigs
 
-open Misc
+module type ENCODED_VALUE = sig
-
+  type t
-type context = {
+  val encoding: t Data_encoding.t
-  context: Context.t ;
-  constants: Constants_repr.constants ;
-  first_level: Raw_level_repr.t ;
-  level: Level_repr.t ;
-  timestamp: Time.t ;
-  fitness: Int64.t ;
-}
-
-(*-- Errors ------------------------------------------------------------------*)
-
-type error += Storage_error of string
-
-let () =
-  let open Data_encoding in
-  register_error_kind `Permanent
-    ~id:"storageError"
-    ~title: "Storage error (fatal internal error)"
-    ~description:
-      "An error that should never happen unless something \
-       has been deleted or corrupted in the database"
-    ~pp:(fun ppf msg ->
-        Format.fprintf ppf "@[<v 2>Storage error:@ %a@]"
-          pp_print_paragraph msg)
-    (obj1 (req "msg" string))
-    (function Storage_error msg -> Some msg | _ -> None)
-    (fun msg -> Storage_error msg)
-
-(*-- Generic data accessor ---------------------------------------------------*)
-
-module type Raw_data_description = sig
-  type key
-  type value
-  val name : string
-  val key : key -> string list
-  val of_bytes : MBytes.t -> value tzresult
-  val to_bytes : value -> MBytes.t
 end
 
-module Make_raw_data_storage (P : Raw_data_description) = struct
+module Make_value (V : ENCODED_VALUE) = struct
-
+  type t = V.t
-  type key = P.key
+  let of_bytes b =
-  type value = P.value
+    match Data_encoding.Binary.of_bytes V.encoding b with
-
+    | None -> Error [Raw_context.Storage_error (Corrupted_data [(* FIXME??*)])]
-  let key k = P.key k
-
-  let key_to_string l = String.concat "/" (key l)
-
-  let get { context = c } k =
-    Context.get c (key k) >>= function
-    | None ->
-        let msg =
-          "cannot get undefined " ^ P.name ^ " key " ^ key_to_string k in
-        fail (Storage_error msg)
-    | Some bytes ->
-        Lwt.return (P.of_bytes bytes)
-
-  let mem { context = c } k = Context.mem c (key k)
-
-  let get_option { context = c } k =
-    Context.get c (key k) >>= function
-    | None -> return None
-    | Some bytes ->
-        Lwt.return (P.of_bytes bytes >|? fun v -> Some v)
-
-  (* Verify that the key is present before modifying *)
-  let set ({ context = c } as s) k v =
-    let key = key k in
-    Context.get c key >>= function
-    | None ->
-        let msg =
-          "cannot set undefined " ^ P.name ^ " key " ^ key_to_string k in
-        fail (Storage_error msg)
-    | Some old ->
-        let bytes = P.to_bytes v in
-        if MBytes.(old = bytes) then
-          return { s with context = c }
-        else
-          Context.set c key (P.to_bytes v) >>= fun c ->
-          return { s with context = c }
-
-  (* Verify that the key is not present before inserting *)
-  let init ({ context = c } as s) k v =
-    let key = key k in
-    Context.get c key >>=
-    function
-    | Some _ ->
-        let msg
-          = "cannot init existing " ^ P.name ^ " key " ^ key_to_string k in
-        fail (Storage_error msg)
-    | None ->
-        Context.set c key (P.to_bytes v) >>= fun c ->
-        return { s with context = c }
-
-  (* Does not verify that the key is present or not *)
-  let init_set ({ context = c } as s) k v =
-    Context.set c (key k) (P.to_bytes v) >>= fun c ->
-    return { s with context = c }
-
-  (* Verify that the key is present before deleting *)
-  let delete ({ context = c } as s) k =
-    let key = key k in
-    Context.get c key >>= function
-    | Some _ ->
-        Context.del c key >>= fun c ->
-        return { s with context = c }
-    | None ->
-        let msg =
-          "cannot delete undefined " ^ P.name ^ " key " ^ key_to_string k in
-        fail (Storage_error msg)
-
-  (* Do not verify before deleting *)
-  let remove ({ context = c } as s) k =
-    Context.del c (key k) >>= fun c ->
-    Lwt.return { s with context = c }
-
-end
-
-(*-- Indexed data accessor ---------------------------------------------------*)
-
-module type Data_description = sig
-  type value
-  val name : string
-  val encoding : value Data_encoding.t
-end
-
-module type Indexed_data_description = sig
-  type key
-  val key : key -> string list
-  include Data_description
-end
-
-module Make_indexed_data_storage (P : Indexed_data_description) =
-  Make_raw_data_storage(struct
-    include P
-
-    let of_bytes b =
-      match Data_encoding.Binary.of_bytes P.encoding b with
-      | None ->
-          let msg =
-            "cannot deserialize " ^ P.name ^ " value" in
-          error (Storage_error msg)
-      | Some v -> Ok v
-    let to_bytes v = Data_encoding.Binary.to_bytes P.encoding v
-  end)
-
-module Make_indexed_optional_data_storage (P : Indexed_data_description) = struct
-  module Raw = Make_indexed_data_storage(P)
-  type key = P.key
-  type value = P.value
-  let get = Raw.get_option
-  let mem = Raw.mem
-  let set c k r =
-    match r with
-    | None -> Raw.remove c k >>= fun c -> return c
-    | Some r -> Raw.init_set c k r
-end
-
-(*-- Single data accessor ----------------------------------------------------*)
-
-module type Single_data_description = sig
-  val key : string list
-  include Data_description
-end
-
-module Make_single_data_storage (P : Single_data_description) = struct
-  module Single_desc = struct
-    type value = P.value
-    type key = unit
-    let encoding = P.encoding
-    let name = P.name
-    let key () = P.key
-  end
-  include Make_indexed_data_storage(Single_desc)
-  let get c = get c ()
-  let mem c = mem c ()
-  let get_option c = get_option c ()
-  let set c r = set c () r
-  let init c r = init c () r
-  let init_set c r = init_set c () r
-  let remove c = remove c ()
-  let delete c = delete c ()
-end
-
-module Make_single_optional_data_storage (P : Single_data_description) = struct
-  module Raw = Make_single_data_storage (P)
-  type value = P.value
-  let get = Raw.get_option
-  let mem = Raw.mem
-  let set c r =
-    match r with
-    | None -> Raw.remove c >>= fun c -> return c
-    | Some r -> Raw.init_set c r
-end
-
-(*-- Data set (set of homogeneous data under a key prefix) -------------------*)
-
-module Make_data_set_storage (P : Single_data_description) = struct
-
-  module Key = struct
-    include Hash.Make_minimal_Blake2B(struct
-        let name = P.name
-        let title = ("A " ^ P.name ^ "key")
-        let size = None
-      end)
-    let of_path = of_path_exn
-    let prefix = P.key
-    let length = path_length
-  end
-
-  module HashTbl =
-    Persist.MakePersistentMap(Context)(Key)(Persist.RawValue)
-
-  type value = P.value
-
-  let serial v =
-    let data = Data_encoding.Binary.to_bytes P.encoding v in
-    Key.hash_bytes [data], data
-
-  let unserial b =
-    match Data_encoding.Binary.of_bytes P.encoding b with
-    | None ->
-        let msg =
-          "cannot deserialize " ^ P.name ^ " value" in
-        error (Storage_error msg)
     | Some v -> Ok v
-
+  let to_bytes v =
-  let add ({ context = c } as s) v =
+    try Data_encoding.Binary.to_bytes V.encoding v
-    let hash, data = serial v in
+    with _ -> MBytes.create 0
-    HashTbl.mem c hash >>= function
-    | true ->
-        return { s with context = c }
-    | false ->
-        HashTbl.set c hash data >>= fun c ->
-        return { s with context = c }
-
-  let del ({ context = c } as s) v =
-    let hash, _ = serial v in
-    HashTbl.mem c hash >>= function
-    | false ->
-        return { s with context = c }
-    | true ->
-        HashTbl.del c hash >>= fun c ->
-        return { s with context = c }
-
-  let mem { context = c } v =
-    let hash, _ = serial v in
-    HashTbl.mem c hash >>= fun v ->
-    return v
-
-  let elements { context = c } =
-    HashTbl.bindings c >>= fun elts ->
-    map_s (fun (_, data) -> Lwt.return (unserial data)) elts
-
-  let fold { context = c } init ~f =
-    HashTbl.fold c ~init:(ok init)
-      ~f:(fun _ data acc ->
-          match acc with
-          | Error _ -> Lwt.return acc
-          | Ok acc ->
-              match unserial data with
-              | Error _ as err -> Lwt.return err
-              | Ok data ->
-                  f data acc >>= fun acc ->
-                  return acc)
-
-  let clear ({ context = c } as s) =
-    HashTbl.fold c ~init:c ~f:(fun hash _ c -> HashTbl.del c hash) >>= fun c ->
-    return { s with context = c }
-
 end
 
-module Raw_make_iterable_data_storage
+module Raw_value = struct
-    (K: Persist.KEY)
+  type t = MBytes.t
-    (P: Data_description) = struct
+  let of_bytes b = ok b
+  let to_bytes b = b
+end
 
-  type key = K.t
+let map_key f = function
-  type value = P.value
+  | `Key k -> `Key (f k)
+  | `Dir k -> `Dir (f k)
 
-  module HashTbl =
+let map_option f = function
-    Persist.MakePersistentMap(Context)(K)(struct
+  | None -> None
-      type t = P.value
+  | Some x -> Some (f x)
-      let of_bytes b = Data_encoding.Binary.of_bytes P.encoding b
-      let to_bytes v = Data_encoding.Binary.to_bytes P.encoding v
-    end)
 
-  let key_to_string k = String.concat "/" (K.to_path k)
+module Make_subcontext (C : Raw_context.T) (N : NAME)
+  : Raw_context.T with type t = C.t = struct
+  type t = C.t
+  type context = t
+  let name_length = List.length N.name
+  let to_key k = N.name @ k
+  let of_key k = Misc.remove_elem_from_list name_length k
+  let mem t k = C.mem t (to_key k)
+  let dir_mem t k = C.dir_mem t (to_key k)
+  let get t k = C.get t (to_key k)
+  let get_option t k = C.get_option t (to_key k)
+  let init t k v = C.init t (to_key k) v
+  let set t k v = C.set t (to_key k) v
+  let init_set t k v = C.init_set t (to_key k) v
+  let set_option t k v = C.set_option t (to_key k) v
+  let delete t k = C.delete t (to_key k)
+  let remove t k = C.remove t (to_key k)
+  let remove_rec t k = C.remove_rec t (to_key k)
+  let fold t k ~init ~f =
+    C.fold t (to_key k) ~init
+      ~f:(fun k acc -> f (map_key of_key k) acc)
+  let keys t k = C.keys t (to_key k) >|= fun keys -> List.map of_key keys
+  let fold_keys t k ~init ~f =
+    C.fold_keys t (to_key k) ~init ~f:(fun k acc -> f (of_key k) acc)
+  let project = C.project
+end
 
-  let get { context = c } k =
+module Make_single_data_storage (C : Raw_context.T) (N : NAME) (V : VALUE)
-    HashTbl.get c k >>= function
+  : Single_data_storage with type t = C.t
-    | None ->
+                         and type value = V.t = struct
-        let msg =
+  type t = C.t
-          "cannot get undefined " ^ P.name ^ " key " ^ key_to_string k in
+  type context = t
-        fail (Storage_error msg)
+  type value = V.t
-    | Some v ->
+  let mem t =
-        return v
+    C.mem t N.name
-
+  let get t =
-  let mem { context = c } k = HashTbl.mem c k
+    C.get t N.name >>=? fun b ->
-
+    Lwt.return (V.of_bytes b)
-  let get_option { context = c } k =
+  let get_option t =
-    HashTbl.get c k >>= function
+    C.get_option t N.name >>= function
     | None -> return None
-    | Some v -> return (Some v)
+    | Some b ->
+        match V.of_bytes b with
+        | Ok v -> return (Some v)
+        | Error _ as err -> Lwt.return err
+  let init t v =
+    C.init t N.name (V.to_bytes v) >>=? fun t ->
+    return (C.project t)
+  let set t v =
+    C.set t N.name (V.to_bytes v) >>=? fun t ->
+    return (C.project t)
+  let init_set t v =
+    C.init_set t N.name (V.to_bytes v) >>= fun t ->
+    Lwt.return (C.project t)
+  let set_option t v =
+    C.set_option t N.name (map_option V.to_bytes v) >>= fun t ->
+    Lwt.return (C.project t)
+  let remove t =
+    C.remove t N.name >>= fun t ->
+    Lwt.return (C.project t)
+  let delete t =
+    C.delete t N.name >>=? fun t ->
+    return (C.project t)
+end
 
-  (* Verify that the key is present before modifying *)
+module type INDEX = sig
-  let set ({ context = c } as s) k v =
+  type t
-    HashTbl.get c k >>= function
+  val path_length: int
-    | None ->
+  val to_path: t -> string list -> string list
-        let msg =
+  val of_path: string list -> t option
-          "cannot set undefined " ^ P.name ^ " key " ^ key_to_string k in
+end
-        fail (Storage_error msg)
-    | Some _ ->
-        HashTbl.set c k v >>= fun c ->
-        return { s with context = c }
 
-  (* Verify that the key is not present before inserting *)
+module Pair(I1 : INDEX)(I2 : INDEX)
-  let init ({ context = c } as s) k v =
+  : INDEX with type t = I1.t * I2.t = struct
-    HashTbl.get c k >>=
+  type t = I1.t * I2.t
-    function
+  let path_length = I1.path_length + I2.path_length
-    | Some _ ->
+  let to_path (x, y) l = I1.to_path x (I2.to_path y l)
-        let msg
+  let of_path l =
-          = "cannot init existing " ^ P.name ^ " key " ^ key_to_string k in
+    match Misc.take I1.path_length l with
-        fail (Storage_error msg)
+    | None -> None
-    | None ->
+    | Some (l1, l2) ->
-        HashTbl.set c k v >>= fun c ->
+        match I1.of_path l1, I2.of_path l2 with
-        return { s with context = c }
+        | Some x, Some y -> Some (x, y)
+        | _ -> None
+end
 
-  (* Does not verify that the key is present or not *)
+module Make_data_set_storage (C : Raw_context.T) (I : INDEX)
-  let init_set ({ context = c } as s) k v =
+  : Data_set_storage with type t = C.t and type elt = I.t = struct
-    HashTbl.set c k v >>= fun c ->
-    return { s with context = c }
 
-  (* Verify that the key is present before deleting *)
+  type t = C.t
-  let delete ({ context = c } as s) k =
+  type context = t
-    HashTbl.get c k >>= function
+  type elt = I.t
-    | Some _ ->
-        HashTbl.del c k >>= fun c ->
-        return { s with context = c }
-    | None ->
-        let msg =
-          "cannot delete undefined " ^ P.name ^ " key " ^ key_to_string k in
-        fail (Storage_error msg)
 
-  (* Do not verify before deleting *)
+  let inited = MBytes.of_string "inited"
-  let remove ({ context = c } as s) k =
-    HashTbl.del c k >>= fun c ->
-    Lwt.return { s with context = c }
 
-  let clear ({ context = c } as s) =
+  let mem s i =
-    HashTbl.clear c >>= fun c ->
+    C.mem s (I.to_path i [])
-    Lwt.return { s with context = c }
+  let add s i =
+    C.init_set s (I.to_path i []) inited >>= fun t ->
+    Lwt.return (C.project t)
+  let del s i =
+    C.remove s (I.to_path i []) >>= fun t ->
+    Lwt.return (C.project t)
+  let clear s =
+    C.remove_rec s [] >>= fun t ->
+    Lwt.return (C.project t)
 
-  let fold { context = c } x ~f = HashTbl.fold c ~init:x ~f:(fun k v acc -> f k v acc)
+  let fold s ~init ~f =
-  let iter { context = c } ~f = HashTbl.fold c ~init:() ~f:(fun k v () -> f k v)
+    let rec dig i path acc =
+      if Compare.Int.(i <= 1) then
+        C.fold s path ~init:acc ~f:begin fun k acc ->
+          match k with
+          | `Dir _ -> Lwt.return acc
+          | `Key file ->
+              match I.of_path file with
+              | None -> assert false
+              | Some p -> f p acc
+        end
+      else
+        C.fold s path ~init:acc ~f:begin fun k acc ->
+          match k with
+          | `Dir k ->
+              dig (i-1) k acc
+          | `Key _ ->
+              Lwt.return acc
+        end in
+    dig I.path_length [] init
+
+  let elements s =
+    fold s ~init:[] ~f:(fun p acc -> Lwt.return (p :: acc))
 
 end
 
-module Make_iterable_data_storage (H: HASH) (P: Single_data_description) =
+module Make_indexed_data_storage
-  Raw_make_iterable_data_storage(struct
+    (C : Raw_context.T) (I : INDEX) (V : VALUE)
-    include H
+  : Indexed_data_storage with type t = C.t
-    let of_path = H.of_path_exn
+                          and type key = I.t
-    let prefix = P.key
+                          and type value = V.t = struct
-    let length = path_length
+  type t = C.t
-  end)(P)
+  type context = t
+  type key = I.t
+  type value = V.t
+  let mem s i =
+    C.mem s (I.to_path i [])
+  let get s i =
+    C.get s (I.to_path i []) >>=? fun b ->
+    Lwt.return (V.of_bytes b)
+  let get_option s i =
+    C.get_option s (I.to_path i []) >>= function
+    | None -> return None
+    | Some b ->
+        match V.of_bytes b with
+        | Ok v -> return (Some v)
+        | Error _ as err -> Lwt.return err
+  let set s i v =
+    C.set s (I.to_path i []) (V.to_bytes v) >>=? fun t ->
+    return (C.project t)
+  let init s i v =
+    C.init s (I.to_path i []) (V.to_bytes v) >>=? fun t ->
+    return (C.project t)
+  let init_set s i v =
+    C.init_set s (I.to_path i []) (V.to_bytes v) >>= fun t ->
+    Lwt.return (C.project t)
+  let set_option s i v =
+    C.set_option s (I.to_path i []) (map_option V.to_bytes v) >>= fun t ->
+    Lwt.return (C.project t)
+  let remove s i =
+    C.remove s (I.to_path i []) >>= fun t ->
+    Lwt.return (C.project t)
+  let delete s i =
+    C.delete s (I.to_path i []) >>=? fun t ->
+    return (C.project t)
+  let clear s =
+    C.remove_rec s [] >>= fun t ->
+    Lwt.return (C.project t)
+  let fold s ~init ~f =
+    let rec dig i path acc =
+      if Compare.Int.(i <= 1) then
+        C.fold s path ~init:acc ~f:begin fun k acc ->
+          match k with
+          | `Dir _ -> Lwt.return acc
+          | `Key file ->
+              C.get_option s file >>= function
+              | None -> Lwt.return acc
+              | Some b ->
+                  match V.of_bytes b with
+                  | Error _ ->
+                      (* Silently ignore unparsable data *)
+                      Lwt.return acc
+                  | Ok v ->
+                      match I.of_path file with
+                      | None -> assert false
+                      | Some path -> f path v acc
+        end
+      else
+        C.fold s path ~init:acc ~f:begin fun k acc ->
+          match k with
+          | `Dir k -> dig (i-1) k acc
+          | `Key _ -> Lwt.return acc
+        end in
+    dig I.path_length [] init
 
-let register_resolvers (module H : Hash.HASH) prefixes =
+  let bindings s =
+    fold s ~init:[] ~f:(fun p v acc -> Lwt.return ((p,v) :: acc))
+  let fold_keys s ~init ~f =
+    C.fold s [] ~init
+      ~f:(fun p acc ->
+          match p with
+          | `Dir _ -> Lwt.return acc
+          | `Key p ->
+              match I.of_path p with
+              | None -> assert false
+              | Some path -> f path acc)
+  let keys s =
+    fold_keys s ~init:[] ~f:(fun p acc -> Lwt.return (p :: acc))
 
-  let module Set = H.Set in
+end
 
-  let resolvers =
+module Make_indexed_subcontext (C : Raw_context.T) (I : INDEX)
-    List.map
+  : Indexed_raw_context with type t = C.t
-      (fun prefix ->
+                         and type key = I.t = struct
-         let module R = Persist.MakeHashResolver(struct
-             include Context
-             let prefix = prefix
-           end)(H) in
-         R.resolve)
-      prefixes in
 
-  let resolve c m =
+  type t = C.t
-    match resolvers with
+  type context = t
-    | [resolve] -> resolve c m
+  type key = I.t
-    | resolvers ->
-        Lwt_list.map_p (fun resolve -> resolve c m) resolvers >|= fun hs ->
-        List.fold_left
-          (fun acc hs -> List.fold_left (fun acc h -> Set.add h acc) acc hs)
-          Set.empty hs |>
-        Set.elements in
 
-  Context.register_resolver H.b58check_encoding resolve
+  module Raw_context = struct
+    type t = C.t * I.t
+    type context = t
+    let to_key i k = I.to_path i k
+    let of_key k = Misc.remove_elem_from_list I.path_length k
+    let mem (t, i) k = C.mem t (to_key i k)
+    let dir_mem (t, i) k = C.dir_mem t (to_key i k)
+    let get (t, i) k = C.get t (to_key i k)
+    let get_option (t, i) k = C.get_option t (to_key i k)
+    let init (t, i) k v =
+      C.init t (to_key i k) v >>=? fun t -> return (t, i)
+    let set (t, i) k v =
+      C.set t (to_key i k) v >>=? fun t -> return (t, i)
+    let init_set (t, i) k v =
+      C.init_set t (to_key i k) v >>= fun t -> Lwt.return (t, i)
+    let set_option (t, i) k v =
+      C.set_option t (to_key i k) v >>= fun t -> Lwt.return (t, i)
+    let delete (t, i) k =
+      C.delete t (to_key i k) >>=? fun t -> return (t, i)
+    let remove (t, i) k =
+      C.remove t (to_key i k) >>= fun t -> Lwt.return (t, i)
+    let remove_rec (t, i) k =
+      C.remove_rec t (to_key i k) >>= fun t -> Lwt.return (t, i)
+    let fold (t, i) k ~init ~f =
+      C.fold t (to_key i k) ~init
+        ~f:(fun k acc -> f (map_key of_key k) acc)
+    let keys (t, i) k = C.keys t (to_key i k) >|= fun keys -> List.map of_key keys
+    let fold_keys (t, i) k ~init ~f =
+      C.fold_keys t (to_key i k) ~init ~f:(fun k acc -> f (of_key k) acc)
+    let project (t, _) = C.project t
+  end
 
+  let clear t i =
+    Raw_context.remove_rec (t, i) [] >>= fun (t, _) ->
+    Lwt.return (C.project t)
 
+  let fold_keys t ~init ~f =
+    let rec dig i path acc =
+      if Compare.Int.(i <= 0) then
+        match I.of_path path with
+        | None -> assert false
+        | Some path -> f path acc
+      else
+        C.fold t path ~init:acc ~f:begin fun k acc ->
+          match k with
+          | `Dir k -> dig (i-1) k acc
+          | `Key _ -> Lwt.return acc
+        end in
+    dig I.path_length [] init
+
+  let keys t =
+    fold_keys t ~init:[] ~f:(fun i acc -> Lwt.return (i :: acc))
+
+  let list t k = C.fold t k ~init:[] ~f:(fun k acc -> Lwt.return (k :: acc))
+  let resolve t prefix =
+    let rec loop i prefix = function
+      | [] when Compare.Int.(i = I.path_length) -> begin
+          match I.of_path prefix with
+          | None -> assert false
+          | Some path -> Lwt.return [path]
+        end
+      | [] ->
+          list t prefix >>= fun prefixes ->
+          Lwt_list.map_p (function
+              | `Key prefix | `Dir prefix -> loop (i+1) prefix []) prefixes
+          >|= List.flatten
+      | [d] when Compare.Int.(i = I.path_length - 1) ->
+          if Compare.Int.(i >= I.path_length) then invalid_arg "IO.resolve" ;
+          list t prefix >>= fun prefixes ->
+          Lwt_list.map_p (function
+              | `Key prefix | `Dir prefix ->
+                  match Misc.remove_prefix ~prefix:d (List.hd (List.rev prefix)) with
+                  | None -> Lwt.return_nil
+                  | Some _ -> loop (i+1) prefix [])
+            prefixes
+          >|= List.flatten
+      | "" :: ds ->
+          list t prefix >>= fun prefixes ->
+          Lwt_list.map_p (function
+              | `Key prefix | `Dir prefix -> loop (i+1) prefix ds) prefixes
+          >|= List.flatten
+      | d :: ds ->
+          if Compare.Int.(i >= I.path_length) then invalid_arg "IO.resolve" ;
+          C.dir_mem t (prefix @ [d]) >>= function
+          | true -> loop (i+1) (prefix @ [d]) ds
+          | false -> Lwt.return_nil in
+    loop 0 [] prefix
+
+  module Make_set (N : NAME) = struct
+    type t = C.t
+    type context = t
+    type elt = I.t
+    let inited = MBytes.of_string "inited"
+    let mem s i = Raw_context.mem (s, i) N.name
+    let add s i =
+      Raw_context.init_set (s, i) N.name inited >>= fun (s, _) ->
+      Lwt.return (C.project s)
+    let del s i =
+      Raw_context.remove (s, i) N.name >>= fun (s, _) ->
+      Lwt.return (C.project s)
+    let clear s =
+      fold_keys s
+        ~init:s
+        ~f:begin fun i s ->
+          Raw_context.remove (s, i) N.name >>= fun (s, _) ->
+          Lwt.return s
+        end >>= fun t ->
+      Lwt.return (C.project t)
+    let fold s ~init ~f =
+      fold_keys s ~init
+        ~f:(fun i acc ->
+            mem s i >>= function
+            | true -> f i acc
+            | false -> Lwt.return acc)
+    let elements s =
+      fold s ~init:[] ~f:(fun p acc -> Lwt.return (p :: acc))
+  end
+
+  module Make_map (N : NAME) (V : VALUE) = struct
+    type t = C.t
+    type context = t
+    type key = I.t
+    type value = V.t
+    let mem s i =
+      Raw_context.mem (s,i) N.name
+    let get s i =
+      Raw_context.get (s,i) N.name >>=? fun b ->
+      Lwt.return (V.of_bytes b)
+    let get_option s i =
+      Raw_context.get_option (s,i) N.name >>= function
+      | None -> return None
+      | Some b ->
+          match V.of_bytes b with
+          | Ok v -> return (Some v)
+          | Error _ as err -> Lwt.return err
+    let set s i v =
+      Raw_context.set (s,i) N.name (V.to_bytes v) >>=? fun (s, _) ->
+      return (C.project s)
+    let init s i v =
+      Raw_context.init (s,i) N.name (V.to_bytes v) >>=? fun (s, _) ->
+      return (C.project s)
+    let init_set s i v =
+      Raw_context.init_set (s,i) N.name (V.to_bytes v) >>= fun (s, _) ->
+      Lwt.return (C.project s)
+    let set_option s i v =
+      Raw_context.set_option (s,i)
+        N.name (map_option V.to_bytes v) >>= fun (s, _) ->
+      Lwt.return (C.project s)
+    let remove s i =
+      Raw_context.remove (s,i) N.name >>= fun (s, _) ->
+      Lwt.return (C.project s)
+    let delete s i =
+      Raw_context.delete (s,i) N.name >>=? fun (s, _) ->
+      return (C.project s)
+    let clear s =
+      fold_keys s ~init:s
+        ~f:begin fun i s ->
+          Raw_context.remove (s,i) N.name >>= fun (s, _) ->
+          Lwt.return s
+        end >>= fun t ->
+      Lwt.return (C.project t)
+    let fold s ~init ~f =
+      fold_keys s ~init
+        ~f:(fun i acc ->
+            get s i >>= function
+            | Error _ -> Lwt.return acc
+            | Ok v -> f i v acc)
+    let bindings s =
+      fold s ~init:[] ~f:(fun p v acc -> Lwt.return ((p,v) :: acc))
+    let fold_keys s ~init ~f =
+      fold_keys s ~init
+        ~f:(fun i acc ->
+            mem s i >>= function
+            | false -> Lwt.return acc
+            | true -> f i acc)
+    let keys s =
+      fold_keys s ~init:[] ~f:(fun p acc -> Lwt.return (p :: acc))
+  end
+
+end

src/proto/alpha/storage_functors.mli

@@ -7,103 +7,43 @@
 (*                                                                        *)
 (**************************************************************************)
 
-(** Tezos Protocol Implementation - Typed storage accessor builders
+(** Tezos Protocol Implementation - Typed storage builders. *)
-
-    This module hides the hierarchical (key x value) database under
-    three kinds of typed data accessors (single typed data, homgeneous
-    indexed data and homgeneous data set). *)
-
-
-type context = {
-  context: Context.t ;
-  constants: Constants_repr.constants ;
-  first_level: Raw_level_repr.t ;
-  level: Level_repr.t ;
-  timestamp: Time.t ;
-  fitness: Int64.t ;
-}
 
 open Storage_sigs
 
-(** {1 Errors} ****************************************************************)
+module type ENCODED_VALUE = sig
-
+  type t
-(** An internal storage error that should not happen *)
+  val encoding: t Data_encoding.t
-type error += Storage_error of string
-
-(** {1 Data Accessor Parameters} *********************************************)
-
-(** Description of a single data typed accessor. *)
-module type Data_description = sig
-  (** The OCaml type of value contents *)
-  type value
-
-  (** A name (only used for error messages) *)
-  val name : string
-
-  (** The serialization format *)
-  val encoding : value Data_encoding.t
 end
 
-module type Single_data_description = sig
+module Make_value (V : ENCODED_VALUE) : VALUE with type t = V.t
 
-  (** The concrete key in the hierarchical database *)
+module Raw_value : VALUE with type t = MBytes.t
-  val key : string list
 
-  include Data_description
+module Make_subcontext (C : Raw_context.T) (N : NAME)
+  : Raw_context.T with type t = C.t
 
+module Make_single_data_storage (C : Raw_context.T) (N : NAME) (V : VALUE)
+  : Single_data_storage with type t = C.t
+                         and type value = V.t
+
+module type INDEX = sig
+  type t
+  val path_length: int
+  val to_path: t -> string list -> string list
+  val of_path: string list -> t option
 end
 
-(** Describes how to map abstract OCaml types for some (key x value)
+module Pair(I1 : INDEX)(I2 : INDEX) : INDEX with type t = I1.t * I2.t
-    pair to the concrete path in the hierarchical database structure
-    and the serialization format. *)
-module type Indexed_data_description = sig
 
-  (** The OCaml type for keys *)
+module Make_data_set_storage (C : Raw_context.T) (I : INDEX)
-  type key
+  : Data_set_storage with type t = C.t and type elt = I.t
 
-  (** How to produce a concrete key from an abstract one  *)
+module Make_indexed_data_storage (C : Raw_context.T) (I : INDEX) (V : VALUE)
-  val key : key -> string list
+  : Indexed_data_storage with type t = C.t
-
+                          and type key = I.t
-  include Data_description
+                          and type value = V.t
-
-end
-
-(** {1 Data Accessor Builders} ***********************************************)
-
-(** Single data typed accessor builder *)
-module Make_single_data_storage (P : Single_data_description) :
-  Single_data_storage with type value = P.value
-                       and type context := context
-
-module Make_single_optional_data_storage (P : Single_data_description) :
-  Single_optional_data_storage with type value = P.value
-                                and type context := context
-
-(** Indexed data accessor builder *)
-module Make_indexed_data_storage (P : Indexed_data_description) :
-  Indexed_data_storage with type key = P. key
-                        and type value = P.value
-                        and type context := context
-
-module Make_indexed_optional_data_storage (P : Indexed_data_description) :
-  Indexed_optional_data_storage with type key = P. key
-                                 and type value = P.value
-                                 and type context := context
-
-(** Data set builder (set of homogeneous data under a key prefix) *)
-module Make_data_set_storage (P : Single_data_description) :
-  Data_set_storage with type value = P.value
-                    and type context := context
-
-module Make_iterable_data_storage (H : HASH) (P: Single_data_description) :
-  Iterable_data_storage with type key = H.t
-                         and type value = P.value
-                         and type context := context
-
-module Raw_make_iterable_data_storage (K: Persist.KEY) (P: Data_description) :
-  Iterable_data_storage with type key = K.t
-                         and type value = P.value
-                         and type context := context
-
-val register_resolvers: (module Hash.HASH) -> string list list -> unit
 
+module Make_indexed_subcontext (C : Raw_context.T) (I : INDEX)
+  : Indexed_raw_context with type t = C.t
+                         and type key = I.t

src/proto/alpha/storage_sigs.ml

@@ -9,66 +9,56 @@
 
 (** {1 Entity Accessor Signatures} ****************************************)
 
-module type Single_optional_data_storage = sig
-  type context
-  type value
-  val get : context -> value option tzresult Lwt.t
-  val mem : context -> bool Lwt.t
-  val set : context -> value option -> context tzresult Lwt.t
-end
-
 (** The generic signature of a single data accessor (a single value
     bound to a specific key in the hierarchical (key x value)
     database). *)
 module type Single_data_storage = sig
 
-  type context
+  type t
+  type context = t
 
   (** The type of the value *)
   type value
 
+  (** Tells if the data is already defined *)
+  val mem: context -> bool Lwt.t
+
   (** Retrieve the value from the storage bucket ; returns a
       {!Storage_error} if the key is not set or if the deserialisation
       fails *)
-  val get : context -> value tzresult Lwt.t
+  val get: context -> value tzresult Lwt.t
 
   (** Retrieves the value from the storage bucket ; returns [None] if
       the data is not initialized, or {!Storage_helpers.Storage_error}
       if the deserialisation fails *)
-  val get_option : context -> value option tzresult Lwt.t
+  val get_option: context -> value option tzresult Lwt.t
-
-  (** Tells if the data is already defined *)
-  val mem : context -> bool Lwt.t
-
-  (** Updates the content of the bucket ; returns a {!Storage_Error}
-      if the value does not exists *)
-  val set : context -> value -> context tzresult Lwt.t
 
   (** Allocates the storage bucket and initializes it ; returns a
-      {!Storage_error} if the bucket exists *)
+      {!Storage_error Missing_key} if the bucket exists *)
-  val init : context -> value -> context tzresult Lwt.t
+  val init: context -> value -> Raw_context.t tzresult Lwt.t
 
-  (** Delete the storage bucket ; returns a {!Storage_error} if the
+  (** Updates the content of the bucket ; returns a {!Storage_Error
-      bucket does not exists *)
+      Existing_key} if the value does not exists *)
-  val delete : context -> context tzresult Lwt.t
+  val set: context -> value -> Raw_context.t tzresult Lwt.t
 
   (** Allocates the data and initializes it with a value ; just
       updates it if the bucket exists *)
-  val init_set : context -> value -> context tzresult Lwt.t
+  val init_set: context -> value -> Raw_context.t Lwt.t
 
-  (** Removes the storage bucket and its contents ; does nothing if the
+  (** When the value is [Some v], allocates the data and initializes
-      bucket does not exists *)
+      it with [v] ; just updates it if the bucket exists. When the
-  val remove : context -> context Lwt.t
+      valus is [None], delete the storage bucket when the value ; does
+      nothing if the bucket does not exists. *)
+  val set_option: context -> value option -> Raw_context.t Lwt.t
 
-end
+  (** Delete the storage bucket ; returns a {!Storage_error
+      Missing_key} if the bucket does not exists *)
+  val delete: context -> Raw_context.t tzresult Lwt.t
+
+  (** Removes the storage bucket and its contents ; does nothing if
+      the bucket does not exists *)
+  val remove: context -> Raw_context.t Lwt.t
 
-module type Indexed_optional_data_storage = sig
-  type context
-  type key
-  type value
-  val get : context -> key -> value option tzresult Lwt.t
-  val mem : context -> key -> bool Lwt.t
-  val set : context -> key -> value option -> context tzresult Lwt.t
 end
 
 (** The generic signature of indexed data accessors (a set of values
@@ -76,7 +66,8 @@ end
     hierarchical (key x value) database). *)
 module type Indexed_data_storage = sig
 
-  type context
+  type t
+  type context = t
 
   (** An abstract type for keys *)
   type key
@@ -84,46 +75,56 @@ module type Indexed_data_storage = sig
   (** The type of values *)
   type value
 
-  (** Retrieve a value from the storage bucket at a given key ;
-      returns a {!Storage_error} if the key is not set or if the
-      deserialisation fails *)
-  val get : context -> key -> value tzresult Lwt.t
-
   (** Tells if a given key is already bound to a storage bucket *)
-  val mem : context -> key -> bool Lwt.t
+  val mem: context -> key -> bool Lwt.t
 
   (** Retrieve a value from the storage bucket at a given key ;
-      returns [None] if the value is not set an error if the
+      returns {!Storage_error Missing_key} if the key is not set ;
-      deserialisation fails *)
+      returns {!Storage_error Corrupted_data} if the deserialisation
-  val get_option : context -> key -> value option tzresult Lwt.t
+      fails. *)
+  val get: context -> key -> value tzresult Lwt.t
 
-  (** Updates the content of a bucket ; returns A {!Storage_Error} if
+  (** Retrieve a value from the storage bucket at a given key ;
-      the value does not exists *)
+      returns [None] if the value is not set ; returns {!Storage_error
-  val set : context -> key -> value -> context tzresult Lwt.t
+      Corrupted_data} if the deserialisation fails. *)
+  val get_option: context -> key -> value option tzresult Lwt.t
+
+  (** Updates the content of a bucket ; returns A {!Storage_Error
+      Missing_key} if the value does not exists. *)
+  val set: context -> key -> value -> Raw_context.t tzresult Lwt.t
 
   (** Allocates a storage bucket at the given key and initializes it ;
-      returns a {!Storage_error} if the bucket exists *)
+      returns a {!Storage_error Existing_key} if the bucket exists. *)
-  val init : context -> key -> value -> context tzresult Lwt.t
+  val init: context -> key -> value -> Raw_context.t tzresult Lwt.t
-
-  (** Delete a storage bucket and its contents ; returns a
-      {!Storage_error} if the bucket does not exists *)
-  val delete : context -> key -> context tzresult Lwt.t
 
   (** Allocates a storage bucket at the given key and initializes it
-      with a value ; just updates it if the bucket exists *)
+      with a value ; just updates it if the bucket exists. *)
-  val init_set : context -> key -> value -> context tzresult Lwt.t
+  val init_set: context -> key -> value -> Raw_context.t Lwt.t
+
+  (** When the value is [Some v], allocates the data and initializes
+      it with [v] ; just updates it if the bucket exists. When the
+      valus is [None], delete the storage bucket when the value ; does
+      nothing if the bucket does not exists. *)
+  val set_option: context -> key -> value option -> Raw_context.t Lwt.t
+
+  (** Delete a storage bucket and its contents ; returns a
+      {!Storage_error Missing_key} if the bucket does not exists. *)
+  val delete: context -> key -> Raw_context.t tzresult Lwt.t
 
   (** Removes a storage bucket and its contents ; does nothing if the
-      bucket does not exists *)
+      bucket does not exists. *)
-  val remove : context -> key -> context Lwt.t
+  val remove: context -> key -> Raw_context.t Lwt.t
 
-end
+  val clear: context -> Raw_context.t Lwt.t
+
+  val keys: context -> key list Lwt.t
+  val bindings: context -> (key * value) list Lwt.t
+
+  val fold:
+    context -> init:'a -> f:(key -> value -> 'a -> 'a Lwt.t) -> 'a Lwt.t
+  val fold_keys:
+    context -> init:'a -> f:(key -> 'a -> 'a Lwt.t) -> 'a Lwt.t
 
-module type Iterable_data_storage = sig
-  include Indexed_data_storage
-  val iter : context -> f:(key -> value -> unit Lwt.t) -> unit Lwt.t
-  val fold : context -> 'a -> f:(key -> value -> 'a -> 'a Lwt.t) -> 'a Lwt.t
-  val clear : context -> context Lwt.t
 end
 
 (** The generic signature of a data set accessor (a set of values
@@ -131,28 +132,65 @@ end
     database). *)
 module type Data_set_storage = sig
 
-  type context
+  type t
+  type context = t
 
-  (** The type of values *)
+  (** The type of elements. *)
-  type value
+  type elt
 
-  (** Tells if a value is a member of the set *)
+  (** Tells if a elt is a member of the set *)
-  val mem : context -> value -> bool tzresult Lwt.t
+  val mem: context -> elt -> bool Lwt.t
 
-  (** Adds a value is a member of the set *)
+  (** Adds a elt is a member of the set *)
-  val add : context -> value -> context tzresult Lwt.t
+  val add: context -> elt -> Raw_context.t Lwt.t
 
-  (** Removes a value of the set ; does nothing if not a member *)
+  (** Removes a elt of the set ; does nothing if not a member *)
-  val del : context -> value -> context tzresult Lwt.t
+  val del: context -> elt -> Raw_context.t Lwt.t
 
   (** Returns the elements of the set, deserialized in a list in no
-      particular order ; returns a {!Storage_helpers.Storage_error} if
+      particular order. *)
-      a deserialization error occurs *)
+  val elements: context -> elt list Lwt.t
-  val elements : context -> value list tzresult Lwt.t
 
-  val fold :
+  val fold: context -> init:'a -> f:(elt -> 'a -> 'a Lwt.t) -> 'a Lwt.t
-    context -> 'a -> f:(value -> 'a -> 'a Lwt.t) -> 'a tzresult Lwt.t
 
   (** Removes all elements in the set *)
-  val clear : context -> context tzresult Lwt.t
+  val clear: context -> Raw_context.t Lwt.t
+
+end
+
+module type NAME = sig
+  val name: Raw_context.key
+end
+
+module type VALUE = sig
+  type t
+  val of_bytes: MBytes.t -> t tzresult
+  val to_bytes: t -> MBytes.t
+end
+
+module type Indexed_raw_context = sig
+
+  type t
+  type context = t
+  type key
+
+  val clear: context -> key -> Raw_context.t Lwt.t
+
+  val fold_keys:
+    context -> init:'a -> f:(key -> 'a -> 'a Lwt.t) -> 'a Lwt.t
+  val keys: context -> key list Lwt.t
+
+  val resolve: context -> string list -> key list Lwt.t
+
+  module Make_set (N : NAME)
+    : Data_set_storage with type t = t
+                        and type elt = key
+
+  module Make_map (N : NAME) (V : VALUE)
+    : Indexed_data_storage with type t = t
+                            and type key = key
+                            and type value = V.t
+
+  module Raw_context : Raw_context.T with type t = t * key
+
 end

src/proto/alpha/tezos_context.ml

@@ -7,7 +7,7 @@
 (*                                                                        *)
 (**************************************************************************)
 
-type t = Storage.t
+type t = Raw_context.t
 type context = t
 
 module type BASIC_DATA = sig
@@ -22,7 +22,7 @@ module Period = Period_repr
 
 module Timestamp = struct
   include Time_repr
-  let current = Storage.current_timestamp
+  let current = Raw_context.current_timestamp
 end
 
 include Operation_repr
@@ -41,7 +41,7 @@ module Script_int = Script_int_repr
 module Script_timestamp = struct
   include Script_timestamp_repr
   let now ctxt =
-    Storage.current_timestamp ctxt
+    Raw_context.current_timestamp ctxt
     |> Timestamp.to_seconds
     |> of_int64
 end
@@ -59,31 +59,31 @@ include Tezos_hash
 module Constants = struct
   include Constants_repr
   let cycle_length c =
-    let constants = Storage.constants c in
+    let constants = Raw_context.constants c in
     constants.cycle_length
   let voting_period_length c =
-    let constants = Storage.constants c in
+    let constants = Raw_context.constants c in
     constants.voting_period_length
   let time_before_reward c =
-    let constants = Storage.constants c in
+    let constants = Raw_context.constants c in
     constants.time_before_reward
   let slot_durations c =
-    let constants = Storage.constants c in
+    let constants = Raw_context.constants c in
     constants.slot_durations
   let first_free_baking_slot c =
-    let constants = Storage.constants c in
+    let constants = Raw_context.constants c in
     constants.first_free_baking_slot
   let max_signing_slot c =
-    let constants = Storage.constants c in
+    let constants = Raw_context.constants c in
     constants.max_signing_slot
   let instructions_per_transaction c =
-    let constants = Storage.constants c in
+    let constants = Raw_context.constants c in
     constants.instructions_per_transaction
   let proof_of_work_threshold c =
-    let constants = Storage.constants c in
+    let constants = Raw_context.constants c in
     constants.proof_of_work_threshold
   let dictator_pubkey c =
-    let constants = Storage.constants c in
+    let constants = Raw_context.constants c in
     constants.dictator_pubkey
 end
 
@@ -124,10 +124,10 @@ let init = Init_storage.may_initialize
 
 let finalize ?commit_message:message c =
   let fitness = Fitness.from_int64 (Fitness.current c) in
-  let context = Storage.recover c in
+  let context = Raw_context.recover c in
   { Updater.context ; fitness ; message ; max_operations_ttl = 60 }
 
-let configure_sandbox = Init_storage.configure_sandbox
+let configure_sandbox = Raw_context.configure_sandbox
 
-let activate = Storage.activate
+let activate = Raw_context.activate
-let fork_test_network = Storage.fork_test_network
+let fork_test_network = Raw_context.fork_test_network

src/proto/alpha/tezos_context.mli

@@ -295,7 +295,7 @@ module Delegates_pubkey : sig
     context -> public_key_hash -> context Lwt.t
 
   val list:
-    context -> (public_key_hash * public_key) list tzresult Lwt.t
+    context -> (public_key_hash * public_key) list Lwt.t
 
 end
 
@@ -413,7 +413,7 @@ module Contract : sig
   val exists: context -> contract -> bool tzresult Lwt.t
   val must_exist: context -> contract -> unit tzresult Lwt.t
 
-  val list: context -> contract list tzresult Lwt.t
+  val list: context -> contract list Lwt.t
 
   type origination_nonce
 
@@ -485,10 +485,10 @@ module Vote : sig
 
   val record_proposal:
     context -> Protocol_hash.t -> public_key_hash ->
-    context tzresult Lwt.t
+    context Lwt.t
   val get_proposals:
-    context -> int32 Protocol_hash.Map.t tzresult Lwt.t
+    context -> int32 Protocol_hash.Map.t Lwt.t
-  val clear_proposals: context -> context tzresult Lwt.t
+  val clear_proposals: context -> context Lwt.t
 
   val freeze_listings: context -> context tzresult Lwt.t
   val clear_listings: context -> context tzresult Lwt.t
@@ -504,7 +504,7 @@ module Vote : sig
   }
 
   val record_ballot:
-    context -> public_key_hash -> ballot -> context tzresult Lwt.t
+    context -> public_key_hash -> ballot -> context Lwt.t
   val get_ballots: context -> ballots tzresult Lwt.t
   val clear_ballots: context -> context Lwt.t
 

src/proto/alpha/vote_storage.ml

@@ -11,7 +11,8 @@ let record_proposal ctxt delegate proposal =
   Storage.Vote.Proposals.add ctxt (delegate, proposal)
 
 let get_proposals ctxt =
-  Storage.Vote.Proposals.fold ctxt Protocol_hash.Map.empty
+  Storage.Vote.Proposals.fold ctxt
+    ~init:Protocol_hash.Map.empty
     ~f:(fun (proposal, _delegate) acc ->
         let previous =
           try Protocol_hash.Map.find proposal acc
@@ -41,7 +42,7 @@ let get_ballots ctxt =
           | Nay  -> ok { ballots with nay = count ballots.nay }
           | Pass  -> ok { ballots with pass = count ballots.pass }
         end)
-    (ok { yay = 0l ; nay = 0l; pass = 0l })
+    ~init:(ok { yay = 0l ; nay = 0l; pass = 0l })
 
 let clear_ballots = Storage.Vote.Ballots.clear
 
@@ -57,7 +58,7 @@ let freeze_listings ctxt =
               | Some count -> return count
             end >>=? fun count ->
             Storage.Vote.Listings.init_set
-              ctxt delegate (Int32.succ count) >>=? fun ctxt ->
+              ctxt delegate (Int32.succ count) >>= fun ctxt ->
             return (ctxt, Int32.succ total)) >>=? fun (ctxt, total) ->
   Storage.Vote.Listings_size.init ctxt total >>=? fun ctxt ->
   return ctxt

src/proto/alpha/vote_storage.mli

@@ -8,13 +8,13 @@
 (**************************************************************************)
 
 val record_proposal:
-  Storage.t -> Protocol_hash.t -> Ed25519.Public_key_hash.t ->
+  Raw_context.t -> Protocol_hash.t -> Ed25519.Public_key_hash.t ->
-  Storage.t tzresult Lwt.t
+  Raw_context.t Lwt.t
 
 val get_proposals:
-  Storage.t -> int32 Protocol_hash.Map.t tzresult Lwt.t
+  Raw_context.t -> int32 Protocol_hash.Map.t Lwt.t
 
-val clear_proposals: Storage.t -> Storage.t tzresult Lwt.t
+val clear_proposals: Raw_context.t -> Raw_context.t Lwt.t
 
 type ballots = {
   yay: int32 ;
@@ -23,30 +23,30 @@ type ballots = {
 }
 
 val record_ballot:
-  Storage.t -> Ed25519.Public_key_hash.t -> Vote_repr.ballot ->
+  Raw_context.t -> Ed25519.Public_key_hash.t -> Vote_repr.ballot ->
-  Storage.t tzresult Lwt.t
+  Raw_context.t Lwt.t
-val get_ballots: Storage.t -> ballots tzresult Lwt.t
+val get_ballots: Raw_context.t -> ballots tzresult Lwt.t
-val clear_ballots: Storage.t -> Storage.t Lwt.t
+val clear_ballots: Raw_context.t -> Raw_context.t Lwt.t
 
-val freeze_listings: Storage.t -> Storage.t tzresult Lwt.t
+val freeze_listings: Raw_context.t -> Raw_context.t tzresult Lwt.t
-val clear_listings: Storage.t -> Storage.t tzresult Lwt.t
+val clear_listings: Raw_context.t -> Raw_context.t tzresult Lwt.t
 
-val listing_size: Storage.t -> int32 tzresult Lwt.t
+val listing_size: Raw_context.t -> int32 tzresult Lwt.t
 val in_listings:
-  Storage.t -> Ed25519.Public_key_hash.t -> bool Lwt.t
+  Raw_context.t -> Ed25519.Public_key_hash.t -> bool Lwt.t
 
-val get_current_quorum: Storage.t -> int32 tzresult Lwt.t
+val get_current_quorum: Raw_context.t -> int32 tzresult Lwt.t
-val set_current_quorum: Storage.t -> int32 -> Storage.t tzresult Lwt.t
+val set_current_quorum: Raw_context.t -> int32 -> Raw_context.t tzresult Lwt.t
 
 val get_current_period_kind:
-  Storage.t -> Voting_period_repr.kind tzresult Lwt.t
+  Raw_context.t -> Voting_period_repr.kind tzresult Lwt.t
 val set_current_period_kind:
-  Storage.t -> Voting_period_repr.kind -> Storage.t tzresult Lwt.t
+  Raw_context.t -> Voting_period_repr.kind -> Raw_context.t tzresult Lwt.t
 
 val get_current_proposal:
-  Storage.t -> Protocol_hash.t tzresult Lwt.t
+  Raw_context.t -> Protocol_hash.t tzresult Lwt.t
 val init_current_proposal:
-  Storage.t -> Protocol_hash.t -> Storage.t tzresult Lwt.t
+  Raw_context.t -> Protocol_hash.t -> Raw_context.t tzresult Lwt.t
-val clear_current_proposal: Storage.t -> Storage.t tzresult Lwt.t
+val clear_current_proposal: Raw_context.t -> Raw_context.t tzresult Lwt.t
 
-val init: Storage.t -> Storage.t tzresult Lwt.t
+val init: Raw_context.t -> Raw_context.t tzresult Lwt.t

src/utils/hash.ml

@@ -54,7 +54,7 @@ module type MINIMAL_HASH = sig
   val read: MBytes.t -> int -> t
   val write: MBytes.t -> int -> t -> unit
 
-  val to_path: t -> string list
+  val to_path: t -> string list -> string list
   val of_path: string list -> t option
   val of_path_exn: string list -> t
 
@@ -226,11 +226,11 @@ module Make_minimal_Blake2B (K : Name) = struct
     loop init off
 
   let path_length = 6
-  let to_path key =
+  let to_path key l =
     let key = to_hex key in
-    [ String.sub key 0 2 ; String.sub key 2 2 ;
+    String.sub key 0 2 :: String.sub key 2 2 ::
-      String.sub key 4 2 ; String.sub key 6 2 ;
+    String.sub key 4 2 :: String.sub key 6 2 ::
-      String.sub key 8 2 ; String.sub key 10 (size * 2 - 10) ]
+    String.sub key 8 2 :: String.sub key 10 (size * 2 - 10) :: l
   let of_path path =
     let path = String.concat "" path in
     of_hex path
@@ -677,7 +677,7 @@ module Net_id = struct
     loop init off
 
   let path_length = 1
-  let to_path key = [to_hex key]
+  let to_path key l = to_hex key :: l
   let of_path path =
     let path = String.concat "" path in
     of_hex path

src/utils/hash.mli

@@ -48,7 +48,7 @@ module type MINIMAL_HASH = sig
   val read: MBytes.t -> int -> t
   val write: MBytes.t -> int -> t -> unit
 
-  val to_path: t -> string list
+  val to_path: t -> string list -> string list
   val of_path: string list -> t option
   val of_path_exn: string list -> t
 

test/proto_alpha/proto_alpha_helpers.ml

@@ -342,9 +342,8 @@ module Assert = struct
     Assert.contain_error ~msg ~f:(ecoproto_error (fun _ -> true))
 
   let unknown_contract ~msg =
-    let open Storage_functors in
     Assert.contain_error ~msg ~f:begin ecoproto_error (function
-        | Storage_error _ -> true
+        | Raw_context.Storage_error _ -> true
         | _ -> false)
     end