1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
|
{-# LANGUAGE TypeFamilies, QuasiQuotes, TemplateHaskell, MultiParamTypeClasses, OverloadedStrings #-}
module YesodCoreTest.Ssl ( sslOnlySpec, unsecSpec, sameSiteSpec ) where
import qualified YesodCoreTest.StubSslOnly as Ssl
import qualified YesodCoreTest.StubLaxSameSite as LaxSameSite
import qualified YesodCoreTest.StubStrictSameSite as StrictSameSite
import qualified YesodCoreTest.StubUnsecured as Unsecured
import Yesod.Core
import Test.Hspec
import Network.Wai
import Network.Wai.Test
import qualified Data.ByteString.Char8 as C8
import qualified Web.Cookie as Cookie
import qualified Data.List as DL
type CookieSpec = Cookie.SetCookie -> Bool
type ResponseExpectation = SResponse -> Session ()
homeFixtureFor :: YesodDispatch a => a -> ResponseExpectation -> IO ()
homeFixtureFor app assertion = do
wa <- toWaiApp app
runSession (getHome >>= assertion) wa
where
getHome = request defaultRequest
cookieShouldSatisfy :: String -> CookieSpec -> ResponseExpectation
cookieShouldSatisfy name spec response =
liftIO $
case DL.filter matchesName $ cookiesIn response of
[] -> expectationFailure $ DL.concat
[ "Expected a cookie named "
, name
, " but none is set"
]
[c] -> c `shouldSatisfy` spec
_ -> expectationFailure $ DL.concat
[ "Expected one cookie named "
, name
, " but found more than one"
]
where
matchesName c = (Cookie.setCookieName c) == C8.pack name
cookiesIn r =
DL.map
(Cookie.parseSetCookie . snd)
(DL.filter (("Set-Cookie"==) . fst) $ simpleHeaders r)
sslOnlySpec :: Spec
sslOnlySpec = describe "A Yesod application with sslOnly on" $ do
it "serves a Strict-Transport-Security header in all responses" $
atHome $ assertHeader "Strict-Transport-Security"
"max-age=7200; includeSubDomains"
it "sets the Secure flag on its session cookie" $
atHome $ "_SESSION" `cookieShouldSatisfy` Cookie.setCookieSecure
where
atHome = homeFixtureFor Ssl.App
unsecSpec :: Spec
unsecSpec = describe "A Yesod application with sslOnly off" $ do
it "never serves a Strict-Transport-Security header" $ do
atHome $ assertNoHeader "Strict-Transport-Security"
it "does not set the Secure flag on its session cookie" $ do
atHome $ "_SESSION" `cookieShouldSatisfy` isNotSecure
where
atHome = homeFixtureFor Unsecured.App
isNotSecure c = not $ Cookie.setCookieSecure c
sameSiteSpec :: Spec
sameSiteSpec = describe "A Yesod application" $ do
it "can set a Lax SameSite option" $
laxHome $ "_SESSION" `cookieShouldSatisfy` isLax
it "can set a Strict SameSite option" $
strictHome $ "_SESSION" `cookieShouldSatisfy` isStrict
where
laxHome = homeFixtureFor LaxSameSite.App
strictHome = homeFixtureFor StrictSameSite.App
isLax = (== Just Cookie.sameSiteLax) . Cookie.setCookieSameSite
isStrict = (== Just Cookie.sameSiteStrict) . Cookie.setCookieSameSite
|
