Merge pull request #634 from JacobChang/cookie-samesite

Support samesite flag of cookie

Author: Henrik Feldt

src/Suave.Tests/Cookie.fs

@@ -24,7 +24,36 @@ let parseResultCookie (_:SuaveConfig) =
           path      = Some "/"
           domain    = None
           secure    = false
-          httpOnly = true }
+          httpOnly  = true
+          sameSite  = None }
+      Expect.equal subject expected "cookie should eq"
+
+    testCase "parse SameSite=Strict" <| fun _ ->
+      let sample = @"st=oFqpYxbMObHvpEW!QLzedHwSZ1gZnotBs$; Path=/; HttpOnly; SameSite=Strict"
+      let subject = Cookie.parseResultCookie sample
+      let expected =
+        { name      = "st"
+          value     = "oFqpYxbMObHvpEW!QLzedHwSZ1gZnotBs$"
+          expires   = None
+          path      = Some "/"
+          domain    = None
+          secure    = false
+          httpOnly  = true
+          sameSite  = Some Strict }
+      Expect.equal subject expected "cookie should eq"
+
+    testCase "parse SameSite=Lax" <| fun _ ->
+      let sample = @"st=oFqpYxbMObHvpEW!QLzedHwSZ1gZnotBs$; Path=/; HttpOnly; SameSite=Lax"
+      let subject = Cookie.parseResultCookie sample
+      let expected =
+        { name      = "st"
+          value     = "oFqpYxbMObHvpEW!QLzedHwSZ1gZnotBs$"
+          expires   = None
+          path      = Some "/"
+          domain    = None
+          secure    = false
+          httpOnly  = true
+          sameSite  = Some Lax }
       Expect.equal subject expected "cookie should eq"
 
     testCase "parse secure" <| fun _ ->
@@ -35,7 +64,8 @@ let parseResultCookie (_:SuaveConfig) =
           path      = Some "/"
           domain    = None
           secure    = true
-          httpOnly = false }
+          httpOnly  = false
+          sameSite  = None }
       let parsed = Cookie.parseResultCookie (HttpCookie.toHeader cookie)
       Expect.equal parsed cookie "eq"
 
@@ -87,7 +117,8 @@ let setCookie (_ : SuaveConfig) =
           path      = Some "/"
           domain    = None
           secure    = true
-          httpOnly  = false }
+          httpOnly  = false
+          sameSite  = None }
       let ctx = Cookie.setCookie cookie { HttpContext.empty with runtime = { HttpRuntime.empty with logger = log }}
       Expect.isTrue (List.isEmpty log.logs) "Should be no logs generated"
     testCase "set cookie - no warning when = 4k" <| fun _ ->
@@ -99,7 +130,8 @@ let setCookie (_ : SuaveConfig) =
           path      = Some "/"
           domain    = None
           secure    = true
-          httpOnly  = false }
+          httpOnly  = false
+          sameSite  = None }
       let ctx = Cookie.setCookie cookie { HttpContext.empty with runtime = { HttpRuntime.empty with logger = log }}
       Expect.isTrue (List.isEmpty log.logs) "Should be no logs generated"
 
@@ -112,7 +144,8 @@ let setCookie (_ : SuaveConfig) =
           path      = Some "/"
           domain    = None
           secure    = true
-          httpOnly  = false }
+          httpOnly  = false
+          sameSite  = None }
       let ctx =
         let input = { HttpContext.empty with runtime = { HttpRuntime.empty with logger = log }}
         Cookie.setCookie cookie input |> Async.RunSynchronously

src/Suave.Tests/HttpWriters.fs

@@ -27,7 +27,8 @@ let cookies cfg =
       domain   = None
       path     = Some "/"
       httpOnly = false
-      secure   = false }
+      secure   = false
+      sameSite = None }
 
   let ip, port =
     let binding = SuaveConfig.firstBinding cfg

src/Suave/Cookie.fs

@@ -40,6 +40,11 @@ module Cookie =
   let parseResultCookie (s : string) : HttpCookie =
     let parseExpires (str : string) =
       DateTimeOffset.ParseExact(str, "R", CultureInfo.InvariantCulture)
