Import new version of vendors/ocplib-resto

The new version of ocplib-resto :

- uses jbuilder ;
- is functorized over `Json_encoding` rather than `Json_repr` ;
- handles query parameters ;
- handles HTTP methods (GET, POST, DELETE, PUT, PATCH) ;
- replaces `custom_service` by a more generic trailer argument ;
- replaces generic answer `(code, body)` by a more ad-hoc sum type
  (allowing distinct encoding for success and error) ;
- includes a minimal HTTP-server based on Cohttp
  (includings CORS and media type negotiation).
- adds a function `Directory.transparent_lookup` to lookup/call
  a service handler without serializing the various parameters
  (path, query, request body).

As a first consequences in Tezos, this patch allows binary
communication between the client and the node.

This patch tries to be minimal inside the tezos source code and
therefore it introduces a minimal compatibility layer in
`RPC.ml`. This code should be removed as soon as possible.

.dockerignore

@@ -1,6 +1,6 @@
 
 _build
-tezos.install
+**/*.install
 
 tezos-node
 tezos-protocol-compiler

.gitignore

@@ -1,6 +1,6 @@
 
 /_build
-/tezos.install
+*.install
 
 /tezos-node
 /tezos-protocol-compiler

scripts/install_build_deps.sh

@@ -19,7 +19,6 @@ set -x
 opam pin --yes add --no-action --dev-repo sodium
 opam pin --yes add --no-action --dev-repo ocp-ocamlres
 opam pin --yes add --no-action --dev-repo ocplib-json-typed
-opam pin --yes add --no-action --dev-repo ocplib-resto
 ## Force opam to take account of the new `tezos-deps.opam`
 opam pin --yes remove tezos
 opam pin --yes add --no-action tezos $src_dir

src/client/client_generic_rpcs.ml

@@ -176,12 +176,10 @@ module StringMap = Map.Make(String)
 let rec count =
   let open RPC.Description in
   function
+  | Empty -> 0
   | Dynamic _ -> 1
-  | Static { service ; subdirs } ->
+  | Static { services ; subdirs } ->
-      let service =
+      let service = RPC.MethMap.cardinal services in
-        match service with
-        | None -> 0
-        | Some _ -> 1 in
       let subdirs =
         match subdirs with
         | None -> 0
@@ -213,11 +211,19 @@ let list url cctxt =
         Format.fprintf ppf "<%s>%a" arg.RPC.Arg.name display_paragraph descr
   in
   let display_service ppf (_path, tpath, service) =
-    Format.fprintf ppf "- /%s" (String.concat "/" tpath) ;
+    Format.fprintf ppf "- %s /%s"
+      (RPC.string_of_meth service.meth)
+      (String.concat "/" tpath) ;
     match service.description with
     | None | Some "" -> ()
     | Some description -> display_paragraph ppf description
   in
+  let display_services ppf (_path, tpath, services) =
+    Format.pp_print_list
+      (fun ppf (_,s) -> display_service ppf (_path, tpath, s))
+      ppf
+      (RPC.MethMap.bindings services)
+  in
   let rec display ppf (path, tpath, tree) =
     match tree with
     | Dynamic description -> begin
@@ -226,23 +232,23 @@ let list url cctxt =
         | None | Some "" -> ()
         | Some description -> display_paragraph ppf description
       end
-    | Static { service = None ; subdirs = None } -> ()
+    | Empty -> ()
-    | Static { service = Some service ; subdirs = None } ->
+    | Static { services ; subdirs = None } ->
-        display_service ppf (path, tpath, service)
+        display_services ppf (path, tpath, services)
-    | Static { service ; subdirs = Some (Suffixes subdirs) } -> begin
+    | Static { services ; subdirs = Some (Suffixes subdirs) } -> begin
-        match service, StringMap.bindings subdirs with
+        match RPC.MethMap.cardinal services, StringMap.bindings subdirs with
-        | None, [] -> ()
+        | 0, [] -> ()
-        | None, [ n, solo ] ->
+        | 0, [ n, solo ] ->
             display ppf (path @ [ n ], tpath @ [ n ], solo)
-        | None, items when count tree >= 3 && path <> [] ->
+        | _, items when count tree >= 3 && path <> [] ->
             Format.fprintf ppf "@[<v 2>+ %s/@,%a@]"
               (String.concat "/" path) (display_list tpath) items
-        | Some service, items when count tree >= 3 && path <> [] ->
+        | _, items when count tree >= 3 && path <> [] ->
             Format.fprintf ppf "@[<v 2>+ %s@,%a@,%a@]"
               (String.concat "/" path)
-              display_service (path, tpath, service)
+              display_services (path, tpath, services)
               (display_list tpath) items
-        | None, (n, t) :: items ->
+        | 0, (n, t) :: items ->
             Format.fprintf ppf "%a"
               display (path @ [ n ], tpath @ [ n ], t) ;
             List.iter
@@ -250,22 +256,23 @@ let list url cctxt =
                  Format.fprintf ppf "@,%a"
                    display (path @ [ n ], tpath @ [ n ], t))
               items
-        | Some service, items ->
+        | _, items ->
-            display_service ppf (path, tpath, service) ;
+            display_services ppf (path, tpath, services) ;
             List.iter
               (fun (n, t) ->
                  Format.fprintf ppf "@,%a"
                    display (path @ [ n ], tpath @ [ n ], t))
               items
       end
-    | Static { service = None ; subdirs = Some (Arg (arg, solo)) } ->
+    | Static { services ; subdirs = Some (Arg (arg, solo)) }
+      when RPC.MethMap.cardinal services = 0 ->
         collect arg ;
         let name = Printf.sprintf "<%s>" arg.RPC.Arg.name in
         display ppf (path @ [ name ], tpath @ [ name ], solo)
-    | Static { service = Some service ;
+    | Static { services;
                subdirs = Some (Arg (arg, solo)) } ->
         collect arg ;
-        display_service ppf (path, tpath, service) ;
+        display_services ppf (path, tpath, services) ;
         Format.fprintf ppf "@," ;
         let name = Printf.sprintf "<%s>" arg.RPC.Arg.name in
         display ppf (path @ [ name ], tpath @ [ name ], solo)
@@ -286,11 +293,22 @@ let schema url cctxt =
   let args = Utils.split '/' url in
   let open RPC.Description in
   Client_node_rpcs.describe cctxt.rpc_config ~recurse:false args >>=? function
-  | Static { service = Some { input ; output } } ->
+  | Static { services } -> begin
-      let json = `O [ "input", Json_schema.to_json input ;
+      match RPC.MethMap.find `POST services with
-                      "output", Json_schema.to_json output ] in
+      | exception Not_found ->
-      cctxt.message "%a" Json_repr.(pp (module Ezjsonm)) json >>= fun () ->
+          cctxt.message
-      return ()
+            "No service found at this URL (but this is a valid prefix)\n%!" >>= fun () ->
+          return ()
+      | { input = Some input ; output } ->
+          let json = `O [ "input", Json_schema.to_json input ;
+                          "output", Json_schema.to_json output ] in
+          cctxt.message "%a" Json_repr.(pp (module Ezjsonm)) json >>= fun () ->
+          return ()
+      | { input = None ; output } ->
+          let json = `O [ "output", Json_schema.to_json output ] in
+          cctxt.message "%a" Json_repr.(pp (module Ezjsonm)) json >>= fun () ->
+          return ()
+    end
   | _ ->
       cctxt.message
         "No service found at this URL (but this is a valid prefix)\n%!" >>= fun () ->
@@ -300,15 +318,29 @@ let format url cctxt =
   let args = Utils.split '/' url in
   let open RPC.Description in
   Client_node_rpcs.describe cctxt.rpc_config ~recurse:false args >>=? function
-  | Static { service = Some { input ; output } } ->
+  | Static { services } -> begin
-      cctxt.message
+      match RPC.MethMap.find `POST services with
-        "@[<v 0>\
+      | exception Not_found ->
-         @[<v 2>Input format:@,%a@]@,\
+          cctxt.message
-         @[<v 2>Output format:@,%a@]@,\
+            "No service found at this URL (but this is a valid prefix)\n%!" >>= fun () ->
-         @]"
+          return ()
-        Json_schema.pp input
+      | { input = Some input ; output } ->
-        Json_schema.pp output >>= fun () ->
+          cctxt.message
-      return ()
+            "@[<v 0>\
+             @[<v 2>Input format:@,%a@]@,\
+             @[<v 2>Output format:@,%a@]@,\
+             @]"
+            Json_schema.pp input
+            Json_schema.pp output >>= fun () ->
+          return ()
+      | { input = None ; output } ->
+          cctxt.message
+            "@[<v 0>\
+             @[<v 2>Output format:@,%a@]@,\
+             @]"
+            Json_schema.pp output >>= fun () ->
+          return ()
+    end
   | _ ->
       cctxt.message
         "No service found at this URL (but this is a valid prefix)\n%!" >>= fun () ->
@@ -325,16 +357,23 @@ let call url cctxt =
   let args = Utils.split '/' url in
   let open RPC.Description in
   Client_node_rpcs.describe cctxt.rpc_config ~recurse:false args >>=? function
-  | Static { service = Some { input } } -> begin
+  | Static { services } -> begin
-      fill_in input >>= function
+      match RPC.MethMap.find `POST services with
-      | Error msg ->
+      | exception Not_found ->
-          cctxt.error "%s" msg >>= fun () ->
+          cctxt.message
-          return ()
+            "No service found at this URL (but this is a valid prefix)\n%!" >>= fun () ->
-      | Ok json ->
-          Client_rpcs.get_json cctxt.rpc_config `POST args json >>=? fun json ->
-          cctxt.message "%a"
-            Json_repr.(pp (module Ezjsonm)) json >>= fun () ->
           return ()
+      | { input = None } -> assert false (* TODO *)
+      | { input = Some input } ->
+          fill_in input >>= function
+          | Error msg ->
+              cctxt.error "%s" msg >>= fun () ->
+              return ()
+          | Ok json ->
+              Client_rpcs.get_json cctxt.rpc_config `POST args json >>=? fun json ->
+              cctxt.message "%a"
+                Json_repr.(pp (module Ezjsonm)) json >>= fun () ->
+              return ()
     end
   | _ ->
       cctxt.message

src/client/client_node_rpcs.ml

@@ -42,8 +42,17 @@ let complete cctxt ?block prefix =
   | Some block ->
       call_service2 cctxt Services.Blocks.complete block prefix ()
 
-let describe config ?recurse path =
+let describe config ?(recurse = true) path =
-  call_describe0 config Services.describe path recurse
+  let { RPC.Service.meth ; path } =
+    RPC.Service.forge_request Node_rpc_services.describe
+      ((), path) { RPC.Description.recurse } in
+  get_json config meth path (`O []) >>=? fun json ->
+  match Data_encoding.Json.destruct (RPC.Service.output_encoding Node_rpc_services.describe) json with
+  | exception msg ->
+      let msg =
+        Format.asprintf "%a" (fun x -> Data_encoding.Json.print_error x) msg in
+      failwith "Failed to parse Json answer: %s" msg
+  | v -> return v
 
 module Blocks = struct
 

src/client/client_node_rpcs.mli

@@ -177,4 +177,4 @@ val complete:
 val describe:
   config ->
   ?recurse:bool -> string list ->
-  RPC.Description.directory_descr tzresult Lwt.t
+  Data_encoding.json_schema RPC.Description.directory tzresult Lwt.t

src/client/client_rpcs.ml

@@ -192,7 +192,9 @@ let make_request config log_request meth service json =
   let reqbody = Data_encoding_ezjsonm.to_string json in
   Lwt.catch begin fun () ->
     let body = Cohttp_lwt_body.of_string reqbody in
-    Cohttp_lwt_unix.Client.call meth ~body uri >>= fun (code, ansbody) ->
+    Cohttp_lwt_unix.Client.call
+      (meth :> Cohttp.Code.meth)
+      ~body uri >>= fun (code, ansbody) ->
     log_request uri json >>= fun reqid ->
     return (reqid, code.Cohttp.Response.status, ansbody)
   end begin fun exn ->
@@ -257,10 +259,12 @@ let get_json config meth service json =
       fail config (Request_failed (service, err))
 
 let parse_answer config service path json =
-  match RPC.read_answer service json with
+  match Data_encoding.Json.destruct (RPC.Service.output_encoding service) json with
-  | Error msg ->
+  | exception msg ->
+      let msg =
+        Format.asprintf "%a" (fun x -> Data_encoding.Json.print_error x) msg in
       fail config (Unexpected_json (path, json, msg))
-  | Ok v -> return v
+  | v -> return v
 
 let call_service0 cctxt service arg =
   let meth, path, arg = RPC.forge_request service () arg in
@@ -302,10 +306,12 @@ let call_streamed_service1 cctxt service arg1 arg2 =
   call_streamed cctxt service (RPC.forge_request service ((), arg1) arg2)
 
 let parse_err_answer config service path json =
-  match RPC.read_answer service json with
+  match Data_encoding.Json.destruct (RPC.Service.output_encoding service) json with
-  | Error msg -> (* TODO print_error *)
+  | exception msg -> (* TODO print_error *)
+      let msg =
+        Format.asprintf "%a" (fun x -> Data_encoding.Json.print_error x) msg in
       fail config (Unexpected_json (path, json, msg))
-  | Ok v -> Lwt.return v
+  | v -> Lwt.return v
 
 let call_err_service0 cctxt service arg =
   let meth, path, arg = RPC.forge_request service () arg in
@@ -322,11 +328,6 @@ let call_err_service2 cctxt service a1 a2 arg =
   get_json cctxt meth path arg >>=? fun json ->
   parse_err_answer cctxt service path json
 
-let call_describe0 cctxt service path arg =
-  let meth, prefix, arg = RPC.forge_request service () arg in
-  get_json cctxt meth (prefix @ path) arg >>=? fun json ->
-  parse_answer cctxt service prefix json
-
 type block = Node_rpc_services.Blocks.block
 
 let last_baked_block = function

src/client/client_rpcs.mli

@@ -73,11 +73,6 @@ val call_err_service2:
   (unit, (unit * 'a) * 'b, 'i, 'o tzresult) RPC.service ->
   'a -> 'b -> 'i -> 'o tzresult Lwt.t
 
-val call_describe0:
-  config ->
-  (unit, unit, 'a, 'b) RPC.service ->
-  string list -> 'a -> 'b tzresult Lwt.t
-
 type block = Node_rpc_services.Blocks.block
 
 val last_baked_block:

src/environment/v1/RPC.mli

@@ -13,10 +13,20 @@
     function. However, it cannot register new or update existing
     procedures afterwards, neither can it see other procedures. *)
 
+(** HTTP methods. *)
+type meth = [
+  | `GET
+  | `POST
+  | `DELETE
+  | `PUT
+  | `PATCH
+]
+
 (** Typed path argument. *)
 module Arg : sig
 
-  type 'a arg
+  type 'a t
+  type 'a arg = 'a t
   val make:
     ?descr:string ->
     name:string ->
@@ -40,10 +50,12 @@ end
 (** Parametrized path to services. *)
 module Path : sig
 
-  type ('prefix, 'params) path
+  type ('prefix, 'params) t
+  type ('prefix, 'params) path = ('prefix, 'params) t
   type 'prefix context = ('prefix, 'prefix) path
 
-  val root: 'a context
+  val root: unit context
+  val open_root: 'a context
 
   val add_suffix:
     ('prefix, 'params) path -> string -> ('prefix, 'params) path
@@ -51,9 +63,14 @@ module Path : sig
     ('prefix, 'params) path -> string -> ('prefix, 'params) path
 
   val add_arg:
-    ('prefix, 'params) path -> 'a Arg.arg -> ('prefix, 'params * 'a) path
+    ('prefix, 'params) path -> 'a Arg.t -> ('prefix, 'params * 'a) path
   val (/:):
-    ('prefix, 'params) path -> 'a Arg.arg -> ('prefix, 'params * 'a) path
+    ('prefix, 'params) path -> 'a Arg.t -> ('prefix, 'params * 'a) path
+
+  val add_final_args:
+    ('prefix, 'params) path -> 'a Arg.t -> ('prefix, 'params * 'a list) path
+  val (/:*):
+    ('prefix, 'params) path -> 'a Arg.t -> ('prefix, 'params * 'a list) path
 
   val prefix:
     ('prefix, 'a) path -> ('a, 'params) path -> ('prefix, 'params) path
@@ -63,100 +80,249 @@ module Path : sig
 
 end
 
+module Query : sig
+
+  type 'a t
+  type 'a query = 'a t
+
+  val empty: unit query
+
+  type ('a, 'b) field
+  val field:
+    ?descr: string ->
+    string -> 'a Arg.t -> 'a -> ('b -> 'a) -> ('b, 'a) field
+
+  type ('a, 'b, 'c) open_query
+  val query: 'b -> ('a, 'b, 'b) open_query
+  val (|+):
+    ('a, 'b, 'c -> 'd) open_query ->
+    ('a, 'c) field -> ('a, 'b, 'd) open_query
+  val seal: ('a, 'b, 'a) open_query -> 'a t
+
+  type untyped = (string * string) list
+  exception Invalid of string
+  val parse: 'a query -> untyped -> 'a
+
+end
+
 (** Services. *)
-type ('prefix, 'params, 'input, 'output) service
+module Service : sig
 
-(** HTTP methods as defined in Cohttp.Code *)
+  type (+'meth, 'prefix, 'params, 'query, 'input, 'output, 'error) t
-type meth = [
+    constraint 'meth = [< meth ]
-  | `GET
+  type (+'meth, 'prefix, 'params, 'query, 'input, 'output, 'error) service =
-  | `POST
+    ('meth, 'prefix, 'params, 'query, 'input, 'output, 'error) t
-  | `HEAD
-  | `DELETE
-  | `PATCH
-  | `PUT
-  | `OPTIONS
-  | `TRACE
-  | `CONNECT
-  | `Other of string
-]
 
-val service:
+  val query:
-  ?meth: meth ->
+    ('meth, 'prefix, 'params, 'query, 'input, 'output, 'error) service ->
-  ?description: string ->
+    'query Query.t
-  input: 'input Data_encoding.t ->
+
-  output: 'output Data_encoding.t ->
+  type _ input =
-  ('prefix, 'params) Path.path ->
+    | No_input : unit input
-  ('prefix, 'params, 'input, 'output) service
+    | Input : 'input Data_encoding.t -> 'input input
+
+  val input_encoding:
+    ('meth, 'prefix, 'params, 'query, 'input, 'output, 'error) service ->
+    'input input
+
+  val output_encoding:
+    ('meth, 'prefix, 'params, 'query, 'input, 'output, 'error) service ->
+    'output Data_encoding.t
+
+  val error_encoding:
+    ('meth, 'prefix, 'params, 'query, 'input, 'output, 'error) service ->
+    'error Data_encoding.t
+
+  val prefix:
+    ('prefix, 'inner_prefix) Path.t ->
+    ('meth, 'inner_prefix, 'params, 'query,
+     'input, 'output, 'error) service ->
+    ('meth, 'prefix, 'params,
+     'query, 'input, 'output, 'error) service
+
+  val map:
+    ('a -> 'b) ->
+    ('b -> 'a) ->
+    ('meth, 'pr, 'a, 'q, 'i, 'o, 'e) service ->
+    ('meth, 'pr, 'b, 'q, 'i, 'o, 'e) service
+
+  val get_service:
+    ?description: string ->
+    query: 'query Query.t ->
+    output: 'output Data_encoding.t ->
+    error: 'error Data_encoding.t ->
+    ('prefix, 'params) Path.t ->
+    ([ `GET ], 'prefix, 'params, 'query, unit, 'output, 'error) service
+
+  val post_service:
+    ?description: string ->
+    query:'query Query.t ->
+    input: 'input Data_encoding.t ->
+    output: 'output Data_encoding.t ->
+    error: 'error Data_encoding.t ->
+    ('prefix, 'params) Path.t ->
+    ([ `POST ], 'prefix, 'params, 'query, 'input, 'output, 'error) service
+
+  val delete_service:
+    ?description: string ->
+    query:'query Query.t ->
+    output: 'output Data_encoding.t ->
+    error: 'error Data_encoding.t ->
+    ('prefix, 'params) Path.t ->
+    ([ `DELETE ], 'prefix, 'params, 'query, unit, 'output, 'error) service
+
+  val patch_service:
+    ?description: string ->
+    query:'query Query.t ->
+    input: 'input Data_encoding.t ->
+    output: 'output Data_encoding.t ->
+    error: 'error Data_encoding.t ->
+    ('prefix, 'params) Path.t ->
+    ([ `PATCH ], 'prefix, 'params, 'query, 'input, 'output, 'error) service
+
+  val put_service:
+    ?description: string ->
+    query:'query Query.t ->
+    input: 'input Data_encoding.t ->
+    output: 'output Data_encoding.t ->
+    error: 'error Data_encoding.t ->
+    ('prefix, 'params) Path.t ->
+    ([ `PUT ], 'prefix, 'params, 'query, 'input, 'output, 'error) service
+
+end
 
 module Answer : sig
 
   (** Return type for service handler *)
-  type 'a answer =
+  type ('o, 'e) t =
-    { code : int ;
+    [ `Ok of 'o (* 200 *)
-      body : 'a output ;
+    | `OkStream of 'o stream (* 200 *)
-    }
+    | `Created of string option (* 201 *)
-
+    | `No_content (* 204 *)
-  and 'a output =
+    | `Unauthorized of 'e option (* 401 *)
-    | Empty
+    | `Forbidden of 'e option (* 403 *)
-    | Single of 'a
+    | `Not_found of 'e option (* 404 *)
-    | Stream of 'a stream
+    | `Conflict of 'e option (* 409 *)
+    | `Error of 'e option (* 500 *)
+    ]
 
   and 'a stream = {
     next: unit -> 'a option Lwt.t ;
     shutdown: unit -> unit ;
   }
 
-  val ok: 'a -> 'a answer
+  val return: 'o -> ('o, 'e) t Lwt.t
-  val answer: ?code:int -> 'a -> 'a answer
+  val return_stream: 'o stream -> ('o, 'e) t Lwt.t
-  val return: ?code:int -> 'a -> 'a answer Lwt.t
 
 end
 
-(** Dispatch tree *)
+module Directory : sig
-type 'prefix directory
 
-val empty: 'prefix directory
+  (** Dispatch tree *)
+  type 'prefix t
+  type 'prefix directory = 'prefix t
+
+  (** Empty list of dispatch trees *)
+  val empty: 'prefix directory
+
+  val map: ('a -> 'b) -> 'b directory -> 'a directory
+
+  val prefix: ('pr, 'p) Path.path -> 'p directory -> 'pr directory
+  val merge: 'a directory -> 'a directory -> 'a directory
+
+  (** Possible error while registring services. *)
+  type step =
+    | Static of string
+    | Dynamic of Arg.descr
+    | DynamicTail of Arg.descr
+
+  type conflict =
+    | CService of meth | CDir | CBuilder | CTail
+    | CTypes of Arg.descr *
+                Arg.descr
+    | CType of Arg.descr * string list
+  exception Conflict of step list * conflict
+
+  (** Registring handler in service tree. *)
+  val register:
+    'prefix directory ->
+    ('meth, 'prefix, 'params, 'query, 'input, 'output, 'error) Service.t ->
+    ('params -> 'query -> 'input -> [< ('output, 'error) Answer.t ] Lwt.t) ->
+    'prefix directory
+
+  (** Registring handler in service tree. Curryfied variant.  *)
+  val register0:
+    unit directory ->
+    ('m, unit, unit, 'q, 'i, 'o, 'e) Service.t ->
+    ('q -> 'i -> [< ('o, 'e) Answer.t ] Lwt.t) ->
+    unit directory
+
+  val register1:
+    'prefix directory ->
+    ('m, 'prefix, unit * 'a, 'q , 'i, 'o, 'e) Service.t ->
+    ('a -> 'q -> 'i -> [< ('o, 'e) Answer.t ] Lwt.t) ->
+    'prefix directory
+
+  val register2:
+    'prefix directory ->
+    ('m, 'prefix, (unit * 'a) * 'b, 'q , 'i, 'o, 'e) Service.t ->
+    ('a -> 'b -> 'q -> 'i -> [< ('o, 'e) Answer.t ] Lwt.t) ->
+    'prefix directory
+
+  val register3:
+    'prefix directory ->
+    ('m, 'prefix, ((unit * 'a) * 'b) * 'c, 'q , 'i, 'o, 'e) Service.t ->
+    ('a -> 'b -> 'c -> 'q -> 'i -> [< ('o, 'e) Answer.t ] Lwt.t) ->
+    'prefix directory
+
+  val register4:
+    'prefix directory ->
+    ('m, 'prefix, (((unit * 'a) * 'b) * 'c) * 'd, 'q , 'i, 'o, 'e) Service.t ->
+    ('a -> 'b -> 'c -> 'd -> 'q -> 'i -> [< ('o, 'e) Answer.t ] Lwt.t) ->
+    'prefix directory
+
+  val register5:
+    'prefix directory ->
+    ('m, 'prefix, ((((unit * 'a) * 'b) * 'c) * 'd) * 'e, 'q , 'i, 'o, 'e) Service.t ->
+    ('a -> 'b -> 'c -> 'd -> 'e -> 'q -> 'i -> [< ('o, 'e) Answer.t ] Lwt.t) ->
+    'prefix directory
+
+end
+
+(** Compatibility layer, to be removed ASAP. *)
+
+type 'a directory = 'a Directory.t
+
+type ('prefix, 'params, 'input, 'output) service =
+  ([ `POST ], 'prefix, 'params, unit, 'input, 'output, unit) Service.t
+
+val service:
+  ?description: string ->
+  input: 'input Data_encoding.t ->
+  output: 'output Data_encoding.t ->
+  ('prefix, 'params) Path.t ->
+  ('prefix, 'params, 'input, 'output) service
 
-(** Registring handler in service tree. *)
 val register:
   'prefix directory ->
   ('prefix, 'params, 'input, 'output) service ->
-  ('params -> 'input -> 'output Answer.answer Lwt.t) ->
+  ('params -> 'input -> [< ('output, unit) Answer.t ] Lwt.t) ->
   'prefix directory
 
-(** Registring handler in service tree. Curryfied variant.  *)
 val register0:
   unit directory ->
   (unit, unit, 'i, 'o) service ->
-  ('i -> 'o Answer.answer Lwt.t) ->
+  ('i -> [< ('o, unit) Answer.t ] Lwt.t) ->
   unit directory
 
 val register1:
   'prefix directory ->
   ('prefix, unit * 'a, 'i, 'o) service ->
-  ('a -> 'i -> 'o Answer.answer Lwt.t) ->
+  ('a -> 'i -> [< ('o, unit) Answer.t ] Lwt.t) ->
   'prefix directory
 
 val register2:
   'prefix directory ->
   ('prefix, (unit * 'a) * 'b, 'i, 'o) service ->
-  ('a -> 'b -> 'i -> 'o Answer.answer Lwt.t) ->
+  ('a -> 'b -> 'i -> [< ('o, unit) Answer.t ] Lwt.t) ->
-  'prefix directory
-
-val register3:
-  'prefix directory ->
-  ('prefix, ((unit * 'a) * 'b) * 'c, 'i, 'o) service ->
-  ('a -> 'b -> 'c -> 'i -> 'o Answer.answer Lwt.t) ->
-  'prefix directory
-
-val register4:
-  'prefix directory ->
-  ('prefix, (((unit * 'a) * 'b) * 'c) * 'd, 'i, 'o) service ->
-  ('a -> 'b -> 'c -> 'd -> 'i -> 'o Answer.answer Lwt.t) ->
-  'prefix directory
-
-val register5:
-  'prefix directory ->
-  ('prefix, ((((unit * 'a) * 'b) * 'c) * 'd) * 'e, 'i, 'o) service ->
-  ('a -> 'b -> 'c -> 'd -> 'e -> 'i -> 'o Answer.answer Lwt.t) ->
   'prefix directory

src/minutils/RPC.ml

@@ -7,255 +7,174 @@
 (*                                                                        *)
 (**************************************************************************)
 
-open Lwt.Infix
+module Data = struct
+  type 'a t = 'a Data_encoding.t
+  type schema = Data_encoding.json_schema
+  let unit = Data_encoding.empty
+  let schema = Data_encoding.Json.schema
+  module StringMap = Map.Make(String)
 
-module Arg = Resto.Arg
+  let arg_encoding =
-module Path = Resto.Path
+    let open Data_encoding in
+    conv
+      (fun {Resto.Arg.name; descr} -> (name, descr))
+      (fun (name, descr) -> {name; descr})
+      (obj2 (req "name" string) (opt "descr" string))
 
-(* Services *)
+  open Resto.Description
 
-(* HTTP methods as defined in Cohttp.Code *)
+  let meth_encoding =
-type meth = [
+    Data_encoding.string_enum
-  | `GET
+      [ "GET", `GET ;
-  | `POST
+        "POST", `POST ;
-  | `HEAD
+        "DELETE", `DELETE ;
-  | `DELETE
+        "PUT", `PUT ;
-  | `PATCH
+        "PATCH", `PATCH ]
-  | `PUT
-  | `OPTIONS
-  | `TRACE
-  | `CONNECT
-  | `Other of string
-]
 
+  let path_item_encoding =
+    let open Data_encoding in
+    union [
+      case ~tag:0 string
+        (function PStatic s -> Some s | _ -> None)
+        (fun s -> PStatic s) ;
+      case ~tag:1 arg_encoding
+        (function PDynamic s -> Some s | _ -> None)
+        (fun s -> PDynamic s) ;
+    ]
+
+  let query_item_encoding =
+    let open Data_encoding in
+    conv
+      (fun {name ; description} -> (name, description))
+      (fun (name, description) -> {name ; description})
+      (obj2 (req "name" string) (opt "description" string))
+
+  let service_descr_encoding =
+    let open Data_encoding in
+    conv
+      (fun { meth ; path ; description ; query ; input ; output ; error } ->
+         (meth, path, description, query, input, output, error))
+      (fun (meth, path, description, query, input, output, error) ->
+         { meth ; path ; description ; query ; input ; output ; error })
+      (obj7
+         (req "meth" meth_encoding)
+         (req "path" (list path_item_encoding))
+         (opt "description" string)
+         (req "query" (list query_item_encoding))
+         (opt "input" json_schema)
+         (req "output" json_schema)
+         (req "erro" json_schema))
+
+  let directory_descr_encoding =
+    let open Data_encoding in
+    mu "service_tree" @@ fun directory_descr_encoding ->
+    let static_subdirectories_descr_encoding =
+      union [
+        case ~tag:0 (obj1 (req  "suffixes"
+                      (list (obj2 (req "name" string)
+                               (req "tree" directory_descr_encoding)))))
+          (function Suffixes map ->
+             Some (StringMap.bindings map) | _ -> None)
+          (fun m ->
+             let add acc (n,t) =  StringMap.add n t acc in
+             Suffixes (List.fold_left add StringMap.empty m)) ;
+        case ~tag:1 (obj1 (req "dynamic_dispatch"
+                      (obj2
+                         (req "arg" arg_encoding)
+                         (req "tree" directory_descr_encoding))))
+          (function Arg (ty, tree) -> Some (ty, tree) | _ -> None)
+          (fun (ty, tree) -> Arg (ty, tree))
+      ] in
+
+    let static_directory_descr_encoding =
+      conv
+        (fun { services ; subdirs } ->
+           let find s =
+             try Some (Resto.MethMap.find s services) with Not_found -> None in
+           (find `GET, find `POST, find `DELETE,
+            find `PUT, find `PATCH, subdirs))
+        (fun (get, post, delete, put, patch, subdirs) ->
+           let add meth s services =
+             match s with
+             | None -> services
+             | Some s -> Resto.MethMap.add meth s services in
+           let services =
+             Resto.MethMap.empty
+             |> add `GET get
+             |> add `POST post
+             |> add `DELETE delete
+             |> add `PUT put
+             |> add `PATCH patch in
+           { services ; subdirs })
+        (obj6
+           (opt "get_service" service_descr_encoding)
+           (opt "post_service" service_descr_encoding)
+           (opt "delete_service" service_descr_encoding)
+           (opt "put_service" service_descr_encoding)
+           (opt "patch_service" service_descr_encoding)
+           (opt "subdirs" static_subdirectories_descr_encoding)) in
+    union [
+      case ~tag:0 (obj1 (req "static" static_directory_descr_encoding))
+        (function Static descr -> Some descr | _ -> None)
+        (fun descr -> Static descr) ;
+      case ~tag:1 (obj1 (req "dynamic" (option string)))
+        (function Dynamic descr -> Some descr | _ -> None)
+        (fun descr -> Dynamic descr) ;
+    ]
+
+  let description_request_encoding =
+    let open Data_encoding in
+    conv
+      (fun { recurse } -> recurse)
+      (function recurse -> { recurse })
+      (obj1 (dft "recursive" bool false))
+
+  let description_answer_encoding = directory_descr_encoding
+
+end
+
+include Resto
+include RestoDirectory
+module Directory = RestoDirectory.MakeDirectory(Data)
+module Service = Directory.Service
+
+
+(* Compatibility layer, to be removed ASAP. *)
+
+type 'a directory = 'a Directory.t
 type ('prefix, 'params, 'input, 'output) service =
-  meth * ('prefix, 'params, 'input, 'output) Resto.service
+  ([ `POST ], 'prefix, 'params, unit, 'input, 'output, unit) Service.t
 
-(* The default HTTP method for services *)
+let service ?description ~input ~output path =
-let default_meth = `POST
+  Service.post_service
-
+    ?description
-(* Commonly used REST HTTP methods *)
+    ~query: Query.empty
-let rest_meths = [`GET; `POST; `HEAD; `DELETE; `PATCH; `PUT; `OPTIONS]
+    ~input
-
+    ~output
-let string_of_method = function
+    ~error: Data_encoding.null
-  | `GET -> "GET"
-  | `POST -> "POST"
-  | `HEAD -> "HEAD"
-  | `DELETE -> "DELETE"
-  | `PATCH -> "PATCH"
-  | `PUT -> "PUT"
-  | `OPTIONS -> "OPTIONS"
-  | `TRACE -> "TRACE"
-  | `CONNECT -> "CONNECT"
-  | `Other s -> s
-
-let service ?(meth = default_meth) ?description ~input ~output path =
-  (meth,
-   Resto.service
-     ?description
-     ~input:(Data_encoding.Json.convert input)
-     ~output:(Data_encoding.Json.convert output)
-     path)
-
-(* REST services *)
-
-(* GET service: no input body *)
-let get_service ?description ~output path =
-  service ~meth:`GET ?description
-    ~input:Data_encoding.empty ~output
     path
 
-(* HEAD service: same as GET, but without output body *)
+type directory_descr = Data_encoding.json_schema Description.directory
-let head_service ?description path =
-  service ~meth:`HEAD ?description
-    ~input:Data_encoding.empty ~output:Data_encoding.empty
-    path
 
-let post_service ?description ~input ~output path =
+let empty = Directory.empty
-  service ~meth:`POST ?description ~input ~output path
+let register d s f = Directory.register d s (fun p () i -> f p i)
 
-let put_service ?description ~input ~output path =
+open Directory.Curry
-  service ~meth:`PUT ?description ~input ~output path
+let register0 root s f = register root s (curry Z f)
+let register1 root s f = register root s (curry (S Z) f)
+let register2 root s f = register root s (curry (S (S Z)) f)
+(* let register3 root s f = register root s (curry (S (S (S Z))) f) *)
+(* let register4 root s f = register root s (curry (S (S (S (S Z)))) f) *)
+(* let register5 root s f = register root s (curry (S (S (S (S (S Z))))) f) *)
 
-let delete_service ?description ~input ~output path =
+let register_dynamic_directory1 =
-  service ~meth:`DELETE ?description ~input ~output path
+  Directory.register_dynamic_directory1
 
-let prefix p (meth, s) = (meth, RestoDirectory.prefix p s)
+let forge_request (type i) (service: (_,_,_,_,i,_,_) Service.t) params body =
-
+  let { Service.meth ; path } =
-let forge_request (meth, service) params input =
+    Service.forge_request service params () in
-  let path, arg = Resto.forge_request service params input in
+  let json =
-  meth, path, arg
+    match Service.input_encoding service with
-
+    | Service.No_input -> assert false (* TODO *)
-let read_answer (_meth, service) json =
+    | Service.Input input -> Data_encoding.Json.construct input body in
-  Resto.read_answer service json
+  meth, path, json
-
-module Description = struct
-
-  include Resto.Description
-
-  let service ?(meth = default_meth) ?description path =
-    (meth, Resto.Description.service ?description path)
-
-end
-
-module Answer = struct
-
-  include RestoDirectory.Answer
-
-  let answer ?(code = 200) json = { code; body = Single json }
-  let return ?code json = Lwt.return (answer ?code json)
-
-end
-
-
-type step = RestoDirectory.step =
-  | Static of string
-  | Dynamic of Arg.descr
-
-type conflict = RestoDirectory.conflict =
-  | CService
-  | CDir
-  | CBuilder
-  | CCustom
-  | CTypes of Arg.descr * Arg.descr
-  | CType of Arg.descr * string list
-
-exception Conflict = RestoDirectory.Conflict
-exception Cannot_parse = RestoDirectory.Cannot_parse
-
-(* Dispatch *)
-
-type 'prefix directory = (meth * 'prefix RestoDirectory.directory) list
-
-let empty = []
-
-let map_dirs f dirs =
-  List.map (fun (meth, dir) -> (meth, f ~meth dir)) dirs
-
-let map f dirs =
-  map_dirs (fun ~meth:_ dir -> RestoDirectory.map f dir) dirs
-
-let prefix path dirs =
-  map_dirs (fun ~meth:_ dir -> RestoDirectory.prefix path dir) dirs
-
-let merge dirs1 dirs2 =
-  let compare (meth1, _dir1) (meth2, _dir2) = compare meth1 meth2 in
-  let f (meth1, dir1) (_, dir2) = (meth1, RestoDirectory.merge dir1 dir2) in
-  Utils.merge_list2 ~compare ~f dirs1 dirs2
-
-(*****************************************************************************
- * Registration
- ****************************************************************************)
-
-(** [replace_assoc ~init ~f k l] searches for value corresponding to [k] in an
-    association list, and replaces it with [f value]. If not found, a new pair
-    [(k, f init)] is added to the list. *)
-(* TODO: move to Utils? *)
-let replace_assoc ?(finalize = List.rev) ~init ~f key l =
-  let rec aux acc = function
-    | [] -> finalize ((key, f init) :: acc)
-    | (k, v) :: tl when k = key -> finalize ((key, f v) :: acc) @ tl
-    | hd :: tl -> aux (hd :: acc) tl
-  in
-  aux [] l
-
-(* Register [service] to the directory with corresponding [meth] using [reg] *)
-let register dirs (meth, service) handler =
-  let init = RestoDirectory.empty in
-  let f dir = RestoDirectory.register dir service handler in
-  replace_assoc ~init ~f meth dirs
-
-(* Register dynamic directory *)
-
-(* By default, the [builder] function of dynamic directory is registered for
-   HTTP methods listed in [rest_meths] *)
-let register_dynamic_directory
-    ?(meths = rest_meths) ?descr init_dirs path builder =
-  let builder' ~meth prefix =
-    builder prefix >>= fun dirs ->
-    Lwt.return (List.assoc meth dirs)
-  in
-  let init = RestoDirectory.empty in
-  List.fold_left (fun dirs meth ->
-      let f dir =
-        RestoDirectory.register_dynamic_directory
-          ?descr dir path (builder' ~meth)
-      in
-      replace_assoc ~init ~f meth dirs)
-    init_dirs meths
-
-(* Register custom lookup *)
-
-type custom_lookup = RestoDirectory.custom_lookup
-
-let register_custom_lookup ?(meth = default_meth) ?descr dirs s f =
-  let init = RestoDirectory.empty in
-  let f dir = RestoDirectory.register_custom_lookup ?descr dir s f in
-  replace_assoc ~init ~f meth dirs
-
-(* Register description service *)
-
-let register_describe_directory_service dirs (meth, service) =
-  let init = RestoDirectory.empty in
-  let f dir = RestoDirectory.register_describe_directory_service dir service in
-  replace_assoc ~init ~f meth dirs
-
-(*****************************************************************************
- * Lookup
- ****************************************************************************)
-
-let lookup dirs ?(meth = default_meth) args path =
-  let dir = List.assoc meth dirs in
-  RestoDirectory.lookup dir args path
-
-(*****************************************************************************
- * Currying
- ****************************************************************************)
-
-(* Service registration *)
-
-let register0 root s f =
-  register root s RestoDirectory.Internal.(curry Z f)
-
-let register1 root s f =
-  register root s RestoDirectory.Internal.(curry (S Z) f)
-
-let register2 root s f =
-  register root s RestoDirectory.Internal.(curry (S (S Z)) f)
-
-let register3 root s f =
-  register root s RestoDirectory.Internal.(curry (S (S (S Z))) f)
-
-let register4 root s f =
-  register root s RestoDirectory.Internal.(curry (S (S (S (S Z)))) f)
-
-let register5 root s f =
-  register root s RestoDirectory.Internal.(curry (S (S (S (S (S Z))))) f)
-
-(* Dynamic directory registration *)
-
-let register_dynamic_directory1 ?descr root s f =
-  register_dynamic_directory
-    ?descr root s RestoDirectory.Internal.(curry (S Z) f)
-
-let register_dynamic_directory2 ?descr root s f =
-  register_dynamic_directory
-    ?descr root s RestoDirectory.Internal.(curry (S (S Z)) f)
-
-let register_dynamic_directory3 ?descr root s f =
-  register_dynamic_directory
-    ?descr root s RestoDirectory.Internal.(curry (S (S (S Z))) f)
-
-(* Custom lookup registration *)
-
-let register_custom_lookup1 ?meth ?descr root s f =
-  register_custom_lookup ?meth ?descr root s
-    RestoDirectory.Internal.(curry (S Z) f)
-
-let register_custom_lookup2 ?meth ?descr root s f =
-  register_custom_lookup ?meth ?descr root s
-    RestoDirectory.Internal.(curry (S (S Z)) f)
-
-let register_custom_lookup3 ?meth ?descr root s f =
-  register_custom_lookup ?meth ?descr root s
-    RestoDirectory.Internal.(curry (S (S (S Z))) f)

src/minutils/RPC.mli

@@ -9,263 +9,55 @@
 
 (** Typed RPC services: definition, binding and dispatch. *)
 
-(** Typed path argument. *)
-module Arg : sig
 
-  type 'a arg
+module Data : Resto.ENCODING with type 'a t = 'a Data_encoding.t
-  val make:
+                              and type schema = Data_encoding.json_schema
-    ?descr:string ->
-    name:string ->
-    destruct:(string -> ('a, string) result) ->
-    construct:('a -> string) ->
-    unit -> 'a arg
 
-  type descr = {
+include (module type of struct include Resto end)
-    name: string ;
+include (module type of struct include RestoDirectory end)
-    descr: string option ;
+module Directory : (module type of struct include RestoDirectory.MakeDirectory(Data) end)
-  }
+module Service : (module type of struct include Directory.Service end)
-  val descr: 'a arg -> descr
 
-  val int: int arg
+(** Compatibility layer, to be removed ASAP. *)
-  val int32: int32 arg
-  val int64: int64 arg
-  val float: float arg
 
-end
+type 'a directory = 'a Directory.t
-
+type ('prefix, 'params, 'input, 'output) service =
-(** Parametrized path to services. *)
+  ([ `POST ], 'prefix, 'params, unit, 'input, 'output, unit) Service.t
-module Path : sig
-
-  type ('prefix, 'params) path
-  type 'prefix context = ('prefix, 'prefix) path
-
-  val root: 'a context
-
-  val add_suffix:
-    ('prefix, 'params) path -> string -> ('prefix, 'params) path
-  val (/):
-    ('prefix, 'params) path -> string -> ('prefix, 'params) path
-
-  val add_arg:
-    ('prefix, 'params) path -> 'a Arg.arg -> ('prefix, 'params * 'a) path
-  val (/:):
-    ('prefix, 'params) path -> 'a Arg.arg -> ('prefix, 'params * 'a) path
-
-  val prefix:
-    ('prefix, 'a) path -> ('a, 'params) path -> ('prefix, 'params) path
-
-  val map:
-    ('a -> 'b) -> ('b -> 'a) -> ('prefix, 'a) path -> ('prefix, 'b) path
-
-end
-
-(** HTTP methods as defined in Cohttp.Code *)
-
-type meth = [
-  | `GET
-  | `POST
-  | `HEAD
-  | `DELETE
-  | `PATCH
-  | `PUT
-  | `OPTIONS
-  | `TRACE
-  | `CONNECT
-  | `Other of string
-]
-
-val string_of_method : meth -> string
-
-(** Services. *)
-type ('prefix, 'params, 'input, 'output) service
 
 val service:
-  ?meth: meth ->
   ?description: string ->
   input: 'input Data_encoding.t ->
   output: 'output Data_encoding.t ->
-  ('prefix, 'params) Path.path ->
+  ('prefix, 'params) Path.t ->
   ('prefix, 'params, 'input, 'output) service
 
-val get_service:
+type directory_descr = Data_encoding.json_schema Description.directory
-  ?description: string ->
-  output: 'output Data_encoding.t ->
-  ('prefix, 'params) Path.path ->
-  ('prefix, 'params, unit, 'output) service
 
-val head_service:
+val empty: 'a directory
-  ?description: string ->
-  ('prefix, 'params) Path.path ->
-  ('prefix, 'params, unit, unit) service
-
-val post_service:
-  ?description: string ->
-  input: 'input Data_encoding.t ->
-  output: 'output Data_encoding.t ->
-  ('prefix, 'params) Path.path ->
-  ('prefix, 'params, 'input, 'output) service
-
-val put_service:
-  ?description: string ->
-  input: 'input Data_encoding.t ->
-  output: 'output Data_encoding.t ->
-  ('prefix, 'params) Path.path ->
-  ('prefix, 'params, 'input, 'output) service
-
-val delete_service:
-  ?description: string ->
-  input: 'input Data_encoding.t ->
-  output: 'output Data_encoding.t ->
-  ('prefix, 'params) Path.path ->
-  ('prefix, 'params, 'input, 'output) service
-
-val prefix:
-  ('prefix, 'inner_prefix) Path.path ->
-  ('inner_prefix, 'params, 'input, 'output) service ->
-  ('prefix, 'params, 'input, 'output) service
-
-val forge_request:
-  (unit, 'params, 'input, 'output) service ->
-  'params -> 'input -> meth * string list * Data_encoding.json
-
-val read_answer:
-  (unit, 'params, 'input, 'output) service ->
-  Data_encoding.json -> ('output, string) result
-
-(** Service directory description *)
-module Description : sig
-
-  type service_descr = {
-    description: string option ;
-    input: Json_schema.schema ;
-    output: Json_schema.schema ;
-  }
-
-  type directory_descr =
-    | Static of static_directory_descr
-    | Dynamic of string option
-
-  and static_directory_descr = {
-    service: service_descr option ;
-    subdirs: static_subdirectories_descr option ;
-  }
-
-  and static_subdirectories_descr =
-    | Suffixes of directory_descr Map.Make(String).t
-    | Arg of Arg.descr * directory_descr
-
-  val service:
-    ?meth: meth ->
-    ?description:string ->
-    ('prefix, 'params) Path.path ->
-    ('prefix, 'params, bool option, directory_descr) service
-
-  val pp_print_directory_descr:
-    Format.formatter -> directory_descr -> unit
-
-end
-
-module Answer : sig
-
-  (** Return type for service handler *)
-  type 'a answer =
-    { code : int ;
-      body : 'a output ;
-    }
-
-  and 'a output =
-    | Empty
-    | Single of 'a
-    | Stream of 'a stream
-
-  and 'a stream = {
-    next: unit -> 'a option Lwt.t ;
-    shutdown: unit -> unit ;
-  }
-
-  val ok: 'a -> 'a answer
-  val answer: ?code:int -> 'a -> 'a answer
-  val return: ?code:int -> 'a -> 'a answer Lwt.t
-  val return_stream: 'a stream -> 'a answer Lwt.t
-
-end
-
-(** Dispatch tree *)
-type 'prefix directory
-
-(** Empty list of dispatch trees *)
-val empty: 'prefix directory
-
-val map: ('a -> 'b) -> 'b directory -> 'a directory
-
-val prefix: ('pr, 'p) Path.path -> 'p directory -> 'pr directory
-val merge: 'a directory -> 'a directory -> 'a directory
-
-(** Possible error while registring services. *)
-type step =
-  | Static of string
-  | Dynamic of Arg.descr
-type conflict =
-  | CService | CDir | CBuilder | CCustom
-  | CTypes of Arg.descr *
-              Arg.descr
-  | CType of Arg.descr * string list
-exception Conflict of step list * conflict
-
-(** Registring handler in service tree. *)
 val register:
   'prefix directory ->
   ('prefix, 'params, 'input, 'output) service ->
-  ('params -> 'input -> 'output Answer.answer Lwt.t) ->
+  ('params -> 'input -> [< ('output, unit) RestoDirectory.Answer.t ] Lwt.t) ->
   'prefix directory
 
-(** Registring handler in service tree. Curryfied variant.  *)
 val register0:
   unit directory ->
   (unit, unit, 'i, 'o) service ->
-  ('i -> 'o Answer.answer Lwt.t) ->
+  ('i -> [< ('o, unit) Answer.t ] Lwt.t) ->
   unit directory
 
 val register1:
   'prefix directory ->
   ('prefix, unit * 'a, 'i, 'o) service ->
-  ('a -> 'i -> 'o Answer.answer Lwt.t) ->
+  ('a -> 'i -> [< ('o, unit) Answer.t ] Lwt.t) ->
   'prefix directory
 
 val register2:
   'prefix directory ->
   ('prefix, (unit * 'a) * 'b, 'i, 'o) service ->
-  ('a -> 'b -> 'i -> 'o Answer.answer Lwt.t) ->
+  ('a -> 'b -> 'i -> [< ('o, unit) Answer.t ] Lwt.t) ->
   'prefix directory
 
-val register3:
-  'prefix directory ->
-  ('prefix, ((unit * 'a) * 'b) * 'c, 'i, 'o) service ->
-  ('a -> 'b -> 'c -> 'i -> 'o Answer.answer Lwt.t) ->
-  'prefix directory
-
-val register4:
-  'prefix directory ->
-  ('prefix, (((unit * 'a) * 'b) * 'c) * 'd, 'i, 'o) service ->
-  ('a -> 'b -> 'c -> 'd -> 'i -> 'o Answer.answer Lwt.t) ->
-  'prefix directory
-
-val register5:
-  'prefix directory ->
-  ('prefix, ((((unit * 'a) * 'b) * 'c) * 'd) * 'e, 'i, 'o) service ->
-  ('a -> 'b -> 'c -> 'd -> 'e -> 'i -> 'o Answer.answer Lwt.t) ->
-  'prefix directory
-
-(** Registring dynamic subtree. *)
-val register_dynamic_directory:
-  ?meths:meth list ->
-  ?descr:string ->
-  'prefix directory ->
-  ('prefix, 'a) Path.path ->
-  ('a -> 'a directory Lwt.t) ->
-  'prefix directory
-
-(** Registring dynamic subtree. (Curryfied variant) *)
 val register_dynamic_directory1:
   ?descr:string ->
   'prefix directory ->
@@ -273,68 +65,7 @@ val register_dynamic_directory1:
   ('a -> (unit * 'a) directory Lwt.t) ->
   'prefix directory
 
-val register_dynamic_directory2:
+val forge_request:
-  ?descr:string ->
+  (unit, 'params, 'input, _) service ->
-  'prefix directory ->
+  'params -> 'input -> MethMap.key * string list * Data_encoding.json
-  ('prefix, (unit * 'a) * 'b) Path.path ->
-  ('a -> 'b -> ((unit * 'a) * 'b) directory Lwt.t) ->
-  'prefix directory
 
-val register_dynamic_directory3:
-  ?descr:string ->
-  'prefix directory ->
-  ('prefix, ((unit * 'a) * 'b) * 'c) Path.path ->
-  ('a -> 'b -> 'c -> (((unit * 'a) * 'b) * 'c) directory Lwt.t) ->
-  'prefix directory
-
-(** Registring custom directory lookup. *)
-type custom_lookup = RestoDirectory.custom_lookup
-(* | CustomService of Description.service_descr * *)
-(*                    ( Data_encoding.json option -> *)
-(*                      Data_encoding.json Answer.answer Lwt.t ) *)
-(* | CustomDirectory of Description.directory_descr *)
-
-val register_custom_lookup:
-  ?meth:meth ->
-  ?descr:string ->
-  'prefix directory ->
-  ('prefix, 'params) Path.path ->
-  ('params -> string list -> custom_lookup Lwt.t) ->
-  'prefix directory
-
-val register_custom_lookup1:
-  ?meth:meth ->
-  ?descr:string ->
-  'prefix directory ->
-  ('prefix, unit * 'a) Path.path ->
-  ('a -> string list -> custom_lookup Lwt.t) ->
-  'prefix directory
-
-val register_custom_lookup2:
-  ?meth:meth ->
-  ?descr:string ->
-  'prefix directory ->
-  ('prefix, (unit * 'a) * 'b) Path.path ->
-  ('a -> 'b -> string list -> custom_lookup Lwt.t) ->
-  'prefix directory
-
-val register_custom_lookup3:
-  ?meth:meth ->
-  ?descr:string ->
-  'prefix directory ->
-  ('prefix, ((unit * 'a) * 'b) * 'c) Path.path ->
-  ('a -> 'b -> 'c -> string list -> custom_lookup Lwt.t) ->
-  'prefix directory
-
-(** Registring a description service. *)
-val register_describe_directory_service:
-  'prefix directory ->
-  ('prefix, 'prefix, bool option, Description.directory_descr) service ->
-  'prefix directory
-
-exception Cannot_parse of Arg.descr * string * string list
-
-(** Resolve a service. *)
-val lookup:
-  'prefix directory -> ?meth:meth -> 'prefix -> string list ->
-  (Data_encoding.json option -> Data_encoding.json Answer.answer Lwt.t) Lwt.t

src/minutils/jbuild

@@ -6,7 +6,7 @@
   (libraries (cstruct
               lwt
               ocplib-json-typed.bson
-              ocplib-resto.directory
+              ocplib-resto-directory
               ocplib-endian.bigstring))
   (flags (:standard -w -9+27-30-32-40@8 -safe-string))
   (wrapped false)))

src/node/main/node_run_command.ml

@@ -176,7 +176,9 @@ let init_rpc (rpc_config: Node_config_file.rpc) node =
             port
             (if rpc_config.tls = None then "" else " (TLS enabled)") >>= fun () ->
           RPC_server.launch ~host mode dir
-            rpc_config.cors_origins rpc_config.cors_headers >>= fun server ->
+            ~media_types:RPC_server.[ json ; octet_stream ]
+            ~cors:{ allowed_origins = rpc_config.cors_origins ;
+                    allowed_headers = rpc_config.cors_headers } >>= fun server ->
           return (Some server)
 
 let init_signal () =

src/node/net/RPC_server.ml

@@ -7,255 +7,40 @@
 (*                                                                        *)
 (**************************************************************************)
 
-open RPC
+type cors = RestoCohttp.cors = {
-open Logging.RPC
+  allowed_headers : string list ;
+  allowed_origins : string list ;
+}
 
-(* public types *)
+include RestoCohttp.Make(RPC.Data)(Logging.RPC)
-type server = (* hidden *)
-  { shutdown : unit -> unit Lwt.t ;
-    mutable root : unit directory }
 
-module ConnectionMap = Map.Make(Cohttp.Connection)
+let json  = {
+  name = "application/json" ;
+  construct = begin fun enc v ->
+    Data_encoding_ezjsonm.to_string @@
+    Data_encoding.Json.construct enc v
+  end ;
+  destruct = begin fun enc body ->
+    match Data_encoding_ezjsonm.from_string body with
+    | Error _ as err -> err
+    | Ok json ->
+        try Ok (Data_encoding.Json.destruct enc json)
+        with Data_encoding.Json.Cannot_destruct (_, exn) ->
+          Error (Format.asprintf "%a"
+                   (fun fmt -> Data_encoding.Json.print_error fmt)
+                   exn)
+  end ;
+}
 
-exception Invalid_method of { allowed : RPC.meth list }
+let octet_stream = {
-exception Cannot_parse_body of string
+  name = "application/octet-stream" ;
-
+  construct = begin fun enc v ->
-let check_origin_matches origin allowed_origin =
+    MBytes.to_string @@
-  String.equal "*" allowed_origin ||
+    Data_encoding.Binary.to_bytes enc v
-  String.equal allowed_origin origin ||
+  end ;
-  begin
+  destruct = begin fun enc s ->
-    let allowed_w_slash = allowed_origin ^ "/" in
+    match Data_encoding.Binary.of_bytes enc (MBytes.of_string s) with
-    let len_a_w_s = String.length allowed_w_slash in
+    | None -> Error "Failed to parse binary data."
-    let len_o = String.length origin in
+    | Some data -> Ok data
-    (len_o >= len_a_w_s) &&
+  end ;
-    String.equal allowed_w_slash @@ String.sub origin 0 len_a_w_s
+}
-  end
-
-let find_matching_origin allowed_origins origin =
-  let matching_origins = List.filter (check_origin_matches origin) allowed_origins in
-  let compare_by_length_neg a b = ~- (compare (String.length a) (String.length b)) in
-  let matching_origins_sorted = List.sort compare_by_length_neg matching_origins in
-  match matching_origins_sorted with
-  | [] -> None
-  | x :: _ -> Some x
-
-let make_cors_headers ?(headers=Cohttp.Header.init ())
-    cors_allowed_headers cors_allowed_origins origin_header =
-  let cors_headers = Cohttp.Header.add_multi headers
-      "Access-Control-Allow-Headers" cors_allowed_headers in
-  match origin_header with
-  | None -> cors_headers
-  | Some origin ->
-      match find_matching_origin cors_allowed_origins origin with
-      | None -> cors_headers
-      | Some allowed_origin ->
-          Cohttp.Header.add_multi cors_headers
-            "Access-Control-Allow-Origin" [allowed_origin]
-
-(* Promise a running RPC server. *)
-let launch ?pre_hook ?post_hook ?(host="::") mode root cors_allowed_origins cors_allowed_headers =
-  (* launch the worker *)
-  let cancelation, canceler, _ = Lwt_utils.canceler () in
-  let open Cohttp_lwt_unix in
-  let streams = ref ConnectionMap.empty in
-  let create_stream _io con to_string (s: _ Answer.stream) =
-    let running = ref true in
-    let stream =
-      Lwt_stream.from
-        (fun () ->
-           if not !running then Lwt.return None else
-             s.next () >|= function
-             | None -> None
-             | Some x -> Some (to_string x)) in
-    let shutdown () = running := false ; s.shutdown () in
-    streams := ConnectionMap.add con shutdown !streams ;
-    stream
-  in
-  let shutdown_stream con =
-    try ConnectionMap.find con !streams ()
-    with Not_found -> () in
-  let call_hook (io, con) req ?(answer_404 = false) hook =
-    match hook with
-    | None -> Lwt.return None
-    | Some hook ->
-        Lwt.catch
-          (fun () ->
-             hook (Uri.path (Cohttp.Request.uri req))
-             >>= fun (content_type, { Answer.code ; body }) ->
-             let headers =
-               match content_type with
-               | None -> Cohttp.Header.init ()
-               | Some ct -> Cohttp.Header.init_with "Content-Type" ct
-             in
-             if code = 404 && not answer_404 then
-               Lwt.return None
-             else
-               let body = match body with
-                 | Answer.Empty ->
-                     Cohttp_lwt_body.empty
-                 | Single body ->
-                     Cohttp_lwt_body.of_string body
-                 | Stream s ->
-                     let stream =
-                       create_stream io con (fun s -> s) s in
-                     Cohttp_lwt_body.of_stream stream in
-               Lwt.return_some
-                 (Response.make ~flush:true ~status:(`Code code) ~headers (),
-                  body))
-          (function
-            | Not_found -> Lwt.return None
-            | exn -> Lwt.fail exn) in
-  let callback (io, con) req body =
-    (* FIXME: check inbound adress *)
-    let path = Utils.split_path (Uri.path (Cohttp.Request.uri req)) in
-    let req_headers = Cohttp.Request.headers req in
-    let origin_header = Cohttp.Header.get req_headers "origin" in
-    let answer_with_cors_headers ?headers ?body status =
-      let headers = match headers with
-        | None -> Cohttp.Header.init ()
-        | Some headers -> headers in
-      let body = match body with
-        | None -> Cohttp_lwt_body.empty
-        | Some body -> body in
-      let headers =
-        make_cors_headers ~headers
-          cors_allowed_headers cors_allowed_origins origin_header in
-      Lwt.return (Response.make ~flush:true ~status ~headers (), body) in
-    lwt_log_info "(%s) receive request to %s"
-      (Cohttp.Connection.to_string con) (Uri.path (Cohttp.Request.uri req)) >>= fun () ->
-    Lwt.catch
-      (fun () ->
-         call_hook (io, con) req pre_hook >>= function
-         | Some res ->
-             Lwt.return res
-         | None ->
-             let existing_methods () =
-               let supported_meths =
-                 [ `OPTIONS ; `POST ; `PUT ; `PATCH ; `DELETE ; `GET ; `HEAD ] in
-               Lwt_list.filter_map_p
-                 (fun meth ->
-                    Lwt.catch
-                      (fun () ->
-                         lookup root ~meth () path >>= fun _handler ->
-                         Lwt.return_some meth)
-                      (function Not_found | Cannot_parse _ -> Lwt.return_none
-                              | exn -> Lwt.fail exn))
-                 supported_meths >>= function
-               | [] -> Lwt.fail Not_found (* No handler at all -> 404 *)
-               | meths -> Lwt.return meths in
-             Lwt.catch
-               (fun () ->
-                  lookup root ~meth:req.meth () path >>= fun handler ->
-                  Lwt.return_some handler)
-               (function Not_found | Cannot_parse _ -> Lwt.return_none
-                       | exn -> Lwt.fail exn) >>= function
-             | None ->
-                 begin
-                   (* Default OPTIONS handler for CORS preflight *)
-                   if req.meth = `OPTIONS && origin_header <> None then
-                     match Cohttp.Header.get req_headers
-                             "Access-Control-Request-Method" with
-                     | Some meth ->
-                         let meth = Cohttp.Code.method_of_string meth in
-                         lookup root ~meth () path >>= fun _handler ->
-                         (* unless [lookup] failed with [Not_found] -> 404 *)
-                         Lwt.return [ meth ]
-                     | None -> existing_methods ()
-                   else
-                     existing_methods () >>= fun allowed ->
-                     Lwt.fail (Invalid_method { allowed })
-                 end >>= fun cors_allowed_meths ->
-                 lwt_log_info "(%s) RPC preflight"
-                   (Cohttp.Connection.to_string con) >>= fun () ->
-                 let headers =
-                   Cohttp.Header.add_multi
-                     (Cohttp.Header.init ())
-                     "Access-Control-Allow-Methods"
-                     (List.map Cohttp.Code.string_of_method cors_allowed_meths) in
-                 answer_with_cors_headers ~headers `OK
-             | Some handler ->
-                 begin match req.meth with
-                   | `POST
-                   | `PUT
-                   | `PATCH
-                   | `DELETE -> begin
-                       Cohttp_lwt_body.to_string body >>= fun body ->
-                       match Data_encoding_ezjsonm.from_string body with
-                       | Error msg -> Lwt.fail (Cannot_parse_body msg)
-                       | Ok body -> Lwt.return (Some body)
-                     end
-                   | `GET
-                   | `HEAD
-                   | `OPTIONS -> Lwt.return None
-                   | _ ->
-                       existing_methods () >>= fun allowed ->
-                       Lwt.fail (Invalid_method { allowed })
-                 end >>= fun body ->
-                 handler body >>= fun { Answer.code ; body } ->
-                 let body = match body with
-                   | Empty ->
-                       Cohttp_lwt_body.empty
-                   | Single json ->
-                       Cohttp_lwt_body.of_string (Data_encoding_ezjsonm.to_string json)
-                   | Stream s ->
-                       let stream =
-                         create_stream io con Data_encoding_ezjsonm.to_string s in
-                       Cohttp_lwt_body.of_stream stream in
-                 lwt_log_info "(%s) RPC %s"
-                   (Cohttp.Connection.to_string con)
-                   (if Cohttp.Code.is_error code
-                    then "failed"
-                    else "success") >>= fun () ->
-                 let headers =
-                   Cohttp.Header.init_with "Content-Type" "application/json" in
-                 answer_with_cors_headers ~headers ~body (`Code code))
-      (function
-        | Not_found | Cannot_parse _ ->
-            lwt_log_info "(%s) not found"
-              (Cohttp.Connection.to_string con) >>= fun () ->
-            (call_hook (io, con) req ~answer_404: true post_hook >>= function
-              | Some res -> Lwt.return res
-              | None -> answer_with_cors_headers `Not_found)
-        | Invalid_method { allowed } ->
-            lwt_log_info "(%s) bad method"
-              (Cohttp.Connection.to_string con) >>= fun () ->
-            let headers =
-              Cohttp.Header.add_multi (Cohttp.Header.init ())
-                "Allow"
-                (List.map Cohttp.Code.string_of_method allowed) in
-            answer_with_cors_headers ~headers `Method_not_allowed
-        | Cannot_parse_body msg ->
-            lwt_log_info "(%s) can't parse RPC body"
-              (Cohttp.Connection.to_string con) >>= fun () ->
-            let body = Cohttp_lwt_body.of_string msg in
-            answer_with_cors_headers ~body `Bad_request
-        | e -> Lwt.fail e)
-  and conn_closed (_, con) =
-    log_info "connection closed %s" (Cohttp.Connection.to_string con) ;
-    shutdown_stream con  in
-  Conduit_lwt_unix.init ~src:host () >>= fun ctx ->
-  let ctx = Cohttp_lwt_unix_net.init ~ctx () in
-  let stop = cancelation () in
-  let on_exn = function
-    | Unix.Unix_error (Unix.EADDRINUSE, "bind", _) ->
-        log_error "RPC server port already taken, \
-                   the node will be shutdown" ;
-        Lwt_exit.exit 1
-    | Unix.Unix_error (ECONNRESET, _, _)
-    | Unix.Unix_error (EPIPE, _, _)  -> ()
-    | exn -> !Lwt.async_exception_hook exn
-  in
-  let server =
-    Server.create ~stop ~ctx ~mode ~on_exn
-      (Server.make ~callback ~conn_closed ()) in
-  let shutdown () =
-    canceler () >>= fun () ->
-    server in
-  Lwt.return { shutdown ; root }
-
-let root_service { root } = root
-
-let set_root_service server root = server.root <- root
-
-let shutdown server =
-  server.shutdown ()

src/node/net/RPC_server.mli

@@ -9,49 +9,31 @@
 
 (** Typed RPC services: server implementation. *)
 
+type cors = {
+  allowed_headers : string list ;
+  allowed_origins : string list ;
+}
+
+type media_type = {
+  name: string ;
+  construct: 'a. 'a Data_encoding.t -> 'a -> string ;
+  destruct: 'a. 'a Data_encoding.t -> string -> ('a, string) result ;
+}
+
+val json : media_type
+val octet_stream : media_type
+
 (** A handle on the server worker. *)
 type server
 
-(** Promise a running RPC server. To call an RPC at /p/a/t/h/ in the
+(** Promise a running RPC server.*)
-    provided service, one must call the URI /call/p/a/t/h/. Calling
-    /list/p/a/t/h/ will list the services prefixed by /p/a/t/h/, if
-    any. Calling /schema/p/a/t/h/ will describe the input and output
-    of the service, if it is callable. Calling /pipe will read a
-    sequence of services to call in sequence from the request body,
-    see {!pipe_encoding}.
-
-    The arguments cors_allowed_origins and cors_allowed_headers define
-    the cross-origin resource sharing using the headers
-    Access-Control-Allow-Origin and Access-Control-Allow-Headers. The
-    argument cors_allowed_headers sets the content of
-    Access-Control-Allow-Headers. Since you cannot have multiple
-    values for Access-Control-Allow-Origin, the server accepts a list
-    in cors_allowed_origins and matches it against the origin of the
-    incoming request; then returns the longest element of the passed
-    list as the content of Access-Control-Allow-Origin.
-
-    The optional [pre_hook] is called with the path part of the URL
-    before resolving each request, to delegate the answering to
-    another resolution mechanism. Its result is ignored if the return
-    code is [404]. The optional [post_hook] is called if both the
-    [pre_hook] and the serviced answered with a [404] code. [pre_hook] and
-    [post_hook] return a pair made of an optional Content-Type value and the
-    answer. *)
 val launch :
-  ?pre_hook: (string -> (string option * string RPC.Answer.answer) Lwt.t) ->
-  ?post_hook: (string -> (string option * string RPC.Answer.answer) Lwt.t) ->
   ?host:string ->
+  ?cors:cors ->
+  media_types:media_type list ->
   Conduit_lwt_unix.server ->
-  unit RPC.directory ->
+  unit RPC.Directory.t ->
-  string list ->
-  string list ->
   server Lwt.t
 
 (** Kill an RPC server. *)
 val shutdown : server -> unit Lwt.t
-
-(** Retrieve the root service of the server. *)
-val root_service : server -> unit RPC.directory
-
-(** Change the root service of the server. *)
-val set_root_service : server -> unit RPC.directory -> unit

src/node/net/jbuild

@@ -3,7 +3,7 @@
 (library
  ((name node_net)
   (public_name tezos.node.net)
-  (libraries (utils minutils conduit-lwt-unix cohttp cohttp-lwt-unix))
+  (libraries (utils minutils lwt.unix ocplib-resto-cohttp))
   (flags (:standard -w -9+27-30-32-40@8
                     -safe-string
                     -open Error_monad

src/node/shell/node.ml

@@ -522,8 +522,8 @@ module RPC = struct
     | Some rpc_context ->
         Context.get_protocol rpc_context.context >>= fun protocol_hash ->
         let (module Proto) = State.Registred_protocol.get_exn protocol_hash in
-        let dir = RPC.map (fun () -> rpc_context) Proto.rpc_services in
+        let dir = RPC.Directory.map (fun () -> rpc_context) Proto.rpc_services in
-        Lwt.return (Some (RPC.map (fun _ -> ()) dir))
+        Lwt.return (Some (RPC.Directory.map (fun _ -> ()) dir))
 
   let heads node =
     let net_state = Net_validator.net_state node.mainnet_validator in

src/node/shell/node_rpc.ml

@@ -533,5 +533,5 @@ let build_rpc_directory node =
         Node.RPC.Network.Point.events node point |> RPC.Answer.return in
     RPC.register1 dir Services.Network.Point.events implementation in
   let dir =
-    RPC.register_describe_directory_service dir Services.describe in
+    RPC.Directory.register_describe_directory_service dir Services.describe in
   dir

src/node/shell/node_rpc_services.ml

@@ -19,13 +19,14 @@ module Error = struct
       RPC.Path.(root / "errors")
 
   let encoding =
-    let meth, path, _ = RPC.forge_request service () () in
+    let { RPC.Service.meth ;  path ; _ } =
+      RPC.Service.forge_request service () () in
     describe
       ~description:
         (Printf.sprintf
            "The full list of error is available with \
             the global RPC `%s /%s`"
-           (RPC.string_of_method meth) (String.concat "/" path))
+           (RPC.string_of_meth meth) (String.concat "/" path))
       (conv
          ~schema:Json_schema.any
          (fun exn -> `A (List.map json_of_error exn))
@@ -749,6 +750,6 @@ let complete =
     RPC.Path.(root / "complete" /: prefix_arg )
 
 let describe =
-  RPC.Description.service
+  RPC.Service.description_service
     ~description: "RPCs documentation and input/output schema"
     RPC.Path.(root / "describe")

src/node/shell/node_rpc_services.mli

@@ -201,5 +201,4 @@ val bootstrapped: (unit, unit, unit, Block_hash.t * Time.t) RPC.service
 
 val complete: (unit, unit * string, unit, string list) RPC.service
 
-val describe:
+val describe: (unit, unit) RPC.Service.description_service
-  (unit, unit, bool option, RPC.Description.directory_descr) RPC.service

src/node/updater/updater.ml

@@ -137,7 +137,7 @@ module Node_protocol_environment_sigs = struct
        and type Tezos_data.Operation.t = Tezos_data.Operation.t
        and type Tezos_data.Block_header.shell_header = Tezos_data.Block_header.shell_header
        and type Tezos_data.Block_header.t = Tezos_data.Block_header.t
-       and type 'a RPC.directory = 'a RPC.directory
+       and type 'a RPC.Directory.t = 'a RPC.Directory.t
        and type Updater.validation_result = validation_result
        and type Updater.rpc_context = rpc_context
 

src/node/updater/updater.mli

@@ -99,7 +99,7 @@ module Node_protocol_environment_sigs : sig
        and type Tezos_data.Operation.t = Tezos_data.Operation.t
        and type Tezos_data.Block_header.shell_header = Tezos_data.Block_header.shell_header
        and type Tezos_data.Block_header.t = Tezos_data.Block_header.t
-       and type 'a RPC.directory = 'a RPC.directory
+       and type 'a RPC.Directory.t = 'a RPC.Directory.t
        and type Updater.validation_result = validation_result
        and type Updater.rpc_context = rpc_context
 

src/proto/alpha/services_registration.ml

@@ -26,11 +26,11 @@ let rpc_init
   Tezos_context.init ~level ~timestamp ~fitness context >>=? fun context ->
   return { block_hash ; block_header ; operation_hashes ; operations ; context }
 
-let rpc_services = ref (RPC.empty : Updater.rpc_context RPC.directory)
+let rpc_services = ref (RPC.Directory.empty : Updater.rpc_context RPC.directory)
 
 let register0_fullctxt s f =
   rpc_services :=
-    RPC.register !rpc_services (s RPC.Path.root)
+    RPC.register !rpc_services (s RPC.Path.open_root)
       (fun ctxt () ->
          ( rpc_init ctxt >>=? fun ctxt ->
            f ctxt ) >>= RPC.Answer.return)
@@ -38,19 +38,19 @@ let register0 s f = register0_fullctxt s (fun { context } -> f context)
 
 let register1_fullctxt s f =
   rpc_services :=
-    RPC.register !rpc_services (s RPC.Path.root)
+    RPC.register !rpc_services (s RPC.Path.open_root)
       (fun ctxt arg ->
          ( rpc_init ctxt >>=? fun ctxt ->
            f ctxt arg ) >>= RPC.Answer.return)
 let register1 s f = register1_fullctxt s (fun { context } x -> f context x)
 let register1_noctxt s f =
   rpc_services :=
-    RPC.register !rpc_services (s RPC.Path.root)
+    RPC.register !rpc_services (s RPC.Path.open_root)
       (fun _ arg -> f arg >>= RPC.Answer.return)
 
 let register2_fullctxt s f =
   rpc_services :=
-    RPC.register !rpc_services (s RPC.Path.root)
+    RPC.register !rpc_services (s RPC.Path.open_root)
       (fun (ctxt, arg1) arg2 ->
          ( rpc_init ctxt >>=? fun ctxt ->
            f ctxt arg1 arg2 ) >>= RPC.Answer.return)
@@ -208,7 +208,7 @@ let () =
 let () =
   let register2 s f =
     rpc_services :=
-      RPC.register !rpc_services (s RPC.Path.root)
+      RPC.register !rpc_services (s RPC.Path.open_root)
         (fun (ctxt, contract) arg ->
            ( rpc_init ctxt >>=? fun { context = ctxt } ->
              Contract.exists ctxt contract >>=? function

src/proto/demo/jbuild

@@ -52,4 +52,4 @@
   (deps ((glob_files *.ml)
          (glob_files *.mli)
          TEZOS_PROTOCOL))
-  (action (run ${exe:../../compiler_main.exe} dummy_genesis ${path-no-dep:.}))))
+  (action (chdir ${ROOT} (run ${exe:../../compiler_main.exe} dummy_genesis ${path-no-dep:.})))))

src/proto/demo/services.ml

@@ -46,17 +46,17 @@ let failing_service custom_root =
     RPC.Path.(custom_root / "failing")
 
 let rpc_services : Updater.rpc_context RPC.directory =
-  let dir = RPC.empty in
+  let dir = RPC.Directory.empty in
   let dir =
     RPC.register
       dir
-      (failing_service RPC.Path.root)
+      (failing_service RPC.Path.open_root)
       (fun _ctxt x -> Error.demo_error x >>= RPC.Answer.return)
   in
   let dir =
     RPC.register
       dir
-      (echo_service RPC.Path.root)
+      (echo_service RPC.Path.open_root)
       (fun _ctxt x -> RPC.Answer.return x)
   in
   dir

src/proto/genesis/jbuild

@@ -55,4 +55,4 @@
   (deps ((glob_files *.ml)
          (glob_files *.mli)
          TEZOS_PROTOCOL))
-  (action (run ${exe:../../compiler_main.exe} dummy_genesis ${path-no-dep:.}))))
+  (action (chdir ${ROOT} (run ${exe:../../compiler_main.exe} dummy_genesis ${path-no-dep:.})))))

src/proto/genesis/services.ml

@@ -59,11 +59,11 @@ let operations_hash =
   Operation_list_list_hash.compute []
 
 let rpc_services : Updater.rpc_context RPC.directory =
-  let dir = RPC.empty in
+  let dir = RPC.Directory.empty in
   let dir =
     RPC.register
       dir
-      (Forge.block RPC.Path.root)
+      (Forge.block RPC.Path.open_root)
       (fun _ctxt ((_net_id, level, proto_level, predecessor,
                    timestamp, fitness), command) ->
         let shell = { Block_header.level ; proto_level ; predecessor ;

tezos.opam

@@ -27,7 +27,6 @@ depends: [
   "ocp-ocamlres" { >= "dev" }
   "ocplib-endian"
   "ocplib-json-typed"
-  "ocplib-resto" { >= "dev" }
   "reactiveData"
   "sodium" { >= "0.3.0" }
   "magic-mime"
@@ -39,5 +38,5 @@ build: [
   [ "jbuilder" "build" "-p" name "-j" jobs ]
 ]
 build-test: [
-  [ "jbuilder" "runtest" ]
+  [ "jbuilder" "runtest" "-p" name "-j" jobs ]
-]
+]

vendors/ocplib-resto/.gitignore

@@ -0,0 +1,6 @@
+
+*~
+_build
+
+.merlin
+*.install

vendors/ocplib-resto/.ocp-indent

@@ -0,0 +1 @@
+match_clause = 4

vendors/ocplib-resto/.travis.yml

@@ -0,0 +1,12 @@
+language: c
+sudo: false
+services:
+  - docker
+install: wget https://raw.githubusercontent.com/ocaml/ocaml-travisci-skeleton/master/.travis-docker.sh
+script: bash ./.travis-docker.sh
+env:
+  global:
+    - PACKAGE="ocplib-resto"
+  matrix:
+    - DISTRO=debian-stable OCAML_VERSION=4.03.0
+    - DISTRO=debian-stable OCAML_VERSION=4.02.3

vendors/ocplib-resto/CHANGES.md

@@ -0,0 +1,3 @@
+### 0.2 (2017-11-21)
+
+* Switch to jbuilder

vendors/ocplib-resto/LICENSE

@@ -0,0 +1,203 @@
+In the following, "ocplib-resto" refers to all files marked
+"Copyright OCamlPro" in this distribution.
+
+ocplib-resto is distributed under the terms of the
+GNU Lesser General Public License (LGPL) version 2.1 (included below).
+
+As a special exception to the GNU Lesser General Public License, you
+may link, statically or dynamically, a "work that uses ocplib-resto"
+with a publicly distributed version of ocplib-resto to produce an
+executable file containing portions of ocplib-resto, and distribute
+that executable file under terms of your choice, without any of the
+additional requirements listed in clause 6 of the GNU Lesser General
+Public License. By "a publicly distributed version of ocplib-resto",
+we mean either the unmodified ocplib-resto as distributed by OCamlPro,
+or a modified version of ocplib-resto that is distributed under the
+conditions defined in clause 2 of the GNU Lesser General Public
+License. This exception does not however invalidate any other reasons
+why the executable file might be covered by the GNU Lesser General
+Public License.
+
+----------------------------------------------------------------------
+
+GNU LESSER GENERAL PUBLIC LICENSE
+
+Version 2.1, February 1999
+
+Copyright (C) 1991, 1999 Free Software Foundation, Inc.
+51 Franklin Street, Fifth Floor, Boston, MA  02110-1301  USA
+Everyone is permitted to copy and distribute verbatim copies
+of this license document, but changing it is not allowed.
+
+[This is the first released version of the Lesser GPL.  It also counts
+ as the successor of the GNU Library Public License, version 2, hence
+ the version number 2.1.]
+
+Preamble
+
+The licenses for most software are designed to take away your freedom to share and change it. By contrast, the GNU General Public Licenses are intended to guarantee your freedom to share and change free software--to make sure the software is free for all its users.
+
+This license, the Lesser General Public License, applies to some specially designated software packages--typically libraries--of the Free Software Foundation and other authors who decide to use it. You can use it too, but we suggest you first think carefully about whether this license or the ordinary General Public License is the better strategy to use in any particular case, based on the explanations below.
+
+When we speak of free software, we are referring to freedom of use, not price. Our General Public Licenses are designed to make sure that you have the freedom to distribute copies of free software (and charge for this service if you wish); that you receive source code or can get it if you want it; that you can change the software and use pieces of it in new free programs; and that you are informed that you can do these things.
+
+To protect your rights, we need to make restrictions that forbid distributors to deny you these rights or to ask you to surrender these rights. These restrictions translate to certain responsibilities for you if you distribute copies of the library or if you modify it.
+
+For example, if you distribute copies of the library, whether gratis or for a fee, you must give the recipients all the rights that we gave you. You must make sure that they, too, receive or can get the source code. If you link other code with the library, you must provide complete object files to the recipients, so that they can relink them with the library after making changes to the library and recompiling it. And you must show them these terms so they know their rights.
+
+We protect your rights with a two-step method: (1) we copyright the library, and (2) we offer you this license, which gives you legal permission to copy, distribute and/or modify the library.
+
+To protect each distributor, we want to make it very clear that there is no warranty for the free library. Also, if the library is modified by someone else and passed on, the recipients should know that what they have is not the original version, so that the original author's reputation will not be affected by problems that might be introduced by others.
+
+Finally, software patents pose a constant threat to the existence of any free program. We wish to make sure that a company cannot effectively restrict the users of a free program by obtaining a restrictive license from a patent holder. Therefore, we insist that any patent license obtained for a version of the library must be consistent with the full freedom of use specified in this license.
+
+Most GNU software, including some libraries, is covered by the ordinary GNU General Public License. This license, the GNU Lesser General Public License, applies to certain designated libraries, and is quite different from the ordinary General Public License. We use this license for certain libraries in order to permit linking those libraries into non-free programs.
+
+When a program is linked with a library, whether statically or using a shared library, the combination of the two is legally speaking a combined work, a derivative of the original library. The ordinary General Public License therefore permits such linking only if the entire combination fits its criteria of freedom. The Lesser General Public License permits more lax criteria for linking other code with the library.
+
+We call this license the "Lesser" General Public License because it does Less to protect the user's freedom than the ordinary General Public License. It also provides other free software developers Less of an advantage over competing non-free programs. These disadvantages are the reason we use the ordinary General Public License for many libraries. However, the Lesser license provides advantages in certain special circumstances.
+
+For example, on rare occasions, there may be a special need to encourage the widest possible use of a certain library, so that it becomes a de-facto standard. To achieve this, non-free programs must be allowed to use the library. A more frequent case is that a free library does the same job as widely used non-free libraries. In this case, there is little to gain by limiting the free library to free software only, so we use the Lesser General Public License.
+
+In other cases, permission to use a particular library in non-free programs enables a greater number of people to use a large body of free software. For example, permission to use the GNU C Library in non-free programs enables many more people to use the whole GNU operating system, as well as its variant, the GNU/Linux operating system.
+
+Although the Lesser General Public License is Less protective of the users' freedom, it does ensure that the user of a program that is linked with the Library has the freedom and the wherewithal to run that program using a modified version of the Library.
+
+The precise terms and conditions for copying, distribution and modification follow. Pay close attention to the difference between a "work based on the library" and a "work that uses the library". The former contains code derived from the library, whereas the latter must be combined with the library in order to run.
+
+TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION
+
+0. This License Agreement applies to any software library or other program which contains a notice placed by the copyright holder or other authorized party saying it may be distributed under the terms of this Lesser General Public License (also called "this License"). Each licensee is addressed as "you".
+
+A "library" means a collection of software functions and/or data prepared so as to be conveniently linked with application programs (which use some of those functions and data) to form executables.
+
+The "Library", below, refers to any such software library or work which has been distributed under these terms. A "work based on the Library" means either the Library or any derivative work under copyright law: that is to say, a work containing the Library or a portion of it, either verbatim or with modifications and/or translated straightforwardly into another language. (Hereinafter, translation is included without limitation in the term "modification".)
+
+"Source code" for a work means the preferred form of the work for making modifications to it. For a library, complete source code means all the source code for all modules it contains, plus any associated interface definition files, plus the scripts used to control compilation and installation of the library.
+
+Activities other than copying, distribution and modification are not covered by this License; they are outside its scope. The act of running a program using the Library is not restricted, and output from such a program is covered only if its contents constitute a work based on the Library (independent of the use of the Library in a tool for writing it). Whether that is true depends on what the Library does and what the program that uses the Library does.
+
+1. You may copy and distribute verbatim copies of the Library's complete source code as you receive it, in any medium, provided that you conspicuously and appropriately publish on each copy an appropriate copyright notice and disclaimer of warranty; keep intact all the notices that refer to this License and to the absence of any warranty; and distribute a copy of this License along with the Library.
+
+You may charge a fee for the physical act of transferring a copy, and you may at your option offer warranty protection in exchange for a fee.
+
+2. You may modify your copy or copies of the Library or any portion of it, thus forming a work based on the Library, and copy and distribute such modifications or work under the terms of Section 1 above, provided that you also meet all of these conditions:
+
+    a) The modified work must itself be a software library.
+    b) You must cause the files modified to carry prominent notices stating that you changed the files and the date of any change.
+    c) You must cause the whole of the work to be licensed at no charge to all third parties under the terms of this License.
+    d) If a facility in the modified Library refers to a function or a table of data to be supplied by an application program that uses the facility, other than as an argument passed when the facility is invoked, then you must make a good faith effort to ensure that, in the event an application does not supply such function or table, the facility still operates, and performs whatever part of its purpose remains meaningful.
+
+    (For example, a function in a library to compute square roots has a purpose that is entirely well-defined independent of the application. Therefore, Subsection 2d requires that any application-supplied function or table used by this function must be optional: if the application does not supply it, the square root function must still compute square roots.)
+
+These requirements apply to the modified work as a whole. If identifiable sections of that work are not derived from the Library, and can be reasonably considered independent and separate works in themselves, then this License, and its terms, do not apply to those sections when you distribute them as separate works. But when you distribute the same sections as part of a whole which is a work based on the Library, the distribution of the whole must be on the terms of this License, whose permissions for other licensees extend to the entire whole, and thus to each and every part regardless of who wrote it.
+
+Thus, it is not the intent of this section to claim rights or contest your rights to work written entirely by you; rather, the intent is to exercise the right to control the distribution of derivative or collective works based on the Library.
+
+In addition, mere aggregation of another work not based on the Library with the Library (or with a work based on the Library) on a volume of a storage or distribution medium does not bring the other work under the scope of this License.
+
+3. You may opt to apply the terms of the ordinary GNU General Public License instead of this License to a given copy of the Library. To do this, you must alter all the notices that refer to this License, so that they refer to the ordinary GNU General Public License, version 2, instead of to this License. (If a newer version than version 2 of the ordinary GNU General Public License has appeared, then you can specify that version instead if you wish.) Do not make any other change in these notices.
+
+Once this change is made in a given copy, it is irreversible for that copy, so the ordinary GNU General Public License applies to all subsequent copies and derivative works made from that copy.
+
+This option is useful when you wish to copy part of the code of the Library into a program that is not a library.
+
+4. You may copy and distribute the Library (or a portion or derivative of it, under Section 2) in object code or executable form under the terms of Sections 1 and 2 above provided that you accompany it with the complete corresponding machine-readable source code, which must be distributed under the terms of Sections 1 and 2 above on a medium customarily used for software interchange.
+
+If distribution of object code is made by offering access to copy from a designated place, then offering equivalent access to copy the source code from the same place satisfies the requirement to distribute the source code, even though third parties are not compelled to copy the source along with the object code.
+
+5. A program that contains no derivative of any portion of the Library, but is designed to work with the Library by being compiled or linked with it, is called a "work that uses the Library". Such a work, in isolation, is not a derivative work of the Library, and therefore falls outside the scope of this License.
+
+However, linking a "work that uses the Library" with the Library creates an executable that is a derivative of the Library (because it contains portions of the Library), rather than a "work that uses the library". The executable is therefore covered by this License. Section 6 states terms for distribution of such executables.
+
+When a "work that uses the Library" uses material from a header file that is part of the Library, the object code for the work may be a derivative work of the Library even though the source code is not. Whether this is true is especially significant if the work can be linked without the Library, or if the work is itself a library. The threshold for this to be true is not precisely defined by law.
+
+If such an object file uses only numerical parameters, data structure layouts and accessors, and small macros and small inline functions (ten lines or less in length), then the use of the object file is unrestricted, regardless of whether it is legally a derivative work. (Executables containing this object code plus portions of the Library will still fall under Section 6.)
+
+Otherwise, if the work is a derivative of the Library, you may distribute the object code for the work under the terms of Section 6. Any executables containing that work also fall under Section 6, whether or not they are linked directly with the Library itself.
+
+6. As an exception to the Sections above, you may also combine or link a "work that uses the Library" with the Library to produce a work containing portions of the Library, and distribute that work under terms of your choice, provided that the terms permit modification of the work for the customer's own use and reverse engineering for debugging such modifications.
+
+You must give prominent notice with each copy of the work that the Library is used in it and that the Library and its use are covered by this License. You must supply a copy of this License. If the work during execution displays copyright notices, you must include the copyright notice for the Library among them, as well as a reference directing the user to the copy of this License. Also, you must do one of these things:
+
+    a) Accompany the work with the complete corresponding machine-readable source code for the Library including whatever changes were used in the work (which must be distributed under Sections 1 and 2 above); and, if the work is an executable linked with the Library, with the complete machine-readable "work that uses the Library", as object code and/or source code, so that the user can modify the Library and then relink to produce a modified executable containing the modified Library. (It is understood that the user who changes the contents of definitions files in the Library will not necessarily be able to recompile the application to use the modified definitions.)
+    b) Use a suitable shared library mechanism for linking with the Library. A suitable mechanism is one that (1) uses at run time a copy of the library already present on the user's computer system, rather than copying library functions into the executable, and (2) will operate properly with a modified version of the library, if the user installs one, as long as the modified version is interface-compatible with the version that the work was made with.
+    c) Accompany the work with a written offer, valid for at least three years, to give the same user the materials specified in Subsection 6a, above, for a charge no more than the cost of performing this distribution.
+    d) If distribution of the work is made by offering access to copy from a designated place, offer equivalent access to copy the above specified materials from the same place.
+    e) Verify that the user has already received a copy of these materials or that you have already sent this user a copy.
+
+For an executable, the required form of the "work that uses the Library" must include any data and utility programs needed for reproducing the executable from it. However, as a special exception, the materials to be distributed need not include anything that is normally distributed (in either source or binary form) with the major components (compiler, kernel, and so on) of the operating system on which the executable runs, unless that component itself accompanies the executable.
+
+It may happen that this requirement contradicts the license restrictions of other proprietary libraries that do not normally accompany the operating system. Such a contradiction means you cannot use both them and the Library together in an executable that you distribute.
+
+7. You may place library facilities that are a work based on the Library side-by-side in a single library together with other library facilities not covered by this License, and distribute such a combined library, provided that the separate distribution of the work based on the Library and of the other library facilities is otherwise permitted, and provided that you do these two things:
+
+    a) Accompany the combined library with a copy of the same work based on the Library, uncombined with any other library facilities. This must be distributed under the terms of the Sections above.
+    b) Give prominent notice with the combined library of the fact that part of it is a work based on the Library, and explaining where to find the accompanying uncombined form of the same work.
+
+8. You may not copy, modify, sublicense, link with, or distribute the Library except as expressly provided under this License. Any attempt otherwise to copy, modify, sublicense, link with, or distribute the Library is void, and will automatically terminate your rights under this License. However, parties who have received copies, or rights, from you under this License will not have their licenses terminated so long as such parties remain in full compliance.
+
+9. You are not required to accept this License, since you have not signed it. However, nothing else grants you permission to modify or distribute the Library or its derivative works. These actions are prohibited by law if you do not accept this License. Therefore, by modifying or distributing the Library (or any work based on the Library), you indicate your acceptance of this License to do so, and all its terms and conditions for copying, distributing or modifying the Library or works based on it.
+
+10. Each time you redistribute the Library (or any work based on the Library), the recipient automatically receives a license from the original licensor to copy, distribute, link with or modify the Library subject to these terms and conditions. You may not impose any further restrictions on the recipients' exercise of the rights granted herein. You are not responsible for enforcing compliance by third parties with this License.
+
+11. If, as a consequence of a court judgment or allegation of patent infringement or for any other reason (not limited to patent issues), conditions are imposed on you (whether by court order, agreement or otherwise) that contradict the conditions of this License, they do not excuse you from the conditions of this License. If you cannot distribute so as to satisfy simultaneously your obligations under this License and any other pertinent obligations, then as a consequence you may not distribute the Library at all. For example, if a patent license would not permit royalty-free redistribution of the Library by all those who receive copies directly or indirectly through you, then the only way you could satisfy both it and this License would be to refrain entirely from distribution of the Library.
+
+If any portion of this section is held invalid or unenforceable under any particular circumstance, the balance of the section is intended to apply, and the section as a whole is intended to apply in other circumstances.
+
+It is not the purpose of this section to induce you to infringe any patents or other property right claims or to contest validity of any such claims; this section has the sole purpose of protecting the integrity of the free software distribution system which is implemented by public license practices. Many people have made generous contributions to the wide range of software distributed through that system in reliance on consistent application of that system; it is up to the author/donor to decide if he or she is willing to distribute software through any other system and a licensee cannot impose that choice.
+
+This section is intended to make thoroughly clear what is believed to be a consequence of the rest of this License.
+
+12. If the distribution and/or use of the Library is restricted in certain countries either by patents or by copyrighted interfaces, the original copyright holder who places the Library under this License may add an explicit geographical distribution limitation excluding those countries, so that distribution is permitted only in or among countries not thus excluded. In such case, this License incorporates the limitation as if written in the body of this License.
+
+13. The Free Software Foundation may publish revised and/or new versions of the Lesser General Public License from time to time. Such new versions will be similar in spirit to the present version, but may differ in detail to address new problems or concerns.
+
+Each version is given a distinguishing version number. If the Library specifies a version number of this License which applies to it and "any later version", you have the option of following the terms and conditions either of that version or of any later version published by the Free Software Foundation. If the Library does not specify a license version number, you may choose any version ever published by the Free Software Foundation.
+
+14. If you wish to incorporate parts of the Library into other free programs whose distribution conditions are incompatible with these, write to the author to ask for permission. For software which is copyrighted by the Free Software Foundation, write to the Free Software Foundation; we sometimes make exceptions for this. Our decision will be guided by the two goals of preserving the free status of all derivatives of our free software and of promoting the sharing and reuse of software generally.
+
+NO WARRANTY
+
+15. BECAUSE THE LIBRARY IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE LIBRARY, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE LIBRARY "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE LIBRARY IS WITH YOU. SHOULD THE LIBRARY PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION.
+
+16. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE LIBRARY AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE LIBRARY (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE LIBRARY TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES.
+END OF TERMS AND CONDITIONS
+
+How to Apply These Terms to Your New Libraries
+
+If you develop a new library, and you want it to be of the greatest possible use to the public, we recommend making it free software that everyone can redistribute and change. You can do so by permitting redistribution under these terms (or, alternatively, under the terms of the ordinary General Public License).
+
+To apply these terms, attach the following notices to the library. It is safest to attach them to the start of each source file to most effectively convey the exclusion of warranty; and each file should have at least the "copyright" line and a pointer to where the full notice is found.
+
+one line to give the library's name and an idea of what it does.
+Copyright (C) year  name of author
+
+This library is free software; you can redistribute it and/or
+modify it under the terms of the GNU Lesser General Public
+License as published by the Free Software Foundation; either
+version 2.1 of the License, or (at your option) any later version.
+
+This library is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+Lesser General Public License for more details.
+
+You should have received a copy of the GNU Lesser General Public
+License along with this library; if not, write to the Free Software
+Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301  USA
+
+Also add information on how to contact you by electronic and paper mail.
+
+You should also get your employer (if you work as a programmer) or your school, if any, to sign a "copyright disclaimer" for the library, if necessary. Here is a sample; alter the names:
+
+Yoyodyne, Inc., hereby disclaims all copyright interest in
+the library `Frob' (a library for tweaking knobs) written
+by James Random Hacker.
+
+signature of Ty Coon, 1 April 1990
+Ty Coon, President of Vice
+
+That's all there is to it!
+
+--------------------------------------------------

vendors/ocplib-resto/Makefile

@@ -0,0 +1,13 @@
+
+all:
+	jbuilder build --dev
+
+.PHONY: test
+test:
+	jbuilder runtest --dev
+
+doc-html:
+	jbuilder build @doc --dev
+
+clean:
+	jbuilder clean

vendors/ocplib-resto/README.md

@@ -0,0 +1,9 @@
+# ocplib-resto (WIP)
+
+This is a minimal OCaml library for type-safe HTTP/JSON RPCs.
+
+This is based on a notion of service, *à la* Eliom, and it uses
+`ocplib-json-typed` for self-documenting JSON encoders.
+
+See `test_ezresto-directory/ezResto_test.ml`
+or `test_resto-directory/resto_test.ml` for example.`

vendors/ocplib-resto/jbuild

@@ -0,0 +1 @@
+(jbuild_version 1)

vendors/ocplib-resto/lib_ezresto-directory/ezRestoDirectory.ml

@@ -0,0 +1,81 @@
+(**************************************************************************)
+(*  ocplib-resto                                                          *)
+(*  Copyright (C) 2016, OCamlPro.                                         *)
+(*                                                                        *)
+(*    All rights reserved.  This file is distributed under the terms      *)
+(*    of the GNU Lesser General Public License version 2.1, with the      *)
+(*    special exception on linking described in the file LICENSE.         *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Resto
+open Lwt.Infix
+
+open RestoDirectory
+module Directory = RestoDirectory.MakeDirectory(RestoJson.Encoding)
+open Directory
+
+module Answer = Answer
+
+type step = Directory.step =
+  | Static of string
+  | Dynamic of Arg.descr
+  | DynamicTail of Arg.descr
+
+type conflict = Directory.conflict =
+  | CService of meth | CDir | CBuilder | CTail
+  | CTypes of Arg.descr * Arg.descr
+  | CType of Arg.descr * string list
+
+exception Conflict = Directory.Conflict
+
+type directory = unit Directory.directory
+let empty = empty
+let prefix path dir = (prefix path (map (fun _ -> ()) dir))
+let merge = merge
+
+let register d s h = register d s h
+let register0 d s h = register0 d s h
+let register1 d s h = register1 d s h
+let register2 d s h = register2 d s h
+let register3 d s h = register3 d s h
+let register4 d s h = register4 d s h
+let register5 d s h = register5 d s h
+
+let register_dynamic_directory ?descr dir path builder =
+  register_dynamic_directory ?descr dir path
+    (fun p -> builder p >>= fun dir -> Lwt.return (map (fun _ -> ()) dir))
+
+let register_dynamic_directory1 ?descr root s f =
+  register_dynamic_directory ?descr root s Curry.(curry (S Z) f)
+let register_dynamic_directory2 ?descr root s f =
+  register_dynamic_directory ?descr root s Curry.(curry (S (S Z)) f)
+let register_dynamic_directory3 ?descr root s f =
+  register_dynamic_directory ?descr root s Curry.(curry (S (S (S Z))) f)
+
+let register_describe_directory_service =
+  register_describe_directory_service
+
+type 'input input = 'input Service.input =
+  | No_input : unit input
+  | Input : 'input Json_encoding.encoding -> 'input input
+
+type ('q, 'i, 'o, 'e) types = ('q, 'i, 'o, 'e) Directory.types = {
+  query : 'q Resto.Query.t ;
+  input : 'i Service.input ;
+  output : 'o Json_encoding.encoding ;
+  error : 'e Json_encoding.encoding ;
+}
+
+type registred_service = Directory.registred_service =
+  | Service :
+      { types : ('q, 'i, 'o, 'e) types ;
+        handler : ('q -> 'i -> ('o, 'e) Answer.t Lwt.t) ;
+      } -> registred_service
+
+type lookup_error = Directory.lookup_error
+
+let lookup directory args query =
+  Directory.lookup directory () args query
+let allowed_methods dir path = Directory.allowed_methods dir () path
+let transparent_lookup = Directory.transparent_lookup

vendors/ocplib-resto/lib_ezresto-directory/ezRestoDirectory.mli

@@ -0,0 +1,170 @@
+(**************************************************************************)
+(*  ocplib-resto                                                          *)
+(*  Copyright (C) 2016, OCamlPro.                                         *)
+(*                                                                        *)
+(*    All rights reserved.  This file is distributed under the terms      *)
+(*    of the GNU Lesser General Public License version 2.1, with the      *)
+(*    special exception on linking described in the file LICENSE.         *)
+(*                                                                        *)
+(**************************************************************************)
+
+open EzResto
+
+module Answer : sig
+
+  (** Return type for service handler *)
+  type ('o, 'e) t =
+    [ `Ok of 'o (* 200 *)
+    | `OkStream of 'o stream (* 200 *)
+    | `Created of string option (* 201 *)
+    | `No_content (* 204 *)
+    | `Unauthorized of 'e option (* 401 *)
+    | `Forbidden of 'e option (* 403 *)
+    | `Not_found of 'e option (* 404 *)
+    | `Conflict of 'e option (* 409 *)
+    | `Error of 'e option (* 500 *)
+    ]
+
+  and 'a stream = {
+    next: unit -> 'a option Lwt.t ;
+    shutdown: unit -> unit ;
+  }
+
+end
+
+(** Possible error while registring services. *)
+type step =
+  | Static of string
+  | Dynamic of Arg.descr
+  | DynamicTail of Arg.descr
+
+type conflict =
+  | CService of meth | CDir | CBuilder | CTail
+  | CTypes of Arg.descr * Arg.descr
+  | CType of Arg.descr * string list
+
+exception Conflict of step list * conflict
+
+(** Dispatch tree *)
+type directory
+
+(** Empty tree *)
+val empty: directory
+
+val prefix: 'a Path.t -> directory -> directory
+val merge: directory -> directory -> directory
+
+type 'input input =
+  | No_input : unit input
+  | Input : 'input Json_encoding.encoding -> 'input input
+
+type ('q, 'i, 'o, 'e) types = {
+  query : 'q Resto.Query.t ;
+  input : 'i input ;
+  output : 'o Json_encoding.encoding ;
+  error : 'e Json_encoding.encoding ;
+}
+
+type registred_service =
+  | Service :
+      { types : ('q, 'i, 'o, 'e) types ;
+        handler : ('q -> 'i -> ('o, 'e) Answer.t Lwt.t) ;
+      } -> registred_service
+
+type lookup_error =
+  [ `Not_found (* 404 *)
+  | `Method_not_allowed of meth list (* 405 *)
+  | `Cannot_parse_path of string list * Arg.descr * string (* 400 *)
+  ]
+
+(** Resolve a service. *)
+val lookup: directory -> meth -> string list -> (registred_service, [> lookup_error ]) result Lwt.t
+
+val allowed_methods:
+  directory -> string list ->
+  (meth list, [> lookup_error ]) result Lwt.t
+
+val transparent_lookup:
+  directory ->
+  ('meth, 'params, 'query, 'input, 'output, 'error) EzResto.service ->
+  'params -> 'query -> 'input -> [> ('output, 'error) Answer.t ] Lwt.t
+
+
+(** Registring handler in service tree. *)
+val register:
+  directory ->
+  ('meth, 'params, 'query, 'input, 'output, 'error) EzResto.service ->
+  ('params -> 'query -> 'input -> ('output, 'error) Answer.t Lwt.t) ->
+  directory
+
+(** Registring handler in service tree. Curryfied variant.  *)
+val register0:
+  directory ->
+  ('meth, unit, 'q, 'i, 'o, 'e) EzResto.service ->
+  ('q -> 'i -> ('o, 'e) Answer.t Lwt.t) ->
+  directory
+
+val register1:
+  directory ->
+  ('meth, unit * 'a, 'q, 'i, 'o, 'e) EzResto.service ->
+  ('a -> 'q -> 'i -> ('o, 'e) Answer.t Lwt.t) ->
+  directory
+
+val register2:
+  directory ->
+  ('meth, (unit * 'a) * 'b, 'q, 'i, 'o, 'e) EzResto.service ->
+  ('a -> 'b -> 'q -> 'i -> ('o, 'e) Answer.t Lwt.t) ->
+  directory
+
+val register3:
+  directory ->
+  ('meth, ((unit * 'a) * 'b) * 'c, 'q, 'i, 'o, 'e) EzResto.service ->
+  ('a -> 'b -> 'c -> 'q -> 'i -> ('o, 'e) Answer.t Lwt.t) ->
+  directory
+
+val register4:
+  directory ->
+  ('meth, (((unit * 'a) * 'b) * 'c) * 'd, 'q, 'i, 'o, 'e) EzResto.service ->
+  ('a -> 'b -> 'c -> 'd -> 'q -> 'i -> ('o, 'e) Answer.t Lwt.t) ->
+  directory
+
+val register5:
+  directory ->
+  ('meth, ((((unit * 'a) * 'b) * 'c) * 'd) * 'e, 'q, 'i, 'o, 'e) EzResto.service ->
+  ('a -> 'b -> 'c -> 'd -> 'e -> 'q -> 'i -> ('o, 'e) Answer.t Lwt.t) ->
+  directory
+
+(** Registring dynamic subtree. *)
+val register_dynamic_directory:
+  ?descr:string ->
+  directory ->
+  'params Path.t ->
+  ('params -> directory Lwt.t) ->
+  directory
+
+(** Registring dynamic subtree. (Curryfied variant) *)
+val register_dynamic_directory1:
+  ?descr:string ->
+  directory ->
+  (unit * 'a) Path.t ->
+  ('a -> directory Lwt.t) ->
+  directory
+
+val register_dynamic_directory2:
+  ?descr:string ->
+  directory ->
+  ((unit * 'a) * 'b) Path.t ->
+  ('a -> 'b -> directory Lwt.t) ->
+  directory
+
+val register_dynamic_directory3:
+  ?descr:string ->
+  directory ->
+  (((unit * 'a) * 'b) * 'c) Path.t ->
+  ('a -> 'b -> 'c -> directory Lwt.t) ->
+  directory
+
+(** Registring a description service. *)
+val register_describe_directory_service:
+  directory -> EzResto.description_service -> directory
+

vendors/ocplib-resto/lib_ezresto-directory/jbuild

@@ -0,0 +1,8 @@
+(jbuild_version 1)
+
+(library
+ ((name ezresto_directory)
+  (public_name ocplib-ezresto-directory)
+  (libraries (ocplib-ezresto ocplib-resto-directory))
+  (modules (EzRestoDirectory))
+  (wrapped false)))

vendors/ocplib-resto/lib_ezresto/ezResto.ml

@@ -0,0 +1,54 @@
+(**************************************************************************)
+(*  ocplib-resto                                                          *)
+(*  Copyright (C) 2016, OCamlPro.                                         *)
+(*                                                                        *)
+(*    All rights reserved.  This file is distributed under the terms      *)
+(*    of the GNU Lesser General Public License version 2.1, with the      *)
+(*    special exception on linking described in the file LICENSE.         *)
+(*                                                                        *)
+(**************************************************************************)
+
+
+open Resto
+module Service = Resto.MakeService(RestoJson.Encoding)
+open Service
+
+type meth = [ `GET | `POST | `DELETE | `PUT | `PATCH ]
+module Arg = Arg
+module Path = struct
+  type 'params t = (unit, 'params) Path.path
+  type 'params path = (unit, 'params) Path.path
+  let root = Path.root
+  let add_suffix = Path.add_suffix
+  let add_arg = Path.add_arg
+  let (/) = add_suffix
+  let (/:) = add_arg
+  let map = Path.map
+end
+module Query = Query
+type ('meth, 'params, 'query, 'input, 'output, 'error) service =
+  ('meth, unit, 'params, 'query, 'input, 'output, 'error) Service.t
+let get_service = get_service
+let post_service = post_service
+let delete_service = delete_service
+let put_service = put_service
+let patch_service = patch_service
+type 'input input = 'input Service.input =
+  | No_input : unit input
+  | Input : 'input Json_encoding.encoding -> 'input input
+type 'input request = 'input Service.request = {
+  meth: meth ;
+  path: string list ;
+  query: (string * string) list ;
+  input: 'input input ;
+}
+let forge_request = forge_request
+let query = query
+let input_encoding = input_encoding
+let output_encoding = output_encoding
+let error_encoding = error_encoding
+module Description = Resto.Description
+type description_service =
+  ([`GET], unit * string list, Description.request,
+   unit, Json_schema.schema Description.directory, unit) service
+let description_service = description_service

vendors/ocplib-resto/lib_ezresto/ezResto.mli

@@ -0,0 +1,168 @@
+(**************************************************************************)
+(*  ocplib-resto                                                          *)
+(*  Copyright (C) 2016, OCamlPro.                                         *)
+(*                                                                        *)
+(*    All rights reserved.  This file is distributed under the terms      *)
+(*    of the GNU Lesser General Public License version 2.1, with the      *)
+(*    special exception on linking described in the file LICENSE.         *)
+(*                                                                        *)
+(**************************************************************************)
+
+type meth = [ `GET | `POST | `DELETE | `PUT | `PATCH ]
+
+(** Typed path argument. *)
+module Arg : sig
+
+  type 'a t = 'a Resto.Arg.arg
+  type 'a arg = 'a t
+  val make:
+    ?descr:string ->
+    name:string ->
+    destruct:(string -> ('a, string) result) ->
+    construct:('a -> string) ->
+    unit -> 'a arg
+
+  type descr = Resto.Arg.descr = {
+    name: string ;
+    descr: string option ;
+  }
+  val descr: 'a arg -> descr
+
+  val int: int arg
+  val int32: int32 arg
+  val int64: int64 arg
+  val float: float arg
+
+end
+
+(** Parametrized path to services. *)
+module Path : sig
+
+  type 'params t = (unit, 'params) Resto.Path.path
+  type 'params path = 'params t
+
+  val root: unit path
+
+  val add_suffix: 'params path -> string -> 'params path
+  val (/): 'params path -> string -> 'params path
+
+  val add_arg: 'params path -> 'a Arg.arg -> ('params * 'a) path
+  val (/:): 'params path -> 'a Arg.arg -> ('params * 'a) path
+
+  val map: ('a -> 'b) -> ('b -> 'a) -> 'a path -> 'b path
+
+end
+
+module Query : sig
+
+  type 'a t
+  type 'a query = 'a t
+
+  val empty: unit query
+
+  type ('a, 'b) field
+  val field:
+    ?descr: string ->
+    string -> 'a Arg.t -> 'a -> ('b -> 'a) -> ('b, 'a) field
+
+  type ('a, 'b, 'c) open_query
+  val query: 'b -> ('a, 'b, 'b) open_query
+  val (|+):
+    ('a, 'b, 'c -> 'd) open_query ->
+    ('a, 'c) field -> ('a, 'b, 'd) open_query
+  val seal: ('a, 'b, 'a) open_query -> 'a t
+
+  type untyped = (string * string) list
+  exception Invalid of string
+  val parse: 'a query -> untyped -> 'a
+
+end
+
+(** Services. *)
+type ('meth, 'params, 'query, 'input, 'output, 'error) service =
+  ('meth, unit, 'params, 'query, 'input, 'output, 'error) Resto.MakeService(RestoJson.Encoding).service
+
+val get_service:
+  ?description: string ->
+  query: 'query Query.t ->
+  output: 'output Json_encoding.encoding ->
+  error: 'error Json_encoding.encoding ->
+  'params Path.t ->
+  ([ `GET ], 'params, 'query, unit, 'output, 'error) service
+
+val post_service:
+  ?description: string ->
+  query: 'query Query.t ->
+  input: 'input Json_encoding.encoding ->
+  output: 'output Json_encoding.encoding ->
+  error: 'error Json_encoding.encoding ->
+  'params Path.t ->
+  ([ `POST ], 'params, 'query, 'input, 'output, 'error) service
+
+val delete_service:
+  ?description: string ->
+  query: 'query Query.t ->
+  output: 'output Json_encoding.encoding ->
+  error: 'error Json_encoding.encoding ->
+  'params Path.t ->
+  ([ `DELETE ], 'params, 'query, unit, 'output, 'error) service
+
+
+val put_service:
+  ?description: string ->
+  query: 'query Query.t ->
+  input: 'input Json_encoding.encoding ->
+  output: 'output Json_encoding.encoding ->
+  error: 'error Json_encoding.encoding ->
+  'params Path.t ->
+  ([ `PUT ], 'params, 'query, 'input, 'output, 'error) service
+
+val patch_service:
+  ?description: string ->
+  query: 'query Query.t ->
+  input: 'input Json_encoding.encoding ->
+  output: 'output Json_encoding.encoding ->
+  error: 'error Json_encoding.encoding ->
+  'params Path.t ->
+  ([ `PATCH ], 'params, 'query, 'input, 'output, 'error) service
+
+type 'input input =
+  | No_input : unit input
+  | Input : 'input Json_encoding.encoding -> 'input input
+
+type 'input request = {
+  meth: meth ;
+  path: string list ;
+  query: (string * string) list ;
+  input: 'input input ;
+}
+
+val forge_request:
+  ('meth, 'params, 'query, 'input, 'output, 'error) service ->
+  'params -> 'query -> 'input request
+
+val query:
+  ('meth, 'params, 'query, 'input, 'output, 'error) service ->
+  'query Query.t
+
+val input_encoding:
+  ('meth, 'params, 'query, 'input, 'output, 'error) service ->
+  'input input
+
+val output_encoding:
+  ('meth, 'params, 'query, 'input, 'output, 'error) service ->
+  'output Json_encoding.encoding
+
+val error_encoding:
+  ('meth, 'params, 'query, 'input, 'output, 'error) service ->
+  'error Json_encoding.encoding
+
+module Description = Resto.Description
+
+type description_service =
+  ([`GET], unit * string list, Description.request,
+   unit, Json_schema.schema Description.directory, unit) service
+
+val description_service:
+  ?description:string -> unit Path.path -> description_service
+

vendors/ocplib-resto/lib_ezresto/jbuild

@@ -0,0 +1,8 @@
+(jbuild_version 1)
+
+(library
+ ((name ezresto)
+  (public_name ocplib-ezresto)
+  (libraries (ocplib-resto-json))
+  (modules (EzResto))
+  (wrapped false)))

vendors/ocplib-resto/lib_resto-cohttp/jbuild

@@ -0,0 +1,9 @@
+(jbuild_version 1)
+
+(library
+ ((name resto_cohttp)
+  (public_name ocplib-resto-cohttp)
+  (libraries (ocplib-resto-directory cohttp-lwt-unix))
+  (modules (RestoCohttp))
+  (wrapped false)))
+

vendors/ocplib-resto/lib_resto-cohttp/restoCohttp.ml

@@ -0,0 +1,444 @@
+(**************************************************************************)
+(*                                                                        *)
+(*    Copyright (c) 2014 - 2017.                                          *)
+(*    Dynamic Ledger Solutions, Inc. <contact@tezos.com>                  *)
+(*                                                                        *)
+(*    All rights reserved. No warranty, explicit or implicit, provided.   *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Lwt.Infix
+
+module Utils = struct
+
+  let split_path path =
+    let l = String.length path in
+    let rec do_slashes acc i =
+      if i >= l then
+        List.rev acc
+      else if String.get path i = '/' then
+        do_slashes acc (i + 1)
+      else
+        do_component acc i i
+    and do_component acc i j =
+      if j >= l then
+        if i = j then
+          List.rev acc
+        else
+          List.rev (String.sub path i (j - i) :: acc)
+      else if String.get path j = '/' then
+        do_slashes (String.sub path i (j - i) :: acc) j
+      else
+        do_component acc i (j + 1) in
+    do_slashes [] 0
+
+end
+
+type cors = {
+  allowed_headers : string list ;
+  allowed_origins : string list ;
+}
+
+module Cors = struct
+
+  let default = { allowed_headers = [] ; allowed_origins = [] }
+
+  let check_origin_matches origin allowed_origin =
+    String.equal "*" allowed_origin ||
+    String.equal allowed_origin origin ||
+    begin
+      let allowed_w_slash = allowed_origin ^ "/" in
+      let len_a_w_s = String.length allowed_w_slash in
+      let len_o = String.length origin in
+      (len_o >= len_a_w_s) &&
+      String.equal allowed_w_slash @@ String.sub origin 0 len_a_w_s
+    end
+
+  let find_matching_origin allowed_origins origin =
+    let matching_origins =
+      List.filter (check_origin_matches origin) allowed_origins in
+    let compare_by_length_neg a b =
+      ~- (compare (String.length a) (String.length b)) in
+    let matching_origins_sorted =
+      List.sort compare_by_length_neg matching_origins in
+    match matching_origins_sorted with
+    | [] -> None
+    | x :: _ -> Some x
+
+  let add_headers headers cors origin_header =
+    let cors_headers =
+      Cohttp.Header.add_multi headers
+        "Access-Control-Allow-Headers" cors.allowed_headers in
+    match origin_header with
+    | None -> cors_headers
+    | Some origin ->
+        match find_matching_origin cors.allowed_origins origin with
+        | None -> cors_headers
+        | Some allowed_origin ->
+            Cohttp.Header.add_multi cors_headers
+              "Access-Control-Allow-Origin" [allowed_origin]
+
+end
+
+module ConnectionMap = Map.Make(Cohttp.Connection)
+
+module type LOGGING = sig
+
+  val debug: ('a, Format.formatter, unit, unit) format4 -> 'a
+  val log_info: ('a, Format.formatter, unit, unit) format4 -> 'a
+  val log_notice: ('a, Format.formatter, unit, unit) format4 -> 'a
+  val warn: ('a, Format.formatter, unit, unit) format4 -> 'a
+  val log_error: ('a, Format.formatter, unit, unit) format4 -> 'a
+
+  val lwt_debug: ('a, Format.formatter, unit, unit Lwt.t) format4 -> 'a
+  val lwt_log_info: ('a, Format.formatter, unit, unit Lwt.t) format4 -> 'a
+  val lwt_log_notice: ('a, Format.formatter, unit, unit Lwt.t) format4 -> 'a
+  val lwt_warn: ('a, Format.formatter, unit, unit Lwt.t) format4 -> 'a
+  val lwt_log_error: ('a, Format.formatter, unit, unit Lwt.t) format4 -> 'a
+
+end
+
+module Make (Encoding : Resto.ENCODING)(Log : LOGGING) = struct
+
+  open Log
+  open Cohttp
+
+  module Service = Resto.MakeService(Encoding)
+  module Directory = RestoDirectory.MakeDirectory(Encoding)
+
+  type media_type = {
+    name: string ;
+    construct: 'a. 'a Encoding.t -> 'a -> string ;
+    destruct: 'a. 'a Encoding.t -> string -> ('a, string) result ;
+  }
+
+  module Media_type = struct
+
+    (* Inspired from ocaml-webmachine *)
+
+    let media_match (_, (range, _)) media =
+      let type_, subtype =
+        match Utils.split_path media.name with
+        | [x ; y] -> x, y
+        | _      ->
+            Format.kasprintf invalid_arg "invalid media_type '%s'" media.name in
+      let open Accept in
+      match range with
+      | AnyMedia                     -> true
+      | AnyMediaSubtype type_'       -> type_' = type_
+      | MediaType (type_', subtype') -> type_' = type_ && subtype' = subtype
+
+    let match_header provided header =
+      let ranges = Accept.(media_ranges header |> qsort) in
+      let rec loop = function
+        | [] -> None
+        | r :: rs ->
+            try Some(List.find (media_match r) provided)
+            with Not_found -> loop rs
+      in
+      loop ranges
+
+  end
+
+  type server = {
+    root : unit Directory.directory ;
+    mutable streams : (unit -> unit) ConnectionMap.t ;
+    cors : cors ;
+    media_types : media_type list ;
+    default_media_type : media_type ;
+    stopper : unit Lwt.u ;
+    mutable worker : unit Lwt.t ;
+  }
+
+  let create_stream server con to_string s =
+    let running = ref true in
+    let stream =
+      Lwt_stream.from
+        (fun () ->
+           if not !running then
+             Lwt.return None
+           else
+             s.RestoDirectory.Answer.next () >|= function
+             | None -> None
+             | Some x -> Some (to_string x)) in
+    let shutdown () =
+      running := false ;
+      s.shutdown () ;
+      server.streams <- ConnectionMap.remove con server.streams in
+    server.streams <- ConnectionMap.add con shutdown server.streams ;
+    stream
+
+  let (>>=?) m f =
+    m >>= function
+    | Ok x -> f x
+    | Error err -> Lwt.return_error err
+
+  let callback server (_io, con) req body =
+    (* FIXME: check inbound adress *)
+    let uri = Request.uri req in
+    lwt_log_info "(%s) receive request to %s"
+      (Connection.to_string con) (Uri.path uri) >>= fun () ->
+    let path = Utils.split_path (Uri.path uri) in
+    let req_headers = Request.headers req in
+    begin
+      match Request.meth req with
+      | #Resto.meth as meth -> begin
+          Directory.lookup server.root ()
+            meth path >>=? fun (Directory.Service s) ->
+          begin
+            match Header.get req_headers "content-type" with
+            | None -> Lwt.return_ok server.default_media_type
+            | Some content_type ->
+                match List.find (fun { name ; _ } -> name = content_type)
+                        server.media_types with
+                | exception Not_found ->
+                    Lwt.return_error (`Unsupported_media_type content_type)
+                | media_type -> Lwt.return_ok media_type
+          end >>=? fun input_media_type ->
+          begin
+            match Header.get req_headers "accept" with
+            | None -> Lwt.return_ok server.default_media_type
+            | Some accepted ->
+                match Media_type.match_header
+                        server.media_types (Some accepted) with
+                | None -> Lwt.return_error `Not_acceptable
+                | Some media_type -> Lwt.return_ok media_type
+          end >>=? fun output_media_type ->
+          begin
+            match Resto.Query.parse s.types.query
+                    (List.map
+                       (fun (k, l) -> (k, String.concat "," l))
+                       (Uri.query uri)) with
+            | exception (Resto.Query.Invalid s) ->
+                Lwt.return_error (`Cannot_parse_query s)
+            | query -> Lwt.return_ok query
+          end >>=? fun query ->
+          let output = output_media_type.construct s.types.output
+          and error = function
+            | None -> Cohttp_lwt_body.empty, Transfer.Fixed 0L
+            | Some e ->
+                let s = output_media_type.construct s.types.error e in
+                Cohttp_lwt_body.of_string s,
+                Transfer.Fixed (Int64.of_int (String.length s)) in
+          let headers = Header.init () in
+          let headers =
+            Header.add headers "content-type" output_media_type.name in
+          begin
+            match s.types.input with
+            | Service.No_input ->
+                s.handler query () >>= Lwt.return_ok
+            | Service.Input input ->
+                Cohttp_lwt_body.to_string body >>= fun body ->
+                match
+                  input_media_type.destruct input body
+                with
+                | Error s ->
+                    Lwt.return_error (`Cannot_parse_body s)
+                | Ok body ->
+                    s.handler query body >>= Lwt.return_ok
+          end >>=? function
+          | `Ok o ->
+              let body = output o in
+              let encoding =
+                Transfer.Fixed (Int64.of_int (String.length body)) in
+              Lwt.return_ok
+                (Response.make ~status:`OK ~encoding ~headers (),
+                 Cohttp_lwt_body.of_string body)
+          | `OkStream o ->
+              let body = create_stream server con output o in
+              let encoding = Transfer.Chunked in
+              Lwt.return_ok
+                (Response.make ~status:`OK ~encoding ~headers (),
+                 Cohttp_lwt_body.of_stream body)
+          | `Created s ->
+              let headers = Header.init () in
+              let headers =
+                match s with
+                | None -> headers
+                | Some s -> Header.add headers "location" s in
+              Lwt.return_ok
+                (Response.make ~status:`Created  ~headers (),
+                 Cohttp_lwt_body.empty)
+          | `No_content ->
+              Lwt.return_ok
+                (Response.make ~status:`No_content (),
+                 Cohttp_lwt_body.empty)
+          | `Unauthorized e ->
+              let body, encoding = error e in
+              let status = `Unauthorized in
+              Lwt.return_ok
+                (Response.make ~status ~encoding ~headers (), body)
+          | `Forbidden e ->
+              let body, encoding = error e in
+              let status = `Forbidden in
+              Lwt.return_ok
+                (Response.make ~status ~encoding ~headers (), body)
+          | `Not_found e ->
+              let body, encoding = error e in
+              let status = `Not_found in
+              Lwt.return_ok
+                (Response.make ~status ~encoding ~headers (), body)
+          | `Conflict e ->
+              let body, encoding = error e in
+              let status = `Conflict in
+              Lwt.return_ok
+                (Response.make ~status ~encoding ~headers (), body)
+          | `Error e ->
+              let body, encoding = error e in
+              let status = `Internal_server_error in
+              Lwt.return_ok
+                (Response.make ~status ~encoding ~headers (), body)
+        end
+      | `HEAD ->
+          (* TODO ??? *)
+          Lwt.return_error `Not_implemented
+      | `OPTIONS ->
+          let req_headers = Request.headers req in
+          let origin_header = Header.get req_headers "origin" in
+          begin
+            (* Default OPTIONS handler for CORS preflight *)
+            if origin_header = None then
+              Directory.allowed_methods server.root () path
+            else
+              match Header.get req_headers
+                      "Access-Control-Request-Method" with
+              | None ->
+                  Directory.allowed_methods server.root () path
+              | Some meth ->
+                  match Code.method_of_string meth with
+                  | #Resto.meth as meth ->
+                      Directory.lookup server.root () meth path >>=? fun _handler ->
+                      Lwt.return_ok [ meth ]
+                  | _ ->
+                      Lwt.return_error `Not_found
+          end >>=? fun cors_allowed_meths ->
+          lwt_log_info "(%s) RPC preflight"
+            (Connection.to_string con) >>= fun () ->
+          let headers = Header.init () in
+          let headers =
+            Header.add_multi headers
+              "Access-Control-Allow-Methods"
+              (List.map Resto.string_of_meth cors_allowed_meths) in
+          let headers = Cors.add_headers headers server.cors origin_header in
+          Lwt.return_ok
+            (Response.make ~flush:true ~status:`OK ~headers (),
+             Cohttp_lwt_body.empty)
+      | _ ->
+          Lwt.return_error `Not_implemented
+    end >>= function
+    | Ok answer -> Lwt.return answer
+    | Error `Not_implemented ->
+        Lwt.return
+          (Response.make ~status:`Not_implemented (),
+           Cohttp_lwt_body.empty)
+    | Error `Method_not_allowed methods ->
+        let headers = Header.init () in
+        let headers =
+          Header.add_multi headers "allow"
+            (List.map Resto.string_of_meth methods) in
+        Lwt.return
+          (Response.make ~status:`Method_not_allowed ~headers (),
+           Cohttp_lwt_body.empty)
+    | Error `Cannot_parse_path (context, arg, value) ->
+        let headers = Header.init () in
+        let headers =
+          Header.add headers "content-type" "text/plain" in
+        Lwt.return
+          (Response.make ~status:`Bad_request ~headers (),
+           Format.kasprintf Cohttp_lwt_body.of_string
+             "Failed to parsed an argument in path. After \"%s\", \
+              the value \"%s\" is not acceptable for type \"%s\""
+             (String.concat "/" context) value arg.name)
+    | Error `Cannot_parse_body s ->
+        let headers = Header.init () in
+        let headers =
+          Header.add headers "content-type" "text/plain" in
+        Lwt.return
+          (Response.make ~status:`Bad_request ~headers (),
+           Format.kasprintf Cohttp_lwt_body.of_string
+             "Failed to parse the request body: %s" s)
+    | Error `Cannot_parse_query s ->
+        let headers = Header.init () in
+        let headers =
+          Header.add headers "content-type" "text/plain" in
+        Lwt.return
+          (Response.make ~status:`Bad_request ~headers (),
+           Format.kasprintf Cohttp_lwt_body.of_string
+             "Failed to parse the query string: %s" s)
+    | Error `Not_acceptable ->
+        let accepted_encoding =
+          String.concat ", "
+            (List.map (fun f -> f.name)
+               server.media_types) in
+        Lwt.return
+          (Response.make ~status:`Not_acceptable (),
+           Cohttp_lwt_body.of_string accepted_encoding)
+    | Error `Unsupported_media_type _ ->
+        Lwt.return
+          (Response.make ~status:`Unsupported_media_type (),
+           Cohttp_lwt_body.empty)
+    | Error `Not_found ->
+        Lwt.return
+          (Response.make ~status:`Not_found (),
+           Cohttp_lwt_body.empty)
+
+  (* Promise a running RPC server. *)
+
+  let launch
+      ?(host="::")
+      ?(cors = Cors.default)
+      ~media_types
+      mode root =
+    if media_types = [] then
+      invalid_arg "RestoCohttp.launch(empty media type list)" ;
+    let default_media_type = List.hd media_types in
+    let stop, stopper = Lwt.wait () in
+    let server = {
+      root ;
+      streams = ConnectionMap.empty ;
+      cors ;
+      media_types ;
+      default_media_type ;
+      stopper ;
+      worker = Lwt.return_unit ;
+    } in
+    let open Cohttp_lwt_unix in
+    Conduit_lwt_unix.init ~src:host () >>= fun ctx ->
+    let ctx = Cohttp_lwt_unix_net.init ~ctx () in
+    server.worker <- begin
+      let conn_closed (_, con) =
+        log_info "connection closed %s" (Connection.to_string con) ;
+        try ConnectionMap.find con server.streams ()
+        with Not_found -> ()
+      and on_exn = function
+        | Unix.Unix_error (Unix.EADDRINUSE, "bind", _) ->
+            log_error "RPC server port already taken, \
+                       the node will be shutdown" ;
+            exit 1
+        | Unix.Unix_error (ECONNRESET, _, _)
+        | Unix.Unix_error (EPIPE, _, _)  -> ()
+        | exn -> !Lwt.async_exception_hook exn
+      and callback (io, con) req body =
+        Lwt.catch
+          begin fun () -> callback server (io, con) req body end
+          begin fun exn ->
+            let headers = Header.init () in
+            let headers =
+              Header.add headers "content-type" "text/ocaml.exception" in
+            let status = `Internal_server_error in
+            let body = Cohttp_lwt_body.of_string (Printexc.to_string exn) in
+            Lwt.return (Response.make ~status ~headers (), body)
+          end
+      in
+      Server.create ~stop ~ctx ~mode ~on_exn
+        (Server.make ~callback ~conn_closed ())
+    end ;
+    Lwt.return server
+
+  let shutdown server =
+    Lwt.wakeup_later server.stopper () ;
+    server.worker >>= fun () ->
+    ConnectionMap.iter (fun _ f -> f ()) server.streams ;
+    Lwt.return_unit
+
+end

vendors/ocplib-resto/lib_resto-cohttp/restoCohttp.mli

@@ -0,0 +1,57 @@
+(**************************************************************************)
+(*  ocplib-resto                                                          *)
+(*  Copyright (C) 2016, OCamlPro.                                         *)
+(*                                                                        *)
+(*    All rights reserved.  This file is distributed under the terms      *)
+(*    of the GNU Lesser General Public License version 2.1, with the      *)
+(*    special exception on linking described in the file LICENSE.         *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Typed RPC services: server implementation. *)
+
+type cors = {
+  allowed_headers : string list ;
+  allowed_origins : string list ;
+}
+
+module type LOGGING = sig
+
+  val debug: ('a, Format.formatter, unit, unit) format4 -> 'a
+  val log_info: ('a, Format.formatter, unit, unit) format4 -> 'a
+  val log_notice: ('a, Format.formatter, unit, unit) format4 -> 'a
+  val warn: ('a, Format.formatter, unit, unit) format4 -> 'a
+  val log_error: ('a, Format.formatter, unit, unit) format4 -> 'a
+
+  val lwt_debug: ('a, Format.formatter, unit, unit Lwt.t) format4 -> 'a
+  val lwt_log_info: ('a, Format.formatter, unit, unit Lwt.t) format4 -> 'a
+  val lwt_log_notice: ('a, Format.formatter, unit, unit Lwt.t) format4 -> 'a
+  val lwt_warn: ('a, Format.formatter, unit, unit Lwt.t) format4 -> 'a
+  val lwt_log_error: ('a, Format.formatter, unit, unit Lwt.t) format4 -> 'a
+
+end
+
+module Make (Encoding : Resto.ENCODING) (Log : LOGGING) : sig
+
+  type media_type = {
+    name: string ;
+    construct: 'a. 'a Encoding.t -> 'a -> string ;
+    destruct: 'a. 'a Encoding.t -> string -> ('a, string) result ;
+  }
+
+  (** A handle on the server worker. *)
+  type server
+
+  (** Promise a running RPC server.*)
+  val launch :
+    ?host:string ->
+    ?cors:cors ->
+    media_types:media_type list ->
+    Conduit_lwt_unix.server ->
+    unit RestoDirectory.MakeDirectory(Encoding).t ->
+    server Lwt.t
+
+  (** Kill an RPC server. *)
+  val shutdown : server -> unit Lwt.t
+
+end

vendors/ocplib-resto/lib_resto-directory/jbuild

@@ -0,0 +1,9 @@
+(jbuild_version 1)
+
+(library
+ ((name resto_directory)
+  (public_name ocplib-resto-directory)
+  (libraries (lwt ocplib-resto))
+  (modules (RestoDirectory))
+  (wrapped false)))
+

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

@@ -0,0 +1,744 @@
+(**************************************************************************)
+(*  ocplib-resto                                                          *)
+(*  Copyright (C) 2016, OCamlPro.                                         *)
+(*                                                                        *)
+(*    All rights reserved.  This file is distributed under the terms      *)
+(*    of the GNU Lesser General Public License version 2.1, with the      *)
+(*    special exception on linking described in the file LICENSE.         *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Resto
+
+let map_option f = function
+  | None -> None
+  | Some x -> Some (f x)
+
+let (>>=) = Lwt.bind
+let (>|=) = Lwt.(>|=)
+
+module Answer = struct
+
+  (** Return type for service handler *)
+  type ('o, 'e) t =
+    [ `Ok of 'o (* 200 *)
+    | `OkStream of 'o stream (* 200 *)
+    | `Created of string option (* 201 *)
+    | `No_content (* 204 *)
+    | `Unauthorized of 'e option (* 401 *)
+    | `Forbidden of 'e option (* 403 *)
+    | `Not_found of 'e option (* 404 *)
+    | `Conflict of 'e option (* 409 *)
+    | `Error of 'e option (* 500 *)
+    ]
+
+  and 'a stream = {
+    next: unit -> 'a option Lwt.t ;
+    shutdown: unit -> unit ;
+  }
+
+  let return x = Lwt.return (`Ok x)
+  let return_stream x = Lwt.return (`OkStream x)
+
+end
+
+module MakeDirectory (Encoding : ENCODING) = struct
+
+  module Service = Resto.MakeService(Encoding)
+
+  module Curry = struct
+
+    type (_,_,_,_,_,_) conv =
+      | Z : (unit, 'g, 'g, unit, 'f, 'f) conv
+      | S : ('t, 'g, 'b * 's, 'rt, 'f, 'r) conv ->
+        ('t * 'b, 'g, 's, 'a * 'rt, 'a -> 'f, 'r) conv
+    let reverse
+      : type a c d e f. (a, c, unit, d, e, f) conv -> a -> c
+      = fun c v ->
+        let rec reverse
+          : type a c d e f g. (a, c, d, e, f, g) conv -> a -> d -> c
+          = fun c v acc ->
+            match c, v with
+            | Z, _ -> acc
+            | S c, (v, x) -> reverse c v (x, acc) in
+        reverse c v ()
+    let rec curry
+      : type a b c d e f. (a, b, c, d, e, f) conv -> e -> d -> f
+      = fun c f ->
+        match c with
+        | Z -> fun () -> f
+        | S c -> (fun (v, x) -> curry c (f v) x)
+    let curry c f =
+      let f = curry c f in
+      fun x -> f (reverse c x)
+
+  end
+
+  type step =
+    | Static of string
+    | Dynamic of Arg.descr
+    | DynamicTail of Arg.descr
+
+  type conflict =
+    | CService of meth
+    | CDir
+    | CBuilder
+    | CTail
+    | CTypes of Arg.descr * Arg.descr
+    | CType of Arg.descr * string list
+
+  exception Conflict of step list * conflict
+
+  open Resto.Internal
+
+  type lookup_error =
+    [ `Not_found (* 404 *)
+    | `Method_not_allowed of meth list (* 405 *)
+    | `Cannot_parse_path of string list * Arg.descr * string (* 400 *)
+    ]
+
+  type ('query, 'input, 'output, 'error) types
+    = ('query, 'input, 'output, 'error) Service.Internal.types
+    = {
+      query : 'query Resto.Query.t ;
+      input : 'input Service.input ;
+      output : 'output Encoding.t ;
+      error : 'error Encoding.t ;
+    }
+
+  type 'key t =
+    | Empty : 'key t
+    | Static : 'key static_directory -> 'key t
+    | Dynamic : string option * ('key -> 'key directory Lwt.t) -> 'key t
+    | DynamicTail : 'a arg * ('key * 'a list) t -> 'key t
+
+  and 'key directory = 'key t
+  and 'key static_directory = {
+    services : 'key registred_service_builder MethMap.t ;
+    subdirs : 'key static_subdirectories option
+  }
+
+  and _ static_subdirectories =
+    | Suffixes: 'key directory StringMap.t -> 'key static_subdirectories
+    | Arg: 'a Resto.Internal.arg * ('key * 'a) directory -> 'key static_subdirectories
+
+  and registred_service =
+    | Service :
+        { types : ('q, 'i, 'o, 'e) types ;
+          handler : ('q -> 'i -> ('o, 'e) Answer.t Lwt.t) ;
+        } -> registred_service
+
+  and 'key registred_service_builder = {
+    meth : Resto.meth ;
+    description : Encoding.schema Description.service ;
+    builder : 'key -> registred_service ;
+  }
+
+  let empty = Empty
+
+  let rec map_directory
+    : type a b.
+      (a -> b) -> b directory -> a directory
+    = fun f t ->
+      match t with
+      | Empty -> Empty
+      | Dynamic (descr, builder) ->
+          let builder a = builder (f a) >|= map_directory f in
+          Dynamic (descr, builder)
+      | DynamicTail (arg, dir) ->
+          DynamicTail (arg, map_directory (fun (x, l) -> (f x, l)) dir)
+      | Static dir ->
+          Static (map_static_directory f dir)
+
+  and map_static_directory
+    : type a b.
+      (a -> b) -> b static_directory -> a static_directory
+    = fun f t ->
+      { services = MethMap.map (map_registred_service f) t.services ;
+        subdirs = map_option (map_static_subdirectories f) t.subdirs ;
+      }
+
+  and map_static_subdirectories
+    : type a b.
+      (a -> b) -> b static_subdirectories -> a static_subdirectories
+    = fun f t ->
+      match t with
+      | Suffixes map ->
+          Suffixes (StringMap.map (map_directory f) map)
+      | Arg (arg, dir) ->
+          let dir = map_directory (fun (a, x) -> f a, x) dir in
+          Arg (arg, dir)
+
+  and map_registred_service
+    : type a b.
+      (a -> b) -> b registred_service_builder -> a registred_service_builder
+    = fun f rs ->
+      { rs with builder = (fun p -> rs.builder (f p)) }
+
+  let map = map_directory
+
+  let prefix
+    : type p pr. (pr, p) Path.path -> p directory -> pr directory
+    = fun path dir ->
+      let rec prefix
+        : type k pr. (pr, k) Resto.Internal.rpath -> k directory -> pr directory
+        = fun path dir ->
+          match path with
+          | Root -> dir
+          | Static (path, name) ->
+              let subdirs = Suffixes (StringMap.singleton name dir) in
+              prefix path (Static { subdirs = Some subdirs ;
+                                    services = MethMap.empty })
+          | Dynamic (path, arg) ->
+              let subdirs = Arg (arg, dir) in
+              prefix path (Static { subdirs = Some subdirs ;
+                                    services = MethMap.empty })
+          | DynamicTail _ ->
+              invalid_arg "RestoDirectory.prefix" in
+      match Resto.Internal.to_path path with
+      | Path path -> prefix path dir
+      | MappedPath (path, map, _) -> prefix path (map_directory map dir)
+
+  let conflict steps kind = raise (Conflict (steps, kind))
+
+  let rec merge
+    : type p.
+      step list -> p directory -> p directory -> p directory
+    = fun path t1 t2 ->
+      match t1, t2 with
+      | Empty, t -> t
+      | t, Empty -> t
+      | Static n1, Static n2 ->
+          Static (merge_static_directory path n1 n2)
+      | Dynamic _, _
+      | _, Dynamic _ -> conflict path CBuilder
+      | DynamicTail _, _
+      | _, DynamicTail _ -> conflict path CTail
+
+  and merge_static_directory
+    : type p.
+      step list -> p static_directory -> p static_directory -> p static_directory
+    = fun path t1 t2 ->
+      let subdirs =
+        match t1.subdirs, t2.subdirs with
+        | None, None -> None
+        | None, Some dir | Some dir, None -> Some dir
+        | Some d1, Some d2 ->
+            match d1, d2 with
+            | Suffixes m1, Suffixes m2 ->
+                let merge =
+                  StringMap.fold
+                    (fun n t m ->
+                       let st =
+                         try StringMap.find n m with Not_found -> empty in
+                       StringMap.add n (merge (Static n :: path) st t) m) in
+                Some (Suffixes (merge m1 m2))
+            | Arg (arg1, subt1), Arg (arg2, subt2) ->
+                begin
+                  try let Ty.Eq = Ty.eq arg1.id arg2.id in
+                    let subt = merge (Dynamic arg1.descr :: path) subt1 subt2 in
+                    Some (Arg (arg1, subt))
+                  with Ty.Not_equal ->
+                    conflict path (CTypes (arg1.descr, arg2.descr))
+                end
+            | Arg (arg, _), Suffixes m ->
+                conflict path
+                  (CType (arg.descr, List.map fst (StringMap.bindings m)))
+            | Suffixes m, Arg (arg, _) ->
+                conflict path
+                  (CType (arg.descr, List.map fst (StringMap.bindings m))) in
+      let services =
+        MethMap.fold
+          begin fun meth s map ->
+            if MethMap.mem meth map then
+              conflict path (CService meth)
+            else
+              MethMap.add meth s map
+          end
+          t1.services t2.services in
+      { subdirs ; services }
+
+  let merge x y = merge [] x y
+
+  let rec describe_directory
+    : type a. recurse:bool -> ?arg:a ->
+    a directory -> Encoding.schema Description.directory Lwt.t
+    = fun ~recurse ?arg dir ->
+      match dir with
+      | Empty -> Lwt.return Description.Empty
+      | Dynamic (descr, builder) -> begin
+          match arg with
+          | None ->
+              Lwt.return (Dynamic descr : Encoding.schema Description.directory)
+          | Some arg ->
+              builder arg >>= fun dir -> describe_directory ~recurse dir
+        end
+      | DynamicTail ( _, dir) -> describe_directory ~recurse dir
+      | Static dir ->
+          describe_static_directory recurse arg dir >>= fun dir ->
+          Lwt.return (Static dir : Encoding.schema Description.directory)
+
+  and describe_static_directory
+    : type a.
+      bool -> a option -> a static_directory ->
+      Encoding.schema Description.static_directory Lwt.t
+    = fun recurse arg 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 ->
+              Lwt.return (Some dirs)
+        else
+          Lwt.return_none
+      end >>= fun subdirs ->
+      Lwt.return ({ services ; subdirs } : Encoding.schema Description.static_directory)
+
+  and describe_static_subdirectories
+    : type a.
+      a option -> a static_subdirectories ->
+      Encoding.schema Description.static_subdirectories Lwt.t
+    = fun arg dir ->
+      match dir with
+      | Suffixes map ->
+          StringMap.fold (fun key dir map ->
+              map >>= fun map ->
+              describe_directory ~recurse:true ?arg 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)
+      | Arg (arg, dir) ->
+          describe_directory ~recurse:true dir >>= fun dir ->
+          Lwt.return (Arg (arg.descr, dir)
+                      : Encoding.schema Description.static_subdirectories)
+
+  and describe_service
+    : type a.
+      a registred_service_builder -> Encoding.schema Description.service
+    = fun { description ; _ } -> description
+
+  and describe_query
+    : type a.
+      a Resto.Internal.query -> Description.query_item list
+    = fun (Fields (fields, _)) ->
+      let rec loop : type a b. (a, b) query_fields -> _ = function
+        | F0 -> []
+        | F1 (f, fs) ->
+            { Description.name = f.fname ;
+              description = f.fdescription } :: loop fs in
+      loop fields
+
+
+  (****************************************************************************
+   * Lookup
+   ****************************************************************************)
+
+  type resolved_directory =
+      Dir: 'a static_directory * 'a -> resolved_directory
+
+  let rec resolve
+    : type a.
+      string list -> a directory -> a -> string list ->
+      (resolved_directory, _) result Lwt.t
+    = fun prefix dir args path ->
+      match path, dir with
+      | _, Empty -> Lwt.return_error `Not_found
+      | path, Dynamic (_, builder) ->
+          builder args >>= fun dir -> resolve prefix dir args path
+      | path, DynamicTail (arg, dir) -> begin
+          match
+            List.fold_right
+              (fun e acc ->
+                 match acc with
+                 | Error _ as err -> err
+                 | Ok (prefix, path) ->
+                     match arg.destruct e with
+                     | Ok s -> Ok (e :: prefix, s :: path)
+                     | Error msg ->
+                         Error (`Cannot_parse_path (List.rev (e :: prefix), arg.descr, msg)))
+
+              path (Ok (prefix, []))
+          with
+          | Ok (prefix, path) -> resolve prefix dir (args, path) []
+          | Error _ as err -> Lwt.return err
+        end
+      | [], Static sdir -> Lwt.return_ok (Dir (sdir, args))
+      | _name :: _path, Static { subdirs = None ; _ } ->
+          Lwt.return_error `Not_found
+      | name :: path,
+        Static { subdirs = Some (Suffixes static) ; _ } -> begin
+          match StringMap.find name static with
+          | exception Not_found -> Lwt.return_error `Not_found
+          | dir -> resolve (name :: prefix) dir args path
+        end
+      | name :: path, Static { subdirs = Some (Arg (arg, dir)) ; _ } ->
+          match arg.destruct name with
+          | Ok x -> resolve (name :: prefix) dir (args, x) path
+          | Error msg ->
+              Lwt.return_error @@
+              `Cannot_parse_path (List.rev (name :: prefix), arg.descr, msg)
+
+  let lookup
+    : type a.
+      a directory -> a -> meth -> string list ->
+      (registred_service, lookup_error) result Lwt.t
+    = fun dir args meth path ->
+      resolve [] dir args path >>= function
+      | Error _ as err -> Lwt.return err
+      | Ok (Dir (dir, args)) -> begin
+          match MethMap.find meth dir.services with
+          | exception Not_found -> begin
+              match MethMap.bindings dir.services with
+              | [] -> Lwt.return_error `Not_found
+              | l -> Lwt.return_error (`Method_not_allowed (List.map fst l))
+            end
+          | rs -> Lwt.return_ok (rs.builder args)
+        end
+
+  let lookup =
+    (lookup
+     : _ -> _ -> _ -> _ -> (_, lookup_error) result Lwt.t
+     :> _ -> _ -> _ -> _ -> (_, [> lookup_error ]) result Lwt.t )
+
+  let allowed_methods
+    : type a.
+      a directory -> a -> string list ->
+      (Resto.meth list, lookup_error) result Lwt.t
+    = fun dir args path ->
+      resolve [] dir args path >>= function
+      | Error err -> Lwt.return_error err
+      | Ok (Dir (dir, _)) -> begin
+          match MethMap.bindings dir.services with
+          | [] -> Lwt.return_error `Not_found
+          | l -> Lwt.return_ok (List.map fst l)
+        end
+
+  let allowed_methods =
+    (allowed_methods
+     : _ -> _ -> _ -> (_, lookup_error) result Lwt.t
+     :> _ -> _ -> _ -> (_, [> lookup_error]) result Lwt.t)
+
+
+  let rec build_dynamic_dir : type p. p directory -> p -> p directory Lwt.t =
+    fun dir args ->
+      match dir with
+      | Dynamic (_, builder) ->
+          builder args >>= fun dir -> build_dynamic_dir dir args
+      | _ -> Lwt.return dir
+
+  let rec transparent_resolve
+    : type pr p.
+      pr directory -> (pr, p) rpath -> p -> p directory option Lwt.t
+    = fun dir path rargs ->
+      match path with
+      | Root -> Lwt.return_some dir
+      | Static (path, name) -> begin
+          transparent_resolve dir path rargs >>= function
+          | None -> Lwt.return_none
+          | Some dir ->
+              build_dynamic_dir dir rargs >>= function
+              | Dynamic (_,_) -> assert false (* should not happen. *)
+              | Static { subdirs = Some (Suffixes s) ; _ } ->
+                  Lwt.return_some (StringMap.find name s)
+              | Empty -> Lwt.return_none
+              | Static _ -> Lwt.return_none
+              | DynamicTail _ -> Lwt.return_none
+        end
+      | Dynamic (ipath, iarg) -> begin
+          transparent_resolve dir ipath (fst rargs) >>= function
+          | None -> Lwt.return_none
+          | Some dir ->
+              build_dynamic_dir dir (fst rargs) >>= function
+              | Dynamic (_, _) -> assert false (* should not happen. *)
+              | Static { subdirs = Some (Arg (arg, dir)) ; _ } -> begin
+                  match Ty.eq iarg.id arg.id with
+                  | exception Ty.Not_equal ->
+                      Lwt.return_none
+                  | Ty.Eq ->
+                      Lwt.return_some (dir : (_ * _) directory :> p directory)
+                end
+              | Empty -> Lwt.return_none
+              | Static _ -> Lwt.return_none
+              | DynamicTail _ -> Lwt.return_none
+        end
+      | DynamicTail (path, arg) -> begin
+          transparent_resolve dir path (fst rargs) >>= function
+          | None -> Lwt.return_none
+          | Some dir ->
+              build_dynamic_dir dir (fst rargs) >>= function
+              | Dynamic (_,_) -> assert false (* should not happen. *)
+              | DynamicTail (iarg, dir) -> begin
+                  match Ty.eq iarg.id arg.id with
+                  | exception Ty.Not_equal ->
+                      Lwt.return_none
+                  | Ty.Eq ->
+                      Lwt.return_some (dir : (_ * _) directory :> p directory)
+                end
+              | Empty -> Lwt.return_none
+              | Static _ -> Lwt.return_none
+        end
+
+  let transparent_lookup :
+    type prefix params query input output error.
+    prefix directory ->
+    (_, prefix, params, query, input, output, error) Service.t ->
+    params -> query -> input -> (output, error) Answer.t Lwt.t =
+    fun dir service params query body ->
+      let service = Service.Internal.to_service service in
+      begin
+        match service.path with
+        | Service.Internal.Path p ->
+            transparent_resolve dir p params
+        | Service.Internal.MappedPath (p, _, f) -> begin
+            transparent_resolve dir p (f params) >>= function
+            | None -> Lwt.return_none
+            | Some dir -> Lwt.return_some (map f dir)
+          end
+      end >>= function
+      | None -> Lwt.return (`Not_found None)
+      | Some (Static { services ; _ }) -> begin
+          try
+            let Service { handler ; types } =
+              (MethMap.find service.meth services).builder params in
+            match Service.Internal.eq types service.types with
+            | exception Service.Internal.Not_equal ->
+                Lwt.return (`Not_found None)
+            | Service.Internal.Eq ->
+                (handler query body
+                 : (_, _) Answer.t Lwt.t :> (output, error) Answer.t Lwt.t)
+          with Not_found -> Lwt.return (`Not_found None)
+        end
+      | Some _ -> Lwt.return (`Not_found None)
+
+  let transparent_lookup =
+    ( transparent_lookup
+      : _ -> (Resto.meth, _, _, _, _, _, _) Service.t ->
+      _ -> _ -> _ -> (_, _) Answer.t Lwt.t
+      :> _ -> ([< Resto.meth ], _, _, _, _, _, _) Service.t ->
+      _ -> _ -> _ -> [> (_, _) Answer.t ] Lwt.t)
+
+  let rec describe_rpath
+    : type a b. Description.path_item list ->
+      (a, b) rpath -> Description.path_item list
+    = fun acc path ->
+      match path with
+      | Root -> acc
+      | Static (rpath, name) ->
+          describe_rpath (PStatic name :: acc) rpath
+      | Dynamic (rpath, arg) ->
+          describe_rpath (PDynamic arg.descr :: acc) rpath
+      | DynamicTail (rpath, arg) ->
+          describe_rpath (PDynamicTail arg.descr :: acc) rpath
+
+  (****************************************************************************
+   * Registration
+   ****************************************************************************)
+
+  let rec step_of_path
+    : type p rk. (rk, p) rpath -> step list -> step list
+    = fun path acc ->
+      match path with
+      | Root -> acc
+      | Static (path, name) -> step_of_path path (Static name :: acc)
+      | Dynamic (path, arg) -> step_of_path path (Dynamic arg.descr :: acc)
+      | DynamicTail (path, arg) -> step_of_path path (DynamicTail arg.descr :: acc)
+  let step_of_path p = step_of_path p []
+
+  let conflict path kind = raise (Conflict (step_of_path path, kind))
+
+  let rec insert
+    : type k rk.
+      (rk, k) rpath -> rk directory -> k directory * (k directory -> rk directory)
+    = fun path dir ->
+      match path with
+      | Root -> dir, (fun x -> x)
+      | Static (subpath, name) -> begin
+          let subdir, rebuild = insert subpath dir in
+          let dirmap, services =
+            match subdir with
+            | Empty ->
+                StringMap.empty, MethMap.empty
+            | Static { subdirs = None ; services } ->
+                StringMap.empty, services
+            | Static { subdirs = Some (Suffixes m) ;
+                       services } ->
+                m, services
+            | Static { subdirs = Some (Arg (arg, _)) ; _ } ->
+                conflict path (CType (arg.descr, [name]))
+            | Dynamic _ -> conflict path CBuilder
+            | DynamicTail _ -> conflict path CTail in
+          let dir =
+            try StringMap.find name dirmap with Not_found -> empty in
+          let rebuild s =
+            let subdirs =
+              Some (Suffixes (StringMap.add name s dirmap)) in
+            rebuild (Static { subdirs ; services }) in
+          dir, rebuild
+        end
+      | Dynamic (subpath, arg) -> begin
+          let subdir, rebuild = insert subpath dir in
+          let dir, services =
+            match subdir with
+            | Empty ->
+                Empty, MethMap.empty
+            | Static { subdirs = None ; services } ->
+                Empty, services
+            | Static { subdirs = Some (Arg (arg', dir)) ;
+                       services } -> begin
+                try
+                  let Ty.Eq = Ty.eq arg.id arg'.id in
+                  (dir :> k directory), services
+                with Ty.Not_equal ->
+                  conflict path (CTypes (arg.descr, arg'.descr))
+              end
+            | Static { subdirs = Some (Suffixes m) ; _ } ->
+                conflict path
+                  (CType (arg.descr, List.map fst (StringMap.bindings m)))
+            | Dynamic _ -> conflict path CBuilder
+            | DynamicTail _ -> conflict path CTail
+          in
+          let rebuild s =
+            let subdirs = Some (Arg (arg, s)) in
+            rebuild (Static { subdirs ; services }) in
+          dir, rebuild
+        end
+      | DynamicTail (subpath, arg) -> begin
+          let subdir, rebuild = insert subpath dir in
+          match subdir with
+          | Empty ->
+              let rebuild s = rebuild (DynamicTail (arg, s)) in
+              empty, rebuild
+          | Static { subdirs = None ; services } ->
+              conflict path (CService (fst (MethMap.min_binding services)))
+          | Static { subdirs = Some (Arg (arg, _)) ; _ } ->
+              conflict path (CType (arg.descr, []))
+          | Static { subdirs = Some (Suffixes m) ; _ } ->
+              conflict path
+                (CType (arg.descr, List.map fst (StringMap.bindings m)))
+          | Dynamic _ -> conflict path CBuilder
+          | DynamicTail _ -> conflict path CTail
+        end
+
+  let register
+    : type p q i o e pr.
+      pr directory -> (_, pr, p, q, i, o, e) Service.t ->
+      (p -> q -> i -> (o, e) Answer.t Lwt.t) -> pr directory =
+    fun root s handler ->
+      let s = Service.Internal.to_service s in
+      let register
+        : type k. (pr, k) rpath -> (k -> q -> i -> (o, e) Answer.t Lwt.t) ->
+          pr directory =
+        fun path handler ->
+          let dir, insert = insert path root in
+          let rs =
+            let description : _ Description.service = {
+              meth = s.meth ;
+              path = describe_rpath [] path ;
+              description = s.description ;
+              query = describe_query (Resto.Internal.to_query s.types.query) ;
+              input = begin
+                match s.types.input with
+                | Service.No_input -> None
+                | Service.Input input -> Some (Encoding.schema input)
+              end ;
+              output = Encoding.schema s.types.output ;
+              error = Encoding.schema s.types.error ;
+            } in
+            let builder key = Service {
+                types = s.types ;
+                handler = handler key ;
+              } in
+            { meth = s.meth ; description ; builder } in
+          match dir with
+          | Empty ->
+              insert (Static { services = MethMap.singleton s.meth rs ;
+                               subdirs = None })
+          | Static ({ services ; _ } as dir)
+            when not (MethMap.mem s.meth services) ->
+              insert (Static { dir with services = MethMap.add s.meth rs services })
+          | Static _ -> conflict path (CService s.meth)
+          | Dynamic _ -> conflict path CBuilder
+          | DynamicTail _ -> conflict path CTail in
+      match s.path with
+      | Path p -> register p handler
+      | MappedPath (p, map, _) -> register p (fun p i -> handler (map p) i)
+
+  let register =
+    (register
+     : _ -> (Resto.meth, _, _, _, _, _, _) Service.t ->
+     (_ -> _ -> _ -> (_, _) Answer.t Lwt.t) -> _
+     :> _ -> ([< Resto.meth ], _, _, _, _, _, _) Service.t ->
+     (_ -> _ -> _ -> [< (_, _) Answer.t ] Lwt.t) -> _)
+
+  let register_dynamic_directory
+    : type pr a pr.
+      ?descr:string ->
+      pr directory -> (pr, a) Path.path ->
+      (a -> a directory Lwt.t) -> pr directory =
+    fun ?descr root path builder ->
+      let path = Resto.Internal.to_path path in
+      let register
+        : type k. (pr, k) rpath -> (k -> k directory Lwt.t) -> pr directory =
+        fun path builder ->
+          let dir, insert = insert path root in
+          match dir with
+          | Empty ->
+              insert (Dynamic (descr, builder))
+          | Static ({ services ; subdirs = None }) ->
+              conflict path (CService (fst (MethMap.choose services)))
+          | Static ({ subdirs = Some _ ; _ }) -> conflict path CDir
+          | Dynamic _ -> conflict path CBuilder
+          | DynamicTail _ -> conflict path CTail in
+      match path with
+      | Path p -> register p builder
+      | MappedPath (p, map, _) ->
+          register p
+            (fun args -> builder (map args) >|= map_directory map)
+
+  let register_describe_directory_service
+    : type pr.
+      pr directory ->
+      (pr, pr) Service.description_service ->
+      pr directory
+    = fun root service ->
+      let dir = ref root in
+      let lookup (args, path) { Description.recurse } () =
+        resolve [] root args path >>= function
+        | Error `Not_found
+        | Error `Cannot_parse_path _ ->
+            Lwt.return (`Not_found None)
+        | Ok (Dir (dir, arg)) ->
+            describe_directory ~recurse ~arg (Static dir) >>= function
+            | Static { services ; _ }
+              when not recurse && MethMap.is_empty services ->
+                Lwt.return (`Not_found None)
+            | d ->
+                Lwt.return (`Ok d)
+      in
+      dir := register root service lookup ;
+      !dir
+
+  (****************************************************************************
+   * Let's currify!
+   ****************************************************************************)
+
+  open Curry
+
+  let register0 root s f = register root s (curry Z f)
+  let register1 root s f = register root s (curry (S Z) f)
+  let register2 root s f = register root s (curry (S (S Z)) f)
+  let register3 root s f = register root s (curry (S (S (S Z))) f)
+  let register4 root s f = register root s (curry (S (S (S (S Z)))) f)
+  let register5 root s f = register root s (curry (S (S (S (S (S Z))))) f)
+
+  let register_dynamic_directory1 ?descr root s f =
+    register_dynamic_directory ?descr root s (curry (S Z) f)
+  let register_dynamic_directory2 ?descr root s f =
+    register_dynamic_directory ?descr root s (curry (S (S Z)) f)
+  let register_dynamic_directory3 ?descr root s f =
+    register_dynamic_directory ?descr root s (curry (S (S (S Z))) f)
+
+
+end

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

@@ -0,0 +1,194 @@
+(**************************************************************************)
+(*  ocplib-resto                                                          *)
+(*  Copyright (C) 2016, OCamlPro.                                         *)
+(*                                                                        *)
+(*    All rights reserved.  This file is distributed under the terms      *)
+(*    of the GNU Lesser General Public License version 2.1, with the      *)
+(*    special exception on linking described in the file LICENSE.         *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Resto
+
+module Answer : sig
+
+  (** Return type for service handler *)
+  type ('o, 'e) t =
+    [ `Ok of 'o (* 200 *)
+    | `OkStream of 'o stream (* 200 *)
+    | `Created of string option (* 201 *)
+    | `No_content (* 204 *)
+    | `Unauthorized of 'e option (* 401 *)
+    | `Forbidden of 'e option (* 403 *)
+    | `Not_found of 'e option (* 404 *)
+    | `Conflict of 'e option (* 409 *)
+    | `Error of 'e option (* 500 *)
+    ]
+
+  and 'a stream = {
+    next: unit -> 'a option Lwt.t ;
+    shutdown: unit -> unit ;
+  }
+
+  val return: 'o -> ('o, 'e) t Lwt.t
+  val return_stream: 'o stream -> ('o, 'e) t Lwt.t
+
+end
+
+module MakeDirectory (Encoding : ENCODING) : sig
+
+  module Service : (module type of (struct include Resto.MakeService(Encoding) end))
+
+  (** Possible error while registring services. *)
+  type step =
+    | Static of string
+    | Dynamic of Arg.descr
+    | DynamicTail of Arg.descr
+
+  type conflict =
+    | CService of meth | CDir | CBuilder | CTail
+    | CTypes of Arg.descr *
+                Arg.descr
+    | CType of Arg.descr * string list
+
+  type ('query, 'input, 'output, 'error) types = {
+    query : 'query Resto.Query.t ;
+    input : 'input Service.input ;
+    output : 'output Encoding.t ;
+    error : 'error Encoding.t ;
+  }
+
+  type registred_service =
+    | Service :
+        { types : ('q, 'i, 'o, 'e) types ;
+          handler : ('q -> 'i -> ('o, 'e) Answer.t Lwt.t) ;
+        } -> registred_service
+
+  (** Dispatch tree *)
+  type 'prefix t
+  type 'prefix directory = 'prefix t
+
+  type lookup_error =
+    [ `Not_found (* 404 *)
+    | `Method_not_allowed of meth list (* 405 *)
+    | `Cannot_parse_path of string list * Arg.descr * string (* 400 *)
+    ]
+
+  (** Resolve a service. *)
+  val lookup:
+    'prefix directory -> 'prefix ->
+    meth -> string list -> (registred_service, [> lookup_error ]) result Lwt.t
+
+  val allowed_methods:
+    'prefix directory -> 'prefix -> string list ->
+    (meth list, [> lookup_error ]) result Lwt.t
+
+  val transparent_lookup:
+    'prefix directory ->
+    ('meth, 'prefix, 'params, 'query, 'input, 'output, 'error) Service.t ->
+    'params -> 'query -> 'input -> [> ('output, 'error) Answer.t ] Lwt.t
+
+  (** Empty tree *)
+  val empty: 'prefix directory
+
+  val map: ('a -> 'b) -> 'b directory -> 'a directory
+
+  val prefix: ('pr, 'p) Path.path -> 'p directory -> 'pr directory
+  val merge: 'a directory -> 'a directory -> 'a directory
+
+  exception Conflict of step list * conflict
+
+  (** Registring handler in service tree. *)
+  val register:
+    'prefix directory ->
+    ('meth, 'prefix, 'params, 'query, 'input, 'output, 'error) Service.t ->
+    ('params -> 'query -> 'input -> [< ('output, 'error) Answer.t ] Lwt.t) ->
+    'prefix directory
+
+  (** Registring handler in service tree. Curryfied variant.  *)
+  val register0:
+    unit directory ->
+    ('m, unit, unit, 'q, 'i, 'o, 'e) Service.t ->
+    ('q -> 'i -> [< ('o, 'e) Answer.t ] Lwt.t) ->
+    unit directory
+
+  val register1:
+    'prefix directory ->
+    ('m, 'prefix, unit * 'a, 'q , 'i, 'o, 'e) Service.t ->
+    ('a -> 'q -> 'i -> [< ('o, 'e) Answer.t ] Lwt.t) ->
+    'prefix directory
+
+  val register2:
+    'prefix directory ->
+    ('m, 'prefix, (unit * 'a) * 'b, 'q , 'i, 'o, 'e) Service.t ->
+    ('a -> 'b -> 'q -> 'i -> [< ('o, 'e) Answer.t ] Lwt.t) ->
+    'prefix directory
+
+  val register3:
+    'prefix directory ->
+    ('m, 'prefix, ((unit * 'a) * 'b) * 'c, 'q , 'i, 'o, 'e) Service.t ->
+    ('a -> 'b -> 'c -> 'q -> 'i -> [< ('o, 'e) Answer.t ] Lwt.t) ->
+    'prefix directory
+
+  val register4:
+    'prefix directory ->
+    ('m, 'prefix, (((unit * 'a) * 'b) * 'c) * 'd, 'q , 'i, 'o, 'e) Service.t ->
+    ('a -> 'b -> 'c -> 'd -> 'q -> 'i -> [< ('o, 'e) Answer.t ] Lwt.t) ->
+    'prefix directory
+
+  val register5:
+    'prefix directory ->
+    ('m, 'prefix, ((((unit * 'a) * 'b) * 'c) * 'd) * 'e, 'q , 'i, 'o, 'e) Service.t ->
+    ('a -> 'b -> 'c -> 'd -> 'e -> 'q -> 'i -> [< ('o, 'e) Answer.t ] Lwt.t) ->
+    'prefix directory
+
+  (** Registring dynamic subtree. *)
+  val register_dynamic_directory:
+    ?descr:string ->
+    'prefix directory ->
+    ('prefix, 'a) Path.path -> ('a -> 'a directory Lwt.t) ->
+    'prefix directory
+
+  (** Registring dynamic subtree. (Curryfied variant) *)
+  val register_dynamic_directory1:
+    ?descr:string ->
+    'prefix directory ->
+    ('prefix, unit * 'a) Path.path ->
+    ('a -> (unit * 'a) directory Lwt.t) ->
+    'prefix directory
+
+  val register_dynamic_directory2:
+    ?descr:string ->
+    'prefix directory ->
+    ('prefix, (unit * 'a) * 'b) Path.path ->
+    ('a -> 'b -> ((unit * 'a) * 'b) directory Lwt.t) ->
+    'prefix directory
+
+  val register_dynamic_directory3:
+    ?descr:string ->
+    'prefix directory ->
+    ('prefix, ((unit * 'a) * 'b) * 'c) Path.path ->
+    ('a -> 'b -> 'c -> (((unit * 'a) * 'b) * 'c) directory Lwt.t) ->
+    'prefix directory
+
+  (** Registring a description service. *)
+  val register_describe_directory_service:
+    'prefix directory ->
+    ('prefix, 'prefix) Service.description_service ->
+    'prefix directory
+
+  (**/**)
+
+  module Curry: sig
+
+    type (_,_,_,_,_,_) conv =
+      | Z : (unit, 'g, 'g, unit, 'f, 'f) conv
+      | S : ('t, 'g, 'b * 's, 'rt, 'f, 'r) conv ->
+        ('t * 'b, 'g, 's, 'a * 'rt, 'a -> 'f, 'r) conv
+    val curry : ('a, 'b, unit, 'b, 'c, 'd) conv -> 'c -> 'a -> 'd
+
+  end
+
+  (**/**)
+
+end

vendors/ocplib-resto/lib_resto-json/jbuild

@@ -0,0 +1,8 @@
+(jbuild_version 1)
+
+(library
+ ((name resto_json)
+  (public_name ocplib-resto-json)
+  (libraries (ocplib-json-typed ocplib-json-typed.bson ocplib-resto))
+  (modules (RestoJson))
+  (wrapped false)))

vendors/ocplib-resto/lib_resto-json/restoJson.ml

@@ -0,0 +1,155 @@
+(**************************************************************************)
+(*  ocplib-resto                                                          *)
+(*  Copyright (C) 2016, OCamlPro.                                         *)
+(*                                                                        *)
+(*    All rights reserved.  This file is distributed under the terms      *)
+(*    of the GNU Lesser General Public License version 2.1, with the      *)
+(*    special exception on linking described in the file LICENSE.         *)
+(*                                                                        *)
+(**************************************************************************)
+
+module Encoding = struct
+
+  include Json_encoding
+  type 'a t = 'a encoding
+  type schema = Json_schema.schema
+
+  module StringMap = Map.Make(String)
+
+  let arg_encoding =
+    let open Json_encoding in
+    conv
+      (fun {Resto.Arg.name; descr} -> (name, descr))
+      (fun (name, descr) -> {name; descr})
+      (obj2 (req "name" string) (opt "descr" string))
+
+  open Resto.Description
+
+  let meth_encoding =
+    Json_encoding.string_enum
+      [ "GET", `GET ;
+        "POST", `POST ;
+        "DELETE", `DELETE ;
+        "PUT", `PUT ;
+        "PATCH", `PATCH ]
+
+  let path_item_encoding =
+    let open Json_encoding in
+    union [
+      case string
+        (function PStatic s -> Some s | _ -> None)
+        (fun s -> PStatic s) ;
+      case arg_encoding
+        (function PDynamic s -> Some s | _ -> None)
+        (fun s -> PDynamic s) ;
+    ]
+
+  let query_item_encoding =
+    let open Json_encoding in
+    conv
+      (fun {name ; description} -> (name, description))
+      (fun (name, description) -> {name ; description})
+      (obj2 (req "name" string) (opt "description" string))
+
+  let service_descr_encoding =
+    let open Json_encoding in
+    conv
+      (fun { meth ; path ; description ; query ; input ; output ; error } ->
+         (meth, path, description, query, input, output, error))
+      (fun (meth, path, description, query, input, output, error) ->
+         { meth ; path ; description ; query ; input ; output ; error })
+      (obj7
+         (req "meth" meth_encoding)
+         (req "path" (list path_item_encoding))
+         (opt "description" string)
+         (req "query" (list query_item_encoding))
+         (opt "input" any_schema)
+         (req "output" any_schema)
+         (req "erro" any_schema))
+
+  let directory_descr_encoding =
+    let open Json_encoding in
+    mu "service_tree" @@ fun directory_descr_encoding ->
+    let static_subdirectories_descr_encoding =
+      union [
+        case (obj1 (req  "suffixes"
+                      (list (obj2 (req "name" string)
+                               (req "tree" directory_descr_encoding)))))
+          (function Suffixes map ->
+             Some (Resto.StringMap.bindings map) | _ -> None)
+          (fun m ->
+             let add acc (n,t) = Resto.StringMap.add n t acc in
+             Suffixes (List.fold_left add Resto.StringMap.empty m)) ;
+        case (obj1 (req "dynamic_dispatch"
+                      (obj2
+                         (req "arg" arg_encoding)
+                         (req "tree" directory_descr_encoding))))
+          (function Arg (ty, tree) -> Some (ty, tree) | _ -> None)
+          (fun (ty, tree) -> Arg (ty, tree))
+      ] in
+
+    let static_directory_descr_encoding =
+      conv
+        (fun { services ; subdirs } ->
+           let find s =
+             try Some (Resto.MethMap.find s services) with Not_found -> None in
+           (find `GET, find `POST, find `DELETE,
+            find `PUT, find `PATCH, subdirs))
+        (fun (get, post, delete, put, patch, subdirs) ->
+           let add meth s services =
+             match s with
+             | None -> services
+             | Some s -> Resto.MethMap.add meth s services in
+           let services =
+             Resto.MethMap.empty
+             |> add `GET get
+             |> add `POST post
+             |> add `DELETE delete
+             |> add `PUT put
+             |> add `PATCH patch in
+           { services ; subdirs })
+        (obj6
+           (opt "get_service" service_descr_encoding)
+           (opt "post_service" service_descr_encoding)
+           (opt "delete_service" service_descr_encoding)
+           (opt "put_service" service_descr_encoding)
+           (opt "patch_service" service_descr_encoding)
+           (opt "subdirs" static_subdirectories_descr_encoding)) in
+    union [
+      case (obj1 (req "static" static_directory_descr_encoding))
+        (function Static descr -> Some descr | _ -> None)
+        (fun descr -> Static descr) ;
+      case (obj1 (req "dynamic" (option string)))
+        (function Dynamic descr -> Some descr | _ -> None)
+        (fun descr -> Dynamic descr) ;
+    ]
+
+  let description_request_encoding =
+    conv
+      (fun { recurse } -> recurse)
+      (function recurse -> { recurse })
+      (obj1 (dft "recursive" bool false))
+
+  let description_answer_encoding = directory_descr_encoding
+
+end
+
+module type VALUE = sig
+  type t
+  type 'a encoding
+  val construct: 'a encoding -> 'a -> t
+  val destruct: 'a encoding -> t -> 'a
+end
+
+module Ezjsonm = struct
+  type t = Json_repr.Ezjsonm.value
+  let construct = Json_encoding.construct
+  let destruct = Json_encoding.destruct
+end
+
+module Bson = struct
+  open Json_repr_bson
+  type t = Repr.value
+  let construct = Json_encoding.construct
+  let destruct = Json_encoding.destruct
+end

vendors/ocplib-resto/lib_resto-json/restoJson.mli

@@ -0,0 +1,28 @@
+(**************************************************************************)
+(*  ocplib-resto                                                          *)
+(*  Copyright (C) 2016, OCamlPro.                                         *)
+(*                                                                        *)
+(*    All rights reserved.  This file is distributed under the terms      *)
+(*    of the GNU Lesser General Public License version 2.1, with the      *)
+(*    special exception on linking described in the file LICENSE.         *)
+(*                                                                        *)
+(**************************************************************************)
+
+module Encoding : Resto.ENCODING
+  with type 'a t = 'a Json_encoding.encoding
+   and type schema = Json_schema.schema
+
+module type VALUE = sig
+  type t
+  type 'a encoding
+  val construct: 'a encoding -> 'a -> t
+  val destruct: 'a encoding -> t -> 'a
+end
+
+module Ezjsonm : VALUE
+  with type t = Json_repr.Ezjsonm.value
+   and type 'a encoding := 'a Encoding.t
+
+module Bson : VALUE
+  with type t = Json_repr_bson.bson
+   and type 'a encoding := 'a Encoding.t

vendors/ocplib-resto/lib_resto/jbuild

@@ -0,0 +1,8 @@
+(jbuild_version 1)
+
+(library
+ ((name resto)
+  (public_name ocplib-resto)
+  (modules (Resto))
+  (flags (-w -30))
+  (wrapped false)))

vendors/ocplib-resto/lib_resto/resto.ml

@@ -0,0 +1,589 @@
+(**************************************************************************)
+(*  ocplib-resto                                                          *)
+(*  Copyright (C) 2016, OCamlPro.                                         *)
+(*                                                                        *)
+(*    All rights reserved.  This file is distributed under the terms      *)
+(*    of the GNU Lesser General Public License version 2.1, with the      *)
+(*    special exception on linking described in the file LICENSE.         *)
+(*                                                                        *)
+(**************************************************************************)
+
+type meth = [ `GET | `POST | `DELETE | `PUT | `PATCH ]
+
+let string_of_meth = function
+  | `GET -> "GET"
+  | `POST -> "POST"
+  | `DELETE -> "DELETE"
+  | `PUT -> "PUT"
+  | `PATCH -> "PATCH"
+
+module MethMap = Map.Make(struct type t = meth let compare = compare end)
+module StringMap = Map.Make(String)
+
+module Internal = struct
+
+  module Ty = struct
+
+    type 'a witness = ..
+    exception Not_equal
+    type (_, _) eq = Eq : ('a, 'a) eq
+    module type Ty = sig
+      type t val witness : t witness
+      val eq: 'a witness -> ('a, t) eq
+    end
+    type 'a id = (module Ty with type t = 'a)
+    let new_id (type a) () =
+      let module Ty = struct
+        type t = a
+        type 'a witness += Ty : t witness
+        let witness = Ty
+        let eq (type b) : b witness -> (b, t) eq =
+          function Ty -> Eq | _ -> raise Not_equal
+      end in
+      (module Ty : Ty with type t = a)
+    let eq : type a b. a id -> b id -> (a, b) eq =
+      fun (module TyA) (module TyB) ->  TyB.eq TyA.witness
+
+  end
+
+  type descr = {
+    name: string ;
+    descr: string option ;
+  }
+
+  type 'a arg = {
+    id: 'a Ty.id;
+    destruct: string -> ('a, string) result ;
+    construct: 'a -> string ;
+    descr: descr ;
+  }
+
+  let from_arg x = x
+  let to_arg x = x
+
+  type (_,_) rpath =
+    | Root : ('rkey, 'rkey) rpath
+    | Static : ('rkey, 'key) rpath * string -> ('rkey, 'key) rpath
+    | Dynamic : ('rkey, 'key) rpath * 'a arg -> ('rkey, 'key * 'a) rpath
+    | DynamicTail : ('rkey, 'key) rpath * 'a arg -> ('rkey, 'key * 'a list) rpath
+
+  type (_,_) path =
+    | Path: ('prefix, 'params) rpath -> ('prefix, 'params) path
+    | MappedPath:
+        ('prefix, 'key) rpath * ('key -> 'params) * ('params -> 'key) ->
+      ('prefix, 'params) path
+
+  let from_path x = x
+  let to_path x = x
+
+  type 'a query =
+    (* inspired from Irmin.Ty.record. *)
+    | Fields: ('a, 'b) query_fields * 'b -> 'a query
+
+  and ('a, 'b) query_fields =
+    | F0: ('a, 'a) query_fields
+    | F1: ('a, 'b) query_field * ('a, 'c) query_fields ->
+      ('a, 'b -> 'c) query_fields
+
+  and ('a, 'b) query_field = {
+    fname : string ;
+    ftype : 'b arg ;
+    fdefault : 'b ;
+    fget : 'a -> 'b ;
+    fdescription : string option ;
+  }
+
+  let from_query x = x
+  let to_query x = x
+
+end
+
+open Internal
+
+module Arg = struct
+
+  type descr = Internal.descr = {
+    name: string ;
+    descr: string option ;
+  }
+  type 'a t = 'a Internal.arg
+  type 'a arg = 'a t
+
+  let make ?descr ~name ~destruct ~construct () =
+    let id = Ty.new_id () in
+    let descr = { name ; descr } in
+    { descr ; id ; construct ; destruct }
+
+  let like arg ?descr name =
+    { arg with id = Ty.new_id () ; descr = { name ; descr } }
+
+  let descr (ty: 'a arg) = ty.descr
+
+  let bool : bool arg =
+    let bool_of_string s =
+      match String.lowercase_ascii s with
+      | "false" | "no" -> Ok false
+      | _ -> Ok true in
+    let string_of_bool = function
+      | true -> "yes"
+      | false -> "no" in
+    make ~name:"bool" ~destruct:bool_of_string ~construct:string_of_bool ()
+  let int =
+    let int_of_string s =
+      try Ok (int_of_string s)
+      with Failure _ ->
+        Error (Printf.sprintf "Cannot parse integer value: %S." s) in
+    make ~name:"int" ~destruct:int_of_string ~construct:string_of_int ()
+  let float =
+    let float_of_string s =
+      try Ok (float_of_string s)
+      with Failure _ ->
+        Error (Printf.sprintf "Cannot parse float value: %S." s) in
+    make ~name:"float" ~destruct:float_of_string ~construct:string_of_float ()
+  let int32 =
+    let int32_of_string s =
+      try Ok (Int32.of_string s)
+      with Failure _ ->
+        Error (Printf.sprintf "Cannot parse int32 value: %S." s) in
+    make ~name:"int32" ~destruct:int32_of_string ~construct:Int32.to_string ()
+  let int64 =
+    let int64_of_string s =
+      try Ok (Int64.of_string s)
+      with Failure _ ->
+        Error (Printf.sprintf "Cannot parse int64 value: %S." s) in
+    make ~name:"int64" ~destruct:int64_of_string ~construct:Int64.to_string ()
+  let string =
+    make ~name:"string" ~destruct:(fun x -> Ok x) ~construct:(fun x -> x) ()
+
+end
+
+module Path = struct
+
+  type ('a, 'b) t = ('a, 'b) Internal.path
+  type ('a, 'b) path = ('a, 'b) Internal.path
+  type ('a, 'b) rpath = ('a, 'b) Internal.rpath
+
+  type 'prefix context = ('prefix, 'prefix) path
+
+  let root = Path Root
+  let open_root = Path Root
+
+  let add_suffix (type p pr) (path : (p, pr) path) name =
+    match path with
+    | Path (DynamicTail _) -> invalid_arg "Resto.Path.add_suffix"
+    | MappedPath (DynamicTail _, _, _) -> invalid_arg "Resto.Path.add_suffix"
+    | Path path -> Path (Static (path, name))
+    | MappedPath (path, map, rmap) ->
+        MappedPath (Static (path, name), map, rmap)
+
+  let add_arg (type p pr) (path : (p, pr) path)  arg =
+    match path with
+    | Path (DynamicTail _) -> invalid_arg "Resto.Path.add_arg"
+    | MappedPath (DynamicTail _, _, _) -> invalid_arg "Resto.Path.add_arg"
+    | Path path -> Path (Dynamic (path, arg))
+    | MappedPath (path, map, rmap) ->
+        MappedPath (Dynamic (path, arg),
+                    (fun (x, y) -> (map x, y)),
+                    (fun (x, y) -> (rmap x, y)))
+
+  let add_final_args (type p pr) (path : (p, pr) path)  arg =
+    match path with
+    | Path (DynamicTail _) -> invalid_arg "Resto.Path.add_final_arg"
+    | MappedPath (DynamicTail _, _, _) -> invalid_arg "Resto.Path.add_final_arg"
+    | Path path -> Path (DynamicTail (path, arg))
+    | MappedPath (path, map, rmap) ->
+        MappedPath (DynamicTail (path, arg),
+                    (fun (x, y) -> (map x, y)),
+                    (fun (x, y) -> (rmap x, y)))
+
+  let map map rmap = function
+    | Path p -> MappedPath (p, map, rmap)
+    | MappedPath (p, map', rmap') ->
+        MappedPath (p, (fun x -> map (map' x)), (fun x -> rmap' (rmap x)))
+
+  let prefix
+    : type p pr a. (pr, a) path -> (a, p) path -> (pr, p) path
+    = fun p1 p2 ->
+      let rec prefix
+        : type pr a k.
+          (pr, a) path -> (a, k) rpath -> (pr, k) path
+        = fun p1 p2 ->
+          match p2 with
+          | Root -> p1
+          | Static (path, name) -> add_suffix (prefix p1 path) name
+          | Dynamic (path, arg) -> add_arg (prefix p1 path) arg
+          | DynamicTail (path, arg) -> add_final_args (prefix p1 path) arg
+      in
+      match p1 with
+      | Path (DynamicTail _) -> invalid_arg "Resto.Path.prefix"
+      | MappedPath (DynamicTail _, _, _) -> invalid_arg "Resto.Path.prefix"
+      | _ ->
+          match p2 with
+          | Path p2 -> prefix p1 p2
+          | MappedPath (p2, m, rm) -> map m rm (prefix p1 p2)
+
+  let (/) = add_suffix
+  let (/:) = add_arg
+  let (/:*) = add_final_args
+
+end
+
+module Query = struct
+
+  type 'a t = 'a Internal.query
+  type 'a query = 'a Internal.query
+  type ('a, 'b) field = ('a, 'b) Internal.query_field
+
+  type ('a, 'b, 'c) open_query =
+    ('a, 'c) query_fields -> 'b * ('a, 'b) query_fields
+
+  let field ?descr fname ftype fdefault fget =
+    { fname; ftype; fdefault ; fget ; fdescription = descr }
+
+  let query : 'b -> ('a, 'b, 'b) open_query =
+    fun c fs -> c, fs
+
+  let app : type a b c d.
+    (a, b, c -> d) open_query -> (a, c) query_field -> (a, b, d) open_query
+    = fun r f fs ->
+      let c, fs = r (F1 (f, fs)) in
+      c, fs
+
+  let seal : type a b. (a, b, a) open_query -> a t =
+    fun r ->
+      let c, fs = r F0 in
+      Fields (fs, c)
+
+  let (|+) = app
+
+  let empty = Fields (F0 , ())
+
+  type 'a efield = Field: ('a, 'b) query_field -> 'a efield
+  let fold_fields (type fs) ~f ~init fs =
+    let rec loop : type f. _ -> (fs, f) query_fields -> _ = fun acc -> function
+      | F0 -> acc
+      | F1 (field, fs) -> loop (f acc (Field field)) fs in
+    loop init fs
+
+  type 'a parsed_field =
+    | Parsed: ('a, 'b) query_field * 'b option -> 'a parsed_field
+
+  let rec rebuild
+    : type fs f. _ -> (fs, f) query_fields -> f -> fs
+    = fun map fs f ->
+      match fs with
+      | F0 -> f
+      | F1 (field, fs) ->
+          let Parsed (field', v) = StringMap.find field.fname map in
+          let Ty.Eq = Ty.eq field.ftype.id field'.ftype.id in
+          let v = match v with None -> field.fdefault | Some v -> v in
+          rebuild map fs (f v)
+
+  exception Invalid of string
+  type untyped = (string * string) list
+  let parse (Fields (fs, f)) =
+    let fields =
+      fold_fields
+        ~f:(fun map (Field f) -> StringMap.add f.fname (Parsed (f, None)) map)
+        ~init:StringMap.empty
+        fs in
+    fun query ->
+      let fail fmt = Format.kasprintf (fun s -> raise (Invalid s)) fmt in
+      let fields =
+        List.fold_left
+          begin fun fields (name, value) ->
+            match StringMap.find name fields with
+            | exception Not_found -> fields
+            | (Parsed (f, Some _)) ->
+                (* TODO add an option to parse multiple as list. *)
+                fail "Duplicate argument '%s' in query string." name
+            | (Parsed (f, None)) ->
+                match f.ftype.destruct value with
+                | Error error ->
+                    fail "Failed to parse argument '%s' (%S): %s"
+                      name value error
+                | Ok v -> StringMap.add name (Parsed (f, Some v)) fields
+          end
+          fields query in
+      rebuild fields fs f
+
+end
+
+module Description = struct
+
+  type request = {
+    recurse: bool ;
+  }
+
+  let request_query =
+    let open Query in
+    query (fun recurse -> { recurse })
+    |+ field "recurse" Arg.bool false (fun t -> t.recurse)
+    |> seal
+
+  type 'schema service = {
+    description: string option ;
+    path: path_item list ;
+    meth: meth ;
+    query: query_item list ;
+    input: 'schema option ;
+    output: 'schema ;
+    error: 'schema ;
+  }
+
+  and path_item =
+    | PStatic of string
+    | PDynamic of Arg.descr
+    | PDynamicTail of Arg.descr
+
+  and query_item = {
+    name: string ;
+    description: string option ;
+  }
+
+  type 'schema directory =
+    | Empty
+    | Static of 'schema static_directory
+    | Dynamic of string option
+
+  and 'schema static_directory = {
+    services: 'schema service MethMap.t ;
+    subdirs: 'schema static_subdirectories option ;
+  }
+
+  and 'schema static_subdirectories =
+    | Suffixes of 'schema directory Map.Make(String).t
+    | Arg of Arg.descr * 'schema directory
+
+  let rec pp_print_directory ppf =
+    let open Format in
+    function
+    | Empty ->
+        fprintf ppf "<empty>"
+    | Static dir ->
+        fprintf ppf "@[%a@]" pp_print_static_directory dir
+    | Dynamic None ->
+        fprintf ppf "<dyntree>"
+    | Dynamic (Some descr) ->
+        fprintf ppf "<dyntree> : %s" descr
+
+  and pp_print_static_directory ppf =
+    let open Format in
+    function
+    | { services ; subdirs = None } when MethMap.is_empty services ->
+        fprintf ppf "{}"
+    | { services ; subdirs = None } ->
+        fprintf ppf "@[<v>%a@]"
+          pp_print_dispatch_services services
+    | { services ; subdirs = Some subdirs } when MethMap.is_empty services ->
+        fprintf ppf "%a"
+          pp_print_static_subdirectories subdirs
+    | { services ; subdirs = Some subdirs } ->
+        fprintf ppf "@[<v>%a@ %a@]"
+          pp_print_dispatch_services services
+          pp_print_static_subdirectories subdirs
+
+  and pp_print_static_subdirectories ppf =
+    let open Format in
+    function
+    | Suffixes map ->
+        let print_binding ppf (name, tree) =
+          fprintf ppf "@[<hov 2>%s:@ %a@]"
+            name pp_print_directory tree in
+        fprintf ppf "@[<v>%a@]"
+          (pp_print_list ~pp_sep:pp_print_cut print_binding)
+          (StringMap.bindings map)
+    | Arg (arg, tree) ->
+        fprintf ppf "@[<hov 2>[:%s:]@ @[%a@]@]"
+          (arg.name) pp_print_directory tree
+
+  and pp_print_dispatch_services ppf services =
+    MethMap.iter
+      begin fun meth s ->
+        match s with
+        | { description = None ; meth ; _ } ->
+            Format.fprintf ppf "<%s>" (string_of_meth meth)
+        | { description = Some descr ; meth ; _ } ->
+            Format.fprintf ppf "<%s> : %s" (string_of_meth meth) descr
+      end
+      services
+
+end
+
+module type ENCODING = sig
+  type 'a t
+  type schema
+  val unit : unit t
+  val schema : 'a t -> schema
+  val description_request_encoding : Description.request t
+  val description_answer_encoding : schema Description.directory t
+end
+
+module MakeService(Encoding : ENCODING) = struct
+
+  module Internal = struct
+    include Internal
+    type ('query, 'input, 'output, 'error) types = {
+      query : 'query query ;
+      input : 'input input ;
+      output : 'output Encoding.t ;
+      error : 'error Encoding.t ;
+    }
+    and _ input =
+      | No_input : unit input
+      | Input : 'input Encoding.t -> 'input input
+    type (+'meth, 'prefix, 'params, 'query,
+          'input, 'output, 'error) iservice = {
+      description : string option ;
+      meth : 'meth ;
+      path : ('prefix, 'params) path ;
+      types : ('query, 'input, 'output, 'error) types ;
+    } constraint 'meth = [< meth ]
+    let from_service x = x
+    let to_service x = x
+
+    type (_, _) eq =
+      | Eq : (('query, 'input, 'output, 'error) types,
+              ('query, 'input, 'output, 'error) types) eq
+    exception Not_equal
+    let eq :
+      type query1 input1 output1 error1  query2 input2 output2 error2.
+      (query1, input1, output1, error1) types ->
+      (query2, input2, output2, error2) types ->
+      ((query1, input1, output1, error1) types,
+       (query2, input2, output2, error2) types) eq
+      = fun x y ->
+        if Obj.magic x == Obj.magic y then
+          Obj.magic Eq (* FIXME *)
+        else
+          raise Not_equal
+
+  end
+  include Internal
+  open Path
+
+  type (+'meth, 'prefix, 'params, 'query, 'input, 'output, 'error) t =
+    ('meth, 'prefix, 'params, 'query, 'input, 'output, 'error) Internal.iservice
+  type (+'meth, 'prefix, 'params, 'query, 'input, 'output, 'error) service =
+    ('meth, 'prefix, 'params, 'query, 'input, 'output, 'error) t
+
+  let get_service ?description ~query ~output ~error path =
+    let input = No_input in
+    { meth = `GET ; description ; path ;
+      types = { query ; input ; output ; error } }
+
+  let post_service ?description ~query ~input ~output ~error path =
+    let input = Input input in
+    { meth = `POST ; description ; path ;
+      types = { query ; input ; output ; error } }
+
+  let delete_service ?description ~query ~output ~error path =
+    let input = No_input in
+    { meth = `DELETE ; description ; path ;
+      types = { query ; input ; output ; error } }
+
+  let put_service ?description ~query ~input ~output ~error path =
+    let input = Input input in
+    { meth = `PUT ; description ; path ;
+      types = { query ; input ; output ; error } }
+
+  let patch_service ?description ~query ~input ~output ~error path =
+    let input = Input input in
+    { meth = `PATCH ; description ; path ;
+      types = { query ; input ; output ; error } }
+
+  let prefix path s = { s with path = Path.prefix path s.path }
+
+  let map f g (s : (_,_,_,_,_,_,_) service) =
+    { s with path = Path.map f g s.path }
+
+
+  let query
+    : type pr p i q o e.
+      (_, pr, p, q, i, o, e) service -> q Query.t
+    = fun { types } -> types.query
+
+  let input_encoding
+    : type pr p i q o e.
+      (_, pr , p, q, i, o, e) service -> i input
+    = fun { types } -> types.input
+
+  let output_encoding
+    : type pr p i q o e.
+      (_, pr, p, q, i, o, e) service -> o Encoding.t
+    = fun { types } -> types.output
+
+  let error_encoding
+    : type pr p i q o e.
+      (_, pr, p, q, i, o, e) service -> e Encoding.t
+    = fun { types } -> types.error
+
+  type ('prefix, 'params) description_service =
+    ([ `GET ], 'prefix, 'params * string list, Description.request,
+     unit, Encoding.schema Description.directory, unit) service
+
+  let description_service ?description path =
+    let description =
+      match description with
+      | Some descr -> descr
+      | None -> "<TODO>"
+    in
+    get_service
+      ~description
+      ~query:Description.request_query
+      ~output:Encoding.description_answer_encoding
+      ~error:Encoding.unit
+      Path.(path /:* Arg.string)
+
+  type 'input request = {
+    meth: meth ;
+    path: string list ;
+    query: (string * string) list ;
+    input: 'input input ;
+  }
+
+  let forge_request_args
+    : type p. (unit, p) path -> p -> string list
+    = fun path args ->
+      let rec forge_request_args
+        : type k. (unit, k) rpath -> k -> string list -> string list
+        = fun path args acc ->
+          match path, args with
+          | Root, _ ->
+              acc
+          | Static (path, name), args ->
+              forge_request_args path args (name :: acc)
+          | Dynamic (path, arg), (args, x) ->
+              forge_request_args path args (arg.construct x :: acc)
+          | DynamicTail (path, arg), (args, xs) ->
+              forge_request_args path args
+                (List.fold_right (fun x acc -> arg.construct x :: acc) xs acc) in
+      match path with
+      | Path path -> forge_request_args path args []
+      | MappedPath (path, _, rmap) -> forge_request_args path (rmap args) []
+
+  let forge_request_query
+    : type q. q query -> q -> (string * string) list
+    = fun (Fields (fields, _)) q ->
+      let rec loop : type t. (q, t) query_fields -> _ = function
+        | F0 -> []
+        | F1 ({ fname ; ftype ; fget ; _ }, fields) ->
+            (fname, ftype.construct (fget q)) :: loop fields in
+      loop fields
+
+  let forge_request
+    : type p i q o e.
+      (_, unit, p, q, i, o, e) service -> p -> q -> i request
+    = fun s args query ->
+      { meth = s.meth ;
+        path = forge_request_args s.path args ;
+        query = forge_request_query s.types.query query ;
+        input = s.types.input ;
+      }
+
+  let forge_request =
+    (forge_request
+     : (meth, _, _, _, _, _, _) service -> _
+     :> ([< meth], _, _, _, _, _, _) service -> _ )
+
+end

vendors/ocplib-resto/lib_resto/resto.mli

@@ -0,0 +1,366 @@
+(**************************************************************************)
+(*  ocplib-resto                                                          *)
+(*  Copyright (C) 2016, OCamlPro.                                         *)
+(*                                                                        *)
+(*    All rights reserved.  This file is distributed under the terms      *)
+(*    of the GNU Lesser General Public License version 2.1, with the      *)
+(*    special exception on linking described in the file LICENSE.         *)
+(*                                                                        *)
+(**************************************************************************)
+
+type meth = [ `GET | `POST | `DELETE | `PUT | `PATCH ]
+
+val string_of_meth: meth -> string
+
+module MethMap : Map.S with type key = meth
+module StringMap : Map.S with type key = string
+
+(** Typed path argument. *)
+module Arg : sig
+
+  type 'a t
+  type 'a arg = 'a t
+  val make:
+    ?descr:string ->
+    name:string ->
+    destruct:(string -> ('a, string) result) ->
+    construct:('a -> string) ->
+    unit -> 'a arg
+
+  type descr = {
+    name: string ;
+    descr: string option ;
+  }
+  val descr: 'a arg -> descr
+
+  val bool: bool arg
+  val int: int arg
+  val int32: int32 arg
+  val int64: int64 arg
+  val float: float arg
+  val string: string arg
+
+  val like: 'a arg -> ?descr:string -> string -> 'a arg
+
+end
+
+
+(** Parametrized path to services. *)
+module Path : sig
+
+  type ('prefix, 'params) t
+  type ('prefix, 'params) path = ('prefix, 'params) t
+  type 'prefix context = ('prefix, 'prefix) path
+
+  val root: unit context
+  val open_root: 'a context
+
+  val add_suffix:
+    ('prefix, 'params) path -> string -> ('prefix, 'params) path
+  val (/):
+    ('prefix, 'params) path -> string -> ('prefix, 'params) path
+
+  val add_arg:
+    ('prefix, 'params) path -> 'a Arg.t -> ('prefix, 'params * 'a) path
+  val (/:):
+    ('prefix, 'params) path -> 'a Arg.t -> ('prefix, 'params * 'a) path
+
+  val add_final_args:
+    ('prefix, 'params) path -> 'a Arg.t -> ('prefix, 'params * 'a list) path
+  val (/:*):
+    ('prefix, 'params) path -> 'a Arg.t -> ('prefix, 'params * 'a list) path
+
+  val prefix:
+    ('prefix, 'a) path -> ('a, 'params) path -> ('prefix, 'params) path
+
+  val map:
+    ('a -> 'b) -> ('b -> 'a) -> ('prefix, 'a) path -> ('prefix, 'b) path
+
+end
+
+(** Service directory description *)
+module Description : sig
+
+  type request = {
+    recurse: bool ;
+  }
+
+  type 'schema service = {
+    description: string option ;
+    path: path_item list ;
+    meth: meth ;
+    query: query_item list ;
+    input: 'schema option ;
+    output: 'schema ;
+    error: 'schema ;
+  }
+
+  and path_item =
+    | PStatic of string
+    | PDynamic of Arg.descr
+    | PDynamicTail of Arg.descr
+
+  and query_item = {
+    name: string ;
+    description: string option ;
+  }
+
+  type 'schema directory =
+    | Empty
+    | Static of 'schema static_directory
+    | Dynamic of string option
+
+  and 'schema static_directory = {
+    services: 'schema service MethMap.t ;
+    subdirs: 'schema static_subdirectories option ;
+  }
+
+  and 'schema static_subdirectories =
+    | Suffixes of 'schema directory StringMap.t
+    | Arg of Arg.descr * 'schema directory
+
+  val pp_print_directory:
+    (* ?pp_schema:(Format.formatter -> 'schema -> unit) -> *) (* TODO ?? *)
+    Format.formatter -> 'schema directory -> unit
+
+end
+
+module Query : sig
+
+  type 'a t
+  type 'a query = 'a t
+
+  val empty: unit query
+
+  type ('a, 'b) field
+  val field:
+    ?descr: string ->
+    string -> 'a Arg.t -> 'a -> ('b -> 'a) -> ('b, 'a) field
+
+  type ('a, 'b, 'c) open_query
+  val query: 'b -> ('a, 'b, 'b) open_query
+  val (|+):
+    ('a, 'b, 'c -> 'd) open_query ->
+    ('a, 'c) field -> ('a, 'b, 'd) open_query
+  val seal: ('a, 'b, 'a) open_query -> 'a t
+
+  type untyped = (string * string) list
+  exception Invalid of string
+  val parse: 'a query -> untyped -> 'a
+
+end
+
+(**/**)
+
+module Internal : sig
+
+  module Ty : sig
+
+    exception Not_equal
+    type (_, _) eq = Eq : ('a, 'a) eq
+
+    type 'a id
+    val eq : 'a id -> 'b id -> ('a, 'b) eq
+
+  end
+
+  type 'a arg = {
+    id: 'a Ty.id;
+    destruct: string -> ('a, string) result ;
+    construct: 'a -> string ;
+    descr: Arg.descr ;
+  }
+
+  val from_arg : 'a arg -> 'a Arg.t
+  val to_arg : 'a Arg.t -> 'a arg
+
+  type (_, _) rpath =
+    | Root : ('rkey, 'rkey) rpath
+    | Static : ('rkey, 'key) rpath * string -> ('rkey, 'key) rpath
+    | Dynamic : ('rkey, 'key) rpath * 'a arg -> ('rkey, 'key * 'a) rpath
+    | DynamicTail : ('rkey, 'key) rpath * 'a arg -> ('rkey, 'key * 'a list) rpath
+
+  type (_, _) path =
+    | Path: ('prefix, 'params) rpath -> ('prefix, 'params) path
+    | MappedPath:
+        ('prefix, 'key) rpath * ('key -> 'params) * ('params -> 'key) ->
+      ('prefix, 'params) path
+
+  val from_path : ('a, 'b) path -> ('a, 'b) Path.t
+  val to_path : ('a, 'b) Path.t -> ('a, 'b) path
+
+  type 'a query =
+    | Fields: ('a, 'b) query_fields * 'b -> 'a query
+
+  and ('a, 'b) query_fields =
+    | F0: ('a, 'a) query_fields
+    | F1: ('a, 'b) query_field * ('a, 'c) query_fields ->
+      ('a, 'b -> 'c) query_fields
+
+  and ('a, 'b) query_field = {
+    fname : string ;
+    ftype : 'b arg ;
+    fdefault : 'b ;
+    fget : 'a -> 'b ;
+    fdescription : string option ;
+  }
+
+  val from_query : 'a query -> 'a Query.t
+  val to_query : 'a Query.t -> 'a query
+
+end
+
+(**/**)
+
+module type ENCODING = sig
+  type 'a t
+  type schema
+  val unit : unit t
+  val schema : 'a t -> schema
+  val description_request_encoding : Description.request t
+  val description_answer_encoding : schema Description.directory t
+end
+
+module MakeService(Encoding : ENCODING) : sig
+
+  (** Services. *)
+  type (+'meth, 'prefix, 'params, 'query, 'input, 'output, 'error) t
+    constraint 'meth = [< meth ]
+  type (+'meth, 'prefix, 'params, 'query, 'input, 'output, 'error) service =
+    ('meth, 'prefix, 'params, 'query, 'input, 'output, 'error) t
+
+  val query:
+    ('meth, 'prefix, 'params, 'query, 'input, 'output, 'error) service ->
+    'query Query.t
+
+  type _ input =
+    | No_input : unit input
+    | Input : 'input Encoding.t -> 'input input
+
+  val input_encoding:
+    ('meth, 'prefix, 'params, 'query, 'input, 'output, 'error) service ->
+    'input input
+
+  val output_encoding:
+    ('meth, 'prefix, 'params, 'query, 'input, 'output, 'error) service ->
+    'output Encoding.t
+
+  val error_encoding:
+    ('meth, 'prefix, 'params, 'query, 'input, 'output, 'error) service ->
+    'error Encoding.t
+
+  val get_service:
+    ?description: string ->
+    query: 'query Query.t ->
+    output: 'output Encoding.t ->
+    error: 'error Encoding.t ->
+    ('prefix, 'params) Path.t ->
+    ([ `GET ], 'prefix, 'params, 'query, unit, 'output, 'error) service
+
+  val post_service:
+    ?description: string ->
+    query:'query Query.t ->
+    input: 'input Encoding.t ->
+    output: 'output Encoding.t ->
+    error: 'error Encoding.t ->
+    ('prefix, 'params) Path.t ->
+    ([ `POST ], 'prefix, 'params, 'query, 'input, 'output, 'error) service
+
+  val delete_service:
+    ?description: string ->
+    query:'query Query.t ->
+    output: 'output Encoding.t ->
+    error: 'error Encoding.t ->
+    ('prefix, 'params) Path.t ->
+    ([ `DELETE ], 'prefix, 'params, 'query, unit, 'output, 'error) service
+
+  val patch_service:
+    ?description: string ->
+    query:'query Query.t ->
+    input: 'input Encoding.t ->
+    output: 'output Encoding.t ->
+    error: 'error Encoding.t ->
+    ('prefix, 'params) Path.t ->
+    ([ `PATCH ], 'prefix, 'params, 'query, 'input, 'output, 'error) service
+
+  val put_service:
+    ?description: string ->
+    query:'query Query.t ->
+    input: 'input Encoding.t ->
+    output: 'output Encoding.t ->
+    error: 'error Encoding.t ->
+    ('prefix, 'params) Path.t ->
+    ([ `PUT ], 'prefix, 'params, 'query, 'input, 'output, 'error) service
+
+  val prefix:
+    ('prefix, 'inner_prefix) Path.t ->
+    ('meth, 'inner_prefix, 'params, 'query,
+     'input, 'output, 'error) service ->
+    ('meth, 'prefix, 'params,
+     'query, 'input, 'output, 'error) service
+
+  val map:
+    ('a -> 'b) ->
+    ('b -> 'a) ->
+    ('meth, 'pr, 'a, 'q, 'i, 'o, 'e) service ->
+    ('meth, 'pr, 'b, 'q, 'i, 'o, 'e) service
+
+  type ('prefix, 'params) description_service =
+    ([ `GET ], 'prefix, 'params * string list, Description.request,
+     unit, Encoding.schema Description.directory, unit) service
+
+  val description_service:
+    ?description:string ->
+    ('prefix, 'params) Path.t ->
+    ('prefix, 'params) description_service
+
+  type 'input request = {
+    meth: meth ;
+    path: string list ;
+    query: (string * string) list ;
+    input: 'input input ;
+  }
+
+  val forge_request:
+    ('meth, unit, 'params, 'query, 'input, 'output, 'error) service ->
+    'params -> 'query -> 'input request
+
+  module Internal : sig
+
+    include (module type of (struct include Internal end))
+
+    type ('query, 'input, 'output, 'error) types = {
+      query : 'query Query.t ;
+      input : 'input input ;
+      output : 'output Encoding.t ;
+      error : 'error Encoding.t ;
+    }
+
+    type (+'meth, 'prefix, 'params, 'query,
+          'input, 'output, 'error) iservice = {
+      description : string option ;
+      meth : 'meth ;
+      path : ('prefix, 'params) path ;
+      types : ('query, 'input, 'output, 'error) types ;
+    } constraint 'meth = [< meth ]
+
+    exception Not_equal
+    type (_, _) eq =
+      | Eq : (('query, 'input, 'output, 'error) types,
+              ('query, 'input, 'output, 'error) types) eq
+    val eq :
+      ('query1, 'input1, 'output1, 'error1) types ->
+      ('query2, 'input2, 'output2, 'error2) types ->
+      (('query1, 'input1, 'output1, 'error1) types,
+       ('query2, 'input2, 'output2, 'error2) types) eq
+
+    val from_service:
+      ('meth, 'prefix, 'params, 'query, 'input, 'output, 'error) iservice ->
+      ('meth, 'prefix, 'params, 'query, 'input, 'output, 'error) service
+    val to_service:
+      ('meth, 'prefix, 'params, 'query, 'input, 'output, 'error) service ->
+      ('meth, 'prefix, 'params, 'query, 'input, 'output, 'error) iservice
+
+  end
+
+end

vendors/ocplib-resto/ocplib-ezresto-directory.opam

@@ -0,0 +1,24 @@
+version: "dev"
+opam-version: "1.2"
+name: "ocplib-resto-directory"
+maintainer: "Grégoire Henry <gregoire.henry@tezos.com>"
+authors: "Grégoire Henry <gregoire.henry@tezos.com>"
+license: "LGPL-2.1-with-OCaml-exception"
+homepage: "https://github.com/OCamlPro/ocplib-resto"
+bug-reports: "https://github.com/OCamlPro/ocplib-resto/issues"
+dev-repo: "git+https://github.com/OCamlPro/ocplib-resto"
+
+build: [
+  [ "jbuilder" "subst" "-n" "ocplib-resto" ] {pinned}
+  [ "jbuilder" "build" "-p" name "-j" jobs ]
+]
+build-test: [
+  [ "jbuilder" "runtest" "-p" name "-j" jobs ]
+]
+
+depends: [
+  "ocamlfind" {build}
+  "jbuilder" {build}
+  "ocplib-ezresto"
+  "ocplib-resto-directory"
+]

vendors/ocplib-resto/ocplib-ezresto.opam

@@ -0,0 +1,24 @@
+version: "dev"
+opam-version: "1.2"
+name: "ocplib-ezresto"
+maintainer: "Grégoire Henry <gregoire.henry@tezos.com>"
+authors: "Grégoire Henry <gregoire.henry@tezos.com>"
+license: "LGPL-2.1-with-OCaml-exception"
+homepage: "https://github.com/OCamlPro/ocplib-resto"
+bug-reports: "https://github.com/OCamlPro/ocplib-resto/issues"
+dev-repo: "git+https://github.com/OCamlPro/ocplib-resto"
+
+build: [
+  [ "jbuilder" "subst" "-n" "ocplib-resto" ] {pinned}
+  [ "jbuilder" "build" "-p" name "-j" jobs ]
+]
+build-test: [
+  [ "jbuilder" "runtest" "-p" name "-j" jobs ]
+]
+
+depends: [
+  "ocamlfind" {build}
+  "jbuilder" {build}
+  "ocplib-resto"
+  "ocplib-resto-json"
+]

vendors/ocplib-resto/ocplib-resto-cohttp.opam

@@ -0,0 +1,24 @@
+version: "dev"
+opam-version: "1.2"
+name: "ocplib-resto-cohttp"
+maintainer: "Grégoire Henry <gregoire.henry@tezos.com>"
+authors: "Grégoire Henry <gregoire.henry@tezos.com>"
+license: "LGPL-2.1-with-OCaml-exception"
+homepage: "https://github.com/OCamlPro/ocplib-resto"
+bug-reports: "https://github.com/OCamlPro/ocplib-resto/issues"
+dev-repo: "git+https://github.com/OCamlPro/ocplib-resto"
+
+build: [
+  [ "jbuilder" "subst" "-n" "ocplib-resto" ] {pinned}
+  [ "jbuilder" "build" "-p" name "-j" jobs ]
+]
+build-test: [
+  [ "jbuilder" "runtest" "-p" name "-j" jobs ]
+]
+
+depends: [
+  "ocamlfind" {build}
+  "jbuilder" {build}
+  "ocplib-resto-directory"
+  "cohttp-lwt-unix"
+]

vendors/ocplib-resto/ocplib-resto-directory.opam

@@ -0,0 +1,24 @@
+version: "dev"
+opam-version: "1.2"
+name: "ocplib-resto-directory"
+maintainer: "Grégoire Henry <gregoire.henry@tezos.com>"
+authors: "Grégoire Henry <gregoire.henry@tezos.com>"
+license: "LGPL-2.1-with-OCaml-exception"
+homepage: "https://github.com/OCamlPro/ocplib-resto"
+bug-reports: "https://github.com/OCamlPro/ocplib-resto/issues"
+dev-repo: "git+https://github.com/OCamlPro/ocplib-resto"
+
+build: [
+  [ "jbuilder" "subst" "-n" "ocplib-resto" ] {pinned}
+  [ "jbuilder" "build" "-p" name "-j" jobs ]
+]
+build-test: [
+  [ "jbuilder" "runtest" "-p" name "-j" jobs ]
+]
+
+depends: [
+  "ocamlfind" {build}
+  "jbuilder" {build}
+  "ocplib-resto"
+  "lwt"
+]

vendors/ocplib-resto/ocplib-resto-json.opam

@@ -0,0 +1,24 @@
+version: "dev"
+opam-version: "1.2"
+name: "ocplib-resto-json"
+maintainer: "Grégoire Henry <gregoire.henry@tezos.com>"
+authors: "Grégoire Henry <gregoire.henry@tezos.com>"
+license: "LGPL-2.1-with-OCaml-exception"
+homepage: "https://github.com/OCamlPro/ocplib-resto"
+bug-reports: "https://github.com/OCamlPro/ocplib-resto/issues"
+dev-repo: "git+https://github.com/OCamlPro/ocplib-resto"
+
+build: [
+  [ "jbuilder" "subst" "-n" "ocplib-resto" ] {pinned}
+  [ "jbuilder" "build" "-p" name "-j" jobs ]
+]
+build-test: [
+  [ "jbuilder" "runtest" "-p" name "-j" jobs ]
+]
+
+depends: [
+  "ocamlfind" {build}
+  "jbuilder" {build}
+  "ocplib-resto"
+  "ocplib-json-typed" { >= "0.4" }
+]

vendors/ocplib-resto/ocplib-resto.opam

@@ -0,0 +1,22 @@
+version: "dev"
+opam-version: "1.2"
+name: "ocplib-resto"
+maintainer: "Grégoire Henry <gregoire.henry@tezos.com>"
+authors: "Grégoire Henry <gregoire.henry@tezos.com>"
+license: "LGPL-2.1-with-OCaml-exception"
+homepage: "https://github.com/OCamlPro/ocplib-resto"
+bug-reports: "https://github.com/OCamlPro/ocplib-resto/issues"
+dev-repo: "git+https://github.com/OCamlPro/ocplib-resto"
+
+build: [
+  [ "jbuilder" "subst" "-n" "ocplib-resto" ] {pinned}
+  [ "jbuilder" "build" "-p" name "-j" jobs ]
+]
+build-test: [
+  [ "jbuilder" "runtest" "-p" name "-j" jobs ]
+]
+
+depends: [
+  "ocamlfind" {build}
+  "jbuilder" {build}
+]

vendors/ocplib-resto/ocplib-resto.version

@@ -0,0 +1 @@
+0.2

vendors/ocplib-resto/test/directory.ml

@@ -0,0 +1,47 @@
+(**************************************************************************)
+(*  ocplib-resto                                                          *)
+(*  Copyright (C) 2016, OCamlPro.                                         *)
+(*                                                                        *)
+(*    All rights reserved.  This file is distributed under the terms      *)
+(*    of the GNU Lesser General Public License version 2.1, with the      *)
+(*    special exception on linking described in the file LICENSE.         *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Services
+
+include RestoDirectory.MakeDirectory(RestoJson.Encoding)
+
+let rec repeat i json =
+  if i <= 0 then []
+  else json :: repeat (i-1) json
+
+let dir = empty
+let dir =
+  register1 dir repeat_service
+    (fun i () json -> Lwt.return (`Ok (`A (repeat i json))))
+let dir =
+  register1 dir add_service
+    (fun i () j -> Lwt.return (`Ok (i+j)))
+let dir =
+  register2 dir alternate_add_service
+    (fun i j () () -> Lwt.return (`Ok (float_of_int i+.j)))
+let dir =
+  register dir alternate_add_service'
+    (fun (i,j) () () -> Lwt.return (`Ok (i+j)))
+let dir =
+  register dir dummy_service
+    (fun ((((((((),_a), _b), _c), _d), _e), _f), _g) () () -> Lwt.return (`Ok ()))
+
+let dir =
+  register_dynamic_directory1 dir prefix_dir1
+    (fun _ ->
+       let prefixed_dir = empty in
+       let prefixed_dir =
+         register2 prefixed_dir minus_service
+           (fun i j () () -> Lwt.return (`Ok (i -. float_of_int j))) in
+       Lwt.return prefixed_dir)
+
+let dir =
+  register_describe_directory_service
+    dir describe_service

vendors/ocplib-resto/test/ezDirectory.ml

@@ -0,0 +1,32 @@
+(**************************************************************************)
+(*  ocplib-resto                                                          *)
+(*  Copyright (C) 2016, OCamlPro.                                         *)
+(*                                                                        *)
+(*    All rights reserved.  This file is distributed under the terms      *)
+(*    of the GNU Lesser General Public License version 2.1, with the      *)
+(*    special exception on linking described in the file LICENSE.         *)
+(*                                                                        *)
+(**************************************************************************)
+
+open EzServices
+include EzRestoDirectory
+
+let rec repeat i json =
+  if i <= 0 then []
+  else json :: repeat (i-1) json
+
+let dir = empty let dir =
+                  register1 dir repeat_service
+                    (fun i () json -> Lwt.return (`Ok (`A (repeat i json))))
+let dir =
+  register1 dir add_service
+    (fun i () j -> Lwt.return (`Ok (i+j)))
+let dir =
+  register2 dir alternate_add_service
+    (fun i j () () -> Lwt.return (`Ok (float_of_int i+.j)))
+let dir =
+  register dir alternate_add_service'
+    (fun (i,j) () () -> Lwt.return (`Ok (i+j)))
+let dir =
+  register_describe_directory_service
+    dir describe_service

vendors/ocplib-resto/test/ezResto_test.ml

@@ -0,0 +1,91 @@
+(**************************************************************************)
+(*  ocplib-resto                                                          *)
+(*  Copyright (C) 2016, OCamlPro.                                         *)
+(*                                                                        *)
+(*    All rights reserved.  This file is distributed under the terms      *)
+(*    of the GNU Lesser General Public License version 2.1, with the      *)
+(*    special exception on linking described in the file LICENSE.         *)
+(*                                                                        *)
+(**************************************************************************)
+
+open EzServices
+open EzResto
+open EzDirectory
+open Lwt.Infix
+
+let () =
+  Lwt_main.run begin
+    allowed_methods dir ["foo";"3";"repeat"] >>= function
+    | Ok [`POST] -> Lwt.return_unit
+    | _ -> assert false
+  end
+
+let () =
+  Lwt_main.run begin
+    allowed_methods dir ["bar";"3";"4";"add"] >>= function
+    | Ok [`GET;`POST] -> Lwt.return_unit
+    | _ -> assert false
+  end
+
+module Test(Request : sig
+    val request:
+      ('meth, 'params, 'query, 'input, 'output, 'error) EzResto.service ->
+      'params  -> 'query -> 'input -> [> ('output, 'error) Answer.t ] Lwt.t
+  end) = struct
+
+  let () =
+    Lwt_main.run begin
+      Request.request describe_service ((), []) { Description.recurse = true } () >>= function
+      | `Ok dir ->
+          Format.printf "@[<v>%a@]@." Resto.Description.pp_print_directory dir ;
+          Lwt.return_unit
+      | _ -> assert false
+    end
+
+  let () =
+    let test service args arg expected =
+      Lwt_main.run (Request.request service args () arg) = `Ok expected in
+    assert (test repeat_service ((), 3) (`A []) (`A (repeat 3 (`A [])))) ;
+    assert (test add_service ((), 2) 3 5) ;
+    assert (test alternate_add_service (((), 1), 2.5) () 3.5) ;
+    assert (test alternate_add_service' (1, 2) () 3) ;
+    ()
+end
+
+
+module Faked = Test(struct
+    (** Testing faked client/server communication. *)
+    let request (type i) (service: (_,_,_,i,_,_) service) params query (arg: i) =
+      let { meth ; path ; query ; input } = forge_request service params query in
+      let uri =
+        Uri.make
+          ~path:(String.concat "/" path)
+          ~query:(List.map (fun (k,v) -> k, [v]) query) () in
+      Format.eprintf "\nREQUEST: %a@." Uri.pp_hum uri ;
+      let json =
+        match input with
+        | No_input -> `O []
+        | Input input -> Json_encoding.construct input arg in
+      lookup dir meth path >>= function
+      | Ok (Service s) -> begin
+          let query = Resto.Query.parse s.types.query query in
+          begin
+            match s.types.input with
+            | No_input -> s.handler query ()
+            | Input input ->
+                s.handler query @@ Json_encoding.destruct input json
+          end >>= function
+          | `Ok res ->
+              let json = Json_encoding.construct s.types.output res in
+              Lwt.return (`Ok (Json_encoding.destruct (output_encoding service) json))
+          | _ -> failwith "Unexpected lwt result (1)"
+        end
+      | _ -> failwith "Unexpected lwt result (2)"
+  end)
+
+module Transparent = Test(struct
+    let request x = transparent_lookup dir x
+  end)
+
+let () =
+  Printf.printf "\n### OK EzResto ###\n\n%!"

vendors/ocplib-resto/test/ezServices.ml

@@ -0,0 +1,58 @@
+(**************************************************************************)
+(*  ocplib-resto                                                          *)
+(*  Copyright (C) 2016, OCamlPro.                                         *)
+(*                                                                        *)
+(*    All rights reserved.  This file is distributed under the terms      *)
+(*    of the GNU Lesser General Public License version 2.1, with the      *)
+(*    special exception on linking described in the file LICENSE.         *)
+(*                                                                        *)
+(**************************************************************************)
+
+open EzResto
+
+(** Shared part *)
+
+let repeat_service =
+  post_service
+    ~query:Query.empty
+    ~input:Json_encoding.any_ezjson_value
+    ~output:Json_encoding.any_ezjson_value
+    ~error:Json_encoding.empty
+    Path.(root / "foo" /: Arg.int / "repeat")
+
+let add_service =
+  post_service
+    ~query:Query.empty
+    ~input:Json_encoding.int
+    ~output:Json_encoding.int
+    ~error:Json_encoding.empty
+    Path.(root / "foo" /: Arg.int / "add")
+
+let alternate_add_service =
+  get_service
+    ~query:Query.empty
+    ~output:Json_encoding.float
+    ~error:Json_encoding.empty
+    Path.(root / "bar" /: Arg.int /: Arg.float / "add")
+
+let alternate_add_service' =
+  post_service
+    ~query:Query.empty
+    ~input:Json_encoding.null
+    ~output:Json_encoding.int
+    ~error:Json_encoding.empty
+    Path.(map
+            (fun (((),i),f) -> (i,int_of_float f))
+            (fun (i,f) -> (((),i),float_of_int f))
+            (root / "bar" /: Arg.int /: Arg.float / "add"))
+
+let minus_service r =
+  post_service
+    ~query:Query.empty
+    ~input:Json_encoding.null
+    ~output:Json_encoding.float
+    ~error:Json_encoding.empty
+    Path.(r /: Arg.int / "minus")
+
+let describe_service =
+  description_service Path.(root / "describe")

vendors/ocplib-resto/test/jbuild

@@ -0,0 +1,24 @@
+(jbuild_version 1)
+
+(executable
+ ((name resto_test)
+  (modules (Services Directory Resto_test))
+  (libraries (ocplib-resto-directory ocplib-resto-json lwt.unix))))
+
+(alias
+((name runtest_resto)
+ (action (run ${path:resto_test.exe}))))
+
+(executable
+ ((name ezResto_test)
+  (modules (EzServices EzDirectory EzResto_test))
+  (libraries (ocplib-ezresto-directory lwt.unix))))
+
+(alias
+((name runtest_ezresto)
+ (action (run ${path:ezResto_test.exe}))))
+
+(alias
+((name runtest)
+ (deps ((alias runtest_resto)
+        (alias runtest_ezresto)))))

vendors/ocplib-resto/test/resto_test.ml

@@ -0,0 +1,112 @@
+(**************************************************************************)
+(*  ocplib-resto                                                          *)
+(*  Copyright (C) 2016, OCamlPro.                                         *)
+(*                                                                        *)
+(*    All rights reserved.  This file is distributed under the terms      *)
+(*    of the GNU Lesser General Public License version 2.1, with the      *)
+(*    special exception on linking described in the file LICENSE.         *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Services
+open Directory
+open RestoDirectory
+open Lwt.Infix
+
+let () =
+  Lwt_main.run begin
+    allowed_methods dir () ["foo";"3";"repeat"] >>= function
+    | Ok [`POST] -> Lwt.return_unit
+    | _ -> assert false
+  end
+
+let () =
+  Lwt_main.run begin
+    allowed_methods dir () ["bar";"3";"4";"add"] >>= function
+    | Ok [`GET;`POST] -> Lwt.return_unit
+    | _ -> assert false
+  end
+
+module Test(Request : sig
+    val request:
+      ('meth, unit, 'params, 'query, 'input, 'output, 'error) Service.t ->
+      'params  -> 'query -> 'input -> [> ('output, 'error) Answer.t ] Lwt.t
+  end) = struct
+
+  let () =
+    Lwt_main.run begin
+      Request.request describe_service
+        ((), ["foo"; "3"]) { recurse = true } () >>= function
+      | `Ok dir ->
+          Format.printf "@[<v>%a@]@." Resto.Description.pp_print_directory dir ;
+          Lwt.return_unit
+      | _ -> assert false
+    end
+
+  let () =
+    Lwt_main.run begin
+      Request.request describe_service
+        ((), ["bar"; "3" ; "2." ; "add"]) { recurse = false } () >>= function
+      | `Ok dir ->
+          Format.printf "@[<v>%a@]@." Resto.Description.pp_print_directory dir ;
+          Lwt.return_unit ;
+      | _ -> assert false
+    end
+
+  let () =
+    Lwt_main.run begin
+      Request.request describe_service ((), []) { recurse = true } () >>= function
+      | `Ok dir ->
+          Format.printf "@[<v>%a@]@." Resto.Description.pp_print_directory dir ;
+          Lwt.return_unit ;
+      | _ -> assert false
+    end
+
+  let () =
+    let test service args arg expected =
+      Lwt_main.run (Request.request service args () arg) = (`Ok expected) in
+    assert (test repeat_service ((), 3) (`A []) (`A (repeat 3 (`A [])))) ;
+    assert (test add_service ((), 2) 3 5) ;
+    assert (test alternate_add_service (((), 1), 2.5) () 3.5) ;
+    assert (test real_minus_service1 (((), 2.5), 1) () 1.5) ;
+    assert (test alternate_add_service' (1, 2) () 3) ;
+    ()
+
+end
+
+module Faked = Test(struct
+    (** Testing faked client/server communication. *)
+    let request (type i) (service: (_,_,_,_,i,_,_) Service.t) params query arg =
+      let { Service.meth ; path ; query ; input } = Service.forge_request service params query in
+      let uri =
+        Uri.make
+          ~path:(String.concat "/" path)
+          ~query:(List.map (fun (k,v) -> k, [v]) query) () in
+      Format.eprintf "\nREQUEST: %a@." Uri.pp_hum uri ;
+      let json =
+        match input with
+        | Service.No_input -> `O []
+        | Service.Input input -> Json_encoding.construct input arg in
+      lookup dir () meth path >>= function
+      | Ok (Service s) -> begin
+          let query = Resto.Query.parse s.types.query query in
+          begin
+            match s.types.input with
+            | Service.No_input -> s.handler query ()
+            | Service.Input input ->
+                s.handler query @@ Json_encoding.destruct input json
+          end >>= function
+          | `Ok res ->
+              let json = Json_encoding.construct s.types.output res in
+              Lwt.return (`Ok (Json_encoding.destruct (Service.output_encoding service) json))
+          | _ -> failwith "Unexpected lwt result (1)"
+        end
+      | _ -> failwith "Unexpected lwt result (2)"
+  end)
+
+module Transparent = Test(struct
+    let request x = transparent_lookup dir x
+  end)
+
+let () =
+  Printf.printf "\n### OK Resto ###\n\n%!"

vendors/ocplib-resto/test/services.ml

@@ -0,0 +1,78 @@
+(**************************************************************************)
+(*  ocplib-resto                                                          *)
+(*  Copyright (C) 2016, OCamlPro.                                         *)
+(*                                                                        *)
+(*    All rights reserved.  This file is distributed under the terms      *)
+(*    of the GNU Lesser General Public License version 2.1, with the      *)
+(*    special exception on linking described in the file LICENSE.         *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Resto
+module Service = MakeService(RestoJson.Encoding)
+open Service
+
+(** Shared part *)
+
+let repeat_service =
+  post_service
+    ~query:Query.empty
+    ~input:Json_encoding.any_ezjson_value
+    ~output:Json_encoding.any_ezjson_value
+    ~error:Json_encoding.empty
+    Path.(root / "foo" /: Arg.int / "repeat")
+
+let add_service =
+  post_service
+    ~query:Query.empty
+    ~input:Json_encoding.int
+    ~output:Json_encoding.int
+    ~error:Json_encoding.empty
+    Path.(root / "foo" /: Arg.int / "add")
+
+let alternate_add_service =
+  get_service
+    ~query:Query.empty
+    ~output:Json_encoding.float
+    ~error:Json_encoding.empty
+    Path.(root / "bar" /: Arg.int /: Arg.float / "add")
+
+let alternate_add_service' =
+  post_service
+    ~query:Query.empty
+    ~input:Json_encoding.null
+    ~output:Json_encoding.int
+    ~error:Json_encoding.empty
+    Path.(map
+            (fun (((),i),f) -> (i,int_of_float f))
+            (fun (i,f) -> (((),i),float_of_int f))
+            (root / "bar" /: Arg.int /: Arg.float / "add"))
+
+let minus_service =
+  post_service
+    ~query:Query.empty
+    ~input:Json_encoding.null
+    ~output:Json_encoding.float
+    ~error:Json_encoding.empty
+    Path.(open_root /: Arg.int / "minus")
+
+let describe_service =
+  description_service Path.(root / "describe")
+
+let dummy_service =
+  post_service
+    ~query:Query.empty
+    ~input:Json_encoding.null
+    ~output:Json_encoding.null
+    ~error:Json_encoding.empty
+    Path.(root / "a" / "path" / "long" / "enough" /
+          "for" / "<hov>" / "to" / "trigger"
+          /: Arg.float /: Arg.float /: Arg.float /: Arg.float
+          /: Arg.float /: Arg.float /: Arg.float)
+
+let prefix_dir1 = Path.(root / "tartine" /: Arg.float / "chaussure")
+
+
+(** Client only *)
+
+let real_minus_service1 = Service.prefix prefix_dir1 minus_service