diff --git a/src/.merlin b/src/.merlin index 01927e0d4..52938da1d 100644 --- a/src/.merlin +++ b/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 diff --git a/src/Makefile b/src/Makefile index b9238c37d..73f68c1b7 100644 --- a/src/Makefile +++ b/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/%/, \ diff --git a/src/client/client_generic_rpcs.ml b/src/client/client_generic_rpcs.ml index 15497ca7a..b7acd0225 100644 --- a/src/client/client_generic_rpcs.ml +++ b/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) diff --git a/src/client/client_node_rpcs.ml b/src/client/client_node_rpcs.ml index 4e9649ab4..6a5e74556 100644 --- a/src/client/client_node_rpcs.ml +++ b/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 = - make_request cctxt service json >>= fun (_cpt, time, code, ansbody) -> +let get_streamed_json cctxt meth service json = + 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 = - make_request cctxt service json >>= fun (cpt, time, code, ansbody) -> +let get_json cctxt meth service json = + 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 - get_json cctxt path arg >>= fun json -> + let meth, path, arg = RPC.forge_request service () arg in + 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 - get_json cctxt path arg >>= fun json -> + let meth, path, arg = RPC.forge_request service ((), a1) arg in + 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 - get_json cctxt path arg >>= fun json -> + let meth, path, arg = RPC.forge_request service (((), a1), a2) arg in + 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 - get_streamed_json cctxt path arg >|= fun st -> + let meth, path, arg = RPC.forge_request service () arg in + 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 - get_json cctxt (prefix @ path) arg >>= + let meth, prefix, arg = RPC.forge_request Services.describe () recurse in + get_json cctxt meth (prefix @ path) arg >>= parse_answer cctxt Services.describe prefix module Blocks = struct diff --git a/src/client/client_node_rpcs.mli b/src/client/client_node_rpcs.mli index e8d955f4e..2402177fe 100644 --- a/src/client/client_node_rpcs.mli +++ b/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 -> diff --git a/src/client/embedded/alpha/webclient/browser/webclient_main.ml b/src/client/embedded/alpha/webclient/browser/webclient_main.ml index c1bc4e28f..39c38e53b 100644 --- a/src/client/embedded/alpha/webclient/browser/webclient_main.ml +++ b/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 diff --git a/src/minutils/RPC.ml b/src/minutils/RPC.ml index 313fad0b4..95a1b861e 100644 --- a/src/minutils/RPC.ml +++ b/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 -let forge_request = Resto.forge_request -let service ?description ~input ~output path = + +(* Services *) + +(* 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 -type ('prefix, 'params, 'input, 'output) service = - ('prefix, 'params, 'input, 'output) Resto.service + path) -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) diff --git a/src/minutils/RPC.mli b/src/minutils/RPC.mli index d00770358..d5a2e57e0 100644 --- a/src/minutils/RPC.mli +++ b/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 = - | CustomService of Description.service_descr * - ( Data_encoding.json option -> - Data_encoding.json Answer.answer Lwt.t ) - | CustomDirectory of Description.directory_descr +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 -> @@ -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 diff --git a/src/node/net/RPC_server.ml b/src/node/net/RPC_server.ml index 1c6e1d4ac..97a4229df 100644 --- a/src/node/net/RPC_server.ml +++ b/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 diff --git a/src/node/net/RPC_server.mli b/src/node/net/RPC_server.mli index 3ffb4c11b..47ea165ac 100644 --- a/src/node/net/RPC_server.mli +++ b/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) -> - ?post_hook: (string -> string RPC.Answer.answer Lwt.t) -> + ?pre_hook: (string -> (string option * 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 -> diff --git a/src/node/shell/node_rpc_services.ml b/src/node/shell/node_rpc_services.ml index cf6d7d226..e9b1a0781 100644 --- a/src/node/shell/node_rpc_services.ml +++ b/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)) diff --git a/src/proto/environment/RPC.mli b/src/proto/environment/RPC.mli index 7444f69e0..bbefb2eee 100644 --- a/src/proto/environment/RPC.mli +++ b/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 -> diff --git a/src/tezos-deps.opam b/src/tezos-deps.opam index ba781f9b3..66240813f 100644 --- a/src/tezos-deps.opam +++ b/src/tezos-deps.opam @@ -37,6 +37,7 @@ depends: [ "tyxml" "js_of_ocaml" "sodium" {>= "0.3.0" } + "magic-mime" "kaputt" # { test } "bisect_ppx" # { test } ] diff --git a/src/webclient_main.ml b/src/webclient_main.ml index bd63f2183..55f1bd4b2 100644 --- a/src/webclient_main.ml +++ b/src/webclient_main.ml @@ -125,14 +125,14 @@ let root = Lwt.return directory) in root -let find_static_file path = - let path = OCamlRes.Path.of_string path in +let find_static_file path_str = + let path = OCamlRes.Path.of_string path_str in let index path = match path with - | ([], None) -> ([], Some ("index", Some "html")) - | oth -> oth in + | [], None -> "text/html", ([], Some ("index", Some "html")) + | 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 -> - Lwt.return { RPC.Answer.code = 200 ; body = RPC.Answer.Single body } + | Some (content_type, 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 -> - Lwt.return (RPC.Answer.Single body) + | Some (content_type, body) -> + Lwt.return (Some content_type, RPC.Answer.Single body) | None -> - Lwt.return (RPC.Answer.Empty)) >>= fun body -> - Lwt.return { RPC.Answer.code = 404 ; body } in + Lwt.return (None, RPC.Answer.Empty)) >>= fun (content_type, body) -> + 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 @@