Skip to content
Merged
Show file tree
Hide file tree
Changes from all commits
Commits
File filter

Filter by extension

Filter by extension

Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
7 changes: 5 additions & 2 deletions src/Web/Hyperbole/Data/Cookie.hs
Original file line number Diff line number Diff line change
Expand Up @@ -19,6 +19,7 @@ data Cookie = Cookie
{ key :: Key
, path :: Maybe Path
, value :: Maybe CookieValue
, secure :: Bool
}
deriving (Show, Eq)

Expand Down Expand Up @@ -60,7 +61,9 @@ toList (Cookies m) = M.elems m
render :: Path -> Cookie -> ByteString
render requestPath cookie =
let p = fromMaybe requestPath cookie.path
in cs cookie.key <> "=" <> value cookie.value <> "; SameSite=None; secure; path=" <> cs (uriToText (pathUri p))
secureFlag = if cookie.secure then "; secure" else ""
sameSite = if cookie.secure then "; SameSite=None" else "; SameSite=Lax"
in cs cookie.key <> "=" <> value cookie.value <> sameSite <> secureFlag <> "; path=" <> cs (uriToText (pathUri p))
where
value Nothing = "; expires=Thu, 01 Jan 1970 00:00:00 GMT"
value (Just (CookieValue val)) = urlEncode True $ cs val
Expand All @@ -75,4 +78,4 @@ parse kvs = do
parseValue :: ByteString -> ByteString -> Either String Cookie
parseValue k val = do
let cval = CookieValue $ cs $ urlDecode True val
pure $ Cookie (cs k) Nothing (Just $ cval)
pure $ Cookie (cs k) Nothing (Just $ cval) True
10 changes: 8 additions & 2 deletions src/Web/Hyperbole/Effect/Session.hs
Original file line number Diff line number Diff line change
Expand Up @@ -42,6 +42,12 @@ class Session a where
cookiePath = Nothing


-- | By default cookies are secure (HTTPS only). Set to False for local development or LAN usage
cookieSecure :: Bool
default cookieSecure :: Bool
cookieSecure = True


-- | Encode type to a a cookie value
toCookie :: a -> CookieValue
default toCookie :: (ToEncoded a) => a -> CookieValue
Expand Down Expand Up @@ -113,7 +119,7 @@ modifySession_ f = do
-- | Remove a single 'Session' from the browser cookies
deleteSession :: forall a es. (Session a, Hyperbole :> es) => Eff es ()
deleteSession = do
let cookie = Cookie (sessionKey @a) (cookiePath @a) Nothing
let cookie = Cookie (sessionKey @a) (cookiePath @a) Nothing (cookieSecure @a)
modifyCookies $ Cookie.insert cookie


Expand Down Expand Up @@ -158,7 +164,7 @@ requestSessionCookies = do

sessionCookie :: forall a. (Session a) => a -> Cookie
sessionCookie a =
Cookie (sessionKey @a) (cookiePath @a) (Just $ toCookie a)
Cookie (sessionKey @a) (cookiePath @a) (Just $ toCookie a) (cookieSecure @a)


-- | generic datatype name
Expand Down
21 changes: 18 additions & 3 deletions test/Test/SessionSpec.hs
Original file line number Diff line number Diff line change
Expand Up @@ -21,6 +21,12 @@ instance Session Woot where
cookiePath = Just $ Path ["somepage"]


data InsecureSession = InsecureSession Text
deriving (Generic, Show, ToEncoded, FromEncoded)
instance Session InsecureSession where
cookieSecure = False


spec :: Spec
spec = do
describe "Session" $ do
Expand All @@ -31,16 +37,20 @@ spec = do
describe "sessionCookie" $ do
it "should create cookie" $ do
let woot = Woot "hello"
sessionCookie woot `shouldBe` Cookie (sessionKey @Woot) (cookiePath @Woot) (Just (toCookie woot))
sessionCookie woot `shouldBe` Cookie (sessionKey @Woot) (cookiePath @Woot) (Just (toCookie woot)) (cookieSecure @Woot)

describe "render" $ do
it "should parse cookies" $ do
Cookie.parse [("Woot", "Woot")] `shouldBe` Right (Cookie.fromList [Cookie "Woot" Nothing (Just (CookieValue "Woot"))])
Cookie.parse [("Woot", "Woot")] `shouldBe` Right (Cookie.fromList [Cookie "Woot" Nothing (Just (CookieValue "Woot")) True])

it "should render cookie with root path" $ do
let cookie = Cookie "Woot" Nothing (Just (CookieValue "Woot"))
let cookie = Cookie "Woot" Nothing (Just (CookieValue "Woot")) True
Cookie.render [] cookie `shouldBe` "Woot=Woot; SameSite=None; secure; path=/"

it "should render non-secure cookie" $ do
let cookie = Cookie "Woot" Nothing (Just (CookieValue "Woot")) False
Cookie.render [] cookie `shouldBe` "Woot=Woot; SameSite=Lax; path=/"

it "should render complex cookie with included path" $ do
let woot = Woot "hello world"
let cookie = sessionCookie woot
Expand All @@ -58,6 +68,11 @@ spec = do
Just val <- pure $ Cookie.lookup (sessionKey @Preferences) cooks
parseCookie val `shouldBe` Right prefs

it "should create non-secure cookie when cookieSecure is False" $ do
let insecure = InsecureSession "test"
let cookie = sessionCookie insecure
cookie.secure `shouldBe` False


data Preferences = Preferences
{ message :: Text
Expand Down
Loading