{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ImplicitParams #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Yesod.Test
(
yesodSpec
, YesodSpec
, yesodSpecWithSiteGenerator
, yesodSpecWithSiteGeneratorAndArgument
, yesodSpecApp
, YesodExample
, YesodExampleData(..)
, TestApp
, YSpec
, testApp
, YesodSpecTree (..)
, ydescribe
, yit
, get
, post
, postBody
, performMethod
, followRedirect
, getLocation
, request
, addRequestHeader
, setMethod
, addPostParam
, addGetParam
, addFile
, setRequestBody
, RequestBuilder
, SIO
, setUrl
, clickOn
, byLabel
, byLabelExact
, byLabelContain
, byLabelPrefix
, byLabelSuffix
, fileByLabel
, fileByLabelExact
, fileByLabelContain
, fileByLabelPrefix
, fileByLabelSuffix
, addToken
, addToken_
, addTokenFromCookie
, addTokenFromCookieNamedToHeaderNamed
, assertEqual
, assertNotEq
, assertEqualNoShow
, assertEq
, assertHeader
, assertNoHeader
, statusIs
, bodyEquals
, bodyContains
, bodyNotContains
, htmlAllContain
, htmlAnyContain
, htmlNoneContain
, htmlCount
, getTestYesod
, getResponse
, getRequestCookies
, printBody
, printMatches
, htmlQuery
, parseHTML
, withResponse
) where
import qualified Test.Hspec.Core.Spec as Hspec
import qualified Data.List as DL
import qualified Data.ByteString.Char8 as BS8
import Data.ByteString (ByteString)
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import qualified Data.ByteString.Lazy.Char8 as BSL8
import qualified Test.HUnit as HUnit
import qualified Network.HTTP.Types as H
import qualified Network.Socket.Internal as Sock
import Data.CaseInsensitive (CI)
import Network.Wai
import Network.Wai.Test hiding (assertHeader, assertNoHeader, request)
import Control.Monad.Trans.Reader (ReaderT (..))
import Conduit (MonadThrow)
import Control.Monad.IO.Class
import System.IO
import Yesod.Core.Unsafe (runFakeHandler)
import Yesod.Test.TransversingCSS
import Yesod.Core
import qualified Data.Text.Lazy as TL
import Data.Text.Lazy.Encoding (encodeUtf8, decodeUtf8)
import Text.XML.Cursor hiding (element)
import qualified Text.XML.Cursor as C
import qualified Text.HTML.DOM as HD
import Control.Monad.Trans.Writer
import Data.IORef
import qualified Data.Map as M
import qualified Web.Cookie as Cookie
import qualified Blaze.ByteString.Builder as Builder
import Data.Time.Clock (getCurrentTime)
import Control.Applicative ((<$>))
import Text.Show.Pretty (ppShow)
import Data.Monoid (mempty)
import Data.Semigroup (Semigroup(..))
#if MIN_VERSION_base(4,9,0)
import GHC.Stack (HasCallStack)
#elif MIN_VERSION_base(4,8,1)
import GHC.Stack (CallStack)
type HasCallStack = (?callStack :: CallStack)
#else
import GHC.Exts (Constraint)
type HasCallStack = (() :: Constraint)
#endif
{-# DEPRECATED byLabel "This function seems to have multiple bugs (ref: https://github.com/yesodweb/yesod/pull/1459). Use byLabelExact, byLabelContain, byLabelPrefix or byLabelSuffix instead" #-}
{-# DEPRECATED fileByLabel "This function seems to have multiple bugs (ref: https://github.com/yesodweb/yesod/pull/1459). Use fileByLabelExact, fileByLabelContain, fileByLabelPrefix or fileByLabelSuffix instead" #-}
data YesodExampleData site = YesodExampleData
{ yedApp :: !Application
, yedSite :: !site
, yedCookies :: !Cookies
, yedResponse :: !(Maybe SResponse)
}
type YesodExample site = SIO (YesodExampleData site)
type Cookies = M.Map ByteString Cookie.SetCookie
type YesodSpec site = Writer [YesodSpecTree site] ()
data YesodSpecTree site
= YesodSpecGroup String [YesodSpecTree site]
| YesodSpecItem String (YesodExample site ())
getTestYesod :: YesodExample site site
getTestYesod = fmap yedSite getSIO
getResponse :: YesodExample site (Maybe SResponse)
getResponse = fmap yedResponse getSIO
data RequestBuilderData site = RequestBuilderData
{ rbdPostData :: RBDPostData
, rbdResponse :: (Maybe SResponse)
, rbdMethod :: H.Method
, rbdSite :: site
, rbdPath :: [T.Text]
, rbdGets :: H.Query
, rbdHeaders :: H.RequestHeaders
}
data RBDPostData = MultipleItemsPostData [RequestPart]
| BinaryPostData BSL8.ByteString
data RequestPart
= ReqKvPart T.Text T.Text
| ReqFilePart T.Text FilePath BSL8.ByteString T.Text
type RequestBuilder site = SIO (RequestBuilderData site)
ydescribe :: String -> YesodSpec site -> YesodSpec site
ydescribe label yspecs = tell [YesodSpecGroup label $ execWriter yspecs]
yesodSpec :: YesodDispatch site
=> site
-> YesodSpec site
-> Hspec.Spec
yesodSpec site yspecs =
Hspec.fromSpecList $ map unYesod $ execWriter yspecs
where
unYesod (YesodSpecGroup x y) = Hspec.specGroup x $ map unYesod y
unYesod (YesodSpecItem x y) = Hspec.specItem x $ do
app <- toWaiAppPlain site
evalSIO y YesodExampleData
{ yedApp = app
, yedSite = site
, yedCookies = M.empty
, yedResponse = Nothing
}
yesodSpecWithSiteGenerator :: YesodDispatch site
=> IO site
-> YesodSpec site
-> Hspec.Spec
yesodSpecWithSiteGenerator getSiteAction =
yesodSpecWithSiteGeneratorAndArgument (const getSiteAction)
yesodSpecWithSiteGeneratorAndArgument :: YesodDispatch site
=> (a -> IO site)
-> YesodSpec site
-> Hspec.SpecWith a
yesodSpecWithSiteGeneratorAndArgument getSiteAction yspecs =
Hspec.fromSpecList $ map (unYesod getSiteAction) $ execWriter yspecs
where
unYesod getSiteAction' (YesodSpecGroup x y) = Hspec.specGroup x $ map (unYesod getSiteAction') y
unYesod getSiteAction' (YesodSpecItem x y) = Hspec.specItem x $ \a -> do
site <- getSiteAction' a
app <- toWaiAppPlain site
evalSIO y YesodExampleData
{ yedApp = app
, yedSite = site
, yedCookies = M.empty
, yedResponse = Nothing
}
yesodSpecApp :: YesodDispatch site
=> site
-> IO Application
-> YesodSpec site
-> Hspec.Spec
yesodSpecApp site getApp yspecs =
Hspec.fromSpecList $ map unYesod $ execWriter yspecs
where
unYesod (YesodSpecGroup x y) = Hspec.specGroup x $ map unYesod y
unYesod (YesodSpecItem x y) = Hspec.specItem x $ do
app <- getApp
evalSIO y YesodExampleData
{ yedApp = app
, yedSite = site
, yedCookies = M.empty
, yedResponse = Nothing
}
yit :: String -> YesodExample site () -> YesodSpec site
yit label example = tell [YesodSpecItem label example]
withResponse' :: (state -> Maybe SResponse)
-> [T.Text]
-> (SResponse -> SIO state a)
-> SIO state a
withResponse' getter errTrace f = maybe err f . getter =<< getSIO
where err = failure msg
msg = if null errTrace
then "There was no response, you should make a request."
else
"There was no response, you should make a request. A response was needed because: \n - "
<> T.intercalate "\n - " errTrace
withResponse :: (SResponse -> YesodExample site a) -> YesodExample site a
withResponse = withResponse' yedResponse []
parseHTML :: HtmlLBS -> Cursor
parseHTML html = fromDocument $ HD.parseLBS html
htmlQuery' :: (state -> Maybe SResponse)
-> [T.Text]
-> Query
-> SIO state [HtmlLBS]
htmlQuery' getter errTrace query = withResponse' getter ("Tried to invoke htmlQuery' in order to read HTML of a previous response." : errTrace) $ \ res ->
case findBySelector (simpleBody res) query of
Left err -> failure $ query <> " did not parse: " <> T.pack (show err)
Right matches -> return $ map (encodeUtf8 . TL.pack) matches
htmlQuery :: Query -> YesodExample site [HtmlLBS]
htmlQuery = htmlQuery' yedResponse []
assertEq :: (HasCallStack, Eq a, Show a) => String -> a -> a -> YesodExample site ()
assertEq m a b =
liftIO $ HUnit.assertBool msg (a == b)
where msg = "Assertion: " ++ m ++ "\n" ++
"First argument: " ++ ppShow a ++ "\n" ++
"Second argument: " ++ ppShow b ++ "\n"
assertNotEq :: (HasCallStack, Eq a, Show a) => String -> a -> a -> YesodExample site ()
assertNotEq m a b =
liftIO $ HUnit.assertBool msg (a /= b)
where msg = "Assertion: " ++ m ++ "\n" ++
"Both arguments: " ++ ppShow a ++ "\n"
{-# DEPRECATED assertEqual "Use assertEq instead" #-}
assertEqual :: (HasCallStack, Eq a) => String -> a -> a -> YesodExample site ()
assertEqual = assertEqualNoShow
assertEqualNoShow :: (HasCallStack, Eq a) => String -> a -> a -> YesodExample site ()
assertEqualNoShow msg a b = liftIO $ HUnit.assertBool msg (a == b)
statusIs :: HasCallStack => Int -> YesodExample site ()
statusIs number = withResponse $ \ SResponse { simpleStatus = s } ->
liftIO $ flip HUnit.assertBool (H.statusCode s == number) $ concat
[ "Expected status was ", show number
, " but received status was ", show $ H.statusCode s
]
assertHeader :: HasCallStack => CI BS8.ByteString -> BS8.ByteString -> YesodExample site ()
assertHeader header value = withResponse $ \ SResponse { simpleHeaders = h } ->
case lookup header h of
Nothing -> failure $ T.pack $ concat
[ "Expected header "
, show header
, " to be "
, show value
, ", but it was not present"
]
Just value' -> liftIO $ flip HUnit.assertBool (value == value') $ concat
[ "Expected header "
, show header
, " to be "
, show value
, ", but received "
, show value'
]
assertNoHeader :: HasCallStack => CI BS8.ByteString -> YesodExample site ()
assertNoHeader header = withResponse $ \ SResponse { simpleHeaders = h } ->
case lookup header h of
Nothing -> return ()
Just s -> failure $ T.pack $ concat
[ "Unexpected header "
, show header
, " containing "
, show s
]
bodyEquals :: HasCallStack => String -> YesodExample site ()
bodyEquals text = withResponse $ \ res ->
liftIO $ HUnit.assertBool ("Expected body to equal " ++ text) $
(simpleBody res) == encodeUtf8 (TL.pack text)
bodyContains :: HasCallStack => String -> YesodExample site ()
bodyContains text = withResponse $ \ res ->
liftIO $ HUnit.assertBool ("Expected body to contain " ++ text) $
(simpleBody res) `contains` text
bodyNotContains :: HasCallStack => String -> YesodExample site ()
bodyNotContains text = withResponse $ \ res ->
liftIO $ HUnit.assertBool ("Expected body not to contain " ++ text) $
not $ contains (simpleBody res) text
contains :: BSL8.ByteString -> String -> Bool
contains a b = DL.isInfixOf b (TL.unpack $ decodeUtf8 a)
htmlAllContain :: HasCallStack => Query -> String -> YesodExample site ()
htmlAllContain query search = do
matches <- htmlQuery query
case matches of
[] -> failure $ "Nothing matched css query: " <> query
_ -> liftIO $ HUnit.assertBool ("Not all "++T.unpack query++" contain "++search) $
DL.all (DL.isInfixOf search) (map (TL.unpack . decodeUtf8) matches)
htmlAnyContain :: HasCallStack => Query -> String -> YesodExample site ()
htmlAnyContain query search = do
matches <- htmlQuery query
case matches of
[] -> failure $ "Nothing matched css query: " <> query
_ -> liftIO $ HUnit.assertBool ("None of "++T.unpack query++" contain "++search) $
DL.any (DL.isInfixOf search) (map (TL.unpack . decodeUtf8) matches)
htmlNoneContain :: HasCallStack => Query -> String -> YesodExample site ()
htmlNoneContain query search = do
matches <- htmlQuery query
case DL.filter (DL.isInfixOf search) (map (TL.unpack . decodeUtf8) matches) of
[] -> return ()
found -> failure $ "Found " <> T.pack (show $ length found) <>
" instances of " <> T.pack search <> " in " <> query <> " elements"
htmlCount :: HasCallStack => Query -> Int -> YesodExample site ()
htmlCount query count = do
matches <- fmap DL.length $ htmlQuery query
liftIO $ flip HUnit.assertBool (matches == count)
("Expected "++(show count)++" elements to match "++T.unpack query++", found "++(show matches))
printBody :: YesodExample site ()
printBody = withResponse $ \ SResponse { simpleBody = b } ->
liftIO $ BSL8.hPutStrLn stderr b
printMatches :: Query -> YesodExample site ()
printMatches query = do
matches <- htmlQuery query
liftIO $ hPutStrLn stderr $ show matches
addPostParam :: T.Text -> T.Text -> RequestBuilder site ()
addPostParam name value =
modifySIO $ \rbd -> rbd { rbdPostData = (addPostData (rbdPostData rbd)) }
where addPostData (BinaryPostData _) = error "Trying to add post param to binary content."
addPostData (MultipleItemsPostData posts) =
MultipleItemsPostData $ ReqKvPart name value : posts
addGetParam :: T.Text -> T.Text -> RequestBuilder site ()
addGetParam name value = modifySIO $ \rbd -> rbd
{ rbdGets = (TE.encodeUtf8 name, Just $ TE.encodeUtf8 value)
: rbdGets rbd
}
addFile :: T.Text
-> FilePath
-> T.Text
-> RequestBuilder site ()
addFile name path mimetype = do
contents <- liftIO $ BSL8.readFile path
modifySIO $ \rbd -> rbd { rbdPostData = (addPostData (rbdPostData rbd) contents) }
where addPostData (BinaryPostData _) _ = error "Trying to add file after setting binary content."
addPostData (MultipleItemsPostData posts) contents =
MultipleItemsPostData $ ReqFilePart name path contents mimetype : posts
genericNameFromLabel :: (T.Text -> T.Text -> Bool) -> T.Text -> RequestBuilder site T.Text
genericNameFromLabel match label = do
mres <- fmap rbdResponse getSIO
res <-
case mres of
Nothing -> failure "genericNameFromLabel: No response available"
Just res -> return res
let
body = simpleBody res
mlabel = parseHTML body
$// C.element "label"
>=> isContentMatch label
mfor = mlabel >>= attribute "for"
isContentMatch x c
| x `match` T.concat (c $// content) = [c]
| otherwise = []
case mfor of
for:[] -> do
let mname = parseHTML body
$// attributeIs "id" for
>=> attribute "name"
case mname of
"":_ -> failure $ T.concat
[ "Label "
, label
, " resolved to id "
, for
, " which was not found. "
]
name:_ -> return name
[] -> failure $ "No input with id " <> for
[] ->
case filter (/= "") $ mlabel >>= (child >=> C.element "input" >=> attribute "name") of
[] -> failure $ "No label contained: " <> label
name:_ -> return name
_ -> failure $ "More than one label contained " <> label
byLabelWithMatch :: (T.Text -> T.Text -> Bool)
-> T.Text
-> T.Text
-> RequestBuilder site ()
byLabelWithMatch match label value = do
name <- genericNameFromLabel match label
addPostParam name value
byLabel :: T.Text
-> T.Text
-> RequestBuilder site ()
byLabel = byLabelWithMatch T.isInfixOf
byLabelExact :: T.Text
-> T.Text
-> RequestBuilder site ()
byLabelExact = byLabelWithMatch (==)
byLabelContain :: T.Text
-> T.Text
-> RequestBuilder site ()
byLabelContain = byLabelWithMatch T.isInfixOf
byLabelPrefix :: T.Text
-> T.Text
-> RequestBuilder site ()
byLabelPrefix = byLabelWithMatch T.isPrefixOf
byLabelSuffix :: T.Text
-> T.Text
-> RequestBuilder site ()
byLabelSuffix = byLabelWithMatch T.isSuffixOf
fileByLabelWithMatch :: (T.Text -> T.Text -> Bool)
-> T.Text
-> FilePath
-> T.Text
-> RequestBuilder site ()
fileByLabelWithMatch match label path mime = do
name <- genericNameFromLabel match label
addFile name path mime
fileByLabel :: T.Text
-> FilePath
-> T.Text
-> RequestBuilder site ()
fileByLabel = fileByLabelWithMatch T.isInfixOf
fileByLabelExact :: T.Text
-> FilePath
-> T.Text
-> RequestBuilder site ()
fileByLabelExact = fileByLabelWithMatch (==)
fileByLabelContain :: T.Text
-> FilePath
-> T.Text
-> RequestBuilder site ()
fileByLabelContain = fileByLabelWithMatch T.isInfixOf
fileByLabelPrefix :: T.Text
-> FilePath
-> T.Text
-> RequestBuilder site ()
fileByLabelPrefix = fileByLabelWithMatch T.isPrefixOf
fileByLabelSuffix :: T.Text
-> FilePath
-> T.Text
-> RequestBuilder site ()
fileByLabelSuffix = fileByLabelWithMatch T.isSuffixOf
addToken_ :: Query -> RequestBuilder site ()
addToken_ scope = do
matches <- htmlQuery' rbdResponse ["Tried to get CSRF token with addToken'"] $ scope <> " input[name=_token][type=hidden][value]"
case matches of
[] -> failure $ "No CSRF token found in the current page"
element:[] -> addPostParam "_token" $ head $ attribute "value" $ parseHTML element
_ -> failure $ "More than one CSRF token found in the page"
addToken :: RequestBuilder site ()
addToken = addToken_ ""
addTokenFromCookie :: RequestBuilder site ()
addTokenFromCookie = addTokenFromCookieNamedToHeaderNamed defaultCsrfCookieName defaultCsrfHeaderName
addTokenFromCookieNamedToHeaderNamed :: ByteString
-> CI ByteString
-> RequestBuilder site ()
addTokenFromCookieNamedToHeaderNamed cookieName headerName = do
cookies <- getRequestCookies
case M.lookup cookieName cookies of
Just csrfCookie -> addRequestHeader (headerName, Cookie.setCookieValue csrfCookie)
Nothing -> failure $ T.concat
[ "addTokenFromCookieNamedToHeaderNamed failed to lookup CSRF cookie with name: "
, T.pack $ show cookieName
, ". Cookies were: "
, T.pack $ show cookies
]
getRequestCookies :: RequestBuilder site Cookies
getRequestCookies = do
requestBuilderData <- getSIO
headers <- case simpleHeaders Control.Applicative.<$> rbdResponse requestBuilderData of
Just h -> return h
Nothing -> failure "getRequestCookies: No request has been made yet; the cookies can't be looked up."
return $ M.fromList $ map (\c -> (Cookie.setCookieName c, c)) (parseSetCookies headers)
post :: (Yesod site, RedirectUrl site url)
=> url
-> YesodExample site ()
post = performMethod "POST"
postBody :: (Yesod site, RedirectUrl site url)
=> url
-> BSL8.ByteString
-> YesodExample site ()
postBody url body = request $ do
setMethod "POST"
setUrl url
setRequestBody body
get :: (Yesod site, RedirectUrl site url)
=> url
-> YesodExample site ()
get = performMethod "GET"
performMethod :: (Yesod site, RedirectUrl site url)
=> ByteString
-> url
-> YesodExample site ()
performMethod method url = request $ do
setMethod method
setUrl url
followRedirect :: Yesod site
=> YesodExample site (Either T.Text T.Text)
followRedirect = do
mr <- getResponse
case mr of
Nothing -> return $ Left "followRedirect called, but there was no previous response, so no redirect to follow"
Just r -> do
if not ((H.statusCode $ simpleStatus r) `elem` [301, 302, 303, 307, 308])
then return $ Left "followRedirect called, but previous request was not a redirect"
else do
case lookup "Location" (simpleHeaders r) of
Nothing -> return $ Left "followRedirect called, but no location header set"
Just h -> let url = TE.decodeUtf8 h in
get url >> return (Right url)
getLocation :: ParseRoute site => YesodExample site (Either T.Text (Route site))
getLocation = do
mr <- getResponse
case mr of
Nothing -> return $ Left "getLocation called, but there was no previous response, so no Location header"
Just r -> case lookup "Location" (simpleHeaders r) of
Nothing -> return $ Left "getLocation called, but the previous response has no Location header"
Just h -> case parseRoute $ decodePath h of
Nothing -> return $ Left "getLocation called, but couldn’t parse it into a route"
Just l -> return $ Right l
where decodePath b = let (x, y) = BS8.break (=='?') b
in (H.decodePathSegments x, unJust <$> H.parseQueryText y)
unJust (a, Just b) = (a, b)
unJust (a, Nothing) = (a, Data.Monoid.mempty)
setMethod :: H.Method -> RequestBuilder site ()
setMethod m = modifySIO $ \rbd -> rbd { rbdMethod = m }
setUrl :: (Yesod site, RedirectUrl site url)
=> url
-> RequestBuilder site ()
setUrl url' = do
site <- fmap rbdSite getSIO
eurl <- Yesod.Core.Unsafe.runFakeHandler
M.empty
(const $ error "Yesod.Test: No logger available")
site
(toTextUrl url')
url <- either (error . show) return eurl
let (urlPath, urlQuery) = T.break (== '?') url
modifySIO $ \rbd -> rbd
{ rbdPath =
case DL.filter (/="") $ H.decodePathSegments $ TE.encodeUtf8 urlPath of
("http:":_:rest) -> rest
("https:":_:rest) -> rest
x -> x
, rbdGets = rbdGets rbd ++ H.parseQuery (TE.encodeUtf8 urlQuery)
}
clickOn :: Yesod site => Query -> YesodExample site ()
clickOn query = do
withResponse' yedResponse ["Tried to invoke clickOn in order to read HTML of a previous response."] $ \ res ->
case findAttributeBySelector (simpleBody res) query "href" of
Left err -> failure $ query <> " did not parse: " <> T.pack (show err)
Right [[match]] -> get match
Right matches -> failure $ "Expected exactly one match for clickOn: got " <> T.pack (show matches)
setRequestBody :: BSL8.ByteString -> RequestBuilder site ()
setRequestBody body = modifySIO $ \rbd -> rbd { rbdPostData = BinaryPostData body }
addRequestHeader :: H.Header -> RequestBuilder site ()
addRequestHeader header = modifySIO $ \rbd -> rbd
{ rbdHeaders = header : rbdHeaders rbd
}
request :: RequestBuilder site ()
-> YesodExample site ()
request reqBuilder = do
YesodExampleData app site oldCookies mRes <- getSIO
RequestBuilderData {..} <- liftIO $ execSIO reqBuilder RequestBuilderData
{ rbdPostData = MultipleItemsPostData []
, rbdResponse = mRes
, rbdMethod = "GET"
, rbdSite = site
, rbdPath = []
, rbdGets = []
, rbdHeaders = []
}
let path
| null rbdPath = "/"
| otherwise = TE.decodeUtf8 $ Builder.toByteString $ H.encodePathSegments rbdPath
currentUtc <- liftIO getCurrentTime
let cookies = M.filter (checkCookieTime currentUtc) oldCookies
cookiesForPath = M.filter (checkCookiePath path) cookies
let req = case rbdPostData of
MultipleItemsPostData x ->
if DL.any isFile x
then (multipart x)
else singlepart
BinaryPostData _ -> singlepart
where singlepart = makeSinglepart cookiesForPath rbdPostData rbdMethod rbdHeaders path rbdGets
multipart x = makeMultipart cookiesForPath x rbdMethod rbdHeaders path rbdGets
response <- liftIO $ runSession (srequest req
{ simpleRequest = (simpleRequest req)
{ httpVersion = H.http11
}
}) app
let newCookies = parseSetCookies $ simpleHeaders response
cookies' = M.fromList [(Cookie.setCookieName c, c) | c <- newCookies] `M.union` cookies
putSIO $ YesodExampleData app site cookies' (Just response)
where
isFile (ReqFilePart _ _ _ _) = True
isFile _ = False
checkCookieTime t c = case Cookie.setCookieExpires c of
Nothing -> True
Just t' -> t < t'
checkCookiePath url c =
case Cookie.setCookiePath c of
Nothing -> True
Just x -> x `BS8.isPrefixOf` TE.encodeUtf8 url
boundary :: String
boundary = "*******noneedtomakethisrandom"
separator = BS8.concat ["--", BS8.pack boundary, "\r\n"]
makeMultipart :: M.Map a0 Cookie.SetCookie
-> [RequestPart]
-> H.Method
-> [H.Header]
-> T.Text
-> H.Query
-> SRequest
makeMultipart cookies parts method extraHeaders urlPath urlQuery =
SRequest simpleRequest' (simpleRequestBody' parts)
where simpleRequestBody' x =
BSL8.fromChunks [multiPartBody x]
simpleRequest' = mkRequest
[ ("Cookie", cookieValue)
, ("Content-Type", contentTypeValue)]
method extraHeaders urlPath urlQuery
cookieValue = Builder.toByteString $ Cookie.renderCookies cookiePairs
cookiePairs = [ (Cookie.setCookieName c, Cookie.setCookieValue c)
| c <- map snd $ M.toList cookies ]
contentTypeValue = BS8.pack $ "multipart/form-data; boundary=" ++ boundary
multiPartBody parts =
BS8.concat $ separator : [BS8.concat [multipartPart p, separator] | p <- parts]
multipartPart (ReqKvPart k v) = BS8.concat
[ "Content-Disposition: form-data; "
, "name=\"", TE.encodeUtf8 k, "\"\r\n\r\n"
, TE.encodeUtf8 v, "\r\n"]
multipartPart (ReqFilePart k v bytes mime) = BS8.concat
[ "Content-Disposition: form-data; "
, "name=\"", TE.encodeUtf8 k, "\"; "
, "filename=\"", BS8.pack v, "\"\r\n"
, "Content-Type: ", TE.encodeUtf8 mime, "\r\n\r\n"
, BS8.concat $ BSL8.toChunks bytes, "\r\n"]
makeSinglepart :: M.Map a0 Cookie.SetCookie
-> RBDPostData
-> H.Method
-> [H.Header]
-> T.Text
-> H.Query
-> SRequest
makeSinglepart cookies rbdPostData method extraHeaders urlPath urlQuery =
SRequest simpleRequest' (simpleRequestBody' rbdPostData)
where
simpleRequest' = (mkRequest
([ ("Cookie", cookieValue) ] ++ headersForPostData rbdPostData)
method extraHeaders urlPath urlQuery)
simpleRequestBody' (MultipleItemsPostData x) =
BSL8.fromChunks $ return $ TE.encodeUtf8 $ T.intercalate "&"
$ map singlepartPart x
simpleRequestBody' (BinaryPostData x) = x
cookieValue = Builder.toByteString $ Cookie.renderCookies cookiePairs
cookiePairs = [ (Cookie.setCookieName c, Cookie.setCookieValue c)
| c <- map snd $ M.toList cookies ]
singlepartPart (ReqFilePart _ _ _ _) = ""
singlepartPart (ReqKvPart k v) = T.concat [k,"=",v]
headersForPostData (MultipleItemsPostData []) = []
headersForPostData (MultipleItemsPostData _ ) = [("Content-Type", "application/x-www-form-urlencoded")]
headersForPostData (BinaryPostData _ ) = []
mkRequest headers method extraHeaders urlPath urlQuery = defaultRequest
{ requestMethod = method
, remoteHost = Sock.SockAddrInet 1 2
, requestHeaders = headers ++ extraHeaders
, rawPathInfo = TE.encodeUtf8 urlPath
, pathInfo = H.decodePathSegments $ TE.encodeUtf8 urlPath
, rawQueryString = H.renderQuery False urlQuery
, queryString = urlQuery
}
parseSetCookies :: [H.Header] -> [Cookie.SetCookie]
parseSetCookies headers = map (Cookie.parseSetCookie . snd) $ DL.filter (("Set-Cookie"==) . fst) $ headers
failure :: (MonadIO a) => T.Text -> a b
failure reason = (liftIO $ HUnit.assertFailure $ T.unpack reason) >> error ""
type TestApp site = (site, Middleware)
testApp :: site -> Middleware -> TestApp site
testApp site middleware = (site, middleware)
type YSpec site = Hspec.SpecWith (TestApp site)
instance YesodDispatch site => Hspec.Example (SIO (YesodExampleData site) a) where
type Arg (SIO (YesodExampleData site) a) = TestApp site
evaluateExample example params action =
Hspec.evaluateExample
(action $ \(site, middleware) -> do
app <- toWaiAppPlain site
_ <- evalSIO example YesodExampleData
{ yedApp = middleware app
, yedSite = site
, yedCookies = M.empty
, yedResponse = Nothing
}
return ())
params
($ ())
newtype SIO s a = SIO (ReaderT (IORef s) IO a)
deriving (Functor, Applicative, Monad, MonadIO, MonadThrow, MonadUnliftIO)
getSIO :: SIO s s
getSIO = SIO $ ReaderT readIORef
putSIO :: s -> SIO s ()
putSIO s = SIO $ ReaderT $ \ref -> writeIORef ref $! s
modifySIO :: (s -> s) -> SIO s ()
modifySIO f = SIO $ ReaderT $ \ref -> modifyIORef' ref f
evalSIO :: SIO s a -> s -> IO a
evalSIO (SIO (ReaderT f)) s = newIORef s >>= f
execSIO :: SIO s () -> s -> IO s
execSIO (SIO (ReaderT f)) s = do
ref <- newIORef s
f ref
readIORef ref