Docs/RPC: fix doc generation

The current doc generator does not handles path were multiple method
are registred. The fix remove the intermediate (compilation) tree.

docs/doc_gen/rpcs/jbuild

@@ -4,20 +4,24 @@
  ((name rpc_doc)
   (libraries
    (tezos-base
-    tezos-rpc-http
+    tezos-stdlib-unix
-    tezos-client-base
+    tezos-shell
-    tezos-client-commands
+    tezos-protocol-updater
-    tezos-client-base-unix))
+    tezos-embedded-protocol-alpha
+    re))
   (flags (:standard -w -9+27-30-32-40@8
           -safe-string
           -open Tezos_base__TzPervasives
-          -open Tezos_rpc_http
+          -open Tezos_stdlib_unix
-          -open Tezos_client_base
+          -open Tezos_shell
-          -open Tezos_client_commands
+          -open Tezos_protocol_updater
-          -open Tezos_client_base_unix
           -linkall))
 ))
 
+(alias
+ ((name buildtest)
+  (deps (rpc_doc.exe))))
+
 (alias
  ((name runtest_indent)
   (deps ((glob_files *.ml{,i})))

docs/doc_gen/rpcs/rpc_doc.ml

@@ -7,518 +7,414 @@
 (*                                                                        *)
 (**************************************************************************)
 
-type service_repr =
+let protocols = [
-  { path : string list ;
+  "Alpha", "ProtoALphaALphaALphaALphaALphaALphaALphaALphaDdp3zK" ;
-    meth : Resto.meth ;
+]
-    description : string ;
+
-    query : Resto.Description.query_item list ;
+module Rst = struct
-    input : Json_schema.schema option ;
+
-    output : Json_schema.schema option ;
+  let pp_title ~char ppf title =
-    example : string option ;
+    let sub = String.map (fun _ -> char) title in
-    error : Json_schema.schema option
+    Format.fprintf ppf "@[<v 0>%s@ %s@ @ @]" title sub
+
+  let pp_h1 = pp_title ~char:'#'
+  let pp_h2 = pp_title ~char:'*'
+  let pp_h3 = pp_title ~char:'='
+  let pp_h4 = pp_title ~char:'`'
+
+  let pp_raw_html ppf str =
+    Format.fprintf ppf "@[<v>.. raw:: html@   @   %s@ @ @]"
+      (Re.Str.global_replace (Re.Str.regexp "\n") "\n  " str)
+
+  let pp_html ppf f =
+    Format.fprintf ppf
+      "@[<v 2>.. raw:: html@ @ %a@]@\n@\n"
+      (fun ppf () -> f ppf) ()
+
+  let pp_ref ppf name = Format.fprintf ppf ".. _%s :@\n@\n" name
+
+end
+
+let pp_name ppf = function
+  | [] | [""] -> Format.pp_print_string ppf "/"
+  | prefix -> Format.pp_print_string ppf (String.concat "/" prefix)
+
+let ref_of_service (prefix, meth) =
+  Format.asprintf "%s_%s"
+    (Resto.string_of_meth meth)
+    (Re.Str.global_replace
+       (Re.Str.regexp "<\\([^>]*\\)>")
+       "\\1"
+       (String.concat "--" prefix))
+
+module Index = struct
+
+  let rec pp prefix ppf dir =
+    let open Resto.Description in
+    match dir with
+    | Empty -> Format.fprintf ppf "Empty"
+    | Static { services ; subdirs = None } ->
+        pp_services prefix ppf services
+    | Static { services ; subdirs = Some (Suffixes map) } ->
+        Format.fprintf ppf "@[<v 2>%a@ @ %a@]"
+          (pp_services prefix) services
+          (Format.pp_print_list
+             ~pp_sep:(fun ppf () -> Format.fprintf ppf "@ @ ")
+             (pp_suffixes prefix))
+          (Resto.StringMap.bindings map)
+    | Static { services ; subdirs = Some (Arg (arg, dir)) } ->
+        let name = Format.asprintf "<%s>" arg.name in
+        Format.fprintf ppf "@[<v 2>%a@ @ %a@]"
+          (pp_services prefix) services
+          (pp_suffixes prefix) (name, dir)
+    | Dynamic _ ->
+        Format.fprintf ppf "* %a (<dyn>)" pp_name prefix
+
+  and pp_suffixes prefix ppf (name, dir) =
+    pp (prefix @ [name]) ppf dir
+
+  and pp_services prefix ppf services =
+    match (Resto.MethMap.bindings services) with
+    | [] ->
+        Format.fprintf ppf "* %a" pp_name prefix
+    | _ :: _ as services ->
+        Format.fprintf ppf "* %a (@[<h>%a@])"
+          pp_name prefix
+          (Format.pp_print_list
+             ~pp_sep:Format.pp_print_space
+             (pp_service_method prefix)) services
+
+  and pp_service_method prefix ppf (meth, _service) =
+    Format.fprintf ppf "`%s <%s_>`_"
+      (Resto.string_of_meth meth)
+      (ref_of_service (prefix, meth))
+
+end
+
+module Description = struct
+
+  module Query = struct
+
+    let pp_arg fmt =
+      let open RPC_arg in
+      function { name ; _ } ->
+        Format.fprintf fmt "<%s>" name
+
+    let pp_title_item ppf =
+      let open RPC_description in
+      function {name ; kind ; _ } ->
+      match kind with
+      | Single arg | Optional arg ->
+          Format.fprintf ppf "[%s=%a]" name pp_arg arg
+      | Flag ->
+          Format.fprintf ppf "[%s]" name
+      | Multi arg ->
+          Format.fprintf ppf "(%s=%a)\\*" name pp_arg arg
+
+    let pp_title ppf query =
+      Format.fprintf ppf "%s%a"
+        (if query = [] then "" else "?")
+        (Format.pp_print_list
+           ~pp_sep:(fun ppf () -> Format.fprintf ppf "&")
+           pp_title_item) query
+
+    let pp_html_arg fmt =
+      let open RPC_arg in
+      function { name ; _ } ->
+        Format.fprintf fmt "&lt;%s&gt;" name
+
+    let pp_item ppf =
+      let open RPC_description in
+      function { name ; description ; kind } ->
+        begin match kind with
+          | Single arg
+          | Optional arg
+          | Multi arg ->
+              Format.fprintf ppf
+                "<span class=\"query\">%s = %a</span>"
+                name pp_html_arg arg
+          | Flag ->
+              Format.fprintf ppf
+                "<span class=\"query\">%s</span>"
+                name
+        end ;
+        begin match description with
+          | None -> ()
+          | Some descr -> Format.fprintf ppf " : %s" descr
+        end
+
+    let pp ppf query =
+      match query with
+      | [] -> ()
+      | _ :: _ as query ->
+          Format.fprintf ppf
+            "</p> <p>Optional query arguments :<ul><li>%a</li></ul>"
+            (Format.pp_print_list
+               ~pp_sep:(fun ppf () -> Format.fprintf ppf "</li><li>")
+               pp_item)
+            query
+
+  end
+
+  module Tabs = struct
+
+    let pp_tab_div ppf f =
+      Format.fprintf ppf
+        "@[<v 2><div class=\"tab\">%a</div>@]"
+        (fun ppf () -> f ppf) ()
+
+    let pp_tabcontent_div ~id ~class_ ppf f =
+      Format.fprintf ppf
+        "@[<v 2><div id=\"%s\" class=\"%s tabcontent\">@ \
+         %a@ \
+         @]</div>@ "
+        id class_ (fun ppf () -> f ppf) ()
+
+    let pp_button ppf ?(default=false) ~shortlabel ~content target_ref =
+      Format.fprintf ppf
+        "<button class=\"tablinks%s\" onclick=\"showTab(this, '%s', '%s')\">%s</button>@ "
+        (if default then " defaultOpen" else "")
+        (target_ref ^ shortlabel)
+        target_ref
+        content
+
+    let pp_content ppf ~tag ~shortlabel target_ref pp_content content =
+      pp_tabcontent_div
+        ~id:(target_ref ^ shortlabel) ~class_:target_ref ppf
+        begin fun ppf ->
+          Format.fprintf ppf "<%s>@ %a</%s>" tag pp_content content tag
+        end
+
+    let pp_description ppf (service : _ RPC_description.service) =
+      let open RPC_description in
+      (* TODO collect and display arg description (in path and in query) *)
+      Format.fprintf ppf "%s%a"
+        (Option.unopt ~default:"" service.description)
+        Query.pp service.query
+
+    let pp ppf prefix service =
+      let open RPC_description in
+      let target_ref = ref_of_service (prefix, service.meth) in
+      Rst.pp_html ppf begin fun ppf ->
+        pp_tab_div ppf begin fun ppf ->
+          pp_button ppf
+            ~default:true ~shortlabel:"descr" ~content:"Description"
+            target_ref ;
+          Option.iter service.input ~f: begin fun __ ->
+            pp_button ppf
+              ~default:false ~shortlabel:"input" ~content:"Input format"
+              target_ref
+          end ;
+          pp_button ppf
+            ~default:false ~shortlabel:"output" ~content:"Output format"
+            target_ref ;
+        end ;
+        pp_content ppf
+          ~tag:"p" ~shortlabel:"descr" target_ref
+          pp_description service ;
+        Option.iter service.input ~f: begin fun schema ->
+          pp_content ppf
+            ~tag:"pre" ~shortlabel:"input" target_ref
+            Json_schema.pp schema ;
+        end ;
+        pp_content ppf
+          ~tag:"pre" ~shortlabel:"output" target_ref
+          Json_schema.pp service.output ;
+      end
+
+  end
+
+  let rec pp prefix ppf dir =
+    let open Resto.Description in
+    match dir with
+    | Empty -> ()
+    | Static { services ; subdirs = None } ->
+        pp_services prefix ppf services
+    | Static { services ; subdirs = Some (Suffixes map) } ->
+        pp_services prefix ppf services ;
+        Format.pp_print_list (pp_suffixes prefix)
+          ppf (Resto.StringMap.bindings map)
+    | Static { services ; subdirs = Some (Arg (arg, dir)) } ->
+        let name = Format.asprintf "<%s>" arg.name in
+        pp_services prefix ppf services ;
+        pp_suffixes prefix ppf (name, dir)
+    | Dynamic _ -> ()
+
+  and pp_suffixes prefix ppf (name, dir) =
+    pp (prefix @ [name]) ppf dir
+
+  and pp_services prefix ppf services =
+    List.iter
+      (pp_service prefix ppf)
+      (Resto.MethMap.bindings services)
+
+  and pp_service prefix ppf (meth, service) =
+    Rst.pp_ref ppf (ref_of_service (prefix, meth)) ;
+    Format.fprintf ppf "**%s %a%a**@\n@\n"
+      (Resto.string_of_meth meth)
+      pp_name prefix
+      Query.pp_title service.query ;
+    Tabs.pp ppf prefix service
+
+end
+
+let style = {css|
+<style>
+  .tab {
+    overflow: hidden;
+    border: 1px solid #ccc;
+    background-color: #f1f1f1;
+  }
+  .tab button {
+    background-color: inherit;
+    float: left;
+    border: none;
+    outline: none;
+    cursor: pointer;
+    padding: 5px 10px;
+  }
+  .tab button:hover {
+    background-color: #ddd;
+  }
+  .tab button.active {
+    background-color: #ccc;
+  }
+  .tabcontent {
+    display: none;
+    padding: 6px 12px;
+    border: 1px solid #ccc;
+    border-top: none;
+    max-height: 40ex;
+    margin-bottom: 7ex;
+    overflow: auto;
+  }
+  .tabcontent p {
+    margin-bottom: 12px;
+  }
+  pre {
+    font-size: 12px
+  }
+  .rst-content .section ul p {
+    margin-bottom: 0;
+  }
+  span.query {
+    font-family: monospace;
+    white-space: pre;
+  }
+</style>
+|css}
+
+let script = {script|
+<script>
+  function showTab(elt, tab, ref) {
+    var i, tabcontent, tablinks;
+    tabcontent = document.getElementsByClassName(ref);
+    for (i = 0; i < tabcontent.length; i++) {
+      tabcontent[i].style.display = 'none';
+    }
+
+    tablinks = elt.parentNode.children;
+    for (i = 0; i < tablinks.length; i++) {
+      tablinks[i].className = tablinks[i].className.replace(' active', '');
+    }
+
+    document.getElementById(tab).style.display = 'block';
+    elt.className += ' active';
   }
 
-type service_tree =
+  document.addEventListener('DOMContentLoaded', function() {
-  | Root of service_tree list
+    var a = document.getElementsByClassName('defaultOpen');
-  | Node of service_repr * service_tree list
+    for (i = 0; i < a.length; i++) { a[i].click() }
-  | SymbNode of string list * service_tree list
+  })
+</script>
+|script}
 
-let make_descr = function
-  | None | Some "" -> "No description"
-  | Some s -> s
 
-(** Inspect a JSON schema: if it doesn't contain any field (e.g. { }),
+let pp_document ppf descriptions =
-    return None *)
+  (* Style : hack *)
-let normalize_json_schema = function
+  Format.fprintf ppf "%a@." Rst.pp_raw_html style ;
-  | None -> None
+  (* Script : hack *)
-  | Some schema ->
+  Format.fprintf ppf "%a@." Rst.pp_raw_html script ;
-      let open Json_schema in
+  (* Page title *)
-      let elt = root schema in
+  Format.fprintf ppf "%a" Rst.pp_h1 "RPC API" ;
-      match elt.kind with
+  (* include/copy usage.rst from input  *)
-      | Object specs when
+  let rec loop () =
-          specs = object_specs ||
+    let s = read_line () in
-          specs = { object_specs with additional_properties = None } ->
+    Format.fprintf ppf "%s@\n" s ;
-          None
+    loop () in
-      | _ -> Some schema
+  begin try loop () with End_of_file -> () end ;
+  Format.fprintf ppf "@\n" ;
+  (* Index *)
+  Format.pp_set_margin ppf 10000 ;
+  Format.pp_set_max_indent ppf 9000 ;
+  List.iter
+    (fun (name, prefix, rpc_dir) ->
+       Rst.pp_h2 ppf (Format.asprintf "%s RPCs - Index" name) ;
+       Format.fprintf ppf "%a@\n@\n" (Index.pp prefix) rpc_dir)
+    descriptions ;
+  (* Full description *)
+  Format.pp_set_margin ppf 80 ;
+  Format.pp_set_max_indent ppf 76 ;
+  List.iter
+    (fun (name, prefix, rpc_dir) ->
+       Rst.pp_h2 ppf (Format.asprintf "%s RPCs - Full description" name) ;
+       Format.fprintf ppf "%a@\n@\n" (Description.pp prefix) rpc_dir)
+    descriptions
 
-let repr_of_service path
+let genesis : State.Chain.genesis = {
-    RPC_description.{ description ; error ;
+  time =
-                      meth ; input ; output ;
+    Time.of_notation_exn "2018-04-17T11:46:23Z" ;
-                      query ; _ }  : service_repr =
+  block =
+    Block_hash.of_b58check_exn
+      "BLockGenesisGenesisGenesisGenesisGenesisa52f8bUWPcg" ;
+  protocol =
+    Protocol_hash.of_b58check_exn
+      "ProtoGenesisGenesisGenesisGenesisGenesisGenesk612im" ;
+}
 
-  { path ; meth ; query ;
+let main dir =
-    description = make_descr description ;
+  let (/) = Filename.concat in
-    input = normalize_json_schema input ;
+  let node_config : Node.config = {
-    output = normalize_json_schema (Some output) ;
+    genesis ;
-    example = None ; error = Some error  }
+    patch_context = None ;
-
+    store_root = dir / "store" ;
-open Format
+    context_root = dir / "context" ;
-
+    p2p = None ;
-let pp_print_service fmt
+    test_chain_max_tll = None ;
-    { path ; meth }
+  } in
-  =
+  Node.create
-  fprintf fmt "%s %s" (Resto.string_of_meth meth) (String.concat "/" path)
+    node_config
-
+    Node.default_peer_validator_limits
-let rec pp_print_service_tree fmt = function
+    Node.default_block_validator_limits
-  | Root l ->
+    Node.default_prevalidator_limits
-      fprintf fmt "@[<v 2>/";
+    Node.default_chain_validator_limits >>=? fun node ->
-      List.iter
+  let shell_dir = Node.build_rpc_directory node in
-        (fun tree ->
+  let protocol_dirs =
-           fprintf fmt "@ ";
+    List.map
-           fprintf fmt "%a" pp_print_service_tree tree
+      (fun (name, hash) ->
-        ) l;
+         let hash = Protocol_hash.of_b58check_exn hash in
-      fprintf fmt "@]"
+         let (module Proto) = Registered_protocol.get_exn hash in
-  | Node (repr, l) ->
+         "Protocol " ^ name,
-      fprintf fmt "@[<v 2>%a" pp_print_service repr;
+         [".." ; "<block_id>"] ,
-      List.iter
+         RPC_directory.map (fun () -> assert false) @@
-        (fun tree ->
+         Block_directory.build_raw_rpc_directory (module Proto) (module Proto))
-           fprintf fmt "@ ";
+      protocols in
-           fprintf fmt "%a" pp_print_service_tree tree
+  let dirs = ("Shell", [""], shell_dir) :: protocol_dirs in
-        ) l;
+  Lwt_list.map_p
-      fprintf fmt "@]"
+    (fun (name, path, dir) ->
-  | SymbNode (sl, l) ->
+       RPC_directory.describe_directory ~recurse:true ~arg:() dir >>= fun dir ->
-      fprintf fmt "@[<v 2>%s" (String.concat "/" sl);
+       Lwt.return (name, path, dir))
-      List.iter
+    dirs >>= fun descriptions ->
-        (fun tree ->
+  let ppf = Format.std_formatter in
-           fprintf fmt "@ ";
+  pp_document ppf descriptions ;
-           fprintf fmt "%a" pp_print_service_tree tree
+  return ()
-        ) l;
-      fprintf fmt "@]"
-
-let make_tree cctxt path =
-  let open RPC_description in
-  describe cctxt ~recurse:true path >>=? fun dir ->
-  let rec loop path : _ directory -> service_tree list = function
-    | Dynamic descr ->
-        [ Node ({ path ; meth=`POST ; query = [] ;
-                  description=make_descr descr ;
-                  input = None ; output = None ;
-                  example = None ; error = None }, []) ]
-
-    | Empty -> []
-
-    | Static { services ; subdirs = None } ->
-        let l = RPC_service.MethMap.bindings services in
-        let l = List.map snd l in
-        List.map
-          (fun service -> Node (repr_of_service path service, []))
-          l
-
-    | Static { services ; subdirs = Some (Suffixes subdirs) } ->
-        let subdirs =  Resto.StringMap.bindings subdirs in
-
-        let l = List.map (fun (name, subdir) ->
-            loop (path @ [ name ]) subdir
-          ) subdirs |> List.concat
-        in
-
-        let services = RPC_service.MethMap.bindings services in
-        let services = List.map snd services in
-
-        begin
-          match services with
-          | [] -> [ SymbNode (path, l) ]
-          | service::[] -> [ Node (repr_of_service path service, l) ]
-          | _ -> assert false (* ? *)
-        end
-
-    | Static { services ; subdirs = Some (Arg (arg, solo)) } ->
-        let name = Printf.sprintf "<%s>" arg.RPC_arg.name in
-
-        let services = RPC_service.MethMap.bindings services in
-        let services = List.map snd services in
-
-        let l = loop (path @ [ name ]) solo in
-
-        begin
-          match services with
-          | [] -> [ SymbNode (path, l) ]
-          | service::[] -> [ Node (repr_of_service path service, l) ]
-          | _ -> assert false (* ? *)
-        end
-  in
-  return (Root (loop path dir))
-
-let rec pp_print_hierarchy fmt =
-  let open Format in
-  function
-  | Root l ->
-      List.iter
-        (fun tree ->
-           fprintf fmt "@ ";
-           fprintf fmt "%a" pp_print_hierarchy tree
-        ) l;
-      fprintf fmt "@]"
-
-  | SymbNode (path, l)
-  | Node ( { path } , l) ->
-      if List.length path = 0 then begin
-        List.iter
-          (fun tree ->
-             fprintf fmt "@ ";
-             fprintf fmt "%a" pp_print_hierarchy tree
-          ) l;
-        fprintf fmt "@]"
-      end
-      else
-        begin
-          let name = "/" ^ List.hd (List.rev path) in
-          let offset = max 4 (String.length name / 2) in
-
-          if List.length l = 0 then
-            pp_open_vbox fmt 0
-          else
-            pp_open_vbox fmt offset;
-
-          fprintf fmt "%s" name;
-          List.iter
-            (fun tree ->
-               fprintf fmt "@ ";
-               fprintf fmt "%a" pp_print_hierarchy tree)
-            l;
-          pp_close_box fmt ()
-        end
-
-(**************** RST PRINTING ****************)
-
-let pp_print_rst_title ~char ppf title =
-  let sub = String.map (fun _ -> char) title in
-  Format.fprintf ppf "@[<v 0>%s@ %s@ @ @]" title sub
-
-let pp_print_rst_h1 = pp_print_rst_title ~char:'#'
-let pp_print_rst_h2 = pp_print_rst_title ~char:'*'
-let pp_print_rst_h3 = pp_print_rst_title ~char:'='
-let pp_print_rst_h4 = pp_print_rst_title ~char:'`'
-
-let pp_print_rst_raw_html fmt str =
-  (* let ic = open_in file in *)
-  fprintf fmt "@[<v 2>.. raw:: html@ @ %s@ @ @]" str
-
-let label_table = Hashtbl.create 17
-
-let make_counter () =
-  let i = ref 1 in
-  fun () -> incr i; !i
-
-let count = make_counter ()
-
-let rst_label_of_path path =
-  let label = Printf.sprintf "ref%d" (count ()) in
-  Hashtbl.add label_table path label;
-  "<" ^ label ^ "_>"
-
-let ref_of_path path =
-  Hashtbl.find label_table path
-
-let rec pp_print_rst_hierarchy fmt ~title node =
-  fprintf fmt "%a@ " pp_print_rst_h2 title;
-  let rst_name =
-    String.lowercase_ascii title
-    |> String.map (function ' ' -> '-' | x -> x)
-  in
-  let rst_name =
-    let rec loop str =
-      let open Stringext in
-      if find_from str ~pattern:"--" <> None then
-        loop (replace_all_assoc str [("--","-")])
-      else
-        str
-    in loop rst_name
-  in
-
-  fprintf fmt "%a@." pp_print_rst_raw_html
-    (sprintf "<style>#%s * { margin-bottom:0px }\
-              #%s > *:last-child { margin-bottom:15px }\
-              #%s > h2 { margin-bottom:15px}</style>" rst_name rst_name rst_name);
-
-  let rec loop fmt tree =
-    match tree with
-    | Root l ->
-        (* fprintf fmt "@[<v 4>/"; *)
-        fprintf fmt "@[<v 0>";
-        List.iter
-          (fun tree ->
-             fprintf fmt "@ ";
-             fprintf fmt "%a" loop tree
-          ) l;
-        fprintf fmt "@]"
-    | Node ( { path }, l) ->
-        let name = "/" ^ String.concat "/" path in
-        fprintf fmt "@[<v 4>";
-        fprintf fmt "`%s %s`_"  name (rst_label_of_path path);
-        fprintf fmt "@ ";
-
-        List.iter
-          (fun tree ->
-             fprintf fmt "@ ";
-             fprintf fmt "%a" loop tree
-          ) l;
-        fprintf fmt "@]"
-    | SymbNode (path, l) ->
-        if List.length path > 0 then begin
-          let name = "\\/" ^ String.concat "/" path in
-
-          fprintf fmt "@[<v 2>%s" name;
-          (* fprintf fmt "%s" name; *)
-
-          fprintf fmt "@ ";
-
-          List.iter
-            (fun tree ->
-               fprintf fmt "@ ";
-               fprintf fmt "%a" loop tree
-            ) l;
-          fprintf fmt "@]"
-
-        end else
-          List.iter
-            (fun tree ->
-               fprintf fmt "@ ";
-               fprintf fmt "%a" loop tree
-            ) l
-  in
-  loop fmt node
-
-let pp_print_query_arg fmt =
-  let open RPC_arg in
-  function { name ; _ } ->
-    fprintf fmt "<%s>" name
-
-let pp_print_query_html_arg fmt =
-  let open RPC_arg in
-  function { name ; _ } ->
-    fprintf fmt "&lt;%s&gt;" name
-
-let pp_print_query_title fmt =
-  let open RPC_description in
-  function {name ; kind ; _ } ->
-  match kind with
-  | Single arg -> fprintf fmt "%s=%a" name pp_print_query_arg arg
-  | Optional arg -> fprintf fmt "[%s=%a]" name pp_print_query_arg arg
-  | Flag -> fprintf fmt "%s" name
-  | Multi arg -> fprintf fmt "(%s=%a)\\*" name pp_print_query_arg arg
-
-let pp_print_query_item_descr fmt =
-  let open RPC_description in
-  function { name ; description ; kind } ->
-    begin match kind with
-      | Single arg -> fprintf fmt "%s : %a" name pp_print_query_html_arg arg
-      | Optional arg -> fprintf fmt "[%s : %a] - Optional" name pp_print_query_html_arg arg
-      | Flag -> fprintf fmt "%s - Flag" name
-      | Multi arg -> fprintf fmt "(%s : %a)\\* - Can be given multiple times" name
-                       pp_print_query_html_arg arg
-    end;
-    begin match description with
-      | None -> ()
-      | Some descr -> fprintf fmt " : %s" descr
-    end
-
-let pp_print_html_tab_button fmt ?(default=false) ~shortlabel ~content path =
-  let target_ref = ref_of_path path in
-  fprintf fmt "<button class=\"tablinks%s\" onclick=\"showTab(this, '%s', '%s')\">%s</button>@ "
-    (if default then " defaultOpen" else "")
-    (target_ref ^ shortlabel)
-    target_ref
-    content
-
-let pp_print_html_tab_content fmt ~tag ~shortlabel ~pp_content ~content path =
-  let target_ref = ref_of_path path in
-  fprintf fmt "@[<v 2><div id=\"%s\" class=\"%s tabcontent\" style=\"max-height:200px; overflow:auto\" >@ "
-    (target_ref ^ shortlabel) target_ref;
-  fprintf fmt "<%s>@ %a</%s>@ " tag pp_content content tag;
-  fprintf fmt "</div>@]"
-
-let pp_print_html_tabs fmt { path ; description ; input ; output ; query ; _ (* example ; error *) } =
-  fprintf fmt "@[<v 2>.. raw:: html@ @ ";
-  fprintf fmt "@[<v 2><div class=\"tab\">@ ";
-
-  fprintf fmt "%a" (pp_print_html_tab_button ~default:true ~shortlabel:"descr" ~content:"Description") path;
-  (match input with
-   | Some _ ->
-       fprintf fmt "%a" (pp_print_html_tab_button ~default:false ~shortlabel:"input" ~content:"Input format") path;
-   | None -> ());
-  (match output with
-   | Some _ ->
-       fprintf fmt "%a" (pp_print_html_tab_button ~default:false ~shortlabel:"output" ~content:"Output format") path;
-   | None -> ());
-  (* (match example with
-   *  | Some _ ->
-   *      fprintf fmt "%a" (pp_print_html_tab_button ~default:false ~shortlabel:"example" ~content:"Example") path;
-   *  | None -> ()); *)
-  fprintf fmt "</div>@]@ ";
-
-  let query_item_list =
-    if query <> [] then
-      asprintf "</p> <p>Optional query arguments :<ul><li>%a</li></ul>"
-        (pp_print_list
-           ~pp_sep:(fun fmt () -> fprintf fmt "</li><li>")
-           pp_print_query_item_descr) query
-    else ""
-  in
-  fprintf fmt "%a@ " (pp_print_html_tab_content ~tag:"p" ~shortlabel:"descr"
-                        ~pp_content:pp_print_string ~content:(description^query_item_list)) path;
-  (match input with
-   | Some x -> fprintf fmt "%a@ " (pp_print_html_tab_content ~tag:"pre" ~shortlabel:"input"
-                                     ~pp_content:Json_schema.pp ~content:x) path;
-   | None -> ());
-  (match output with
-   | Some x -> fprintf fmt "%a@ " (pp_print_html_tab_content ~tag:"pre" ~shortlabel:"output"
-                                     ~pp_content:Json_schema.pp ~content:x) path;
-   | None -> ());
-  (* (match example with
-   *  | Some x -> fprintf fmt "%a@ " (pp_print_html_tab_content ~tag:"pre" ~shortlabel:"example"
-   *                                    ~pp_content:pp_print_string ~content:x) path;
-   *  | None -> ()); *)
-
-  fprintf fmt "@]"
-
-let pp_print_rst_full_service fmt ({ path ; meth ; query } as repr) =
-  fprintf fmt ".. _%s :@\n@\n**%s %s%s%a**@\n@\n"
-    (ref_of_path path)
-    (Resto.string_of_meth meth)
-    ("/" ^ String.concat "/" path)
-    (if query = [] then "" else "?")
-    (pp_print_list ~pp_sep:(fun fmt () -> fprintf fmt "&") pp_print_query_title) query;
-  fprintf fmt "%a" pp_print_html_tabs repr
-
-let rec pp_print_rst_service_tree fmt node =
-  let open Format in
-  match node with
-  | Root l -> (pp_print_list ~pp_sep:pp_print_cut pp_print_rst_service_tree) fmt l
-  | SymbNode (_, l) -> (pp_print_list ~pp_sep:pp_print_cut pp_print_rst_service_tree) fmt l
-  | Node ( repr , l) ->
-      (* Generates services details and ref for links  *)
-      fprintf fmt "%a@\n@\n" pp_print_rst_full_service repr;
-      fprintf fmt "%a" (pp_print_list ~pp_sep:pp_print_newline pp_print_rst_service_tree) l
-
-let style =
-  "<style>\
-   .tab {\
-   overflow: hidden;\
-   border: 1px solid #ccc;\
-   background-color: #f1f1f1;\
-   }\
-   .tab button {\
-   background-color: inherit;\
-   float: left;\
-   border: none;\
-   outline: none;\
-   cursor: pointer;\
-   padding: 5px 10px;\
-   }\
-   .tab button:hover {\
-   background-color: #ddd;\
-   }\
-   .tab button.active {\
-   background-color: #ccc;\
-   }\
-   .tabcontent {\
-   display: none;\
-   padding: 6px 12px;\
-   border: 1px solid #ccc;\
-   border-top: none;\
-   margin-bottom: 20px;\
-   }\
-   pre {\
-   font-size: 12px\
-   }</style>"
-
-let script =
-  "<script>\
-   function showTab(elt, tab, ref) {\
-   var i, tabcontent, tablinks;\
-   \
-   tabcontent = document.getElementsByClassName(ref);\
-   for (i = 0; i < tabcontent.length; i++) {\
-   tabcontent[i].style.display = 'none';\
-   }\
-   \
-   tablinks = elt.parentNode.children;\
-   for (i = 0; i < tablinks.length; i++) {\
-   tablinks[i].className = tablinks[i].className.replace(' active', '');\
-   }\
-   \
-   document.getElementById(tab).style.display = 'block';\
-   elt.className += ' active';\
-   }\
-   \
-   document.addEventListener('DOMContentLoaded', function(){\
-   var a = document.getElementsByClassName('defaultOpen');\
-   for (i = 0; i < a.length; i++) { a[i].click() }\
-   })\
-   </script>"
-
-let ppf = Format.std_formatter
-let err_ppf = Format.err_formatter
-
-let run ?(rpc_port=18731) () =
-  (* Client context *)
-  let rpc_config = { RPC_client.default_config with port=rpc_port } in
-  let open Client_config in
-  let {block; _}  = default_cli_args in
-  let (cctxt : #Tezos_client_base.Client_context.full) =
-    new Client_context_unix.unix_full
-      ~block ~confirmations:None ~base_dir: "/" ~rpc_config
-  in
-
-  let print_header () =
-    (* Style : hack *)
-    fprintf ppf "%a@." pp_print_rst_raw_html style;
-    (* Script : hack *)
-    fprintf ppf "%a@." pp_print_rst_raw_html script;
-    (* Page title *)
-    fprintf ppf "%a" pp_print_rst_h1 "RPC API";
-    (* include/copy usage.rst from input  *)
-    let rec loop () =
-      let s = read_line () in
-      fprintf ppf "%s@\n" s;
-      loop ()
-    in begin try loop () with End_of_file -> () end
-  in
-  (make_tree cctxt [] >>= function
-    | Ok service_tree ->
-        (* Print header!! *)
-        fprintf ppf "@\n";
-        print_header ();
-        fprintf ppf "@\n";
-
-        (* Shell RPCs tree *)
-        fprintf ppf "%a@." (pp_print_rst_hierarchy ~title:"Client RPCs - Index") service_tree;
-        fprintf ppf "%a" pp_print_rst_h2 "Client RPCs - Full description";
-        fprintf ppf "%a@." pp_print_rst_service_tree service_tree;
-        Lwt.return 0
-
-    | Error _ ->
-        Format.eprintf "[RPC Doc Generation] Client : Couldn't reach node\n";
-        Lwt.return 1) >>= function
-  | 0 ->
-      (* Alpha Protocol RPCs *)
-      let path_proto_alpha = String.split '/' "/blocks/head/proto" in
-      begin
-        make_tree cctxt path_proto_alpha >>= function
-        | Ok service_tree ->
-            (* Proto alpha RPCs tree *)
-            fprintf ppf "%a@." (pp_print_rst_hierarchy ~title:"Protocol Alpha RPCs - Index") service_tree;
-            fprintf ppf "%a" pp_print_rst_h2 "Protocol Alpha RPCs - Full description";
-            fprintf ppf "%a@." pp_print_rst_service_tree service_tree;
-
-            Lwt.return 0
-
-        | Error _ ->
-            Format.fprintf err_ppf "[RPC Doc Generation] Proto alpha : Couldn't reach node\n";
-            Lwt.return 1
-      end
-  | _ -> Lwt.return 1
 
 let () =
-  Pervasives.exit
+  Lwt_main.run begin
-    (Lwt_main.run
+    Lwt_utils_unix.with_tempdir "tezos_rpcdoc_" main >>= function
-       begin try
+    | Ok _ ->
-           if Array.length Sys.argv > 1 then
+        Lwt.return_unit
-             let rpc_port = int_of_string Sys.argv.(1) in
+    | Error err ->
-             run ~rpc_port ()
+        Format.eprintf "%a@." pp_print_error err ;
-           else
+        Pervasives.exit 1
-             run ()
+  end
-         with _ ->
-           run ()
-       end)

docs/doc_gen/rpcs/run_rpc_doc.sh

@@ -13,44 +13,7 @@ set -o pipefail
 #**************************************************************************#
 
 docgen_dir="$(cd "$(dirname "${BASH_SOURCE[0]}")" && echo "$(pwd -P)")"
-
 rpc_doc="../_build/default/docs/doc_gen/rpcs/rpc_doc.exe"
-
-tezos_sandboxed_node="${1:-$docgen_dir/../../../src/bin_node/tezos-sandboxed-node.sh}"
-tezos_init_sandboxed_client="${3:-$docgen_dir/../../../src/bin_client/tezos-init-sandboxed-client.sh}"
-
-local_node="${2:-$docgen_dir/../../../_build/default/src/bin_node/main.exe}"
-local_client="${2:-$docgen_dir/../../../_build/default/src/bin_client/main_client.exe}"
-
-sandbox_file="/tmp/sandbox.json"
 usage="$docgen_dir/usage.rst"
 
-source $tezos_sandboxed_node
+$rpc_doc < $usage | sed -e 's|/chains/main/blocks/head/|.../<block_id>/|g'
-source $tezos_init_sandboxed_client
-
-start_node() {
-    local id=${1:-1}
-    start_sandboxed_node $id
-    init_sandboxed_client $id
-    wait_for_the_node_to_be_ready
-    add_sandboxed_bootstrap_identities
-    client_instances+=("$client")
-    export "client$id=$client"
-}
-
-cleanup() {
-    set -e
-    cleanup_nodes
-    cleanup_clients
-}
-trap cleanup EXIT INT
-
-# Default to 7 to avoid potentially running nodes
-# TODO : get first available port
-start_node 7 >&2
-
-activate_alpha >&2
-
-sleep 2
-
-$rpc_doc $rpc < $usage | sed -e 's|/chains/main/blocks/head/|.../<block_id>/|g'

src/bin_node/node_config_file.ml

@@ -109,46 +109,10 @@ let default_log = {
 }
 
 let default_shell = {
-  block_validator_limits = {
+  block_validator_limits = Node.default_block_validator_limits ;
-    protocol_timeout = 120. ;
+  prevalidator_limits = Node.default_prevalidator_limits ;
-    worker_limits = {
+  peer_validator_limits = Node.default_peer_validator_limits ;
-      backlog_size = 1000 ;
+  chain_validator_limits = Node.default_chain_validator_limits ;
-      backlog_level = Logging.Debug ;
-      zombie_lifetime = 3600. ;
-      zombie_memory = 1800. ;
-    }
-  } ;
-  prevalidator_limits = {
-    operation_timeout = 10. ;
-    max_refused_operations = 1000 ;
-    worker_limits = {
-      backlog_size = 1000 ;
-      backlog_level = Logging.Info ;
-      zombie_lifetime = 600. ;
-      zombie_memory = 120. ;
-    }
-  } ;
-  peer_validator_limits = {
-    block_header_timeout = 60. ;
-    block_operations_timeout = 60. ;
-    protocol_timeout = 120. ;
-    new_head_request_timeout = 90. ;
-    worker_limits = {
-      backlog_size = 1000 ;
-      backlog_level = Logging.Info ;
-      zombie_lifetime = 600. ;
-      zombie_memory = 120. ;
-    }
-  } ;
-  chain_validator_limits = {
-    bootstrap_threshold = 4 ;
-    worker_limits = {
-      backlog_size = 1000 ;
-      backlog_level = Logging.Info ;
-      zombie_lifetime = 600. ;
-      zombie_memory = 120. ;
-    }
-  }
 }
 
 let default_config = {

src/lib_protocol_updater/registered_protocol.ml

@@ -60,6 +60,9 @@ let get hash =
   try Some (get_exn hash)
   with Not_found -> None
 
+let list () =
+  VersionTable.fold (fun _ p acc -> p :: acc) versions []
+
 let list_embedded () =
   VersionTable.fold (fun k _ acc -> k :: acc) sources []
 

src/lib_protocol_updater/registered_protocol.mli

@@ -22,6 +22,8 @@ type t = (module T)
 
 val mem: Protocol_hash.t -> bool
 
+val list: unit -> t list
+
 val get: Protocol_hash.t -> t option
 val get_exn: Protocol_hash.t -> t
 

src/lib_shell/block_directory.ml

@@ -27,7 +27,7 @@ let rec read_partial_context context path depth =
         end >>= fun l ->
         Lwt.return (Block_services.Dir (List.rev l))
 
-let rpc_directory
+let build_raw_rpc_directory
     (module Proto : Block_services.PROTO)
     (module Next_proto : Registered_protocol.T) =
 
@@ -336,7 +336,7 @@ let get_directory block =
       let next_protocol = get_protocol next_protocol_hash in
       State.Block.predecessor block >>= function
       | None ->
-          Lwt.return (rpc_directory
+          Lwt.return (build_raw_rpc_directory
                         (module Block_services.Fake_protocol)
                         next_protocol)
       | Some pred ->
@@ -345,7 +345,7 @@ let get_directory block =
           State.Block.get_rpc_directory block >>= function
           | Some dir -> Lwt.return dir
           | None ->
-              let dir = rpc_directory (module Proto) next_protocol in
+              let dir = build_raw_rpc_directory (module Proto) next_protocol in
               State.Block.set_rpc_directory block dir >>= fun () ->
               Lwt.return dir
 

src/lib_shell/block_directory.mli

@@ -9,6 +9,11 @@
 
 val get_block: State.Chain.t -> Block_services.block -> State.Block.t Lwt.t
 
+val build_raw_rpc_directory:
+  (module Block_services.PROTO) ->
+  (module Registered_protocol.T) ->
+  State.Block.t RPC_directory.directory
+
 val build_rpc_directory:
   State.Chain.t ->
   Block_services.block ->

src/lib_shell/node.ml

@@ -93,6 +93,47 @@ and chain_validator_limits = Chain_validator.limits = {
   worker_limits : Worker_types.limits ;
 }
 
+let default_block_validator_limits = {
+  protocol_timeout = 120. ;
+  worker_limits = {
+    backlog_size = 1000 ;
+    backlog_level = Logging.Debug ;
+    zombie_lifetime = 3600. ;
+    zombie_memory = 1800. ;
+  }
+}
+let default_prevalidator_limits = {
+  operation_timeout = 10. ;
+  max_refused_operations = 1000 ;
+  worker_limits = {
+    backlog_size = 1000 ;
+    backlog_level = Logging.Info ;
+    zombie_lifetime = 600. ;
+    zombie_memory = 120. ;
+  }
+}
+let default_peer_validator_limits = {
+  block_header_timeout = 60. ;
+  block_operations_timeout = 60. ;
+  protocol_timeout = 120. ;
+  new_head_request_timeout = 90. ;
+  worker_limits = {
+    backlog_size = 1000 ;
+    backlog_level = Logging.Info ;
+    zombie_lifetime = 600. ;
+    zombie_memory = 120. ;
+  }
+}
+let default_chain_validator_limits = {
+  bootstrap_threshold = 4 ;
+  worker_limits = {
+    backlog_size = 1000 ;
+    backlog_level = Logging.Info ;
+    zombie_lifetime = 600. ;
+    zombie_memory = 120. ;
+  }
+}
+
 let create { genesis ; store_root ; context_root ;
              patch_context ; p2p = p2p_params ;
              test_chain_max_tll = max_child_ttl }

src/lib_shell/node.mli

@@ -39,6 +39,11 @@ and chain_validator_limits = {
   worker_limits : Worker_types.limits ;
 }
 
+val default_peer_validator_limits: peer_validator_limits
+val default_prevalidator_limits: prevalidator_limits
+val default_block_validator_limits: block_validator_limits
+val default_chain_validator_limits: chain_validator_limits
+
 val create:
   config ->
   peer_validator_limits ->

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

@@ -177,6 +177,11 @@ module Make (Encoding : ENCODING) : sig
     ('prefix, 'prefix, 'error) Service.description_service ->
     'prefix directory
 
+  val describe_directory:
+    recurse:bool ->
+    ?arg:'a ->
+    'a directory -> Encoding.schema Resto.Description.directory Lwt.t
+
   (**/**)
 
   module Curry: sig