{-# 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
