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

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

Browse Source 
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
}
```
This commit is contained in:
Grégoire Henry 2018-04-24 02:17:25 +02:00 committed by Benjamin Canou
parent 74acad1472
commit 33c3d1fcbd
29 changed files with 740 additions and 191 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
src/bin_client/test/test_basic.sh
View File

@ -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/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/version' | assert '"616c706861"'
$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/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/non-existent?depth=0' | assert 'No service found at this URL'
$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/bytes/non-existent?depth=0' | assert 'No service found at this URL'
bake

7
src/lib_protocol_environment/sigs/v1/RPC_directory.mli
View File

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

2
src/lib_shell/block_directory.ml
View File

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

14
src/lib_shell_services/block_services.ml
View File

@ -648,11 +648,7 @@ module Make(Proto : PROTO)(Next_proto : PROTO) = struct
module Context = struct
let path = RPC_path.(path / "context")
module Raw = struct
let path = RPC_path.(path / "raw")
let path = RPC_path.(path / "context" / "raw" / "bytes")
let context_path_arg : string RPC_arg.t =
let name = "context_path" in
@ -678,8 +674,6 @@ module Make(Proto : PROTO)(Next_proto : PROTO) = struct
end
end
let info =
RPC_service.get_service
~description:"All the information about a block."
@ -872,10 +866,6 @@ module Make(Proto : PROTO)(Next_proto : PROTO) = struct
module S = S.Context
module Raw = struct
module S = S.Raw
let read ctxt =
let f = make_call1 S.read ctxt in
fun ?(chain = `Main) ?(block = `Head 0) ?depth path ->
@ -884,8 +874,6 @@ module Make(Proto : PROTO)(Next_proto : PROTO) = struct
end
end
module Helpers = struct
module S = S.Helpers

8
src/lib_shell_services/block_services.mli
View File

@ -222,8 +222,6 @@ module Make(Proto : PROTO)(Next_proto : PROTO) : sig
module Context : sig
module Raw : sig
val read:
#simple -> ?chain:chain -> ?block:block ->
?depth: int ->
@ -231,8 +229,6 @@ module Make(Proto : PROTO)(Next_proto : PROTO) : sig
end
end
module Helpers : sig
module Forge : sig
@ -433,8 +429,6 @@ module Make(Proto : PROTO)(Next_proto : PROTO) : sig
module Context : sig
module Raw : sig
val read:
([ `GET ], prefix,
prefix * string list, < depth : int option >, unit,
@ -442,8 +436,6 @@ module Make(Proto : PROTO)(Next_proto : PROTO) : sig
end
end
module Helpers : sig
module Forge : sig

2
src/proto_alpha/lib_baking/test/proto_alpha_helpers.ml
View File

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

1
src/proto_alpha/lib_protocol/src/TEZOS_PROTOCOL
View File

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

2
src/proto_alpha/lib_protocol/src/alpha_context.ml
View File

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

2
src/proto_alpha/lib_protocol/src/alpha_context.mli
View File

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

4
src/proto_alpha/lib_protocol/src/blinded_public_key_hash.ml
View File

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

7
src/proto_alpha/lib_protocol/src/blinded_public_key_hash.mli
View File

@ -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
type nonrec t = t
val path_length : int
val to_path : t -> string list -> string list
val of_path : string list -> t option
end
module Index : Storage_description.INDEX with type t = t

3
src/proto_alpha/lib_protocol/src/contract_repr.ml
View File

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

5
src/proto_alpha/lib_protocol/src/contract_repr.mli
View File

@ -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
val path_length: int
val to_path: t -> string list -> string list
val of_path: string list -> t option
include Storage_description.INDEX with type t = t
val contract_prefix: string -> string list
val pkh_prefix_ed25519: string -> string list
val pkh_prefix_secp256k1: string -> string list

3
src/proto_alpha/lib_protocol/src/cycle_repr.ml
View File

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

8
src/proto_alpha/lib_protocol/src/cycle_repr.mli
View File

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

4
src/proto_alpha/lib_protocol/src/raw_context.ml
View File

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

2
src/proto_alpha/lib_protocol/src/raw_context.mli
View File

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

3
src/proto_alpha/lib_protocol/src/raw_level_repr.ml
View File

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

7
src/proto_alpha/lib_protocol/src/raw_level_repr.mli
View File

@ -28,9 +28,4 @@ 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
module Index : Storage_description.INDEX with type t = raw_level

6
src/proto_alpha/lib_protocol/src/roll_repr.ml
View File

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

7
src/proto_alpha/lib_protocol/src/roll_repr.mli
View File

@ -23,9 +23,4 @@ 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
module Index : Storage_description.INDEX with type t = roll

13
src/proto_alpha/lib_protocol/src/services_registration.ml
View File

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

66
src/proto_alpha/lib_protocol/src/storage.ml
View File

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

291
src/proto_alpha/lib_protocol/src/storage_description.ml Normal file
View File

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

66
src/proto_alpha/lib_protocol/src/storage_description.mli Normal file
View File

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

304
src/proto_alpha/lib_protocol/src/storage_functors.ml
View File

@ -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 ->
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)
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)
N.name (Option.map ~f:to_bytes v) >>= fun (s, _) ->
Raw_context.set_option (pack s i)
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, _) ->
Raw_context.mem (s, i) N.name >>= fun exists ->
consume_mem_gas (pack s i) >>=? fun c ->
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) ->
existing_size (s, i) >>=? fun prev_size ->
consume_write_gas Raw_context.set (pack s i) v >>=? fun (c, bytes) ->
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 ->
existing_size (s, i) >>=? fun prev_size ->
consume_remove_gas remove (pack s i) >>=? fun c ->
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 ->
existing_size (s, i) >>=? fun prev_size ->
consume_remove_gas Raw_context.delete (pack s i) >>=? fun c ->
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, _) ->
existing_size (s, i) >>=? fun prev_size ->
remove (s,i) N.name >>=? fun (s, _) ->
Lwt.return (Raw_context.record_bytes_stored (s, i) (Int64.of_int ~-prev_size)) >>=? fun (s, _) ->
consume_remove_gas remove (pack s i) >>=? fun c ->
let (s, _) = unpack c in
existing_size (pack s i) >>=? fun prev_size ->
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, _) ->
Raw_context.get (s, i) N.name >>=? fun b ->
let key = Raw_context.absolute_key (s, i) N.name in
consume_read_gas Raw_context.get (pack s i) >>=? fun c ->
let (s, _) = unpack c 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, _) ->
Raw_context.mem (s, i) N.name >>= function
consume_mem_gas (pack s i) >>=? fun c ->
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

3
src/proto_alpha/lib_protocol/src/storage_functors.mli
View File

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

3
src/proto_alpha/lib_protocol/src/storage_sigs.ml
View File

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

14
vendors/ocplib-resto/lib_resto-directory/resto_directory.ml vendored
View File

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