+    let parseSameSite (str : string) =
+      match str with
+      | "Strict" -> Some Strict
+      | "Lax" -> Some Lax
+      | _ -> None
     s.Split(';')
     |> Array.map (fun (x : string) ->
         let parts = x.Split('=')
@@ -55,6 +60,7 @@ module Cookie =
         | "Expires", expires        -> iter + 1, { cookie with expires = Some (parseExpires expires) }
         | "HttpOnly", _             -> iter + 1, { cookie with httpOnly = true }
         | "Secure", _               -> iter + 1, { cookie with secure = true }
+        | "SameSite", sameSite      -> iter + 1, { cookie with sameSite = parseSameSite sameSite}
         | _                         -> iter + 1, cookie)
         (0, { HttpCookie.empty with httpOnly = false }) // default when parsing
     |> snd

src/Suave/Http.fs

@@ -216,14 +216,19 @@ module Http =
         |> Array.map (fun case -> case.Name, FSharpValue.MakeUnion(case, [||]) :?> HttpCode)
         |> Map.ofArray
 
+  type SameSite =
+      | Strict
+      | Lax
+
   type HttpCookie =
     { name     : string
       value    : string
       expires  : DateTimeOffset option
       path     : string option
       domain   : string option
       secure   : bool
-      httpOnly : bool }
+      httpOnly : bool
+      sameSite : SameSite option }
 
     static member name_     = (fun x -> x.name),    fun v (x : HttpCookie) -> { x with name = v }
     static member value_    = (fun x -> x.value), fun v (x : HttpCookie) -> { x with value = v }
@@ -232,18 +237,20 @@ module Http =
     static member domain_   = (fun x -> x.domain), fun v x -> { x with domain = v }
     static member secure_   = (fun x -> x.secure), fun v x -> { x with secure = v }
     static member httpOnly_ = (fun x -> x.httpOnly), fun v x -> { x with httpOnly = v }
+    static member sameSite_ = (fun x -> x.sameSite), fun v x -> { x with sameSite = v }
 
   [<CompilationRepresentation(CompilationRepresentationFlags.ModuleSuffix)>]
   module HttpCookie =
 
-    let create name value expires path domain secure httpOnly =
+    let create name value expires path domain secure httpOnly sameSite =
       { name      = name
         value     = value
         expires   = expires
         path      = path
         domain    = domain
         secure    = secure
-        httpOnly = httpOnly }
+        httpOnly = httpOnly
+        sameSite = sameSite }
 
 
     let createKV name value =
@@ -253,7 +260,8 @@ module Http =
         path      = Some "/"
         domain    = None
         secure    = false
-        httpOnly = true }
+        httpOnly = true
+        sameSite = None }
 
     let empty = createKV "" ""
 
@@ -267,6 +275,12 @@ module Http =
       x.expires |> appkv "Expires" (fun (i : DateTimeOffset) -> i.ToString("R"))
       if x.httpOnly then app "HttpOnly"
       if x.secure    then app "Secure"
+      match x.sameSite with
+      | None -> ()
+      | Some(sameSite) ->
+        match sameSite with
+        | Strict ->  Some "Strict" |> appkv "SameSite" id
+        | Lax -> Some "Lax" |> appkv "SameSite" id
       sb.ToString ()
 
   type MimeType =

src/Suave/Http.fsi

@@ -60,6 +60,10 @@ module Http =
 
     static member tryParse : code:int -> Choice<HttpCode, string>
 
+  type SameSite =
+    | Strict
+    | Lax
+
   /// HTTP cookie
   type HttpCookie =
     { name     : string
@@ -71,7 +75,8 @@ module Http =
       /// This cookie is not forwarded over plaintext transports
       secure   : bool
       /// This cookie is not readable from JavaScript
-      httpOnly : bool }
+      httpOnly : bool
+      sameSite : SameSite option }
 
     static member name_ : Property<HttpCookie, string>
     static member value_ : Property<HttpCookie, string>
@@ -80,6 +85,7 @@ module Http =
     static member domain_ : Property<HttpCookie, string option>
     static member secure_ : Property<HttpCookie, bool>
     static member httpOnly_ : Property<HttpCookie, bool>
+    static member sameSite_ : Property<HttpCookie, SameSite option>
 
   [<CompilationRepresentation(CompilationRepresentationFlags.ModuleSuffix)>]
   module HttpCookie =
@@ -88,6 +94,7 @@ module Http =
     val create : name:string -> value:string -> expires:DateTimeOffset option
                -> path:string option -> domain:string option -> secure:bool
                -> httpOnly:bool
+               -> sameSite:SameSite option
                -> HttpCookie
 
     /// Create a new cookie with the given name, value, and defaults: