Resto: fix CORS

CORS also requires to send the "Access-Control-Allow-Origin" header on
direct requests or requests following preflight requests.
This commit is contained in:
Vincent Bernardoff 2018-04-29 01:00:00 +02:00 committed by Grégoire Henry
parent 049efb2169
commit 76bf25646c
3 changed files with 16 additions and 8 deletions

View File

@ -36,15 +36,18 @@ let find_matching_origin allowed_origins origin =
| [] -> None | [] -> None
| x :: _ -> Some x | x :: _ -> Some x
let add_allow_origin headers cors origin_header =
match origin_header with
| None -> headers
| Some origin ->
match find_matching_origin cors.allowed_origins origin with
| None -> headers
| Some allowed_origin ->
Cohttp.Header.add headers
"Access-Control-Allow-Origin" allowed_origin
let add_headers headers cors origin_header = let add_headers headers cors origin_header =
let cors_headers = let cors_headers =
Cohttp.Header.add_multi headers Cohttp.Header.add_multi headers
"Access-Control-Allow-Headers" cors.allowed_headers in "Access-Control-Allow-Headers" cors.allowed_headers in
match origin_header with add_allow_origin cors_headers cors origin_header
| 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]

View File

@ -14,6 +14,9 @@ type t = {
val default: t val default: t
val add_allow_origin:
Cohttp.Header.t -> t -> string option -> Cohttp.Header.t
val add_headers: val add_headers:
Cohttp.Header.t -> t -> string option -> Cohttp.Header.t Cohttp.Header.t -> t -> string option -> Cohttp.Header.t

View File

@ -131,6 +131,8 @@ module Make (Encoding : Resto.ENCODING)(Log : LOGGING) = struct
let headers = Header.init () in let headers = Header.init () in
let headers = let headers =
Header.add headers "content-type" output_content_type in Header.add headers "content-type" output_content_type in
let headers = Cors.add_allow_origin
headers server.cors (Header.get req_headers "origin") in
begin begin
match s.types.input with match s.types.input with
| Service.No_input -> | Service.No_input ->