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