rework cors

Author: maxtori

src/common/dune

@@ -1,7 +1,7 @@
 (library
  (name ezAPI)
  (public_name ez_api)
- (modules arg param req path mime meth err security service doc url error_codes multipart ezAPI)
+ (modules misc arg param req path mime meth err security service doc url error_codes multipart ezAPI)
  (libraries lwt ezEncoding ezDebug ezLwtSys uuidm))
 
 (library

src/common/ezAPI.ml

@@ -8,6 +8,7 @@
 (*                                                                        *)
 (**************************************************************************)
 
+include Misc
 module Arg = Arg
 module Url = Url
 module Security = Security
@@ -84,7 +85,7 @@ let encode_params s params =
   let params =
     List.map (fun (param, v) ->
         if not (List.exists (fun p -> p.param_id = param.param_id) (Service.params s))
-        then Printf.kprintf warning "unknown argument %S" param.param_id;
+        then Printf.ksprintf warning "unknown argument %S" param.param_id;
         match v with
         | I n -> param.param_id, [string_of_int n]
         | S s -> param.param_id, [s]
@@ -108,36 +109,36 @@ let forge2 url s arg1 arg2 params =  forge url s ((Req.dummy, arg1), arg2) param
 let raw_service :
   type i. ?section:Doc.section -> ?name:string -> ?descr:string -> ?meth:Meth.t ->
   input:i io -> output:'o io -> ?errors:'e Err.case list -> ?params:Param.t list ->
-  ?security:'s list -> ?access_control:(string * string) list -> ?register:bool -> ?hide:bool ->
+  ?security:'s list -> ?headers:StringSet.t StringMap.t -> ?register:bool -> ?hide:bool ->
   ?input_example:i -> ?output_example:'o -> (Req.t, 'a) Path.t ->
   ('a, i, 'o, 'e, 's) service =
   fun ?section ?name ?descr ?meth ~input ~output ?(errors=[]) ?(params=[])
-    ?(security=[]) ?access_control ?register ?hide ?input_example ?output_example path ->
+    ?(security=[]) ?headers ?register ?hide ?input_example ?output_example path ->
   let meth = match meth, input with
     | None, Empty -> `GET
     | None, _ -> `POST
     | Some m, _ -> m in
   let s = Service.make ~meth ~input ~output
-      ~errors ~params ~security ?access_control path in
+      ~errors ~params ~security ?headers path in
   let doc = Doc.make ?name ?descr ?section ?input_example ?output_example ?hide ?register s in
   { s; doc }
 
 let post_service ?section ?name ?descr ?(meth=`POST)
     ~input ~output ?errors ?params
-    ?security ?register ?access_control ?input_example ?output_example
+    ?security ?register ?headers ?input_example ?output_example
     path =
   raw_service ?section ?name ?descr ~input:(Json input) ~output:(Json output)
-    ?errors ~meth ?params ?security ?access_control ?register ?input_example ?output_example path
+    ?errors ~meth ?params ?security ?headers ?register ?input_example ?output_example path
 
 let service ?section ?name ?descr ?(meth=`GET) ~output ?errors ?params
-    ?security ?access_control ?register ?output_example path =
+    ?security ?headers ?register ?output_example path =
   raw_service ?section ?name ?descr ~input:Empty ~output:(Json output)
-    ?errors ~meth ?params ?security ?access_control ?register ?output_example path
+    ?errors ~meth ?params ?security ?headers ?register ?output_example path
 
 let ws_service ?section ?name ?descr ~input ~output ?errors ?params
-    ?security ?access_control ?register ?output_example path =
+    ?security ?headers ?register ?output_example path =
   raw_service ?section ?name ?descr ~input ~output
-    ?errors ~meth:`GET ?params ?security ?access_control ?register ?output_example path
+    ?errors ~meth:`GET ?params ?security ?headers ?register ?output_example path
 
 let register service =
   Doc.register service.doc;

src/common/js/ezDebug.ml

@@ -10,5 +10,5 @@
 
 open Js_of_ocaml
 
-let printf fmt = Printf.kprintf (fun s -> Console.console##debug (Js.string s)) fmt
+let printf fmt = Printf.ksprintf (fun s -> Console.console##debug (Js.string s)) fmt
 let log s = Console.console##log (Js.string s)

src/common/meth.ml

@@ -30,7 +30,3 @@ let of_string s : [> all | `Other of string ] = match s with
   | "DELETE" -> `DELETE
   | "OPTIONS" -> `OPTIONS
   | s -> `Other s
-
-let headers l =
-  let meths = String.concat "," @@ List.map to_string l in
-  [ "access-control-allow-methods", meths ]

src/common/misc.ml

@@ -0,0 +1,2 @@
+module StringSet = Set.Make(String)
+module StringMap = Map.Make(String)

src/common/multipart.ml

@@ -1,13 +1,15 @@
+open Misc
+
 type 'content form_data = {
   fo_name: string;
   fo_content: 'content;
   fo_filename: string option;
-  fo_headers: string list Req.StringMap.t;
+  fo_headers: string list StringMap.t;
 }
 
 let make ?(headers=[]) ?filename ~name content = {
   fo_name=name; fo_content=content; fo_filename=filename;
-  fo_headers=List.fold_left (fun acc (k, v) -> Req.StringMap.add k v acc) Req.StringMap.empty headers;
+  fo_headers=List.fold_left (fun acc (k, v) -> StringMap.add k v acc) StringMap.empty headers;
 }
 
 let split sep s =
@@ -24,25 +26,25 @@ let split sep s =
 let process_header ?(debug=false) map s = match String.split_on_char ':' s with
   | [ k; v ] ->
     let k, v = String.lowercase_ascii (String.trim k), String.trim v in
-    Req.StringMap.add k (String.split_on_char ',' v) map
+    StringMap.add k (String.split_on_char ',' v) map
   | _ ->
     if debug then Format.eprintf "malformed header: %s@." s;
     map
 
 let make_form_data ?debug ?(index=0) ~headers contents =
-  let headers = List.fold_left (process_header ?debug) Req.StringMap.empty headers in
+  let headers = List.fold_left (process_header ?debug) StringMap.empty headers in
   let unquote s =
     let n = String.length s in
     if n > 1 && String.get s 0 = '"' && String.get s (n-1) = '"' then String.sub s 1 (n-2)
     else s in
   let fo_content = String.concat "\r\n" contents in
   let default = Format.sprintf "part%d" index in
-  let fo_name, fo_filename, fo_headers = match Req.StringMap.find_opt "content-disposition" headers with
+  let fo_name, fo_filename, fo_headers = match StringMap.find_opt "content-disposition" headers with
     | Some [ cd ] ->
       let _, params = Req.header_params ?debug cd in
       Option.value ~default (List.find_map (fun (k, v) -> if k="name" then Some (unquote v) else None) params),
       List.find_map (fun (k, v) -> if k="filename" then Some (unquote v) else None) params,
-      Req.StringMap.remove "content-disposition" headers
+      StringMap.remove "content-disposition" headers
     | _ -> default, None, headers in
   { fo_name; fo_filename; fo_headers; fo_content }
 
@@ -55,7 +57,7 @@ let get_boundary_from_content_type ?debug ct =
     | Some b -> Ok b
 
 let get_boundary ?debug headers =
-  match Req.StringMap.find_opt "content-type" headers with
+  match StringMap.find_opt "content-type" headers with
   | Some [ ct ] -> get_boundary_from_content_type ?debug ct
   | _ -> Error "content-type header not found"
 
@@ -98,7 +100,7 @@ let produce_form_data ~boundary b data =
   Buffer.add_string b ("content-disposition: form-data; name=\"" ^ data.fo_name ^ "\"");
   Option.iter (fun filename -> Buffer.add_string b ("; filename=\"" ^ filename ^ "\"")) data.fo_filename;
   Buffer.add_string b "\r\n";
-  Req.StringMap.iter (fun k lv ->
+  StringMap.iter (fun k lv ->
       Buffer.add_string b (k ^ ":");
       let () = match lv with
         | [] -> ()

src/common/req.ml

@@ -8,7 +8,7 @@
 (*                                                                        *)
 (**************************************************************************)
 
-module StringMap = Map.Make(String)
+open Misc
 
 type version = [ `HTTP_1_0 | `HTTP_1_1 ]
 

src/common/security.ml

@@ -8,6 +8,8 @@
 (*                                                                        *)
 (**************************************************************************)
 
+open Misc
+
 type uninhabited = |
 type none = [ `Nosecurity of uninhabited ]
 type 'a apikey = { ref_name : string; name : 'a }
@@ -44,22 +46,15 @@ let params (l : [< scheme ] list) =
       | `Header _ | `Cookie _  -> acc
     ) [] l
 
-module StringSet = Set.Make(String)
-
 let headers (sec : [< scheme ] list) =
   List.fold_left (fun headers -> function
       | `Nosecurity _ -> headers
-      | `Basic _ | `Bearer _ -> StringSet.add "Authorization" headers
+      | `Basic _ | `Bearer _ -> StringSet.add "authorization" headers
       | `Query _ -> headers
       | `Header { name; _ } -> StringSet.add name headers
-      | `Cookie _ -> StringSet.add "Cookie" headers
+      | `Cookie _ -> StringSet.add "cookie" headers
     ) StringSet.empty sec
 
-let header s =
-  match StringSet.elements s with
-  | [] -> []
-  | l -> ["access-control-allow-headers", String.concat ", " l]
-
 let make_authorization_headers ~kind s =
   [ "authorization", kind ^ " " ^ s ]
 

src/common/service.ml

@@ -51,13 +51,13 @@ type ('args, 'input, 'output, 'error, 'security) t = {
   meth : Meth.t;
   params : Param.t list;
   security: ([< Security.scheme ] as 'security) list;
-  access_control : (string * string) list
+  headers : Misc.StringSet.t Misc.StringMap.t;
 }
 
 let make =
   fun ?(meth : Meth.t =`GET) ?(params=[]) ?(security=[]) ?(errors=[])
-    ?(access_control=[]) ~input ~output path ->
-  { path ; input ; output; errors; meth; params; security; access_control }
+    ?(headers=Misc.StringMap.empty) ~input ~output path ->
+  { path ; input ; output; errors; meth; params; security; headers }
 
 let input s = s.input
 let output s = s.output
@@ -72,7 +72,7 @@ let meth s = s.meth
 let path s = s.path
 let security s = s.security
 let params s = s.params
-let access_control s = s.access_control
+let headers s = s.headers
 
 let error s ~code = Err.get ~code s.errors
 

src/common/unix/ezDebug.ml

@@ -8,5 +8,5 @@
 (*                                                                        *)
 (**************************************************************************)
 
-let printf fmt = Printf.kprintf (fun s -> Format.eprintf "%s@." s) fmt
+let printf fmt = Printf.ksprintf (fun s -> Format.eprintf "%s@." s) fmt
 let log = prerr_endline