RPC: add HTTP methods and Content-Type headers.

src/.merlin

@@ -37,6 +37,7 @@ PKG git
 PKG ipv6-multicast
 PKG irmin
 PKG lwt
+PKG magic-mime
 PKG mtime.os
 PKG nocrypto
 PKG ocplib-endian

src/Makefile

@@ -522,7 +522,8 @@ WEBCLIENT_IMPLS := \
   webclient_main.ml
 
 CLIENT_PACKAGES := \
-  ${NODE_PACKAGES}
+  ${NODE_PACKAGES} \
+  magic-mime \
 
 EMBEDDED_CLIENT_PROTOCOLS := \
   $(patsubst client/embedded/%/, \

src/client/client_generic_rpcs.ml

@@ -308,7 +308,7 @@ let call url cctxt =
       | Error msg ->
           cctxt.error "%s" msg
       | Ok json ->
-          Client_node_rpcs.get_json cctxt args json >>= fun json ->
+          Client_node_rpcs.get_json cctxt `POST args json >>= fun json ->
           cctxt.message
             "Output:\n%s\n%!" (Data_encoding_ezjsonm.to_string json)
     end
@@ -325,7 +325,7 @@ let call_with_json url json (cctxt: Client_commands.context) =
         err
   | Ok json ->
       let open RPC.Description in
-      Client_node_rpcs.get_json cctxt args json >>= fun json ->
+      Client_node_rpcs.get_json cctxt `POST args json >>= fun json ->
       cctxt.message
         "Output:\n%s\n%!" (Data_encoding_ezjsonm.to_string json)
 

src/client/client_node_rpcs.ml

@@ -21,7 +21,7 @@ let log_response { log } cpt code ans =
   log "requests" "<<<<%d: %s\n%s\n" cpt (Cohttp.Code.string_of_status code) ans
 
 let cpt = ref 0
-let make_request cctxt service json =
+let make_request cctxt meth service json =
   incr cpt ;
   let cpt = !cpt in
   let scheme = if Client_config.tls#get then "https" else "http" in
@@ -35,7 +35,7 @@ let make_request cctxt service json =
   catch
     (fun () ->
        let body = Cohttp_lwt_body.of_string reqbody in
-       Cohttp_lwt_unix.Client.post ~body uri >>= fun (code, ansbody) ->
+       Cohttp_lwt_unix.Client.call meth ~body uri >>= fun (code, ansbody) ->
        log_request cctxt cpt string_uri reqbody >>= fun () ->
        return (cpt, Unix.gettimeofday () -. tzero,
                code.Cohttp.Response.status, ansbody))
@@ -45,8 +45,8 @@ let make_request cctxt service json =
          | e -> Printexc.to_string e in
        cctxt.error "cannot connect to the RPC server (%s)" msg)
 
-let get_streamed_json cctxt service json =
+let get_streamed_json cctxt meth service json =
-  make_request cctxt service json >>= fun (_cpt, time, code, ansbody) ->
+  make_request cctxt meth service json >>= fun (_cpt, time, code, ansbody) ->
   let ansbody = Cohttp_lwt_body.to_stream ansbody in
   match code, ansbody with
   | #Cohttp.Code.success_status, ansbody ->
@@ -73,8 +73,8 @@ let get_streamed_json cctxt service json =
       cctxt.error "the RPC server returned a non-success status (%s)"
         (Cohttp.Code.string_of_status err)
 
-let get_json cctxt service json =
+let get_json cctxt meth service json =
-  make_request cctxt service json >>= fun (cpt, time, code, ansbody) ->
+  make_request cctxt meth service json >>= fun (cpt, time, code, ansbody) ->
   Cohttp_lwt_body.to_string ansbody >>= fun ansbody ->
   match code, ansbody with
   | #Cohttp.Code.success_status, ansbody -> begin
@@ -108,23 +108,23 @@ let parse_answer cctxt service path json =
   | Ok v -> return v
 
 let call_service0 cctxt service arg =
