1{-# LANGUAGE OverloadedStrings, TemplateHaskell, QuasiQuotes,
2  TypeFamilies, MultiParamTypeClasses, ViewPatterns #-}
3
4module YesodCoreTest.Header
5  ( headerTest
6  , Widget
7  , resourcesApp
8  ) where
9
10import Data.Text (Text)
11import Network.HTTP.Types (decodePathSegments)
12import Network.Wai
13import Network.Wai.Test
14import Test.Hspec
15import Yesod.Core
16
17data App =
18  App
19
20mkYesod
21  "App"
22  [parseRoutes|
23/header1 Header1R GET
24/header2 Header2R GET
25/header3 Header3R GET
26|]
27
28instance Yesod App
29
30getHeader1R :: Handler RepPlain
31getHeader1R = do
32  addHeader "hello" "world"
33  return $ RepPlain $ toContent ("header test" :: Text)
34
35getHeader2R :: Handler RepPlain
36getHeader2R = do
37  addHeader "hello" "world"
38  replaceOrAddHeader "hello" "sibi"
39  return $ RepPlain $ toContent ("header test" :: Text)
40
41getHeader3R :: Handler RepPlain
42getHeader3R = do
43  addHeader "hello" "world"
44  addHeader "michael" "snoyman"
45  addHeader "yesod" "framework"
46  replaceOrAddHeader "yesod" "book"
47  return $ RepPlain $ toContent ("header test" :: Text)
48
49runner :: Session () -> IO ()
50runner f = toWaiApp App >>= runSession f
51
52addHeaderTest :: IO ()
53addHeaderTest =
54  runner $ do
55    res <- request defaultRequest {pathInfo = decodePathSegments "/header1"}
56    assertHeader "hello" "world" res
57
58multipleHeaderTest :: IO ()
59multipleHeaderTest =
60  runner $ do
61    res <- request defaultRequest {pathInfo = decodePathSegments "/header2"}
62    assertHeader "hello" "sibi" res
63
64header3Test :: IO ()
65header3Test = do
66  runner $ do
67    res <- request defaultRequest {pathInfo = decodePathSegments "/header3"}
68    assertHeader "hello" "world" res
69    assertHeader "michael" "snoyman" res
70    assertHeader "yesod" "book" res
71
72xssHeaderTest :: IO ()
73xssHeaderTest = do
74  runner $ do
75    res <- request defaultRequest {pathInfo = decodePathSegments "/header1"}
76    assertHeader "X-XSS-Protection" "1; mode=block" res
77
78headerTest :: Spec
79headerTest =
80  describe "Test.Header" $ do
81    it "addHeader" addHeaderTest
82    it "multiple header" multipleHeaderTest
83    it "persist headers" header3Test
84    it "has X-XSS-Protection: 1; mode=block" xssHeaderTest
85