RPC: fix CORS preflight.

This commit is contained in:
Benjamin Canou 2017-04-08 16:09:40 +02:00
parent 9628ff0c2d
commit f26dfdbe8e
2 changed files with 90 additions and 52 deletions

View File

@ -108,11 +108,11 @@ module Answer = struct
end end
type step = type step = RestoDirectory.step =
| Static of string | Static of string
| Dynamic of Arg.descr | Dynamic of Arg.descr
type conflict = type conflict = RestoDirectory.conflict =
| CService | CService
| CDir | CDir
| CBuilder | CBuilder
@ -120,8 +120,8 @@ type conflict =
| CTypes of Arg.descr * Arg.descr | CTypes of Arg.descr * Arg.descr
| CType of Arg.descr * string list | CType of Arg.descr * string list
exception Conflict of step list * conflict exception Conflict = RestoDirectory.Conflict
exception Cannot_parse of Arg.descr * string * string list exception Cannot_parse = RestoDirectory.Cannot_parse
(* Dispatch *) (* Dispatch *)

View File

@ -18,7 +18,6 @@ type server = (* hidden *)
module ConnectionMap = Map.Make(Cohttp.Connection) module ConnectionMap = Map.Make(Cohttp.Connection)
exception Invalid_method exception Invalid_method
exception Options_preflight
exception Cannot_parse_body of string exception Cannot_parse_body of string
let check_origin_matches origin allowed_origin = let check_origin_matches origin allowed_origin =
@ -119,46 +118,91 @@ let launch ?pre_hook ?post_hook ?(host="::") mode root cors_allowed_origins cors
| Some res -> | Some res ->
Lwt.return res Lwt.return res
| None -> | None ->
lookup root ~meth:req.meth () path >>= fun handler -> Lwt.catch
begin (fun () ->
match req.meth with lookup root ~meth:req.meth () path >>= fun handler ->
| `POST Lwt.return_some handler)
| `PUT (function Not_found -> Lwt.return_none
| `PATCH | exn -> Lwt.fail exn) >>= function
| `DELETE -> begin | None ->
Cohttp_lwt_body.to_string body >>= fun body -> begin
match Data_encoding_ezjsonm.from_string body with (* Default OPTIONS handler for CORS preflight *)
| Error msg -> Lwt.fail (Cannot_parse_body msg) if req.meth = `OPTIONS && origin_header <> None then
| Ok body -> Lwt.return (Some body) match Cohttp.Header.get req_headers
end "Access-Control-Request-Method" with
| `GET | Some meth ->
| `HEAD -> Lwt.return None let meth = Cohttp.Code.method_of_string meth in
| `OPTIONS -> Lwt.fail Options_preflight lookup root ~meth () path >>= fun _handler ->
| _ -> Lwt.fail Invalid_method (* unless [lookup] failed with [Not_found] -> 404 *)
end >>= fun body -> Lwt.return [ meth ]
handler body >>= fun { Answer.code ; body } -> | None ->
let body = match body with let supported_meths =
| Empty -> [ `POST ; `PUT ; `PATCH ; `DELETE ; `GET ; `HEAD ] in
Cohttp_lwt_body.empty Lwt_list.filter_map_p
| Single json -> (fun meth ->
Cohttp_lwt_body.of_string (Data_encoding_ezjsonm.to_string json) Lwt.catch
| Stream s -> (fun () ->
let stream = lookup root ~meth () path >>= fun _handler ->
create_stream io con Data_encoding_ezjsonm.to_string s in Lwt.return_some meth)
Cohttp_lwt_body.of_stream stream in (function Not_found -> Lwt.return_none
lwt_log_info "(%s) RPC %s" | exn -> Lwt.fail exn))
(Cohttp.Connection.to_string con) supported_meths >>= function
(if Cohttp.Code.is_error code | [] -> Lwt.fail Not_found (* No handler -> 404 *)
then "failed" | meths -> Lwt.return meths
else "success") >>= fun () -> else Lwt.fail Not_found
let headers = end >>= fun cors_allowed_meths ->
Cohttp.Header.init_with "Content-Type" "application/json" in lwt_log_info "(%s) RPC preflight"
let headers = (Cohttp.Connection.to_string con) >>= fun () ->
make_cors_headers ~headers let headers =
cors_allowed_headers cors_allowed_origins origin_header Cohttp.Header.add
in (Cohttp.Header.init ())
Lwt.return (Response.make "Access-Control-Allow-Methods"
~flush:true ~status:(`Code code) ~headers (), body)) (String.concat ", "
(List.map Cohttp.Code.string_of_method cors_allowed_meths)) in
let headers =
make_cors_headers ~headers
cors_allowed_headers cors_allowed_origins origin_header in
Lwt.return (Response.make ~flush:true ~status:(`Code 200) ~headers (),
Cohttp_lwt_body.empty)
| 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
| _ -> Lwt.fail Invalid_method
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
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 (function
| Not_found | Cannot_parse _ -> | Not_found | Cannot_parse _ ->
lwt_log_info "(%s) not found" lwt_log_info "(%s) not found"
@ -184,12 +228,6 @@ let launch ?pre_hook ?post_hook ?(host="::") mode root cors_allowed_origins cors
(Cohttp.Connection.to_string con) >>= fun () -> (Cohttp.Connection.to_string con) >>= fun () ->
Lwt.return (Response.make ~flush:true ~status:`Bad_request (), Lwt.return (Response.make ~flush:true ~status:`Bad_request (),
Cohttp_lwt_body.of_string msg) Cohttp_lwt_body.of_string msg)
| Options_preflight ->
lwt_log_info "(%s) RPC preflight"
(Cohttp.Connection.to_string con) >>= fun () ->
let headers = make_cors_headers cors_allowed_headers cors_allowed_origins origin_header in
Lwt.return (Response.make ~flush:true ~status:(`Code 200) ~headers (),
Cohttp_lwt_body.empty)
| e -> Lwt.fail e) | e -> Lwt.fail e)
and conn_closed (_, con) = and conn_closed (_, con) =
log_info "connection closed %s" (Cohttp.Connection.to_string con) ; log_info "connection closed %s" (Cohttp.Connection.to_string con) ;
@ -200,7 +238,7 @@ let launch ?pre_hook ?post_hook ?(host="::") mode root cors_allowed_origins cors
let on_exn = function let on_exn = function
| Unix.Unix_error (Unix.EADDRINUSE, "bind", _) -> | Unix.Unix_error (Unix.EADDRINUSE, "bind", _) ->
log_error "RPC server port already taken, \ log_error "RPC server port already taken, \
the node will be shutdown" ; the node will be shutdown" ;
Lwt_exit.exit 1 Lwt_exit.exit 1
| Unix.Unix_error (ECONNRESET, _, _) | Unix.Unix_error (ECONNRESET, _, _)
| Unix.Unix_error (EPIPE, _, _) -> () | Unix.Unix_error (EPIPE, _, _) -> ()