Use GADTs for static guarantee you use right type of post data.
This commit is contained in:
Konstantine Rybnikov
parent
eb7ad4e480
commit
3655af11d3
@ -2,6 +2,7 @@
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-|
|
||||
Yesod.Test is a pragmatic framework for testing web applications built
|
||||
using wai and persistent.
|
||||
@ -165,8 +166,8 @@ getTestYesod = fmap yedSite ST.get
|
||||
getResponse :: YesodExample site (Maybe SResponse)
|
||||
getResponse = fmap yedResponse ST.get
|
||||
|
||||
data RequestBuilderData site = RequestBuilderData
|
||||
{ rbdPostData :: RBDPostData
|
||||
data RequestBuilderData site p = RequestBuilderData
|
||||
{ rbdPostData :: Maybe (RBDPostData p)
|
||||
, rbdResponse :: (Maybe SResponse)
|
||||
, rbdMethod :: H.Method
|
||||
, rbdSite :: site
|
||||
@ -175,8 +176,9 @@ data RequestBuilderData site = RequestBuilderData
|
||||
, rbdHeaders :: H.RequestHeaders
|
||||
}
|
||||
|
||||
data RBDPostData = MultipleItemsPostData [RequestPart]
|
||||
| BinaryPostData BSL8.ByteString
|
||||
data RBDPostData a where
|
||||
MultipleItemsPostData :: [RequestPart] -> RBDPostData [RequestPart]
|
||||
BinaryPostData :: BSL8.ByteString -> RBDPostData BSL8.ByteString
|
||||
|
||||
-- | Request parts let us discern regular key/values from files sent in the request.
|
||||
data RequestPart
|
||||
@ -186,7 +188,7 @@ data RequestPart
|
||||
-- | The RequestBuilder state monad constructs an url encoded string of arguments
|
||||
-- to send with your requests. Some of the functions that run on it use the current
|
||||
-- response to analize the forms that the server is expecting to receive.
|
||||
type RequestBuilder site = ST.StateT (RequestBuilderData site) IO
|
||||
type RequestBuilder site p = ST.StateT (RequestBuilderData site p) IO
|
||||
|
||||
-- | Start describing a Tests suite keeping cookies and a reference to the tested 'Application'
|
||||
-- and 'ConnectionPool'
|
||||
@ -372,14 +374,16 @@ printMatches query = do
|
||||
liftIO $ hPutStrLn stderr $ show matches
|
||||
|
||||
-- | Add a parameter with the given name and value.
|
||||
addPostParam :: T.Text -> T.Text -> RequestBuilder site ()
|
||||
addPostParam :: T.Text -> T.Text -> RequestBuilder site [RequestPart] ()
|
||||
addPostParam name value =
|
||||
ST.modify $ \rbd -> rbd { rbdPostData = (addPostData (rbdPostData rbd)) }
|
||||
where addPostData x@(BinaryPostData _) = x
|
||||
addPostData (MultipleItemsPostData posts) =
|
||||
MultipleItemsPostData $ ReqKvPart name value : posts
|
||||
where addPostData :: Maybe (RBDPostData [RequestPart])
|
||||
-> Maybe (RBDPostData [RequestPart])
|
||||
addPostData (Just (MultipleItemsPostData posts)) =
|
||||
Just $ MultipleItemsPostData $ ReqKvPart name value : posts
|
||||
addPostData Nothing = Just $ MultipleItemsPostData $ [ReqKvPart name value]
|
||||
|
||||
addGetParam :: T.Text -> T.Text -> RequestBuilder site ()
|
||||
addGetParam :: T.Text -> T.Text -> RequestBuilder site p ()
|
||||
addGetParam name value = ST.modify $ \rbd -> rbd
|
||||
{ rbdGets = (TE.encodeUtf8 name, Just $ TE.encodeUtf8 value)
|
||||
: rbdGets rbd
|
||||
@ -388,16 +392,20 @@ addGetParam name value = ST.modify $ \rbd -> rbd
|
||||
-- | Add a file to be posted with the current request
|
||||
--
|
||||
-- Adding a file will automatically change your request content-type to be multipart/form-data
|
||||
addFile :: T.Text -> FilePath -> T.Text -> RequestBuilder site ()
|
||||
addFile :: T.Text -> FilePath -> T.Text -> RequestBuilder site [RequestPart] ()
|
||||
addFile name path mimetype = do
|
||||
contents <- liftIO $ BSL8.readFile path
|
||||
ST.modify $ \rbd -> rbd { rbdPostData = (addPostData (rbdPostData rbd) contents) }
|
||||
where addPostData x@(BinaryPostData _) _ = x
|
||||
addPostData (MultipleItemsPostData posts) contents =
|
||||
MultipleItemsPostData $ ReqFilePart name path contents mimetype : posts
|
||||
where addPostData :: Maybe (RBDPostData [RequestPart])
|
||||
-> BSL8.ByteString
|
||||
-> Maybe (RBDPostData [RequestPart])
|
||||
addPostData (Just (MultipleItemsPostData posts)) contents =
|
||||
Just $ MultipleItemsPostData $ ReqFilePart name path contents mimetype : posts
|
||||
addPostData Nothing contents =
|
||||
Just $ MultipleItemsPostData $ [ReqFilePart name path contents mimetype]
|
||||
|
||||
-- This looks up the name of a field based on the contents of the label pointing to it.
|
||||
nameFromLabel :: T.Text -> RequestBuilder site T.Text
|
||||
nameFromLabel :: T.Text -> RequestBuilder site p T.Text
|
||||
nameFromLabel label = do
|
||||
mres <- fmap rbdResponse ST.get
|
||||
res <-
|
||||
@ -436,19 +444,19 @@ nameFromLabel label = do
|
||||
(<>) :: T.Text -> T.Text -> T.Text
|
||||
(<>) = T.append
|
||||
|
||||
byLabel :: T.Text -> T.Text -> RequestBuilder site ()
|
||||
byLabel :: T.Text -> T.Text -> RequestBuilder site [RequestPart] ()
|
||||
byLabel label value = do
|
||||
name <- nameFromLabel label
|
||||
addPostParam name value
|
||||
|
||||
fileByLabel :: T.Text -> FilePath -> T.Text -> RequestBuilder site ()
|
||||
fileByLabel :: T.Text -> FilePath -> T.Text -> RequestBuilder site [RequestPart] ()
|
||||
fileByLabel label path mime = do
|
||||
name <- nameFromLabel label
|
||||
addFile name path mime
|
||||
|
||||
-- | Lookup a _nonce form field and add it's value to the params.
|
||||
-- Receives a CSS selector that should resolve to the form element containing the nonce.
|
||||
addNonce_ :: Query -> RequestBuilder site ()
|
||||
addNonce_ :: Query -> RequestBuilder site [RequestPart] ()
|
||||
addNonce_ scope = do
|
||||
matches <- htmlQuery' rbdResponse $ scope <> "input[name=_token][type=hidden][value]"
|
||||
case matches of
|
||||
@ -457,7 +465,7 @@ addNonce_ scope = do
|
||||
_ -> failure $ "More than one nonce found in the page"
|
||||
|
||||
-- | For responses that display a single form, just lookup the only nonce available.
|
||||
addNonce :: RequestBuilder site ()
|
||||
addNonce :: RequestBuilder site [RequestPart] ()
|
||||
addNonce = addNonce_ ""
|
||||
|
||||
-- | Perform a POST request to url
|
||||
@ -486,12 +494,12 @@ get url = request $ do
|
||||
setMethod "GET"
|
||||
setUrl url
|
||||
|
||||
setMethod :: H.Method -> RequestBuilder site ()
|
||||
setMethod :: H.Method -> RequestBuilder site p ()
|
||||
setMethod m = ST.modify $ \rbd -> rbd { rbdMethod = m }
|
||||
|
||||
setUrl :: (Yesod site, RedirectUrl site url)
|
||||
=> url
|
||||
-> RequestBuilder site ()
|
||||
-> RequestBuilder site p ()
|
||||
setUrl url' = do
|
||||
site <- fmap rbdSite ST.get
|
||||
eurl <- runFakeHandler
|
||||
@ -513,10 +521,10 @@ setUrl url' = do
|
||||
-- | Simple way to set HTTP request body
|
||||
setRequestBody :: (Yesod site)
|
||||
=> BSL8.ByteString
|
||||
-> RequestBuilder site ()
|
||||
setRequestBody body = ST.modify $ \rbd -> rbd { rbdPostData = BinaryPostData body }
|
||||
-> RequestBuilder site BSL8.ByteString ()
|
||||
setRequestBody body = ST.modify $ \rbd -> rbd { rbdPostData = Just (BinaryPostData body) }
|
||||
|
||||
addRequestHeader :: H.Header -> RequestBuilder site ()
|
||||
addRequestHeader :: H.Header -> RequestBuilder site p ()
|
||||
addRequestHeader header = ST.modify $ \rbd -> rbd
|
||||
{ rbdHeaders = header : rbdHeaders rbd
|
||||
}
|
||||
@ -524,13 +532,13 @@ addRequestHeader header = ST.modify $ \rbd -> rbd
|
||||
-- | General interface to performing requests, allowing you to add extra
|
||||
-- headers as well as letting you specify the request method.
|
||||
request :: Yesod site
|
||||
=> RequestBuilder site ()
|
||||
=> RequestBuilder site p ()
|
||||
-> YesodExample site ()
|
||||
request reqBuilder = do
|
||||
YesodExampleData app site oldCookies mRes <- ST.get
|
||||
|
||||
RequestBuilderData {..} <- liftIO $ ST.execStateT reqBuilder RequestBuilderData
|
||||
{ rbdPostData = MultipleItemsPostData []
|
||||
{ rbdPostData = Nothing
|
||||
, rbdResponse = mRes
|
||||
, rbdMethod = "GET"
|
||||
, rbdSite = site
|
||||
@ -546,11 +554,12 @@ request reqBuilder = do
|
||||
cookiesForPath = M.filter (checkCookiePath path) cookies
|
||||
|
||||
let maker = case rbdPostData of
|
||||
MultipleItemsPostData x ->
|
||||
Just (MultipleItemsPostData x) ->
|
||||
if DL.any isFile x
|
||||
then makeMultipart
|
||||
else makeSinglepart
|
||||
BinaryPostData _ -> makeSinglepart
|
||||
Just (BinaryPostData _) -> makeSinglepart
|
||||
Nothing -> makeSinglepart
|
||||
let req = maker cookiesForPath rbdPostData rbdMethod rbdHeaders path rbdGets
|
||||
response <- liftIO $ runSession (srequest req) app
|
||||
let newCookies = map (Cookie.parseSetCookie . snd) $ DL.filter (("Set-Cookie"==) . fst) $ simpleHeaders response
|
||||
@ -572,11 +581,19 @@ request reqBuilder = do
|
||||
boundary :: String
|
||||
boundary = "*******noneedtomakethisrandom"
|
||||
separator = BS8.concat ["--", BS8.pack boundary, "\r\n"]
|
||||
makeMultipart :: M.Map a0 Cookie.SetCookie
|
||||
-> Maybe (RBDPostData [RequestPart])
|
||||
-> H.Method
|
||||
-> [H.Header]
|
||||
-> T.Text
|
||||
-> H.Query
|
||||
-> SRequest
|
||||
makeMultipart cookies rbdPostData method extraHeaders urlPath urlQuery =
|
||||
SRequest simpleRequest' (simpleRequestBody' rbdPostData)
|
||||
where simpleRequestBody' (MultipleItemsPostData x) =
|
||||
where simpleRequestBody' :: Maybe (RBDPostData [RequestPart]) -> BSL8.ByteString
|
||||
simpleRequestBody' (Just (MultipleItemsPostData x)) =
|
||||
BSL8.fromChunks [multiPartBody x]
|
||||
simpleRequestBody' (BinaryPostData _) = ""
|
||||
simpleRequestBody' Nothing = ""
|
||||
simpleRequest' = mkRequest
|
||||
[ ("Cookie", cookieValue)
|
||||
, ("Content-Type", contentTypeValue)]
|
||||
@ -600,7 +617,7 @@ request reqBuilder = do
|
||||
|
||||
-- For building the regular non-multipart requests
|
||||
makeSinglepart :: M.Map a0 Cookie.SetCookie
|
||||
-> RBDPostData
|
||||
-> Maybe (RBDPostData p)
|
||||
-> H.Method
|
||||
-> [H.Header]
|
||||
-> T.Text
|
||||
@ -613,10 +630,11 @@ request reqBuilder = do
|
||||
[ ("Cookie", cookieValue)
|
||||
, ("Content-Type", "application/x-www-form-urlencoded")]
|
||||
method extraHeaders urlPath urlQuery)
|
||||
simpleRequestBody' (MultipleItemsPostData x) =
|
||||
simpleRequestBody' (Just (MultipleItemsPostData x)) =
|
||||
BSL8.fromChunks $ return $ TE.encodeUtf8 $ T.intercalate "&"
|
||||
$ map singlepartPart x
|
||||
simpleRequestBody' (BinaryPostData x) = x
|
||||
simpleRequestBody' (Just (BinaryPostData x)) = x
|
||||
simpleRequestBody' Nothing = ""
|
||||
cookieValue = Builder.toByteString $ Cookie.renderCookies cookiePairs
|
||||
cookiePairs = [ (Cookie.setCookieName c, Cookie.setCookieValue c)
|
||||
| c <- map snd $ M.toList cookies ]
|
||||
|
||||
Loading…
Reference in New Issue
Block a user