Alpha/RPC: add a low-level but typed RPC for context introspection

Example:

```
> tezos-client rpc get /chains/main/blocks/head/context/raw/json/\?depth\=1 | jq
{
  "commitments": [],
  "contracts": {
    "global_counter": 0,
    "index": []
  },
  "cycle": [
    4,
    3,
    2,
    1,
    0
  ],
  "delegates": [
    "tz1gjaF81ZRRvdzjobyfVNsAeSC6PScjfQwN",
    "tz1faswCTDciRzE4oJ9jn2Vm2dvjeyA9fUzU",
    "tz1ddb9NMYHZi5UzPdzTZMYQQZoMub195zgv",
    "tz1b7tUupMgCNw2cCLpKTkSD1NZzB5TkP2sv",
    "tz1KqTpEZ7Yob7QbPE4Hy4Wo8fHG8LhKxZSx"
  ],
  "last_block_priority": 0,
  "rolls": {
    "index": [],
    "next": 2000,
    "owner": {}
  },
  "votes": {
    "ballots": [],
    "current_period_kind": "proposal",
    "current_quorum": 8000,
    "listings": [],
    "proposals": []
  }
}
> tezos-client rpc get /chains/main/blocks/head/context/raw/json/cycle/4\?depth\=2 | jq
{
  "last_roll": [
    [
      0,
      2000
    ]
  ],
  "nonces": [],
  "random_seed": "97d50852c159ada8e9f107e98f693b059ba28336c723e6cd0f6353eb3c0cb415",
  "roll_snapshot": 0
}
> tezos-client rpc get /chains/main/blocks/head/context/raw/json/cycle/5\?depth\=2 | jq
{
  "last_roll": [
    [
      1,
      2000
    ],
    [
      0,
      2000
    ]
  ],
  "nonces": [],
  "roll_snapshot": 2
}
```

src/bin_client/test/test_basic.sh

@@ -13,13 +13,13 @@ $client -w none config update
 sleep 2
 
 #tests for the rpc service raw_context
-$client rpc get '/chains/main/blocks/head/context/raw/version' | assert '"616c706861"'
+$client rpc get '/chains/main/blocks/head/context/raw/bytes/version' | assert '"616c706861"'
-$client rpc get '/chains/main/blocks/head/context/raw/non-existent' | assert 'No service found at this URL'
+$client rpc get '/chains/main/blocks/head/context/raw/bytes/non-existent' | assert 'No service found at this URL'
-$client rpc get '/chains/main/blocks/head/context/raw/delegates/?depth=3' | assert '{ "ed25519":
+$client rpc get '/chains/main/blocks/head/context/raw/bytes/delegates/?depth=3' | assert '{ "ed25519":
     { "02": { "29": null }, "a9": { "ce": null }, "c5": { "5c": null },
       "da": { "c9": null }, "e7": { "67": null } } }'
-$client rpc get '/chains/main/blocks/head/context/raw/non-existent?depth=-1' | assert 'Unexpected server answer'
+$client rpc get '/chains/main/blocks/head/context/raw/bytes/non-existent?depth=-1' | assert 'Unexpected server answer'
-$client rpc get '/chains/main/blocks/head/context/raw/non-existent?depth=0' | assert 'No service found at this URL'
+$client rpc get '/chains/main/blocks/head/context/raw/bytes/non-existent?depth=0' | assert 'No service found at this URL'
 
 bake
 

src/lib_protocol_environment/sigs/v1/RPC_directory.mli

@@ -202,3 +202,10 @@ val lwt_register5:
   ('m, 'prefix, ((((unit * 'a) * 'b) * 'c) * 'd) * 'e, 'q , 'i, 'o) RPC_service.t ->
   ('a -> 'b -> 'c -> 'd -> 'e -> 'q -> 'i -> 'o Lwt.t) ->
   'prefix directory
+
+(** Registring dynamic subtree. *)
+val register_dynamic_directory:
+  ?descr:string ->
+  'prefix directory ->
+  ('prefix, 'a) RPC_path.t -> ('a -> 'a directory Lwt.t) ->
+  'prefix directory

src/lib_shell/block_directory.ml

@@ -218,7 +218,7 @@ let build_raw_rpc_directory
 
   (* context *)
 
-  register1 S.Context.Raw.read begin fun block path q () ->
+  register1 S.Context.read begin fun block path q () ->
     let depth = Option.unopt ~default:max_int q#depth in
     fail_unless (depth >= 0)
       (Tezos_shell_services.Block_services.Invalid_depth_arg (path, depth)) >>=? fun () ->

src/lib_shell_services/block_services.ml

@@ -648,35 +648,29 @@ module Make(Proto : PROTO)(Next_proto : PROTO) = struct
 
     module Context = struct
 
-      let path = RPC_path.(path / "context")
+      let path = RPC_path.(path / "context" / "raw" / "bytes")
 
-      module Raw = struct
+      let context_path_arg : string RPC_arg.t =
+        let name = "context_path" in
+        let descr = "A path inside the context" in
+        let construct = fun s -> s in
+        let destruct = fun s -> Ok s in
+        RPC_arg.make ~name ~descr ~construct ~destruct ()
 
-        let path = RPC_path.(path / "raw")
+      let raw_context_query : < depth: int option > RPC_query.t =
+        let open RPC_query in
+        query (fun depth -> object
+                method depth = depth
+              end)
+        |+ opt_field "depth" RPC_arg.int (fun t -> t#depth)
+        |> seal
 
-        let context_path_arg : string RPC_arg.t =
+      let read =
-          let name = "context_path" in
+        RPC_service.get_service
-          let descr = "A path inside the context" in
+          ~description:"Returns the raw context."
-          let construct = fun s -> s in
+          ~query: raw_context_query
-          let destruct = fun s -> Ok s in
+          ~output: raw_context_encoding
-          RPC_arg.make ~name ~descr ~construct ~destruct ()
+          RPC_path.(path /:* context_path_arg)
-
-        let raw_context_query : < depth: int option > RPC_query.t =
-          let open RPC_query in
-          query (fun depth -> object
-                  method depth = depth
-                end)
-          |+ opt_field "depth" RPC_arg.int (fun t -> t#depth)
-          |> seal
-
-        let read =
-          RPC_service.get_service
-            ~description:"Returns the raw context."
-            ~query: raw_context_query
-            ~output: raw_context_encoding
-            RPC_path.(path /:* context_path_arg)
-
-      end
 
     end
 
@@ -872,17 +866,11 @@ module Make(Proto : PROTO)(Next_proto : PROTO) = struct
 
     module S = S.Context
 
-    module Raw = struct
+    let read ctxt =
-
+      let f = make_call1 S.read ctxt in
-      module S = S.Raw
+      fun ?(chain = `Main) ?(block = `Head 0) ?depth path ->
-
+        f chain block path
-      let read ctxt =
+          (object method depth = depth end) ()
-        let f = make_call1 S.read ctxt in
-        fun ?(chain = `Main) ?(block = `Head 0) ?depth path ->
-          f chain block path
-            (object method depth = depth end) ()
-
-    end
 
   end
 

src/lib_shell_services/block_services.mli

@@ -222,14 +222,10 @@ module Make(Proto : PROTO)(Next_proto : PROTO) : sig
 
   module Context : sig
 
-    module Raw : sig
+    val read:
-
+      #simple -> ?chain:chain -> ?block:block ->
-      val read:
+      ?depth: int ->
-        #simple -> ?chain:chain -> ?block:block ->
+      string list -> raw_context tzresult Lwt.t
-        ?depth: int ->
-        string list -> raw_context tzresult Lwt.t
-
-    end
 
   end
 
@@ -433,14 +429,10 @@ module Make(Proto : PROTO)(Next_proto : PROTO) : sig
 
     module Context : sig
 
-      module Raw : sig
+      val read:
-
+        ([ `GET ], prefix,
-        val read:
+         prefix * string list, < depth : int option >, unit,
-          ([ `GET ], prefix,
+         raw_context) RPC_service.t
-           prefix * string list, < depth : int option >, unit,
-           raw_context) RPC_service.t
-
-      end
 
     end
 

src/proto_alpha/lib_baking/test/proto_alpha_helpers.ml

@@ -152,7 +152,7 @@ let level (chain, block) =
   return level
 
 let rpc_raw_context block path depth =
-  Shell_services.Blocks.Context.Raw.read !rpc_ctxt ~block ~depth path
+  Shell_services.Blocks.Context.read !rpc_ctxt ~block ~depth path
 
 module Account = struct
 

src/proto_alpha/lib_protocol/src/TEZOS_PROTOCOL

@@ -2,6 +2,7 @@
     "hash": "ProtoALphaALphaALphaALphaALphaALphaALphaALphaDdp3zK",
     "modules": [
         "Misc",
+        "Storage_description",
         "State_hash",
         "Nonce_hash",
         "Script_expr_hash",

src/proto_alpha/lib_protocol/src/alpha_context.ml

@@ -150,3 +150,5 @@ let add_rewards = Raw_context.add_rewards
 
 let get_fees = Raw_context.get_fees
 let get_rewards = Raw_context.get_rewards
+
+let description = Raw_context.description

src/proto_alpha/lib_protocol/src/alpha_context.mli

@@ -975,3 +975,5 @@ val add_rewards: context -> Tez.t -> context tzresult Lwt.t
 
 val get_fees: context -> Tez.t
 val get_rewards: context -> Tez.t
+
+val description: context Storage_description.t

src/proto_alpha/lib_protocol/src/blinded_public_key_hash.ml

@@ -43,4 +43,8 @@ module Index = struct
     | [ h1 ; h2 ] -> of_bytes_opt (MBytes.of_hex (`Hex (h1 ^ h2)))
     | _ -> None
 
+  let compare = compare
+  let encoding = encoding
+  let rpc_arg = rpc_arg
+
 end

src/proto_alpha/lib_protocol/src/blinded_public_key_hash.mli

@@ -19,9 +19,4 @@ val of_ed25519_pkh : activation_code -> Ed25519.Public_key_hash.t -> t
 
 val activation_code_of_hex : string -> activation_code
 
-module Index : sig
+module Index : Storage_description.INDEX with type t = t
-  type nonrec t = t
-  val path_length : int
-  val to_path : t -> string list -> string list
-  val of_path : string list -> t option
-end

src/proto_alpha/lib_protocol/src/contract_repr.ml

@@ -178,4 +178,7 @@ module Index = struct
     Ed25519.Public_key_hash.prefix_path s
   let pkh_prefix_secp256k1 s =
     Secp256k1.Public_key_hash.prefix_path s
+  let rpc_arg = rpc_arg
+  let encoding = encoding
+  let compare = compare
 end

src/proto_alpha/lib_protocol/src/contract_repr.mli

@@ -61,10 +61,7 @@ val origination_nonce_encoding : origination_nonce Data_encoding.t
 val rpc_arg : contract RPC_arg.arg
 
 module Index : sig
-  type t = contract
+  include Storage_description.INDEX with type t = t
-  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_ed25519: string -> string list
   val pkh_prefix_secp256k1: string -> string list

src/proto_alpha/lib_protocol/src/cycle_repr.ml

@@ -63,4 +63,7 @@ module Index = struct
         with _ -> None
       end
     | _ -> None
+  let rpc_arg = rpc_arg
+  let encoding = encoding
+  let compare = compare
 end

src/proto_alpha/lib_protocol/src/cycle_repr.mli

@@ -25,10 +25,4 @@ val of_int32_exn: int32 -> cycle
 
 module Map : S.MAP with type key = cycle
 
-module Index : sig
+module Index : Storage_description.INDEX with type t = cycle
-  (* 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/lib_protocol/src/raw_context.ml

@@ -490,6 +490,8 @@ module type T = sig
 
   val record_bytes_stored: context -> Int64.t -> context tzresult
 
+  val description: context Storage_description.t
+
 end
 
 let mem ctxt k = Context.mem ctxt.context k
@@ -563,3 +565,5 @@ let fold_keys ctxt k ~init ~f =
 let project x = x
 
 let absolute_key _ k = k
+
+let description = Storage_description.create ()

src/proto_alpha/lib_protocol/src/raw_context.mli

@@ -182,6 +182,8 @@ module type T = sig
       within a view. *)
   val record_bytes_stored: context -> Int64.t -> context tzresult
 
+  val description: context Storage_description.t
+
 end
 
 include T with type t := t and type context := context

src/proto_alpha/lib_protocol/src/raw_level_repr.ml

@@ -56,4 +56,7 @@ module Index = struct
         with _ -> None
       end
     | _ -> None
+  let rpc_arg = rpc_arg
+  let encoding = encoding
+  let compare = compare
 end

src/proto_alpha/lib_protocol/src/raw_level_repr.mli

@@ -28,9 +28,4 @@ val root: raw_level
 val succ: raw_level -> raw_level
 val pred: raw_level -> raw_level option
 
-module Index : sig
+module Index : Storage_description.INDEX with type t = raw_level
-  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/lib_protocol/src/roll_repr.ml

@@ -7,7 +7,7 @@
 (*                                                                        *)
 (**************************************************************************)
 
-type t = int32
+include Compare.Int32
 type roll = t
 
 let encoding = Data_encoding.int32
@@ -25,7 +25,6 @@ let rpc_arg =
 
 let to_int32 v = v
 
-let (=) = Compare.Int32.(=)
 
 module Index = struct
   type t = roll
@@ -40,4 +39,7 @@ module Index = struct
         with _ -> None
       end
     | _ -> None
+  let rpc_arg = rpc_arg
+  let encoding = encoding
+  let compare = compare
 end

src/proto_alpha/lib_protocol/src/roll_repr.mli

@@ -23,9 +23,4 @@ val to_int32: roll -> Int32.t
 
 val (=): roll -> roll -> bool
 
-module Index : sig
+module Index : Storage_description.INDEX with type t = roll
-  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/lib_protocol/src/services_registration.ml

@@ -64,4 +64,15 @@ let register2_fullctxt s f =
 let register2 s f =
   register2_fullctxt s (fun { context ; _ } a1 a2 q i -> f context a1 a2 q i)
 
-let get_rpc_services () = !rpc_services
+let get_rpc_services () =
+  let p =
+    RPC_directory.map
+      (fun c ->
+         rpc_init c >>= function
+         | Error _ -> assert false
+         | Ok c -> Lwt.return c.context)
+      (Storage_description.build_directory Alpha_context.description) in
+  RPC_directory.register_dynamic_directory
+    !rpc_services
+    RPC_path.(open_root / "context" / "raw" / "json")
+    (fun _ -> Lwt.return p)

src/proto_alpha/lib_protocol/src/storage.ml

@@ -33,6 +33,12 @@ module Int_index = struct
     | [ c ] ->
         try Some (int_of_string c)
         with _ -> None
+  type 'a ipath = 'a * t
+  let args = Storage_description.One {
+      rpc_arg = RPC_arg.int ;
+      encoding = Data_encoding.int31 ;
+      compare = Compare.Int.compare ;
+    }
 end
 
 module String_index = struct
@@ -42,6 +48,23 @@ module String_index = struct
   let of_path = function
     | [ c ] -> Some c
     | [] | _ :: _ :: _ -> None
+  type 'a ipath = 'a * t
+  let args = Storage_description.One {
+      rpc_arg = RPC_arg.string ;
+      encoding = Data_encoding.string ;
+      compare = Compare.String.compare ;
+    }
+end
+
+module Make_index(H : Storage_description.INDEX)
+  : INDEX with type t = H.t and type 'a ipath = 'a * H.t = struct
+  include H
+  type 'a ipath = 'a * t
+  let args = Storage_description.One {
+      rpc_arg ;
+      encoding ;
+      compare ;
+    }
 end
 
 module Last_block_priority =
@@ -66,7 +89,7 @@ module Contract = struct
   module Indexed_context =
     Make_indexed_subcontext
       (Make_subcontext(Raw_context)(struct let name = ["index"] end))
-      (Contract_repr.Index)
+      (Make_index(Contract_repr.Index))
 
   let fold = Indexed_context.fold_keys
   let list = Indexed_context.keys
@@ -81,7 +104,7 @@ module Contract = struct
       (Make_subcontext
          (Indexed_context.Raw_context)
          (struct let name = ["frozen_balance"] end))
-      (Cycle_repr.Index)
+      (Make_index(Cycle_repr.Index))
 
   module Frozen_deposits =
     Frozen_balance_index.Make_map
@@ -130,7 +153,7 @@ module Contract = struct
       (Make_subcontext
          (Indexed_context.Raw_context)
          (struct let name = ["delegated"] end))
-      (Contract_hash)
+      (Make_index(Contract_hash))
 
   module Counter =
     Indexed_context.Make_map
@@ -191,7 +214,7 @@ end
 module Delegates =
   Make_data_set_storage
     (Make_subcontext(Raw_context)(struct let name = ["delegates"] end))
-    (Signature.Public_key_hash)
+    (Make_index(Signature.Public_key_hash))
 
 (** Rolls *)
 
@@ -200,7 +223,7 @@ module Cycle = struct
   module Indexed_context =
     Make_indexed_subcontext
       (Make_subcontext(Raw_context)(struct let name = ["cycle"] end))
-      (Cycle_repr.Index)
+      (Make_index(Cycle_repr.Index))
 
   module Last_roll =
     Make_indexed_data_storage
@@ -254,7 +277,7 @@ module Cycle = struct
       (Make_subcontext
          (Indexed_context.Raw_context)
          (struct let name = ["nonces"] end))
-      (Raw_level_repr.Index)
+      (Make_index(Raw_level_repr.Index))
       (struct
         type t = nonce_status
         let encoding = nonce_status_encoding
@@ -278,7 +301,7 @@ module Roll = struct
   module Indexed_context =
     Make_indexed_subcontext
       (Make_subcontext(Raw_context)(struct let name = ["index"] end))
-      (Roll_repr.Index)
+      (Make_index(Roll_repr.Index))
 
   module Next =
     Make_single_data_storage
@@ -326,13 +349,28 @@ module Roll = struct
               try Some (c, int_of_string l2)
               with _ -> None
             end
+    type 'a ipath = ('a * Cycle_repr.t) * int
+    let left_args =
+      Storage_description.One {
+        rpc_arg = Cycle_repr.rpc_arg ;
+        encoding = Cycle_repr.encoding ;
+        compare = Cycle_repr.compare
+      }
+    let right_args =
+      Storage_description.One {
+        rpc_arg = RPC_arg.int ;
+        encoding = Data_encoding.int31 ;
+        compare = Compare.Int.compare ;
+      }
+    let args =
+      Storage_description.(Pair (left_args, right_args))
   end
 
   module Owner =
     Make_indexed_data_snapshotable_storage
       (Make_subcontext(Raw_context)(struct let name = ["owner"] end))
       (Snapshoted_owner_index)
-      (Roll_repr.Index)
+      (Make_index(Roll_repr.Index))
       (Signature.Public_key)
 
   module Snapshot_for_cycle = Cycle.Roll_snapshot
@@ -379,18 +417,18 @@ module Vote = struct
   module Listings =
     Make_indexed_data_storage
       (Make_subcontext(Raw_context)(struct let name = ["listings"] end))
-      (Signature.Public_key_hash)
+      (Make_index(Signature.Public_key_hash))
       (Int32)
 
   module Proposals =
     Make_data_set_storage
       (Make_subcontext(Raw_context)(struct let name = ["proposals"] end))
-      (Pair(Protocol_hash)(Signature.Public_key_hash))
+      (Pair(Make_index(Protocol_hash))(Make_index(Signature.Public_key_hash)))
 
   module Ballots =
     Make_indexed_data_storage
       (Make_subcontext(Raw_context)(struct let name = ["ballots"] end))
-      (Signature.Public_key_hash)
+      (Make_index(Signature.Public_key_hash))
       (struct
         type t = Vote_repr.ballot
         let encoding = Vote_repr.ballot_encoding
@@ -435,7 +473,7 @@ end
 module Commitments =
   Make_indexed_data_storage
     (Make_subcontext(Raw_context)(struct let name = ["commitments"] end))
-    (Blinded_public_key_hash.Index)
+    (Make_index(Blinded_public_key_hash.Index))
     (Tez_repr)
 
 (** Ramp up security deposits... *)
@@ -445,7 +483,7 @@ module Ramp_up = struct
   module Rewards =
     Make_indexed_data_storage
       (Make_subcontext(Raw_context)(struct let name = ["ramp_up"; "rewards"] end))
-      (Cycle_repr.Index)
+      (Make_index(Cycle_repr.Index))
       (struct
         type t = Tez_repr.t * Tez_repr.t
         let encoding = Data_encoding.tup2 Tez_repr.encoding Tez_repr.encoding
@@ -454,7 +492,7 @@ module Ramp_up = struct
   module Security_deposits =
     Make_indexed_data_storage
       (Make_subcontext(Raw_context)(struct let name = ["ramp_up"; "deposits"] end))
-      (Cycle_repr.Index)
+      (Make_index(Cycle_repr.Index))
       (struct
         type t = Tez_repr.t * Tez_repr.t
         let encoding = Data_encoding.tup2 Tez_repr.encoding Tez_repr.encoding

src/proto_alpha/lib_protocol/src/storage_description.ml

@@ -0,0 +1,291 @@
+(**************************************************************************)
+(*                                                                        *)
+(*    Copyright (c) 2014 - 2018.                                          *)
+(*    Dynamic Ledger Solutions, Inc. <contact@tezos.com>                  *)
+(*                                                                        *)
+(*    All rights reserved. No warranty, explicit or implicit, provided.   *)
+(*                                                                        *)
+(**************************************************************************)
+
+module StringMap = Map.Make(String)
+
+type 'key t = 'key description ref
+
+and 'key description =
+  | Empty : 'key description
+  | Value : { get: 'key -> 'a option tzresult Lwt.t ;
+              encoding: 'a Data_encoding.t } -> 'key description
+  | NamedDir: 'key t StringMap.t -> 'key description
+  | IndexedDir: { arg: 'a RPC_arg.t ;
+                  arg_encoding: 'a Data_encoding.t ;
+                  list: 'key -> 'a list tzresult Lwt.t ;
+                  subdir: ('key * 'a) t }-> 'key description
+
+let rec register_named_subcontext : type r. r t -> string list -> r t =
+  fun dir names ->
+    match !dir, names with
+    | _, [] -> dir
+    | Value _, _ -> invalid_arg ""
+    | IndexedDir _, _ -> invalid_arg ""
+    | Empty, name :: names ->
+        let subdir = ref Empty in
+        dir := NamedDir (StringMap.singleton name subdir) ;
+        register_named_subcontext subdir names
+    | NamedDir map, name :: names ->
+        let subdir =
+          match StringMap.find_opt name map with
+          | Some subdir -> subdir
+          | None ->
+              let subdir = ref Empty in
+              dir := NamedDir (StringMap.add name subdir map) ;
+              subdir in
+        register_named_subcontext subdir names
+
+type (_, _, _) args =
+  | One : { rpc_arg: 'a RPC_arg.t ;
+            encoding: 'a Data_encoding.t ;
+            compare: 'a -> 'a -> int } -> ('key, 'a, 'key * 'a) args
+  | Pair : ('key, 'a, 'inter_key) args *
+           ('inter_key, 'b, 'sub_key) args -> ('key, 'a * 'b, 'sub_key) args
+
+let rec unpack : type a b c. (a, b, c) args -> c -> a * b = function
+  | One _ -> (fun x -> x)
+  | Pair (l, r) ->
+      let unpack_l = unpack l in
+      let unpack_r = unpack r in
+      fun x ->
+        let c, d = unpack_r x in
+        let b, a = unpack_l c in
+        (b, (a, d))
+
+let rec pack : type a b c. (a, b, c) args -> a -> b -> c = function
+  | One _ -> (fun b a -> (b, a))
+  | Pair (l, r) ->
+      let pack_l = pack l in
+      let pack_r = pack r in
+      fun b (a, d) ->
+        let c = pack_l b a in
+        pack_r c d
+
+let rec compare : type a b c. (a, b, c) args -> b -> b -> int = function
+  | One { compare ; _ } -> compare
+  | Pair (l, r) ->
+      let compare_l = compare l in
+      let compare_r = compare r in
+      fun (a1, b1) (a2, b2) ->
+        match compare_l a1 a2 with
+        | 0 -> compare_r b1 b2
+        | x -> x
+
+let destutter equal l =
+  match l with
+  | [] -> []
+  | (i, _) :: l ->
+      let rec loop acc i = function
+        | [] -> acc
+        | (j, _) :: l ->
+            if equal i j then loop acc i l
+            else loop (j :: acc) j l in
+      loop [i] i l
+
+let rec register_indexed_subcontext
+  : type r a b. r t -> list:(r -> a list tzresult Lwt.t) ->
+  (r, a, b) args -> b t =
+  fun dir ~list path ->
+    match path with
+    | Pair (left, right) ->
+        let compare_left = compare left in
+        let equal_left x y = Compare.Int.(compare_left x y = 0) in
+        let list_left r =
+          list r >>=? fun l ->
+          return (destutter equal_left l) in
+        let list_right r =
+          let a, k = unpack left r in
+          list a >>=? fun l ->
+          return
+            (List.map snd
+               (List.filter (fun (x, _) ->  equal_left x k) l)) in
+        register_indexed_subcontext
+          (register_indexed_subcontext dir ~list:list_left left)
+          ~list:list_right right
+    | One { rpc_arg = arg ; encoding = arg_encoding ; _ } ->
+        match !dir with
+        | Value _ -> invalid_arg ""
+        | NamedDir _ -> invalid_arg ""
+        | Empty ->
+            let subdir = ref Empty in
+            dir := IndexedDir { arg ; arg_encoding ; list ;  subdir };
+            subdir
+        | IndexedDir { arg = inner_arg ; subdir ; _ } ->
+            match RPC_arg.eq arg inner_arg with
+            | None -> invalid_arg ""
+            | Some RPC_arg.Eq -> subdir
+
+let register_value :
+  type a b. a t -> get:(a -> b option tzresult Lwt.t) -> b Data_encoding.t -> unit =
+  fun dir ~get encoding ->
+    match !dir with
+    | Empty -> dir := Value { get ; encoding }
+    | _ -> invalid_arg ""
+
+let create () = ref Empty
+
+let rec pp : type a. Format.formatter -> a t -> unit = fun ppf dir ->
+  match !dir with
+  | Empty ->
+      Format.fprintf ppf "EMPTY"
+  | Value _e ->
+      Format.fprintf ppf "Value"
+  | NamedDir map ->
+      Format.fprintf ppf "@[<v>%a@]"
+        (Format.pp_print_list pp_item)
+        (StringMap.bindings map)
+  | IndexedDir { arg ; subdir ; _ } ->
+      let name = Format.asprintf "<%s>" (RPC_arg.descr arg).name in
+      pp_item ppf (name, subdir)
+
+and pp_item : type a. Format.formatter -> (string * a t) -> unit =
+  fun ppf (name, dir) ->
+    Format.fprintf ppf "@[<v 2>%s@ %a@]"
+      name
+      pp dir
+
+
+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
+  val rpc_arg: t RPC_arg.t
+  val encoding: t Data_encoding.t
+  val compare: t -> t -> int
+end
+
+type _ handler =
+    Handler :
+      { encoding: 'a Data_encoding.t ;
+        get: 'key -> int -> 'a tzresult Lwt.t } -> 'key handler
+
+type _ opt_handler =
+    Opt_handler :
+      { encoding: 'a Data_encoding.t ;
+        get: 'key -> int -> 'a option tzresult Lwt.t } -> 'key opt_handler
+
+let rec combine_object = function
+  | [] -> Handler { encoding = Data_encoding.unit ;
+                    get = fun _ _ -> return () }
+  | (name, Opt_handler handler) :: fields ->
+      let Handler handlers = combine_object fields in
+      Handler { encoding =
+                  Data_encoding.merge_objs
+                    Data_encoding.(obj1 (opt name (dynamic_size handler.encoding)))
+                    handlers.encoding ;
+                get = fun k i ->
+                  handler.get k i >>=? fun v1 ->
+                  handlers.get k i >>=? fun v2 ->
+                  return (v1, v2) }
+
+type query = {
+  depth: int ;
+}
+
+let depth_query =
+  let open RPC_query in
+  query (fun depth -> { depth })
+  |+ field "depth" RPC_arg.int 0 (fun t -> t.depth)
+  |> seal
+
+let build_directory : type key. key t -> key RPC_directory.t =
+  fun dir ->
+    let rpc_dir = ref (RPC_directory.empty : key RPC_directory.t) in
+    let register : type ikey. (key, ikey) RPC_path.t -> ikey opt_handler -> unit =
+      fun path (Opt_handler { encoding ; get }) ->
+        let service =
+          RPC_service.get_service
+            ~query: depth_query
+            ~output: encoding
+            path in
+        rpc_dir :=
+          RPC_directory.register !rpc_dir service begin
+            fun k q () ->
+              get k (q.depth + 1) >>=? function
+              | None -> raise Not_found
+              | Some x -> return x
+          end in
+    let rec build_handler : type ikey. ikey t -> (key, ikey) RPC_path.t -> ikey opt_handler =
+      fun dir path ->
+        match !dir with
+        | Empty -> Opt_handler { encoding = Data_encoding.unit ;
+                                 get = fun _ _ -> return None }
+        | Value { get ; encoding } ->
+            let handler =
+              Opt_handler {
+                encoding ;
+                get =
+                  fun k i -> if Compare.Int.(i < 0) then return None else get k
+              } in
+            register path handler ;
+            handler
+        | NamedDir map ->
+            let fields = StringMap.bindings map in
+            let fields =
+              List.map
+                (fun (name, dir) ->
+                   (name, build_handler dir RPC_path.(path / name)))
+                fields in
+            let Handler handler = combine_object fields in
+            let handler =
+              Opt_handler
+                { encoding = handler.encoding ;
+                  get = fun k i ->
+                    if Compare.Int.(i < 0) then
+                      return None
+                    else
+                      handler.get k (i-1) >>=? fun v ->
+                      return (Some v) } in
+            register path handler ;
+            handler
+        | IndexedDir { arg ; arg_encoding ; list ; subdir } ->
+            let Opt_handler handler =
+              build_handler subdir RPC_path.(path /: arg) in
+            let encoding =
+              let open Data_encoding in
+              union [
+                case (Tag 0)
+                  (dynamic_size arg_encoding)
+                  (function (key, None) -> Some key | _ -> None)
+                  (fun key -> (key, None)) ;
+                case (Tag 1)
+                  (tup2
+                     (dynamic_size arg_encoding)
+                     (dynamic_size handler.encoding))
+                  (* (obj2 *)
+                  (* (req "key" (dynamic_size arg_encoding)) *)
+                  (* (req "value" (dynamic_size handler.encoding))) *)
+                  (function (key, Some value) -> Some (key, value) | _ -> None)
+                  (fun (key, value) -> (key, Some value)) ;
+              ] in
+            let get k i =
+              if Compare.Int.(i < 0) then return None
+              else if Compare.Int.(i = 0) then return (Some [])
+              else
+                list k >>=? fun keys ->
+                map_p
+                  (fun key ->
+                     if Compare.Int.(i = 1) then
+                       return (key, None)
+                     else
+                       handler.get (k, key) (i-1) >>=? fun value ->
+                       return (key, value))
+                  keys >>=? fun values ->
+                return (Some values) in
+            let handler =
+              Opt_handler {
+                encoding = Data_encoding.(list (dynamic_size encoding)) ;
+                get ;
+              } in
+            register path handler ;
+            handler in
+    ignore (build_handler dir RPC_path.open_root : key opt_handler) ;
+    !rpc_dir
+

src/proto_alpha/lib_protocol/src/storage_description.mli

@@ -0,0 +1,66 @@
+(**************************************************************************)
+(*                                                                        *)
+(*    Copyright (c) 2014 - 2018.                                          *)
+(*    Dynamic Ledger Solutions, Inc. <contact@tezos.com>                  *)
+(*                                                                        *)
+(*    All rights reserved. No warranty, explicit or implicit, provided.   *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Typed description of the key-value context. *)
+type 'key t
+
+(** Trivial display of the key-value context layout. *)
+val pp: Format.formatter -> 'key t -> unit
+
+(** Export an RPC hierarchy for querying the context. There is one service
+    by possible path in the context. Services for "directory" are able to
+    aggregate in one JSON object the whole subtree. *)
+val build_directory: 'key t -> 'key RPC_directory.t
+
+(** Create a empty context description,
+    keys will be registred by side effects. *)
+val create: unit -> 'key t
+
+(** Register a single key accessor at a given path. *)
+val register_value:
+  'key t ->
+  get:('key -> 'a option tzresult Lwt.t) ->
+  'a Data_encoding.t -> unit
+
+(** Return a description for a prefixed fragment of the given context.
+    All keys registred in the subcontext will be shared by the external
+    context *)
+val register_named_subcontext: 'key t -> string list -> 'key t
+
+(** Description of an index as a sequence of `RPC_arg.t`. *)
+type (_, _, _) args =
+  | One : { rpc_arg: 'a RPC_arg.t ;
+            encoding: 'a Data_encoding.t ;
+            compare: 'a -> 'a -> int } -> ('key, 'a, 'key * 'a) args
+  | Pair : ('key, 'a, 'inter_key) args *
+           ('inter_key, 'b, 'sub_key) args -> ('key, 'a * 'b, 'sub_key) args
+
+(** Return a description for a indexed sub-context.
+    All keys registred in the subcontext will be shared by the external
+    context. One should provide a function to list all the registred
+    index in the context. *)
+val register_indexed_subcontext:
+  'key t ->
+  list:('key -> 'arg list tzresult Lwt.t) ->
+  ('key, 'arg, 'sub_key) args -> 'sub_key t
+
+(** Helpers for manipulating and defining indexes. *)
+
+val pack: ('key, 'a, 'sub_key) args -> 'key -> 'a -> 'sub_key
+val unpack: ('key, 'a, 'sub_key) args -> 'sub_key -> 'key * 'a
+
+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
+  val rpc_arg: t RPC_arg.t
+  val encoding: t Data_encoding.t
+  val compare: t -> t -> int
+end

src/proto_alpha/lib_protocol/src/storage_functors.ml

@@ -77,6 +77,8 @@ module Make_subcontext (C : Raw_context.T) (N : NAME)
   let absolute_key c k = C.absolute_key c (to_key k)
   let consume_gas = C.consume_gas
   let record_bytes_stored = C.record_bytes_stored
+  let description =
+    Storage_description.register_named_subcontext C.description N.name
 end
 
 module Make_single_data_storage (C : Raw_context.T) (N : NAME) (V : VALUE)
@@ -118,6 +120,14 @@ module Make_single_data_storage (C : Raw_context.T) (N : NAME) (V : VALUE)
   let delete t =
     C.delete t N.name >>=? fun t ->
     return (C.project t)
+
+  let () =
+    let open Storage_description in
+    register_value
+      ~get:get_option
+      (register_named_subcontext C.description N.name)
+      V.encoding
+
 end
 
 module Make_single_carbonated_data_storage
@@ -219,6 +229,14 @@ module Make_single_carbonated_data_storage
     match v with
     | None -> remove c
     | Some v -> init_set c v
+
+  let () =
+    let open Storage_description in
+    register_value
+      ~get:(fun c -> get_option c >>=? fun (_, v) -> return v)
+      (register_named_subcontext C.description N.name)
+      V.encoding
+
 end
 
 module type INDEX = sig
@@ -226,6 +244,8 @@ module type INDEX = sig
   val path_length: int
   val to_path: t -> string list -> string list
   val of_path: string list -> t option
+  type 'a ipath
+  val args: ('a, t, 'a ipath) Storage_description.args
 end
 
 module Pair(I1 : INDEX)(I2 : INDEX)
@@ -240,6 +260,8 @@ module Pair(I1 : INDEX)(I2 : INDEX)
         match I1.of_path l1, I2.of_path l2 with
         | Some x, Some y -> Some (x, y)
         | _ -> None
+  type 'a ipath = 'a I1.ipath I2.ipath
+  let args = Storage_description.Pair (I1.args, I2.args)
 end
 
 module Make_data_set_storage (C : Raw_context.T) (I : INDEX)
@@ -290,6 +312,21 @@ module Make_data_set_storage (C : Raw_context.T) (I : INDEX)
   let elements s =
     fold s ~init:[] ~f:(fun p acc -> Lwt.return (p :: acc))
 
+  let () =
+    let open Storage_description in
+    let unpack = unpack I.args in
+    register_value
+      (* TODO fixme 'elements...' *)
+      ~get:(fun c ->
+          let (c, k) = unpack c in
+          mem c k >>= function
+          | true -> return (Some true)
+          | false -> return None)
+      (register_indexed_subcontext
+         ~list:(fun c -> elements c >>= return)
+         C.description I.args)
+      Data_encoding.bool
+
 end
 
 module Make_indexed_data_storage
@@ -371,6 +408,18 @@ module Make_indexed_data_storage
   let keys s =
     fold_keys s ~init:[] ~f:(fun p acc -> Lwt.return (p :: acc))
 
+  let () =
+    let open Storage_description in
+    let unpack = unpack I.args in
+    register_value
+      ~get:(fun c ->
+          let (c, k) = unpack c in
+          get_option c k)
+      (register_indexed_subcontext
+         ~list:(fun c -> keys c >>= return)
+         C.description I.args)
+      V.encoding
+
 end
 
 module Make_indexed_carbonated_data_storage
@@ -536,6 +585,20 @@ module Make_indexed_carbonated_data_storage
   let keys s =
     fold_keys s ~init:[] ~f:(fun p (s, acc) -> return (s, p :: acc))
 
+  let () =
+    let open Storage_description in
+    let unpack = unpack I.args in
+    register_value
+      (* TODO export consumed gas ?? *)
+      ~get:(fun c ->
+          let (c, k) = unpack c in
+          get_option c k >>=? fun (_, v) ->
+          return v)
+      (register_indexed_subcontext
+         ~list:(fun c -> keys c >>=? fun (_, l) -> return l)
+         C.description I.args)
+      V.encoding
+
 end
 
 
@@ -574,54 +637,18 @@ end
 
 module Make_indexed_subcontext (C : Raw_context.T) (I : INDEX)
   : Indexed_raw_context with type t = C.t
-                         and type key = I.t = struct
+                         and type key = I.t
+                         and type 'a ipath = 'a I.ipath = struct
 
   type t = C.t
   type context = t
   type key = I.t
+  type 'a ipath = 'a I.ipath
 
   let clear t =
     C.remove_rec t [] >>= fun t ->
     Lwt.return (C.project t)
 
-  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 copy (t, i) ~from ~to_ =
-      C.copy t ~from:(to_key i from) ~to_:(to_key i to_) >>=? fun t ->
-      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
-    let absolute_key (t, i) k = C.absolute_key t (to_key i k)
-    let consume_gas (t, k) c = C.consume_gas t c >>? fun t -> ok (t, k)
-    let record_bytes_stored (t, k) c = C.record_bytes_stored t c >>? fun t -> ok (t, k)
-  end
-
   let fold_keys t ~init ~f =
     let rec dig i path acc =
       if Compare.Int.(i <= 0) then
@@ -640,6 +667,76 @@ module Make_indexed_subcontext (C : Raw_context.T) (I : INDEX)
     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 description =
+    Storage_description.register_indexed_subcontext
+      ~list:(fun c -> keys c >>= return)
+      C.description
+      I.args
+
+  let unpack = Storage_description.unpack I.args
+  let pack = Storage_description.pack I.args
+
+  module Raw_context = struct
+    type t = C.t I.ipath
+    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 c k = let (t, i) = unpack c in C.mem t (to_key i k)
+    let dir_mem c k = let (t, i) = unpack c in C.dir_mem t (to_key i k)
+    let get c k = let (t, i) = unpack c in C.get t (to_key i k)
+    let get_option c k = let (t, i) = unpack c in C.get_option t (to_key i k)
+    let init c k v =
+      let (t, i) = unpack c in
+      C.init t (to_key i k) v >>=? fun t -> return (pack t i)
+    let set c k v =
+      let (t, i) = unpack c in
+      C.set t (to_key i k) v >>=? fun t -> return (pack t i)
+    let init_set c k v =
+      let (t, i) = unpack c in
+      C.init_set t (to_key i k) v >>= fun t -> Lwt.return (pack t i)
+    let set_option c k v =
+      let (t, i) = unpack c in
+      C.set_option t (to_key i k) v >>= fun t -> Lwt.return (pack t i)
+    let delete c k =
+      let (t, i) = unpack c in
+      C.delete t (to_key i k) >>=? fun t -> return (pack t i)
+    let remove c k =
+      let (t, i) = unpack c in
+      C.remove t (to_key i k) >>= fun t -> Lwt.return (pack t i)
+    let remove_rec c k =
+      let (t, i) = unpack c in
+      C.remove_rec t (to_key i k) >>= fun t -> Lwt.return (pack t i)
+    let copy c ~from ~to_ =
+      let (t, i) = unpack c in
+      C.copy t ~from:(to_key i from) ~to_:(to_key i to_) >>=? fun t ->
+      return (pack t i)
+    let fold c k ~init ~f =
+      let (t, i) = unpack c in
+      C.fold t (to_key i k) ~init
+        ~f:(fun k acc -> f (map_key of_key k) acc)
+    let keys c k =
+      let (t, i) = unpack c in
+      C.keys t (to_key i k) >|= fun keys -> List.map of_key keys
+    let fold_keys c k ~init ~f =
+      let (t, i) = unpack c in
+      C.fold_keys t (to_key i k) ~init ~f:(fun k acc -> f (of_key k) acc)
+    let project c =
+      let (t, _) = unpack c in
+      C.project t
+    let absolute_key c k =
+      let (t, i) = unpack c in
+      C.absolute_key t (to_key i k)
+    let consume_gas c g =
+      let (t, i) = unpack c in
+      C.consume_gas t g >>? fun t -> ok (pack t i)
+    let record_bytes_stored c v =
+      let (t, i) = unpack c in
+      C.record_bytes_stored t v >>? fun t ->
+      ok (pack t i)
+    let description = description
+  end
+
   let resolve t prefix =
     let rec loop i prefix = function
       | [] when Compare.Int.(i = I.path_length) -> begin
@@ -679,12 +776,14 @@ module Make_indexed_subcontext (C : Raw_context.T) (I : INDEX)
     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 mem s i = Raw_context.mem (pack s i) N.name
     let add s i =
-      Raw_context.init_set (s, i) N.name inited >>= fun (s, _) ->
+      Raw_context.init_set (pack s i) N.name inited >>= fun c ->
+      let (s, _) = unpack c in
       Lwt.return (C.project s)
     let del s i =
-      Raw_context.remove (s, i) N.name >>= fun (s, _) ->
+      Raw_context.remove (pack s i) N.name >>= fun c ->
+      let (s, _) = unpack c in
       Lwt.return (C.project s)
     let set s i = function
       | true -> add s i
@@ -693,7 +792,8 @@ module Make_indexed_subcontext (C : Raw_context.T) (I : INDEX)
       fold_keys s
         ~init:s
         ~f:begin fun i s ->
-          Raw_context.remove (s, i) N.name >>= fun (s, _) ->
+          Raw_context.remove (pack s i) N.name >>= fun c ->
+          let (s, _) = unpack c in
           Lwt.return s
         end >>= fun t ->
       Lwt.return (C.project t)
@@ -705,6 +805,19 @@ module Make_indexed_subcontext (C : Raw_context.T) (I : INDEX)
             | false -> Lwt.return acc)
     let elements s =
       fold s ~init:[] ~f:(fun p acc -> Lwt.return (p :: acc))
+
+    let () =
+      let open Storage_description in
+      let unpack = unpack I.args in
+      register_value
+        ~get:(fun c ->
+            let (c, k) = unpack c in
+            mem c k >>= function
+            | true -> return (Some true)
+            | false -> return None)
+        (register_named_subcontext Raw_context.description N.name)
+        Data_encoding.bool
+
   end
 
   module Make_map (N : NAME) (V : VALUE) = struct
@@ -714,42 +827,49 @@ module Make_indexed_subcontext (C : Raw_context.T) (I : INDEX)
     type value = V.t
     include Make_encoder(V)
     let mem s i =
-      Raw_context.mem (s,i) N.name
+      Raw_context.mem (pack s i) N.name
     let get s i =
-      Raw_context.get (s,i) N.name >>=? fun b ->
+      Raw_context.get (pack s i) N.name >>=? fun b ->
-      let key = Raw_context.absolute_key (s,i) N.name in
+      let key = Raw_context.absolute_key (pack s i) N.name in
       Lwt.return (of_bytes ~key b)
     let get_option s i =
-      Raw_context.get_option (s,i) N.name >>= function
+      Raw_context.get_option (pack s i) N.name >>= function
       | None -> return None
       | Some b ->
-          let key = Raw_context.absolute_key (s,i) N.name in
+          let key = Raw_context.absolute_key (pack s i) N.name in
           match of_bytes ~key 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 (to_bytes v) >>=? fun (s, _) ->
+      Raw_context.set (pack s i) N.name (to_bytes v) >>=? fun c ->
+      let (s, _) = unpack c in
       return (C.project s)
     let init s i v =
-      Raw_context.init (s,i) N.name (to_bytes v) >>=? fun (s, _) ->
+      Raw_context.init (pack s i) N.name (to_bytes v) >>=? fun c ->
+      let (s, _) = unpack c in
       return (C.project s)
     let init_set s i v =
-      Raw_context.init_set (s,i) N.name (to_bytes v) >>= fun (s, _) ->
+      Raw_context.init_set (pack s i) N.name (to_bytes v) >>= fun c ->
+      let (s, _) = unpack c in
       Lwt.return (C.project s)
     let set_option s i v =
-      Raw_context.set_option (s,i)
+      Raw_context.set_option (pack s i)
-        N.name (Option.map ~f:to_bytes v) >>= fun (s, _) ->
+        N.name (Option.map ~f:to_bytes v) >>= fun c ->
+      let (s, _) = unpack c in
       Lwt.return (C.project s)
     let remove s i =
-      Raw_context.remove (s,i) N.name >>= fun (s, _) ->
+      Raw_context.remove (pack s i) N.name >>= fun c ->
+      let (s, _) = unpack c in
       Lwt.return (C.project s)
     let delete s i =
-      Raw_context.delete (s,i) N.name >>=? fun (s, _) ->
+      Raw_context.delete (pack s i) N.name >>=? fun c ->
+      let (s, _) = unpack c in
       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, _) ->
+          Raw_context.remove (pack s i) N.name >>= fun c ->
+          let (s, _) = unpack c in
           Lwt.return s
         end >>= fun t ->
       Lwt.return (C.project t)
@@ -769,6 +889,17 @@ module Make_indexed_subcontext (C : Raw_context.T) (I : INDEX)
             | true -> f i acc)
     let keys s =
       fold_keys s ~init:[] ~f:(fun p acc -> Lwt.return (p :: acc))
+
+    let () =
+      let open Storage_description in
+      let unpack = unpack I.args in
+      register_value
+        ~get:(fun c ->
+            let (c, k) = unpack c in
+            get_option c k)
+        (register_named_subcontext Raw_context.description N.name)
+        V.encoding
+
   end
 
   module Make_carbonated_map (N : NAME) (V : CARBONATED_VALUE) = struct
@@ -813,39 +944,40 @@ module Make_indexed_subcontext (C : Raw_context.T) (I : INDEX)
           Lwt.return (Raw_context.consume_gas c (Gas_limit_repr.write_bytes_cost Z.zero)) >>=? fun c ->
           del c (len_name N.name)
     let mem s i =
-      consume_mem_gas (s, i) >>=? fun c ->
+      consume_mem_gas (pack s i) >>=? fun c ->
       Raw_context.mem c N.name >>= fun res ->
       return (Raw_context.project c, res)
     let get s i =
-      consume_read_gas Raw_context.get (s, i) >>=? fun c ->
+      consume_read_gas Raw_context.get (pack s i) >>=? fun c ->
       Raw_context.get c N.name >>=? fun b ->
       let key = Raw_context.absolute_key c N.name in
       Lwt.return (of_bytes ~key b) >>=? fun v ->
       return (Raw_context.project c, v)
     let get_option s i =
-      consume_mem_gas (s, i) >>=? fun (s, _) ->
+      consume_mem_gas (pack s i) >>=? fun c ->
-      Raw_context.mem (s, i) N.name >>= fun exists ->
+      let (s, _) = unpack c in
+      Raw_context.mem (pack s i) N.name >>= fun exists ->
       if exists then
         get s i >>=? fun (s, v) ->
         return (s, Some v)
       else
         return (C.project s, None)
     let set s i v =
-      consume_write_gas Raw_context.set (s, i) v >>=? fun (c, bytes) ->
+      consume_write_gas Raw_context.set (pack s i) v >>=? fun (c, bytes) ->
-      existing_size (s, i) >>=? fun prev_size ->
+      existing_size (pack s i) >>=? fun prev_size ->
       Raw_context.set c N.name bytes >>=? fun c ->
       let size_diff = MBytes.length bytes - prev_size in
       Lwt.return (Raw_context.record_bytes_stored c (Int64.of_int size_diff)) >>=? fun c ->
       return (Raw_context.project c, size_diff)
     let init s i v =
-      consume_write_gas Raw_context.init (s, i) v >>=? fun (c, bytes) ->
+      consume_write_gas Raw_context.init (pack s i) v >>=? fun (c, bytes) ->
       Raw_context.init c N.name bytes >>=? fun c ->
       let size = MBytes.length bytes in
       Lwt.return (Raw_context.record_bytes_stored c (Int64.of_int size)) >>=? fun c ->
       return (Raw_context.project c, size)
     let init_set s i v =
       let init_set c k v = Raw_context.init_set c k v >>= return in
-      consume_write_gas init_set (s, i) v >>=? fun (c, bytes) ->
+      consume_write_gas init_set (pack s i) v >>=? fun (c, bytes) ->
       existing_size c >>=? fun prev_size ->
       init_set c N.name bytes >>=? fun c ->
       let size_diff = MBytes.length bytes - prev_size in
@@ -853,14 +985,14 @@ module Make_indexed_subcontext (C : Raw_context.T) (I : INDEX)
       return (Raw_context.project c, size_diff)
     let remove s i =
       let remove c k = Raw_context.remove c k >>= return in
-      consume_remove_gas remove (s, i) >>=? fun c ->
+      consume_remove_gas remove (pack s i) >>=? fun c ->
-      existing_size (s, i) >>=? fun prev_size ->
+      existing_size (pack s i) >>=? fun prev_size ->
       remove c N.name >>=? fun c ->
       Lwt.return (Raw_context.record_bytes_stored c (Int64.of_int ~-prev_size)) >>=? fun c ->
       return (Raw_context.project c, prev_size)
     let delete s i =
-      consume_remove_gas Raw_context.delete (s, i) >>=? fun c ->
+      consume_remove_gas Raw_context.delete (pack s i) >>=? fun c ->
-      existing_size (s, i) >>=? fun prev_size ->
+      existing_size (pack s i) >>=? fun prev_size ->
       Raw_context.delete c N.name >>=? fun c ->
       Lwt.return (Raw_context.record_bytes_stored c (Int64.of_int ~-prev_size)) >>=? fun c ->
       return (Raw_context.project c, prev_size)
@@ -873,10 +1005,13 @@ module Make_indexed_subcontext (C : Raw_context.T) (I : INDEX)
         ~f:begin fun i s ->
           Lwt.return s >>=? fun (s, total) ->
           let remove c k = Raw_context.remove c k >>= return in
-          consume_remove_gas remove (s, i) >>=? fun (s, _) ->
+          consume_remove_gas remove (pack s i) >>=? fun c ->
-          existing_size (s, i) >>=? fun prev_size ->
+          let (s, _) = unpack c in
-          remove (s,i) N.name >>=? fun (s, _) ->
+          existing_size (pack s i) >>=? fun prev_size ->
-          Lwt.return (Raw_context.record_bytes_stored (s, i) (Int64.of_int ~-prev_size)) >>=? fun (s, _) ->
+          remove (pack s i) N.name >>=? fun c ->
+          let (s, _) = unpack c in
+          Lwt.return (Raw_context.record_bytes_stored (pack s i) (Int64.of_int ~-prev_size)) >>=? fun c ->
+          let (s, _) = unpack c in
           return (s, Z.add total (Z.of_int prev_size))
         end >>=? fun (s, total) ->
       return (C.project s, total)
@@ -884,9 +1019,10 @@ module Make_indexed_subcontext (C : Raw_context.T) (I : INDEX)
       fold_keys s ~init:(ok (s, init))
         ~f:(fun i acc ->
             Lwt.return acc >>=? fun (s, acc) ->
-            consume_read_gas Raw_context.get (s, i) >>=? fun (s, _) ->
+            consume_read_gas Raw_context.get (pack s i) >>=? fun c ->
-            Raw_context.get (s, i) N.name >>=? fun b ->
+            let (s, _) = unpack c in
-            let key = Raw_context.absolute_key (s, i) N.name in
+            Raw_context.get (pack s i) N.name >>=? fun b ->
+            let key = Raw_context.absolute_key (pack s i) N.name in
             Lwt.return (of_bytes ~key b) >>=? fun v ->
             f i v (s, acc)) >>=? fun (s, v) ->
       return (C.project s, v)
@@ -896,14 +1032,28 @@ module Make_indexed_subcontext (C : Raw_context.T) (I : INDEX)
       fold_keys s ~init:(ok (s, init))
         ~f:(fun i acc ->
             Lwt.return acc >>=? fun (s, acc) ->
-            consume_mem_gas (s, i) >>=? fun (s, _) ->
+            consume_mem_gas (pack s i) >>=? fun c ->
-            Raw_context.mem (s, i) N.name >>= function
+            let (s, _) = unpack c in
+            Raw_context.mem (pack s i) N.name >>= function
             | false -> return (s, acc)
             | true -> f i (s, acc)) >>=? fun (s, v) ->
       return (C.project s, v)
     let keys s =
       fold_keys s ~init:[] ~f:(fun p (s, acc) -> return (s, p :: acc))
+
+    let () =
+      let open Storage_description in
+      let unpack = unpack I.args in
+      register_value
+        ~get:(fun c ->
+            let (c, k) = unpack c in
+            get_option c k >>=? fun (_, v) ->
+            return v)
+        (register_named_subcontext Raw_context.description N.name)
+        V.encoding
+
   end
+
 end
 
 module Wrap_indexed_data_storage

src/proto_alpha/lib_protocol/src/storage_functors.mli

@@ -31,6 +31,8 @@ module type INDEX = sig
   val path_length: int
   val to_path: t -> string list -> string list
   val of_path: string list -> t option
+  type 'a ipath
+  val args: ('a, t, 'a ipath) Storage_description.args
 end
 
 module Pair(I1 : INDEX)(I2 : INDEX) : INDEX with type t = I1.t * I2.t
@@ -60,6 +62,7 @@ module Make_indexed_data_snapshotable_storage (C : Raw_context.T)
 module Make_indexed_subcontext (C : Raw_context.T) (I : INDEX)
   : Indexed_raw_context with type t = C.t
                          and type key = I.t
+                         and type 'a ipath = 'a I.ipath
 
 module Wrap_indexed_data_storage
     (C : Indexed_data_storage)

src/proto_alpha/lib_protocol/src/storage_sigs.ml

@@ -389,6 +389,7 @@ module type Indexed_raw_context = sig
   type t
   type context = t
   type key
+  type 'a ipath
 
   val clear: context -> Raw_context.t Lwt.t
 
@@ -412,6 +413,6 @@ module type Indexed_raw_context = sig
                                        and type key = key
                                        and type value = V.t
 
-  module Raw_context : Raw_context.T with type t = t * key
+  module Raw_context : Raw_context.T with type t = t ipath
 
 end

vendors/ocplib-resto/lib_resto-directory/resto_directory.ml

@@ -273,21 +273,21 @@ module Make (Encoding : ENCODING) = struct
         end
       | DynamicTail ( _, dir) -> describe_directory ~recurse dir
       | Static dir ->
-          describe_static_directory recurse arg dir >>= fun dir ->
+          describe_static_directory recurse dir >>= fun dir ->
           Lwt.return (Static dir : Encoding.schema Description.directory)
 
   and describe_static_directory
     : type a.
-      bool -> a option -> a static_directory ->
+      bool -> a static_directory ->
       Encoding.schema Description.static_directory Lwt.t
-    = fun recurse arg dir ->
+    = fun recurse dir ->
       let services = MethMap.map describe_service dir.services in
       begin
         if recurse then
           match dir.subdirs with
           | None -> Lwt.return_none
           | Some subdirs ->
-              describe_static_subdirectories arg subdirs >>= fun dirs ->
+              describe_static_subdirectories subdirs >>= fun dirs ->
               Lwt.return (Some dirs)
         else
           Lwt.return_none
@@ -296,14 +296,14 @@ module Make (Encoding : ENCODING) = struct
 
   and describe_static_subdirectories
     : type a.
-      a option -> a static_subdirectories ->
+      a static_subdirectories ->
       Encoding.schema Description.static_subdirectories Lwt.t
-    = fun arg dir ->
+    = fun dir ->
       match dir with
       | Suffixes map ->
           StringMap.fold (fun key dir map ->
               map >>= fun map ->
-              describe_directory ~recurse:true ?arg dir >>= fun dir ->
+              describe_directory ~recurse:true dir >>= fun dir ->
               Lwt.return (StringMap.add key dir map))
             map (Lwt.return StringMap.empty) >>= fun map ->
           Lwt.return (Suffixes map : Encoding.schema Description.static_subdirectories)