Merge pull request #114 from hernoufM/cookies

Cookies

Author: hernoufM

.gitignore

@@ -4,3 +4,6 @@ _local
 *~
 *.merlin
 *.install
+*.exe
+.ocamlformat
+test/session/*.js

Makefile

@@ -16,3 +16,8 @@ clean:
 doc:
 	@dune build @doc
 	@rsync -ru _build/default/_doc/_html/* docs/
+
+build-tests:
+	@opam install ocurl websocket-lwt-unix js_of_ocaml
+	@dune build test
+	

src/common/ezAPI.ml

@@ -104,38 +104,40 @@ let forge0 url s params = forge url s Req.dummy params
 let forge1 url s arg1 params =  forge url s (Req.dummy, arg1) params
 let forge2 url s arg1 arg2 params =  forge url s ((Req.dummy, arg1), arg2) params
 
+(* access_control allows to set acces control that will be included in server response headers. *)
 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 -> ?register:bool -> ?input_example:i ->
-  ?output_example:'o -> (Req.t, 'a) Path.t -> ('a, i, 'o, 'e, 's) service =
+  ?security:'s list -> ?access_control:(string * string) list -> ?register: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=[]) ?register ?input_example ?output_example path ->
+    ?(security=[]) ?access_control ?register ?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 path in
+      ~errors ~params ~security ?access_control path in
   let doc = Doc.make ?name ?descr ?register ?section ?input_example ?output_example s in
   { s; doc }
 
 let post_service ?section ?name ?descr ?(meth=`POST)
     ~input ~output ?errors ?params
-    ?security ?register ?input_example ?output_example
+    ?security ?register ?access_control ?input_example ?output_example
     path =
   raw_service ?section ?name ?descr ~input:(Json input) ~output:(Json output)
-    ?errors ~meth ?params ?security ?register ?input_example ?output_example path
+    ?errors ~meth ?params ?security ?access_control ?register ?input_example ?output_example path
 
 let service ?section ?name ?descr ?(meth=`GET) ~output ?errors ?params
-    ?security ?register ?output_example path =
+    ?security ?access_control ?register ?output_example path =
   raw_service ?section ?name ?descr ~input:Empty ~output:(Json output)
-    ?errors ~meth ?params ?security ?register ?output_example path
+    ?errors ~meth ?params ?security ?access_control ?register ?output_example path
 
 let ws_service ?section ?name ?descr ~input ~output ?errors ?params
-    ?security ?register ?output_example path =
+    ?security ?access_control ?register ?output_example path =
   raw_service ?section ?name ?descr ~input ~output
-    ?errors ~meth:`GET ?params ?security ?register ?output_example path
+    ?errors ~meth:`GET ?params ?security ?access_control ?register ?output_example path
 
 let register service =
   service.doc.Doc.doc_registered <- true;

src/common/security.ml

@@ -16,7 +16,8 @@ type basic_desc = { basic_name : string }
 type bearer = [ `Bearer of bearer_desc ]
 type basic = [ `Basic of basic_desc ]
 type header = [ `Header of string apikey ]
-type cookie = [ `Cookie of string apikey ]
+(* cookie name * max age atribute (defaults to 1 day) *)
+type cookie = [ `Cookie of string apikey * int64 option ]
 type query = [ `Query of Param.t apikey ]
 type scheme = [
   | none
@@ -32,7 +33,7 @@ let ref_name = function
   | `Nosecurity u -> unreachable u
   | `Basic { basic_name = ref_name }
   | `Bearer { bearer_name = ref_name; format=_  }
-  | `Cookie { ref_name; name=_ }
+  | `Cookie ({ ref_name; name=_ }, _ )
   | `Header { ref_name; name=_ }
   | `Query { ref_name; name=_ } -> ref_name
 

src/common/service.ml

@@ -51,10 +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
 }
 
-let make ?(meth : Meth.t =`GET) ?(params=[]) ?(security=[]) ?(errors=[]) ~input ~output path =
-  { path ; input ; output; errors; meth; params; security }
+let make =
+  fun ?(meth : Meth.t =`GET) ?(params=[]) ?(security=[]) ?(errors=[]) 
+    ?(access_control=[]) ~input ~output path ->
+  { path ; input ; output; errors; meth; params; security; access_control }
 
 let input s = s.input
 let output s = s.output
@@ -69,5 +72,6 @@ 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 error s ~code = Err.get ~code s.errors

src/server/cohttp/ezAPIServerCohttp.ml

@@ -80,12 +80,12 @@ let dispatch ?catch s io req body =
   >>= function
   | `ws (Ok ra) -> Lwt.return ra
   | `ws (Error _) ->
-    let headers = Header.of_list access_control_headers in
+    let headers = Header.of_list default_access_control_headers in
     let status = Code.status_of_code 501 in
     Server.respond_string ~headers ~status ~body:"" () >|= fun (r, b) ->
     `Response (r, b)
   | `http {Answer.code; body; headers} ->
-    let headers = headers @ access_control_headers in
+    let headers = merge_headers_with_default headers in
     let status = Code.status_of_code code in
     debug ~v:(if code >= 200 && code < 300 then 1 else 0) "Reply computed to %S: %d" path_str code;
     debug ~v:3 "Reply content:\n  %s" body;

src/server/directory.ml

@@ -92,7 +92,8 @@ let rec resolve :
   (resolved_directory, lookup_error) result Lwt.t =
   fun prefix dir args path ->
   match path, dir with
-  | [], dir -> Lwt.return_ok (Dir (dir, args))
+  | [], dir -> 
+    Lwt.return_ok (Dir (dir, args))
   | _name :: _path, { subdirs = None, None; _ } -> Lwt.return_error `Not_found
   | name :: path, { subdirs = Some static, None; _ } ->
     begin match StringMap.find_opt name static with
@@ -114,28 +115,33 @@ let rec resolve :
       | Error msg -> Lwt.return_error @@
         `Cannot_parse (arg.Arg.description, msg, name :: prefix)
 
-let io_to_answer : type a. code:int -> a io -> a -> string Answer.t = fun ~code io body ->
+(* Note : headers are merged with predefined headers *)
+let io_to_answer : type a. code:int -> headers:(string * string) list -> a io -> a -> string Answer.t = 
+fun ~code ~headers io body ->
   match io with
-  | Empty -> {Answer.code; body=""; headers=[]}
+  | Empty -> {Answer.code; body=""; headers}
   | Raw l ->
     let content_type = match l with
       | [] -> "application/octet-stream"
       | h :: _ -> Mime.to_string h in
-    {Answer.code; body; headers=["content-type", content_type]}
+    {Answer.code; body; headers=("content-type", content_type)::headers}
   | Json enc ->
     {Answer.code; body = EzEncoding.construct enc body;
-     headers=["content-type", "application/json"]}
+     headers=("content-type", "application/json")::headers}
 
 let ser_handler :
-  type i o e. ?content_type:string -> ('a -> i -> (o, e) result Answer.t Lwt.t) -> 'a ->
+  type i o e. ?content_type:string -> access_control:(string * string) list 
+  -> ('a -> i -> (o, e) result Answer.t Lwt.t) -> 'a ->
   i io -> o io -> e Json_encoding.encoding ->
   string -> (string Answer.t, handler_error) result Lwt.t =
-  fun ?content_type handler args input output errors ->
-  let handle_result {Answer.code; body; _} = match body with
-    | Ok o -> io_to_answer ~code output o
+  fun ?content_type ~access_control handler args input output errors ->
+  let handle_result {Answer.code; body; headers} = 
+    match body with
+    | Ok o -> io_to_answer ~code ~headers:(headers @ access_control) output o
     | Error e ->
       {Answer.code; body = EzEncoding.construct errors e;
-       headers=["content-type", "application/json"]} in
+       headers=("content-type", "application/json")::access_control } 
+  in
   match input with
   | Empty -> (fun _ ->
       Lwt.catch
@@ -185,11 +191,15 @@ let lookup ?meth ?content_type dir r path : (lookup_ok, lookup_error) result Lwt
       begin match MethMap.bindings dir.services with
         | [] -> Lwt.return_error `Not_found
         | l ->
+          (* Todo : combine access control headers correctly. *)
+          let access_control = List.fold_left (fun acc (_,rs) -> match rs with
+              | Http {service; _} when acc = [] -> Service.access_control service
+              | _ -> acc) [] l in 
           let meths = Meth.headers @@ List.map fst l in
           let sec_set = List.fold_left (fun acc (_, rs) -> match rs with
               | Http {service; _} -> Security.StringSet.union acc (Security.headers (Service.security service))
               | Websocket _ -> acc) Security.StringSet.empty l in
-          Lwt.return_ok @@ `options (meths @ (Security.header sec_set))
+          Lwt.return_ok @@ `options (access_control @ meths @ (Security.header sec_set))
       end
     | Some `HEAD -> Lwt.return_ok `head
     | Some (#Meth.t as m) ->
@@ -198,7 +208,8 @@ let lookup ?meth ?content_type dir r path : (lookup_ok, lookup_error) result Lwt
         let input = Service.input service in
         let output = Service.output service in
         let errors = Service.errors_encoding service in
-        let h = ser_handler ?content_type handler args input output errors in
+        let access_control = Service.access_control service in
+        let h = ser_handler ?content_type ~access_control handler args input output errors in
         Lwt.return_ok @@ `http h
       | `GET, Some (Websocket {service; react; bg; onclose; step}) ->
         let input = Service.input service in

src/server/ezAPIServerUtils.ml

@@ -149,6 +149,30 @@ let handle ?meth ?content_type ?ws s r path body =
         | Some ws -> ws ?onclose ?step ~react ~bg r.Req.req_id
       end >|= fun ra -> `ws ra
 
-let access_control_headers = [
+(* Default access control headers *)
+let default_access_control_headers = [
   "access-control-allow-origin", "*";
-  "access-control-allow-headers", "accept, content-type" ]
+  "access-control-allow-headers", "accept, content-type" 
+]
+
+(* merge headers correctly with default one *)
+let merge_headers_with_default headers : (string * string) list =
+  (* combining existing headers *)
+  let l = List.fold_left
+      (fun acc ((hn,hv) as h) ->
+         match List.assoc_opt hn default_access_control_headers with
+         | None -> h::acc
+         | Some _ when hn = "access-control-allow-origin" ->
+           h::acc
+         | Some v when hn = "access-control-allow-headers" ->
+           (hn, hv ^ "," ^ v)::acc 
+         | _ -> acc)
+      []
+      headers
+  in
+  (* Adding default if not present *)
+  List.fold_left (fun acc ((hn,_) as h) ->
+      match List.assoc_opt hn l with
+      | None -> h::acc
+      | _ -> acc    
+    ) l default_access_control_headers

src/server/ezOpenAPI.ml

@@ -480,7 +480,7 @@ module Encoding = struct
       Some (bearer_name, Makers.mk_security_scheme ?format ~scheme:"bearer" "http")
     | `Header { EzAPI.Security.ref_name; name } ->
       Some (ref_name, Makers.mk_security_scheme ~loc:"header" ~name "apiKey")
-    | `Cookie { EzAPI.Security.ref_name; name } ->
+    | `Cookie ({ EzAPI.Security.ref_name; name }, _ ) ->
       Some (ref_name, Makers.mk_security_scheme ~loc:"cookie" ~name "apiKey")
     | `Query { EzAPI.Security.ref_name; name } ->
       Some (ref_name, Makers.mk_security_scheme ~loc:"query" ~name:name.EzAPI.Param.param_id "apiKey")

src/server/httpaf/ezAPIServerHttpAf.ml

@@ -266,7 +266,7 @@ let connection_handler :
          | Some c -> c path_str exn >|= fun a -> `http a)
     >>= function
     | `ws (Error _) ->
-      let headers = Headers.of_list access_control_headers in
+      let headers = Headers.of_list default_access_control_headers in
       let status = Status.unsafe_of_code 501 in
       let response = Response.create ~headers status in
       Reqd.respond_with_string reqd response "";
@@ -276,7 +276,7 @@ let connection_handler :
     | `http {Answer.code; body; headers} ->
       let status = Status.unsafe_of_code code in
       debug ~v:(if code = 200 then 1 else 0) "Reply computed to %S: %d" path_str code;
-      let headers = headers @ access_control_headers in
+      let headers = merge_headers_with_default headers in
       let headers = Headers.of_list headers in
       let len = String.length body in
       let headers = Headers.add headers "content-length" (string_of_int len) in