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
79
80
81
82
83
84
|
{-# LANGUAGE OverloadedStrings, TemplateHaskell, QuasiQuotes,
TypeFamilies, MultiParamTypeClasses, ViewPatterns #-}
module YesodCoreTest.Header
( headerTest
, Widget
, resourcesApp
) where
import Data.Text (Text)
import Network.HTTP.Types (decodePathSegments)
import Network.Wai
import Network.Wai.Test
import Test.Hspec
import Yesod.Core
data App =
App
mkYesod
"App"
[parseRoutes|
/header1 Header1R GET
/header2 Header2R GET
/header3 Header3R GET
|]
instance Yesod App
getHeader1R :: Handler RepPlain
getHeader1R = do
addHeader "hello" "world"
return $ RepPlain $ toContent ("header test" :: Text)
getHeader2R :: Handler RepPlain
getHeader2R = do
addHeader "hello" "world"
replaceOrAddHeader "hello" "sibi"
return $ RepPlain $ toContent ("header test" :: Text)
getHeader3R :: Handler RepPlain
getHeader3R = do
addHeader "hello" "world"
addHeader "michael" "snoyman"
addHeader "yesod" "framework"
replaceOrAddHeader "yesod" "book"
return $ RepPlain $ toContent ("header test" :: Text)
runner :: Session () -> IO ()
runner f = toWaiApp App >>= runSession f
addHeaderTest :: IO ()
addHeaderTest =
runner $ do
res <- request defaultRequest {pathInfo = decodePathSegments "/header1"}
assertHeader "hello" "world" res
multipleHeaderTest :: IO ()
multipleHeaderTest =
runner $ do
res <- request defaultRequest {pathInfo = decodePathSegments "/header2"}
assertHeader "hello" "sibi" res
header3Test :: IO ()
header3Test = do
runner $ do
res <- request defaultRequest {pathInfo = decodePathSegments "/header3"}
assertHeader "hello" "world" res
assertHeader "michael" "snoyman" res
assertHeader "yesod" "book" res
xssHeaderTest :: IO ()
xssHeaderTest = do
runner $ do
res <- request defaultRequest {pathInfo = decodePathSegments "/header1"}
assertHeader "X-XSS-Protection" "1; mode=block" res
headerTest :: Spec
headerTest =
describe "Test.Header" $ do
it "addHeader" addHeaderTest
it "multiple header" multipleHeaderTest
it "persist headers" header3Test
it "has X-XSS-Protection: 1; mode=block" xssHeaderTest
|