-  let path, arg = RPC.forge_request service () arg in
+  let meth, path, arg = RPC.forge_request service () arg in
-  get_json cctxt path arg >>= fun json ->
+  get_json cctxt meth path arg >>= fun json ->
   parse_answer cctxt service path json
 
 let call_service1 cctxt service a1 arg =
-  let path, arg = RPC.forge_request service ((), a1) arg in
+  let meth, path, arg = RPC.forge_request service ((), a1) arg in
-  get_json cctxt path arg >>= fun json ->
+  get_json cctxt meth path arg >>= fun json ->
   parse_answer cctxt service path json
 
 let call_service2 cctxt service a1 a2 arg =
-  let path, arg = RPC.forge_request service (((), a1), a2) arg in
+  let meth, path, arg = RPC.forge_request service (((), a1), a2) arg in
-  get_json cctxt path arg >>= fun json ->
+  get_json cctxt meth path arg >>= fun json ->
   parse_answer cctxt service path json
 
 let call_streamed_service0 cctxt service arg =
-  let path, arg = RPC.forge_request service () arg in
+  let meth, path, arg = RPC.forge_request service () arg in
-  get_streamed_json cctxt path arg >|= fun st ->
+  get_streamed_json cctxt meth path arg >|= fun st ->
   Lwt_stream.map_s (parse_answer cctxt service path) st
 
 module Services = Node_rpc_services
@@ -150,8 +150,8 @@ let complete cctxt ?block prefix =
   | Some block ->
       call_service2 cctxt Services.Blocks.complete block prefix ()
 let describe cctxt ?recurse path =
-  let prefix, arg = RPC.forge_request Services.describe () recurse in
+  let meth, prefix, arg = RPC.forge_request Services.describe () recurse in
-  get_json cctxt (prefix @ path) arg >>=
+  get_json cctxt meth (prefix @ path) arg >>=
   parse_answer cctxt Services.describe prefix
 
 module Blocks = struct

src/client/client_node_rpcs.mli

@@ -185,7 +185,7 @@ val describe:
 
 val get_json:
   Client_commands.context ->
-  string list -> Data_encoding.json -> Data_encoding.json Lwt.t
+  RPC.meth -> string list -> Data_encoding.json -> Data_encoding.json Lwt.t
 
 val call_service0:
   Client_commands.context ->

src/client/embedded/alpha/webclient/browser/webclient_main.ml

@@ -26,7 +26,8 @@ let call_service service params input =
       (module Json_repr_browser.Repr)
       (module Json_repr.Ezjsonm)
       (Js._JSON##parse body) in
-  let path, json = RPC.forge_request service params input in
+  let meth, path, json = RPC.forge_request service params input in
+  let meth_str = RPC.string_of_method meth in
   let url = String.concat "/" path in
   let xhr = XmlHttpRequest.create () in
   let t, u = Lwt.wait () in
@@ -34,7 +35,7 @@ let call_service service params input =
       if xhr##.readyState = XmlHttpRequest.DONE then
         let response = read_json_body xhr##.responseText in
         Lwt.wakeup u response) ;
-  xhr##_open (Js.string "POST") (Js.string url) Js._true ;
+  xhr##_open (Js.string meth_str) (Js.string url) Js._true ;
   xhr##send (Js.Opt.return (write_json_body json)) ;
   t >>= fun json ->
   match RPC.read_answer service json with

src/minutils/RPC.ml

@@ -7,18 +7,247 @@
 (*                                                                        *)
 (**************************************************************************)
 
+open Lwt.Infix
+
 module Arg = Resto.Arg
 module Path = Resto.Path
