balsoft/ligo
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Resto: split Resto_cohttp.Server

Browse Source
This commit is contained in:
Grégoire Henry 2017-12-07 17:43:21 +01:00 committed by Benjamin Canou
parent ebd067a261
commit 26d1c463f9
13 changed files with 327 additions and 177 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
bin_node/node_run_command.ml
View File

@ -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)

33
lib_node_http/RPC_server.ml
View File

@ -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 ;
}

11
lib_node_http/RPC_server.mli
View File

@ -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

45
lib_node_http/media_type.ml Normal file
View File

@ -0,0 +1,45 @@
(**************************************************************************)
(* *)
(* Copyright (c) 2014 - 2017. *)
(* Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* 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 ]

24
lib_node_http/media_type.mli Normal file
View File

@ -0,0 +1,24 @@
(**************************************************************************)
(* *)
(* Copyright (c) 2014 - 2017. *)
(* Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* 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

50
vendors/ocplib-resto/lib_resto-cohttp/cors.ml vendored Normal file
View File

@ -0,0 +1,50 @@
(**************************************************************************)
(* *)
(* Copyright (c) 2014 - 2017. *)
(* Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* 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]

19
vendors/ocplib-resto/lib_resto-cohttp/cors.mli vendored Normal file
View File

@ -0,0 +1,19 @@
(**************************************************************************)
(* *)
(* Copyright (c) 2014 - 2017. *)
(* Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* 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

85
vendors/ocplib-resto/lib_resto-cohttp/media_type.ml vendored Normal file
View File

@ -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

32
vendors/ocplib-resto/lib_resto-cohttp/media_type.mli vendored Normal file
View File

@ -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

149
vendors/ocplib-resto/lib_resto-cohttp/server.ml vendored
View File

@ -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 ;

15
vendors/ocplib-resto/lib_resto-cohttp/server.mli vendored
View File

@ -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

29
vendors/ocplib-resto/lib_resto-cohttp/utils.ml vendored Normal file
View File

@ -0,0 +1,29 @@
(**************************************************************************)
(* *)
(* Copyright (c) 2014 - 2017. *)
(* Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* 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

10
vendors/ocplib-resto/lib_resto-cohttp/utils.mli vendored Normal file
View File

@ -0,0 +1,10 @@
(**************************************************************************)
(* *)
(* Copyright (c) 2014 - 2017. *)
(* Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* All rights reserved. No warranty, explicit or implicit, provided. *)
(* *)
(**************************************************************************)
val split_path: string -> string list