Shell: added rpc to inspect context of a block

Added a block_service and corresponding handler in the node to perform
queries of the form '/blocks/<id>/raw_context/<path>?depth=<n>'
returning the sub-tree corresponding to <path> inside the context of
block <id>. The parameter <depth> controls the size of the tree,
default is 1.

src/lib_shell/node.ml

@@ -561,6 +561,34 @@ module RPC = struct
         let dir = RPC_directory.map (fun () -> Lwt.return rpc_context) Proto.rpc_services in
         Lwt.return (Some (RPC_directory.map (fun _ -> ()) dir))
 
+  let context_raw_get node block ~path ~depth =
+    let open Block_services in
+    (* negative depth could be handled by a more informative error *)
+    if depth < 0 then Lwt.return_none else
+      get_rpc_context node block >>= function
+      | None -> Lwt.return_none
+      | Some rpc_context ->
+          let rec loop path depth = (* non tail-recursive *)
+            if depth = 0 then Lwt.return Cut else
+              (* try to read as file *)
+              Context.get rpc_context.context path >>= function
+              | Some v -> Lwt.return (Key v)
+              | None -> (* try to read as directory *)
+                  Context.fold rpc_context.context path ~init:[]
+                    ~f:(fun k acc ->
+                        match k with
+                        | `Key k | `Dir k ->
+                            loop k (depth-1) >>= fun v ->
+                            let k = List.nth k ((List.length k)-1) in
+                            Lwt.return ((k,v)::acc)) >>= fun l ->
+                  Lwt.return (Dir (List.rev l))
+          in
+          Context.mem rpc_context.context path >>= fun mem ->
+          Context.dir_mem rpc_context.context path >>= fun dir_mem ->
+          if mem || dir_mem then
+            loop path depth >>= Lwt.return_some
+          else Lwt.return_none
+
   let heads node =
     let chain_state = Chain_validator.chain_state node.mainchain_validator in
     Chain.known_heads chain_state >>= fun heads ->

src/lib_shell/node.mli

@@ -112,6 +112,14 @@ module RPC : sig
   val context_dir:
     t -> block -> 'a RPC_directory.t option Lwt.t
 
+  (** Returns the content of the context at the given [path] descending
+      recursively into directories as far as [depth] allows.
+      Returns [None] if a path in not in the context or if [depth] is
+      negative. *)
+  val context_raw_get:
+    t -> block -> path:string list -> depth:int ->
+    Block_services.raw_context_result option Lwt.t
+
   val preapply:
     t -> block ->
     timestamp:Time.t -> protocol_data:MBytes.t ->

src/lib_shell/node_rpc.ml

@@ -436,6 +436,13 @@ let build_rpc_directory node =
   let dir =
     RPC_directory.register2 dir Block_services.S.complete
       (fun block s () () -> Node.RPC.complete node ~block s >>= return) in
+  let dir =
+    RPC_directory.register2 dir Block_services.S.raw_context
+      (fun block path q () ->
+         Node.RPC.context_raw_get node block ~path ~depth:q#depth >>= function
+         | None -> raise Not_found
+         | Some v -> return v)
+  in
 
   (* Workers : Prevalidators *)
 

src/lib_shell_services/block_services.ml

@@ -153,6 +153,23 @@ let preapply_result_encoding =
         (req "operations"
            (list (Preapply_result.encoding RPC_error.encoding)))))
 