-module Description = Resto.Description
+
-let read_answer = Resto.read_answer
+(* Services *)
-let forge_request = Resto.forge_request
+
-let service ?description ~input ~output path =
+(* HTTP methods as defined in Cohttp.Code *)
+type meth = [
+  | `GET
+  | `POST
+  | `HEAD
+  | `DELETE
+  | `PATCH
+  | `PUT
+  | `OPTIONS
+  | `TRACE
+  | `CONNECT
+  | `Other of string
+]
+
+type ('prefix, 'params, 'input, 'output) service =
+  meth * ('prefix, 'params, 'input, 'output) Resto.service
+
+(* The default HTTP method for services *)
+let default_meth = `POST
+
+(* Commonly used REST HTTP methods *)
+let rest_meths = [`GET; `POST; `HEAD; `DELETE; `PATCH; `PUT; `OPTIONS]
+
+let string_of_method = function
+  | `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
+    path)
-type ('prefix, 'params, 'input, 'output) service =
-  ('prefix, 'params, 'input, 'output) Resto.service
 
-include RestoDirectory
+(* 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 *)
+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 =
+  service ~meth:`POST ?description ~input ~output path
+
+let put_service ?description ~input ~output path =
+  service ~meth:`PUT ?description ~input ~output path
+
+let delete_service ?description ~input ~output path =
+  service ~meth:`DELETE ?description ~input ~output path
+
+let prefix p (meth, s) = (meth, RestoDirectory.prefix p s)
+
+let forge_request (meth, service) params input =
+  let path, arg = Resto.forge_request service params input in
+  meth, path, arg
+
+let read_answer (_meth, service) json =
+  Resto.read_answer service json
+
+module Description = struct
+
+  include Resto.Description
+
+  let service ?(meth = default_meth) ?description path =
+    (meth, Resto.Description.service ?description path)
+
+end
+
+module Answer = RestoDirectory.Answer
+
+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
+exception Cannot_parse of Arg.descr * string * string list
+
+(* 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

@@ -59,10 +59,60 @@ module Path : sig
 
 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, 'input, 'output) service
