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,9 +118,54 @@ 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 ->
Lwt.catch
(fun () ->
lookup root ~meth:req.meth () path >>= fun handler -> lookup root ~meth:req.meth () path >>= fun handler ->
Lwt.return_some handler)
(function Not_found -> Lwt.return_none
| exn -> Lwt.fail exn) >>= function
| None ->
begin begin
match req.meth with (* Default OPTIONS handler for CORS preflight *)
if req.meth = `OPTIONS && origin_header <> None then
match Cohttp.Header.get req_headers
"Access-Control-Request-Method" with
| Some meth ->
let meth = Cohttp.Code.method_of_string meth in
lookup root ~meth () path >>= fun _handler ->
(* unless [lookup] failed with [Not_found] -> 404 *)
Lwt.return [ meth ]
| None ->
let supported_meths =
[ `POST ; `PUT ; `PATCH ; `DELETE ; `GET ; `HEAD ] in
Lwt_list.filter_map_p
(fun meth ->
Lwt.catch
(fun () ->
lookup root ~meth () path >>= fun _handler ->
Lwt.return_some meth)
(function Not_found -> Lwt.return_none
| exn -> Lwt.fail exn))
supported_meths >>= function
| [] -> Lwt.fail Not_found (* No handler -> 404 *)
| meths -> Lwt.return meths
else Lwt.fail Not_found
end >>= fun cors_allowed_meths ->
lwt_log_info "(%s) RPC preflight"
(Cohttp.Connection.to_string con) >>= fun () ->
let headers =
Cohttp.Header.add
(Cohttp.Header.init ())
"Access-Control-Allow-Methods"
(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 | `POST
| `PUT | `PUT
| `PATCH | `PATCH
@ -132,8 +176,8 @@ let launch ?pre_hook ?post_hook ?(host="::") mode root cors_allowed_origins cors
| Ok body -> Lwt.return (Some body) | Ok body -> Lwt.return (Some body)
end end
| `GET | `GET
| `HEAD -> Lwt.return None | `HEAD
| `OPTIONS -> Lwt.fail Options_preflight | `OPTIONS -> Lwt.return None
| _ -> Lwt.fail Invalid_method | _ -> Lwt.fail Invalid_method
end >>= fun body -> end >>= fun body ->
handler body >>= fun { Answer.code ; body } -> handler body >>= fun { Answer.code ; body } ->
@ -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) ;