79 lines
3.0 KiB
Haskell
79 lines
3.0 KiB
Haskell
{-# 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
|