diff --git a/bin_node/node_run_command.ml b/bin_node/node_run_command.ml index 27897595f..e7b66d864 100644 --- a/bin_node/node_run_command.ml +++ b/bin_node/node_run_command.ml @@ -176,7 +176,7 @@ 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 - ~media_types:RPC_server.[ json ; octet_stream ] + ~media_types:Media_type.all_media_types ~cors:{ allowed_origins = rpc_config.cors_origins ; allowed_headers = rpc_config.cors_headers } >>= fun server -> return (Some server) diff --git a/lib_node_http/RPC_server.ml b/lib_node_http/RPC_server.ml index fef6ea2ae..c8a033ae8 100644 --- a/lib_node_http/RPC_server.ml +++ b/lib_node_http/RPC_server.ml @@ -7,7 +7,7 @@ (* *) (**************************************************************************) -type cors = Resto_cohttp.Server.cors = { +type cors = Resto_cohttp.Cors.t = { allowed_headers : string list ; allowed_origins : string list ; } @@ -16,34 +16,3 @@ include Resto_directory module Directory = Resto_directory.Make(RPC.Data) include Resto_cohttp.Server.Make(RPC.Data)(Logging.RPC) - -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 ; -} - -let octet_stream = { - name = "application/octet-stream" ; - construct = begin fun enc v -> - MBytes.to_string @@ - Data_encoding.Binary.to_bytes enc v - end ; - destruct = begin fun enc s -> - match Data_encoding.Binary.of_bytes enc (MBytes.of_string s) with - | None -> Error "Failed to parse binary data." - | Some data -> Ok data - end ; -} diff --git a/lib_node_http/RPC_server.mli b/lib_node_http/RPC_server.mli index 6c402dd19..c632fb5fa 100644 --- a/lib_node_http/RPC_server.mli +++ b/lib_node_http/RPC_server.mli @@ -19,15 +19,6 @@ type cors = { 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 @@ -35,7 +26,7 @@ type server val launch : ?host:string -> ?cors:cors -> - media_types:media_type list -> + media_types:Media_type.t list -> Conduit_lwt_unix.server -> unit Directory.t -> server Lwt.t diff --git a/lib_node_http/media_type.ml b/lib_node_http/media_type.ml new file mode 100644 index 000000000..472423d7e --- /dev/null +++ b/lib_node_http/media_type.ml @@ -0,0 +1,45 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2017. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +include Resto_cohttp.Media_type.Make(RPC.Data) + +let json = { + name = Cohttp.Accept.MediaType ("application", "json") ; + q = Some 1000 ; + 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 ; +} + +let octet_stream = { + name = Cohttp.Accept.MediaType ("application", "octet-stream") ; + q = Some 500 ; + construct = begin fun enc v -> + MBytes.to_string @@ + Data_encoding.Binary.to_bytes enc v + end ; + destruct = begin fun enc s -> + match Data_encoding.Binary.of_bytes enc (MBytes.of_string s) with + | None -> Error "Failed to parse binary data." + | Some data -> Ok data + end ; +} + +let all_media_types = [ json ; octet_stream ] diff --git a/lib_node_http/media_type.mli b/lib_node_http/media_type.mli new file mode 100644 index 000000000..a023388e6 --- /dev/null +++ b/lib_node_http/media_type.mli @@ -0,0 +1,24 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2017. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +type t = Resto_cohttp.Media_type.Make(RPC.Data).t = { + name: Cohttp.Accept.media_range ; + q: int option ; + construct: 'a. 'a Data_encoding.t -> 'a -> string ; + destruct: 'a. 'a Data_encoding.t -> string -> ('a, string) result ; +} + +val json : t +val octet_stream : t + +val all_media_types : t list + + +val accept_header : t list -> string +val first_complete_media : t list -> ((string * string) * t) option diff --git a/vendors/ocplib-resto/lib_resto-cohttp/cors.ml b/vendors/ocplib-resto/lib_resto-cohttp/cors.ml new file mode 100644 index 000000000..f33897dab --- /dev/null +++ b/vendors/ocplib-resto/lib_resto-cohttp/cors.ml @@ -0,0 +1,50 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2017. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +type t = { + allowed_headers : string list ; + allowed_origins : string list ; +} + +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] diff --git a/vendors/ocplib-resto/lib_resto-cohttp/cors.mli b/vendors/ocplib-resto/lib_resto-cohttp/cors.mli new file mode 100644 index 000000000..6575d4483 --- /dev/null +++ b/vendors/ocplib-resto/lib_resto-cohttp/cors.mli @@ -0,0 +1,19 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2017. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +type t = { + allowed_headers : string list ; + allowed_origins : string list ; +} + +val default: t + +val add_headers: + Cohttp.Header.t -> t -> string option -> Cohttp.Header.t + diff --git a/vendors/ocplib-resto/lib_resto-cohttp/media_type.ml b/vendors/ocplib-resto/lib_resto-cohttp/media_type.ml new file mode 100644 index 000000000..ede3a9150 --- /dev/null +++ b/vendors/ocplib-resto/lib_resto-cohttp/media_type.ml @@ -0,0 +1,85 @@ +(**************************************************************************) +(* 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 Make (Encoding : Resto.ENCODING) = struct + + open Cohttp + + type t = { + name: Cohttp.Accept.media_range ; + q: int option ; + construct: 'a. 'a Encoding.t -> 'a -> string ; + destruct: 'a. 'a Encoding.t -> string -> ('a, string) result ; + } + + let name_of_media_type = function + | Accept.AnyMedia -> "*/*" + | AnyMediaSubtype type_ -> type_ ^ "/*" + | MediaType (type_, subtype) -> type_ ^ "/" ^ subtype + + let name { name ; _ } = name_of_media_type name + + let rec has_complete_media = function + | [] -> false + | { name = MediaType _ ; _ } :: _ -> true + | _ :: l -> has_complete_media l + + let rec first_complete_media = function + | [] -> None + | { name = MediaType (l,r) ; _ } as m :: _ -> Some ((l, r), m) + | _ :: l -> first_complete_media l + + let matching_media (type_, subtype) = function + | Accept.AnyMedia -> true + | AnyMediaSubtype type_' -> type_' = type_ + | MediaType (type_', subtype') -> type_' = type_ && subtype' = subtype + + let rec find_media received = function + | [] -> None + | { name ; _ } as media :: _ when matching_media received name -> + Some media + | _ :: mts -> find_media received mts + + (* Inspired from ocaml-webmachine *) + + let media_match (_, (range, _)) media = + match media.name with + | AnyMedia | AnyMediaSubtype _ -> false + | MediaType (type_, subtype) -> + let open Accept in + match range with + | AnyMedia -> true + | AnyMediaSubtype type_' -> type_' = type_ + | MediaType (type_', subtype') -> type_' = type_ && subtype' = subtype + + let resolve_accept_header provided header = + let ranges = Accept.(media_ranges header |> qsort) in + let rec loop = function + | [] -> None + | r :: rs -> + try + let media = List.find (media_match r) provided in + Some (name_of_media_type media.name, media) + with Not_found -> loop rs + in + loop ranges + + let accept_header ranges = + let ranges = + List.map (fun r -> + let q = match r.q with None -> 1000 | Some i -> i in + (q, (r.name, []))) ranges in + (Accept.string_of_media_ranges ranges) + + let acceptable_encoding ranges = + String.concat ", " + (List.map (fun f -> name_of_media_type f.name) ranges) + +end diff --git a/vendors/ocplib-resto/lib_resto-cohttp/media_type.mli b/vendors/ocplib-resto/lib_resto-cohttp/media_type.mli new file mode 100644 index 000000000..b00b90ea5 --- /dev/null +++ b/vendors/ocplib-resto/lib_resto-cohttp/media_type.mli @@ -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. *) +(* *) +(**************************************************************************) + +module Make (Encoding : Resto.ENCODING) : sig + + type t = { + name: Cohttp.Accept.media_range ; + q: int option ; + construct: 'a. 'a Encoding.t -> 'a -> string ; + destruct: 'a. 'a Encoding.t -> string -> ('a, string) result ; + } + + val name: t -> string + + val has_complete_media: t list -> bool + val first_complete_media: t list -> ((string * string) * t) option + + val find_media: (string * string) -> t list -> t option + + val resolve_accept_header: t list -> string option -> (string * t) option + + val accept_header: t list -> string + val acceptable_encoding: t list -> string + +end diff --git a/vendors/ocplib-resto/lib_resto-cohttp/server.ml b/vendors/ocplib-resto/lib_resto-cohttp/server.ml index 6374aabb9..e2af00f60 100644 --- a/vendors/ocplib-resto/lib_resto-cohttp/server.ml +++ b/vendors/ocplib-resto/lib_resto-cohttp/server.ml @@ -9,77 +9,6 @@ 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 @@ -106,46 +35,14 @@ module Make (Encoding : Resto.ENCODING)(Log : LOGGING) = struct module Service = Resto.MakeService(Encoding) module Directory = Resto_directory.Make(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 + module Media_type = Media_type.Make(Encoding) type server = { root : unit Directory.directory ; mutable streams : (unit -> unit) ConnectionMap.t ; - cors : cors ; - media_types : media_type list ; - default_media_type : media_type ; + cors : Cors.t ; + media_types : Media_type.t list ; + default_media_type : string * Media_type.t ; stopper : unit Lwt.u ; mutable worker : unit Lwt.t ; } @@ -187,23 +84,31 @@ module Make (Encoding : Resto.ENCODING)(Log : LOGGING) = struct meth path >>=? fun (Directory.Service s) -> begin match Header.get req_headers "content-type" with - | None -> Lwt.return_ok server.default_media_type + | None -> Lwt.return_ok (snd server.default_media_type) | Some content_type -> - match List.find (fun { name ; _ } -> name = content_type) - server.media_types with - | exception Not_found -> + match Utils.split_path content_type with + | [x ; y] -> begin + match Media_type.find_media (x, y) server.media_types with + | None -> + Lwt.return_error (`Unsupported_media_type content_type) + | Some media_type -> + Lwt.return_ok media_type + end + | _ -> Lwt.return_error (`Unsupported_media_type content_type) - | media_type -> Lwt.return_ok media_type end >>=? fun input_media_type -> + lwt_debug "(%s) input media type %s" + (Connection.to_string con) + (Media_type.name input_media_type) >>= fun () -> begin match Header.get req_headers "accept" with | None -> Lwt.return_ok server.default_media_type | Some accepted -> - match Media_type.match_header + match Media_type.resolve_accept_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 -> + end >>=? fun (output_content_type, output_media_type) -> begin match Resto.Query.parse s.types.query (List.map @@ -213,6 +118,9 @@ module Make (Encoding : Resto.ENCODING)(Log : LOGGING) = struct Lwt.return_error (`Cannot_parse_query s) | query -> Lwt.return_ok query end >>=? fun query -> + lwt_debug "(%s) ouput media type %s" + (Connection.to_string con) + (Media_type.name output_media_type) >>= fun () -> let output = output_media_type.construct s.types.output and error = function | None -> Cohttp_lwt.Body.empty, Transfer.Fixed 0L @@ -222,7 +130,7 @@ module Make (Encoding : Resto.ENCODING)(Log : LOGGING) = struct 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 + Header.add headers "content-type" output_content_type in begin match s.types.input with | Service.No_input -> @@ -367,9 +275,7 @@ module Make (Encoding : Resto.ENCODING)(Log : LOGGING) = struct "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 + Media_type.acceptable_encoding server.media_types in Lwt.return (Response.make ~status:`Not_acceptable (), Cohttp_lwt.Body.of_string accepted_encoding) @@ -389,9 +295,10 @@ module Make (Encoding : Resto.ENCODING)(Log : LOGGING) = struct ?(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 default_media_type = + match Media_type.first_complete_media media_types with + | None -> invalid_arg "RestoCohttp.launch(empty media type list)" + | Some ((l, r), m) -> l^"/"^r, m in let stop, stopper = Lwt.wait () in let server = { root ; diff --git a/vendors/ocplib-resto/lib_resto-cohttp/server.mli b/vendors/ocplib-resto/lib_resto-cohttp/server.mli index 04c73ee44..cc42ee45e 100644 --- a/vendors/ocplib-resto/lib_resto-cohttp/server.mli +++ b/vendors/ocplib-resto/lib_resto-cohttp/server.mli @@ -10,11 +10,6 @@ (** 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 @@ -33,20 +28,14 @@ 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 -> + ?cors:Cors.t -> + media_types:Media_type.Make(Encoding).t list -> Conduit_lwt_unix.server -> unit Resto_directory.Make(Encoding).t -> server Lwt.t diff --git a/vendors/ocplib-resto/lib_resto-cohttp/utils.ml b/vendors/ocplib-resto/lib_resto-cohttp/utils.ml new file mode 100644 index 000000000..8d01e5a36 --- /dev/null +++ b/vendors/ocplib-resto/lib_resto-cohttp/utils.ml @@ -0,0 +1,29 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2017. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +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 diff --git a/vendors/ocplib-resto/lib_resto-cohttp/utils.mli b/vendors/ocplib-resto/lib_resto-cohttp/utils.mli new file mode 100644 index 000000000..0afb23f6c --- /dev/null +++ b/vendors/ocplib-resto/lib_resto-cohttp/utils.mli @@ -0,0 +1,10 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2017. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +val split_path: string -> string list