+type raw_context_result =
+  | Key of MBytes.t
+  | Dir of (string * raw_context_result) list
+  | Cut
+
+let raw_context_result_pp t =
+  let open Format in
+  let rec loop ppf = function
+    | Cut -> fprintf ppf "..."
+    | Key v -> let `Hex s = MBytes.to_hex v in fprintf ppf "%S" s
+    | Dir l ->
+        fprintf ppf "{@[<v 1>@,%a@]@,}"
+          (pp_print_list ~pp_sep:Format.pp_print_cut
+             (fun ppf (s,t) -> fprintf ppf "%s : %a" s loop t)) l
+  in
+  asprintf "%a" loop t
+
 module S = struct
 
   let blocks_arg =
@@ -239,6 +256,47 @@ module S = struct
       ~output: (obj1 (req "context" Context_hash.encoding))
       RPC_path.(block_path / "context")
 
+  let raw_context_args : 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 raw_context_result_encoding : raw_context_result Data_encoding.t =
+    let open Data_encoding in
+    obj1 (req "content"
+            (mu "context_tree" (fun raw_context_result_encoding ->
+                 union [
+                   case (Tag 0) bytes
+                     (function Key k -> Some k | _ -> None)
+                     (fun k -> Key k) ;
+                   case (Tag 1) (assoc raw_context_result_encoding)
+                     (function Dir k -> Some k | _ -> None)
+                     (fun k -> Dir k) ;
+                   case (Tag 2) null
+                     (function Cut -> Some () | _ -> None)
+                     (fun () -> Cut) ;
+                 ])))
+
+  (* The depth query argument for the [raw_context] service,
+     default value is 1. *)
+  let depth_query : < depth: int > RPC_query.t =
+    let open RPC_query in
+    query (fun depth -> object
+            method depth = depth
+          end)
+    |+ field "depth" RPC_arg.int 1 (fun t -> t#depth)
+    |> seal
+
+  let raw_context =
+    RPC_service.post_service
+      ~description:"Returns the raw context."
+      ~query: depth_query
+      ~input: empty
+      ~output: raw_context_result_encoding
+      RPC_path.(block_path / "raw_context" /:* raw_context_args)
+
   let timestamp =
     RPC_service.post_service
       ~description:"Returns the block's timestamp."
@@ -508,3 +566,10 @@ let unmark_invalid ctxt h =
 
 let list_invalid ctxt =
   make_call S.list_invalid ctxt () () ()
+
+let raw_context ctxt b key depth =
+  let depth = object
+    method depth = depth
+  end
+  in
+  make_call2 S.raw_context ctxt b key depth ()

src/lib_shell_services/block_services.mli

@@ -102,6 +102,21 @@ val preapply:
 val complete:
   #simple -> block -> string -> string list tzresult Lwt.t
 
+(** Encodes a directory structure returned from a context
+    query as a tree plus a special case [Cut] used when
+    the query is limited by a [depth] value.
+    [Cut] is encoded as [null] in json. *)
+type raw_context_result =
+  | Key of MBytes.t
+  | Dir of (string * raw_context_result) list
+  | Cut
+
+(** Pretty-printer for raw_context_result *)
+val raw_context_result_pp : raw_context_result -> string
+
+val raw_context:
+  #simple -> block -> string list -> int -> raw_context_result tzresult Lwt.t
+
 val monitor_prevalidated_operations:
   ?contents:bool ->
   #streamed ->
@@ -112,7 +127,8 @@ val unmark_invalid:
 val list_invalid:
   #simple -> (Block_hash.t * int32 * error list) list tzresult Lwt.t
 
-
+(** Signatures of all RPCs.
+    This module is shared between the Client and the Node. *)
 module S : sig
 
   val blocks_arg : block RPC_arg.arg
@@ -154,6 +170,19 @@ module S : sig
      unit * block, unit, unit,
      Context_hash.t) RPC_service.t
 
+  (** Accepts queries of the form
+      /blocks/<id>/raw_context/<path>?depth=<n>
+      returning the sub-tree corresponding to <path> inside the context of
+      block <id>. The optional parameter <depth> controls the size of the
+      tree, default is 1.
+      Example:
+      tezos-client rpc call /blocks/head/raw_context/v1?depth=2
+  *)
+  val raw_context:
+    ([ `POST ], unit,
+     (unit * block) * string list, <depth:int>, unit,
+     raw_context_result) RPC_service.t
+
   type operations_param = {
     contents: bool ;
     monitor: bool ;