+
+val get_service:
+  ?description: string ->
+  output: 'output Data_encoding.t ->
+  ('prefix, 'params) Path.path ->
+  ('prefix, 'params, unit, 'output) service
+
+val head_service:
+  ?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 ->
@@ -76,7 +126,7 @@ val prefix:
 
 val forge_request:
   (unit, 'params, 'input, 'output) service ->
-  'params -> 'input -> string list * Data_encoding.json
+  'params -> 'input -> meth * string list * Data_encoding.json
 
 val read_answer:
   (unit, 'params, 'input, 'output) service ->
@@ -105,6 +155,7 @@ module Description : sig
     | Arg of Arg.descr * directory_descr
 
   val service:
+    ?meth: meth ->
     ?description:string ->
     ('prefix, 'params) Path.path ->
     ('prefix, 'params, bool option, directory_descr) service
@@ -141,7 +192,7 @@ end
 (** Dispatch tree *)
 type 'prefix directory
 
-(** Empty tree *)
+(** Empty list of dispatch trees *)
 val empty: 'prefix directory
 
 val map: ('a -> 'b) -> 'b directory -> 'a directory
@@ -206,9 +257,11 @@ val register5:
 
 (** Registring dynamic subtree. *)
 val register_dynamic_directory:
+  ?meths:meth list ->
   ?descr:string ->
   'prefix directory ->
-  ('prefix, 'a) Path.path -> ('a -> 'a directory Lwt.t) ->
+  ('prefix, 'a) Path.path ->
+  ('a -> 'a directory Lwt.t) ->
   'prefix directory
 
 (** Registring dynamic subtree. (Curryfied variant) *)
@@ -234,13 +287,14 @@ val register_dynamic_directory3:
   'prefix directory
 
 (** Registring custom directory lookup. *)
-type custom_lookup =
+type custom_lookup = RestoDirectory.custom_lookup
-  | CustomService of Description.service_descr *
+  (* | CustomService of Description.service_descr * *)
-                     ( Data_encoding.json option ->
+  (*                    ( Data_encoding.json option -> *)
-                       Data_encoding.json Answer.answer Lwt.t )
+  (*                      Data_encoding.json Answer.answer Lwt.t ) *)
-  | CustomDirectory of Description.directory_descr
+  (* | CustomDirectory of Description.directory_descr *)
 
 val register_custom_lookup:
+  ?meth:meth ->
   ?descr:string ->
   'prefix directory ->
   ('prefix, 'params) Path.path ->
@@ -248,6 +302,7 @@ val register_custom_lookup:
   'prefix directory
 
 val register_custom_lookup1:
+  ?meth:meth ->
   ?descr:string ->
   'prefix directory ->
   ('prefix, unit * 'a) Path.path ->
@@ -255,6 +310,7 @@ val register_custom_lookup1:
   'prefix directory
 
 val register_custom_lookup2:
+  ?meth:meth ->
   ?descr:string ->
   'prefix directory ->
   ('prefix, (unit * 'a) * 'b) Path.path ->
@@ -262,6 +318,7 @@ val register_custom_lookup2:
   'prefix directory
 
 val register_custom_lookup3:
+  ?meth:meth ->
   ?descr:string ->
   'prefix directory ->
   ('prefix, ((unit * 'a) * 'b) * 'c) Path.path ->
@@ -278,5 +335,5 @@ exception Cannot_parse of Arg.descr * string * string list
 
 (** Resolve a service. *)
 val lookup:
-  'prefix directory -> 'prefix -> string list ->
+  'prefix directory -> ?meth:meth -> 'prefix -> string list ->
   (Data_encoding.json option -> Data_encoding.json Answer.answer Lwt.t) Lwt.t

src/node/net/RPC_server.ml

@@ -82,7 +82,12 @@ let launch ?pre_hook ?post_hook ?(host="::") mode root cors_allowed_origins cors
         Lwt.catch
           (fun () ->
              hook (Uri.path (Cohttp.Request.uri req))
-             >>= fun { Answer.code ; body } ->
+             >>= 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
@@ -96,7 +101,7 @@ let launch ?pre_hook ?post_hook ?(host="::") mode root cors_allowed_origins cors
                        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) (),
+                 (Response.make ~flush:true ~status:(`Code code) ~headers (),
                   body))
           (function
             | Not_found -> Lwt.return None
@@ -114,16 +119,20 @@ let launch ?pre_hook ?post_hook ?(host="::") mode root cors_allowed_origins cors
          | Some res ->
              Lwt.return res
          | None ->
-             lookup root () path >>= fun handler ->
+             lookup root ~meth:req.meth () path >>= fun handler ->
              begin
                match req.meth with
-               | `POST -> begin
+               | `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 -> Lwt.return None
+               | `GET
+               | `HEAD -> Lwt.return None
                | `OPTIONS -> Lwt.fail Options_preflight
                | _ -> Lwt.fail Invalid_method
              end >>= fun body ->
@@ -142,7 +151,12 @@ let launch ?pre_hook ?post_hook ?(host="::") mode root cors_allowed_origins cors
                (if Cohttp.Code.is_error code
                 then "failed"
                 else "success") >>= fun () ->
-             let headers = make_cors_headers cors_allowed_headers cors_allowed_origins origin_header in
+             let headers =
+               Cohttp.Header.init_with "Content-Type" "application/json" in
+             let headers =
+               make_cors_headers ~headers
+                 cors_allowed_headers cors_allowed_origins origin_header
+             in
              Lwt.return (Response.make
                            ~flush:true ~status:(`Code code) ~headers (), body))
       (function

src/node/net/RPC_server.mli

@@ -34,10 +34,12 @@ type server
     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 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 RPC.Answer.answer Lwt.t) ->
+  ?pre_hook: (string -> (string option * string RPC.Answer.answer) Lwt.t) ->
-  ?post_hook: (string -> string RPC.Answer.answer Lwt.t) ->
+  ?post_hook: (string -> (string option * string RPC.Answer.answer) Lwt.t) ->
   ?host:string ->
   Conduit_lwt_unix.server ->
   unit RPC.directory ->

src/node/shell/node_rpc_services.ml

@@ -19,12 +19,13 @@ module Error = struct
       RPC.Path.(root / "errors")
 
   let encoding =
-    let path, _ = RPC.forge_request service () () in
+    let meth, path, _ = RPC.forge_request service () () in
     describe
       ~description:
         (Printf.sprintf
            "The full list of error is available with \
-            the global RPC `/%s`" (String.concat "/" path))
+            the global RPC `%s /%s`"
+            (RPC.string_of_method meth) (String.concat "/" path))
       (conv
          ~schema:Json_schema.any
          (fun exn -> `A (List.map json_of_error exn))

src/proto/environment/RPC.mli

@@ -57,7 +57,22 @@ end
 (** Services. *)
 type ('prefix, 'params, 'input, 'output) service
 
+(** HTTP methods as defined in Cohttp.Code *)
+type meth = [
+  | `GET
+  | `POST
+  | `HEAD
+  | `DELETE
+  | `PATCH
+  | `PUT
+  | `OPTIONS
+  | `TRACE
+  | `CONNECT
+  | `Other of string
+]
+
 val service:
+  ?meth: meth ->
   ?description: string ->
   input: 'input Data_encoding.t ->
   output: 'output Data_encoding.t ->

src/tezos-deps.opam

@@ -37,6 +37,7 @@ depends: [
   "tyxml"
   "js_of_ocaml"
   "sodium" {>= "0.3.0" }
+  "magic-mime"
   "kaputt" # { test }
   "bisect_ppx" # { test }
 ]

src/webclient_main.ml

@@ -125,14 +125,14 @@ let root =
          Lwt.return directory) in
   root
 
-let find_static_file path =
+let find_static_file path_str =
-  let path = OCamlRes.Path.of_string path in
+  let path = OCamlRes.Path.of_string path_str in
   let index path = match path with
-    | ([], None) -> ([], Some ("index", Some "html"))
+    | [], None -> "text/html", ([], Some ("index", Some "html"))
-    | oth -> oth in
+    | oth -> Magic_mime.lookup path_str, oth in
   match path with
   | ("block" :: block :: path, file) ->
-      let path = index (path, file) in
+      let content_type, path = index (path, file) in
       (match Node_rpc_services.Blocks.parse_block block with
        | Ok block ->
            block_protocol Client_commands.ignore_context block >>= fun version ->
@@ -140,29 +140,33 @@ let find_static_file path =
              (try
                 let root =
                   Webclient_version.find_contextual_static_files version in
-                Some (OCamlRes.Res.find path root)
+                Some (content_type, OCamlRes.Res.find path root)
               with Not_found -> None)
        | Error _ -> Lwt.return None)
   | _ ->
       Lwt.return
         (try
-           Some (OCamlRes.Res.find (index path) Webclient_static.root)
+           let content_type, path = index path in
+           Some (content_type, OCamlRes.Res.find path Webclient_static.root)
          with Not_found -> None)
 
 let http_proxy mode =
   let pre_hook path =
     find_static_file path >>= function
-    | Some body ->
+    | Some (content_type, body) ->
-        Lwt.return { RPC.Answer.code = 200 ; body = RPC.Answer.Single body }
+        Lwt.return
+          (Some content_type,
+            { RPC.Answer.code = 200 ; body = RPC.Answer.Single body })
     | None ->
-        Lwt.return { RPC.Answer.code = 404 ; body = RPC.Answer.Empty } in
+        Lwt.return
+          (None, { RPC.Answer.code = 404 ; body = RPC.Answer.Empty }) in
   let post_hook _ =
     (find_static_file "not_found.html" >>= function
-      | Some body ->
+      | Some (content_type, body) ->
-          Lwt.return (RPC.Answer.Single body)
+          Lwt.return (Some content_type, RPC.Answer.Single body)
       | None ->
-          Lwt.return (RPC.Answer.Empty)) >>= fun body ->
+          Lwt.return (None, RPC.Answer.Empty)) >>= fun (content_type, body) ->
-    Lwt.return { RPC.Answer.code = 404 ; body } in
+    Lwt.return (content_type, { RPC.Answer.code = 404 ; body }) in
   RPC_server.launch ~pre_hook ~post_hook mode root [] []
 
 let web_port = Client_config.in_both_groups @@