Cookie support

hernoufM · hernoufM · commit 6f86823d28b4 · 2023-01-12T18:39:32.000+01:00
diff --git a/.ocamlformat b/.ocamlformat
@@ -0,0 +1,6 @@
+profile = ocamlformat
+break-cases = fit
+margin = 77
+parse-docstrings = true
+wrap-comments = true
+line-endings = lf
diff --git a/src/common/ezAPI.ml b/src/common/ezAPI.ml
@@ -94,38 +94,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;
diff --git a/src/common/security.ml b/src/common/security.ml
@@ -6,7 +6,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
@@ -22,7 +23,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
 
diff --git a/src/common/service.ml b/src/common/service.ml
@@ -41,10 +41,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
@@ -59,5 +62,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
diff --git a/src/server/cohttp/ezAPIServerCohttp.ml b/src/server/cohttp/ezAPIServerCohttp.ml
@@ -70,12 +70,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;
diff --git a/src/server/directory.ml b/src/server/directory.ml
@@ -105,6 +105,7 @@ let rec resolve :
       | Error msg -> Lwt.return_error @@
         `Cannot_parse (arg.Arg.description, msg, name :: prefix)
 
+(* 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
@@ -119,15 +120,18 @@ fun ~code ~headers io body ->
      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; headers} = match body with
-    | Ok o -> io_to_answer ~code ~headers 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
@@ -177,11 +181,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) ->
@@ -190,7 +198,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
diff --git a/src/server/ezAPIServerUtils.ml b/src/server/ezAPIServerUtils.ml
@@ -139,6 +139,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
diff --git a/src/server/ezOpenAPI.ml b/src/server/ezOpenAPI.ml
@@ -470,7 +470,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")
diff --git a/src/server/httpaf/ezAPIServerHttpAf.ml b/src/server/httpaf/ezAPIServerHttpAf.ml
@@ -256,7 +256,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 "";
@@ -266,7 +266,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
diff --git a/src/session/ezCookieServer.cohttp.ml b/src/session/ezCookieServer.cohttp.ml
@@ -14,6 +14,8 @@ open EzAPIServerUtils
 let cookie_re = Re.Str.regexp "[;,][ \t]*"
 let equals_re = Re.Str.regexp_string "="
 
+let day_in_seconds = 86400L
+
 let get ( req : Req.t ) =
   List.fold_left
     (fun acc header ->
@@ -30,13 +32,21 @@ let get ( req : Req.t ) =
       List.fold_left split_pair acc cookies
     ) StringMap.empty (StringMap.find "cookie" req.Req.req_headers)
 
-let set ?secure ?http_only ?expiration (req : Req.t) ~name ~value =
-  let version = req.Req.req_version in
-  Cohttp.Cookie.Set_cookie_hdr.serialize ~version @@
-  Cohttp.Cookie.Set_cookie_hdr.make ?expiration ?secure ?http_only (name, value)
+(* TODO: Find a proper way to do that, Cohttp lib doesn't provide valid header when trying to clear header *)
+let set ?secure ?http_only ~expiration ~name ~value () =
+ ignore secure;
+ ignore http_only;
+ "Set-Cookie", Printf.sprintf "%s=%s; Max-Age=%s" name value (Int64.to_string expiration)
+  (* Cohttp.Cookie.Set_cookie_hdr.serialize ~version:`HTTP_1_0 @@
+  Cohttp.Cookie.Set_cookie_hdr.make ~expiration ?secure ?http_only (name, value) *)
 
-let clear req ~name =
-  set req ~name ~value:"" ~expiration:(`Max_age 0L)
+let clear ~name () =
+  set ~name ~value:"" ~expiration:0L ()
 
-let set ?secure ?http_only req ~name ~value =
-  set ?secure ?http_only req ~name ~value
+let set ?secure ?http_only ?expiration ~name ~value =
+  let expiration = 
+    match expiration with
+    | Some exp -> exp
+    | None -> day_in_seconds
+  in
+  set ?secure ?http_only ~name ~value ~expiration 
diff --git a/src/session/ezCookieServer.dummy.ml b/src/session/ezCookieServer.dummy.ml
@@ -4,8 +4,8 @@ let get ( _req : Req.t ) =
   Format.eprintf "Dummy implementation of cookie server, to install:\n`opam install cohttp`@.";
   StringMap.empty
 
-let set ?secure:_ ?http_only:_ (_req : Req.t) ~name ~value =
+let set ?secure:_ ?http_only:_ ?expiration:_ ~name ~value () =
   Format.eprintf "Dummy implementation of cookie server, to install:\n`opam install cohttp`@.";
   (name, value)
 
-let clear _req ~name = (name, "")
+let clear ~name () = (name, "")
diff --git a/src/session/ezCookieServer.mli b/src/session/ezCookieServer.mli
@@ -5,11 +5,12 @@ val get : Req.t -> string StringMap.t
 
 (** Discards cookie in the 'Set-Cookie' header by setting its value to empty string and
 its max-age to 0*)
-val clear : Req.t -> name:string -> (string * string)
+val clear : name:string -> unit -> (string * string)
 
 (** Creates 'Set-Cokie' header with cookie whose name, value and some parameters are
 specified. *)
 val set :
   ?secure:bool ->
   ?http_only:bool ->
-  Req.t -> name:string -> value:string -> (string * string)
+  ?expiration:int64 ->
+  name:string -> value:string -> unit -> (string * string)
diff --git a/src/session/ezSession.ml b/src/session/ezSession.ml
@@ -33,6 +33,9 @@ module TYPES = struct
     (** Associated to user information *)
     type user_info
 
+    (** Web host, that should be used in access control headers. *)
+    val web_host : string 
+
     (** Json encoding for user's id *)
     val user_id_encoding : user_id Json_encoding.encoding
     
@@ -49,10 +52,10 @@ module TYPES = struct
   (`CSRF "X-Csrf-Token" `).
      *)
 
-    (** Describes two ways to store a token within a client request: 
-    - Store as a cookie associated with the given cookie name. 
-    - Store as a CSRF header with the given name. *)
-    val token_kind : [`Cookie of string | `CSRF of string ]
+    (** Describes two ways to store a token within a client request : 
+    - Stores as a cookie associated with the given cookie name and its max-age, if provided. 
+    - Stores as a CSRF header with the given name. *)
+    val token_kind : [`Cookie of string * int64 option | `CSRF of string ]
   end
 
   (** Authentification information returned by server after successful connection *)
@@ -351,8 +354,8 @@ module Make(S : SessionArg) = struct
       match S.token_kind with
       | `CSRF name ->
         EzAPI.(`Header { Security.ref_name = name ^ " Header"; name })
-      | `Cookie name ->
-        EzAPI.(`Cookie { Security.ref_name = name ^ " Cookie"; name })
+      | `Cookie (name, max_age) ->
+        EzAPI.(`Cookie ({ Security.ref_name = name ^ " Cookie"; name }, max_age))
 
     (** Security that combines [param_security] and [header_cookie_security]
         in the corresponding order. Represents the security configuration for
@@ -369,6 +372,11 @@ module Make(S : SessionArg) = struct
            EzAPI.Path.( path // s )
         ) EzAPI.Path.root S.rpc_path
 
+    let access_control = 
+      [ "access-control-allow-credentials", "true"; 
+        "access-control-allow-origin", S.web_host ]
+
+
     (** Connection service that requires authentication token. For more details, see corresponding 
     [EzSessionServer.Make.connect] handler and default client request implementation 
     [EzSessionClient.Make.connect]. *)
@@ -379,6 +387,7 @@ module Make(S : SessionArg) = struct
         ~output:Encoding.connect_response
         ~errors:[Encoding.session_expired_case; Encoding.invalid_session_connect_case]
         ~security
+        ~access_control
         EzAPI.Path.(rpc_root // "connect")
 
     (** Logining service. For more details, see corresponding [EzSessionServer.Make.login] handler
@@ -394,6 +403,7 @@ module Make(S : SessionArg) = struct
                  Encoding.unverified_user_case;
                  Encoding.challenge_not_found_case;
                  Encoding.invalid_session_login_case]
+        ~access_control
         EzAPI.Path.(rpc_root // "login")
 
     (** Disconnection service that requires authentication token. For more details, see corresponding 
@@ -407,6 +417,7 @@ module Make(S : SessionArg) = struct
         ~output:Encoding.auth_needed
         ~errors:[Encoding.invalid_session_logout_case]
         ~security
+        ~access_control
         EzAPI.Path.(rpc_root // "logout")
   end
 
diff --git a/src/session/ezSessionClient.ml b/src/session/ezSessionClient.ml
diff --git a/src/session/ezSessionClient.mli b/src/session/ezSessionClient.mli
diff --git a/src/session/ezSessionServer.ml b/src/session/ezSessionServer.ml
diff --git a/test/session/client.js b/test/session/client.js
diff --git a/test/session/server.exe b/test/session/server.exe
