diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,6 +1,145 @@ +# ChangeLog for yesod-test + +## 1.7.0.2 + +* Support `yesod-core` 1.7 + +## 1.7.0.1 + +* When `bodyContains` or `bodyNotContains` fail and the content is UTF-8, a partial body is printed to aid debugging. This matches the behavior of `statusIs`. [#1900](https://github.com/yesodweb/yesod/pull/1900) + +## 1.7.0 + +* Make post params be added in addition order like normal forms. [#1867](https://github.com/yesodweb/yesod/pull/1867) + +## 1.6.23.1 + +* Set `base >= 4.11` for less CPP and imports [#1876](https://github.com/yesodweb/yesod/pull/1876) + +## 1.6.23 + +* Add `MonadFail` to `SIO` so tests can fail on pattern match failure. [#1874](https://github.com/yesodweb/yesod/pull/1874) + +## 1.6.22 + +- Add upper bounds to all build dependencies to comply with Hackage upload requirements. [#1873](https://github.com/yesodweb/yesod/pull/1873) + +## 1.6.21 + +* Add `browseBody` to yesod-test. [#1872](https://github.com/yesodweb/yesod/pull/1872) + +## 1.6.20 + +* Add `HasCallStack` to more functions. [#1858](https://github.com/yesodweb/yesod/pull/1858) + +## 1.6.19 + +* Add `selectByLabel` to yesod-test. [#1845](https://github.com/yesodweb/yesod/pull/1845) + +## 1.6.18 + +* Add `checkByLabel` to yesod-test. [#1843](https://github.com/yesodweb/yesod/pull/1843) + +## 1.6.17 + +* Add `chooseByLabel` to yesod-test. [#1842](https://github.com/yesodweb/yesod/pull/1842) + +## 1.6.16 + +* Add `addBareGetParam` to yesod-test. [#1821](https://github.com/yesodweb/yesod/pull/1821) + +## 1.6.15 + +* Add `bySelectorLabelContain`. [#1781](https://github.com/yesodweb/yesod/pull/1781) + +## 1.6.14 + +* Fix quotes not matching in htmlContain* functions [#1768](https://github.com/yesodweb/yesod/pull/1768). +* Add logging of the matches found of these functions [#1768](https://github.com/yesodweb/yesod/pull/1768). +* Improved failure messages from `assertEq`. [#1767](https://github.com/yesodweb/yesod/pull/1767) + +## 1.6.13 + +* Add `Yesod.Test.Internal.SIO` module to expose the `SIO` type. + +## 1.6.12 + +* Fix import in cookie example [#1713](https://github.com/yesodweb/yesod/pull/1713) +* Add `MonadState` instance for `SIO` + +## 1.6.11 + +* Add missing `HasCallStack`s [#1710](https://github.com/yesodweb/yesod/pull/1710) + +## 1.6.10 + +* `statusIs` assertion failures now print a preview of the response body, if the response body is UTF-8 or ASCII. [#1680](https://github.com/yesodweb/yesod/pull/1680/files) +* Adds an `Yesod.Test.Internal`, which exposes functions that yesod-test uses. These functions do _not_ constitute a stable API. + +## 1.6.9.1 + +* Improve documentation [#1676](https://github.com/yesodweb/yesod/pull/1676) +* Require GHC 8.2 (base >= 4.10) + +## 1.6.9 + +Add `requireJSONResponse` function [#1646](https://github.com/yesodweb/yesod/pull/1646) + +## 1.6.8 + +Add `testModifySite` function [#1642](https://github.com/yesodweb/yesod/pull/1642) + +## 1.6.7 + +Add `addBasicAuthHeader` function [#1632](https://github.com/yesodweb/yesod/pull/1632) + +## 1.6.6.2 + +addPostParam will now URL-encode keys and values to prevent corruption +when special characters such as `&` are used +[#1617](https://github.com/yesodweb/yesod/pull/1617) + +## 1.6.6.1 + +* Documentation fixes +* Support for network 3 + +## 1.6.6 + +* Add utility functions to modify cookies [$1570](https://github.com/yesodweb/yesod/pull/1570) + +## 1.6.5.1 + +* Make test suite build with GHC 8.6 [#1561](https://github.com/yesodweb/yesod/pull/1561) + +## 1.6.5 +bodyEquals prints out actual body in addition to expected body in failure msg +[#1525](https://github.com/yesodweb/yesod/pull/1525) + +## 1.6.4 +Add yesodSpecWithSiteGeneratorAndArgument +[#1485](https://github.com/yesodweb/yesod/pull/1485) + +## 1.6.3 +Add performMethod +[#1502](https://github.com/yesodweb/yesod/pull/1502) + +## 1.6.2 + +* Add byLabel-related functions like byLabelContain +[#1482](https://github.com/yesodweb/yesod/pull/1482) + +## 1.6.1 + +* Fix the build with `base-4.11` (GHC 8.4). + +## 1.6.0 + +* Upgrade to yesod-core 1.6.0 + ## 1.5.9.1 -* Fix broken Haddocks +* Fixes a Haddock syntax error in 1.5.9 [#1473](https://github.com/yesodweb/yesod/pull/1473) ## 1.5.9 * Add byLabelExact and related functions diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -42,9 +42,9 @@ addToken -- Add the CSRF _token field with the currently shown value. -- Lookup field by the text on the labels pointing to them. - byLabel "Email:" "gustavo@cerati.com" - byLabel "Password:" "secret" - byLabel "Confirm:" "secret" + byLabelExact "Email:" "gustavo@cerati.com" + byLabelExact "Password:" "secret" + byLabelExact "Confirm:" "secret" it "Sends another form, this one has a file" $ do request $ do diff --git a/Yesod/Test.hs b/Yesod/Test.hs --- a/Yesod/Test.hs +++ b/Yesod/Test.hs @@ -1,1162 +1,1898 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ImplicitParams #-} -{-# LANGUAGE ConstraintKinds #-} - -{-| -Yesod.Test is a pragmatic framework for testing web applications built -using wai and persistent. - -By pragmatic I may also mean 'dirty'. Its main goal is to encourage integration -and system testing of web applications by making everything /easy to test/. - -Your tests are like browser sessions that keep track of cookies and the last -visited page. You can perform assertions on the content of HTML responses, -using CSS selectors to explore the document more easily. - -You can also easily build requests using forms present in the current page. -This is very useful for testing web applications built in yesod, for example, -where your forms may have field names generated by the framework or a randomly -generated CSRF token input. - -Your database is also directly available so you can use 'runDB' to set up -backend pre-conditions, or to assert that your session is having the desired effect. - --} - -module Yesod.Test - ( -- * Declaring and running your test suite - yesodSpec - , YesodSpec - , yesodSpecWithSiteGenerator - , yesodSpecApp - , YesodExample - , YesodExampleData(..) - , TestApp - , YSpec - , testApp - , YesodSpecTree (..) - , ydescribe - , yit - - -- * Making requests - -- | You can construct requests with the 'RequestBuilder' monad, which lets you - -- set the URL and add parameters, headers, and files. Helper functions are provided to - -- lookup fields by label and to add the current CSRF token from your forms. - -- Once built, the request can be executed with the 'request' method. - -- - -- Convenience functions like 'get' and 'post' build and execute common requests. - , get - , post - , postBody - , followRedirect - , getLocation - , request - , addRequestHeader - , setMethod - , addPostParam - , addGetParam - , addFile - , setRequestBody - , RequestBuilder - , setUrl - , clickOn - - -- *** Adding fields by label - -- | Yesod can auto generate field names, so you are never sure what - -- the argument name should be for each one of your inputs when constructing - -- your requests. What you do know is the /label/ of the field. - -- These functions let you add parameters to your request based - -- on currently displayed label names. - , byLabel - , byLabelExact - , fileByLabel - , fileByLabelExact - - -- *** CSRF Tokens - -- | In order to prevent CSRF exploits, yesod-form adds a hidden input - -- to your forms with the name "_token". This token is a randomly generated, - -- per-session value. - -- - -- In order to prevent your forms from being rejected in tests, use one of - -- these functions to add the token to your request. - , addToken - , addToken_ - , addTokenFromCookie - , addTokenFromCookieNamedToHeaderNamed - - -- * Assertions - , assertEqual - , assertNotEq - , assertEqualNoShow - , assertEq - - , assertHeader - , assertNoHeader - , statusIs - , bodyEquals - , bodyContains - , bodyNotContains - , htmlAllContain - , htmlAnyContain - , htmlNoneContain - , htmlCount - - -- * Grab information - , getTestYesod - , getResponse - , getRequestCookies - - -- * Debug output - , printBody - , printMatches - - -- * Utils for building your own assertions - -- | Please consider generalizing and contributing the assertions you write. - , 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 qualified Control.Monad.Trans.State as ST -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 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) -#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 instead" #-} -{-# DEPRECATED fileByLabel "This function seems to have multiple bugs (ref: https://github.com/yesodweb/yesod/pull/1459). Use fileByLabelExact instead" #-} - --- | The state used in a single test case defined using 'yit' --- --- Since 1.2.4 -data YesodExampleData site = YesodExampleData - { yedApp :: !Application - , yedSite :: !site - , yedCookies :: !Cookies - , yedResponse :: !(Maybe SResponse) - } - --- | A single test case, to be run with 'yit'. --- --- Since 1.2.0 -type YesodExample site = ST.StateT (YesodExampleData site) IO - --- | Mapping from cookie name to value. --- --- Since 1.2.0 -type Cookies = M.Map ByteString Cookie.SetCookie - --- | Corresponds to hspec\'s 'Spec'. --- --- Since 1.2.0 -type YesodSpec site = Writer [YesodSpecTree site] () - --- | Internal data structure, corresponding to hspec\'s 'YesodSpecTree'. --- --- Since 1.2.0 -data YesodSpecTree site - = YesodSpecGroup String [YesodSpecTree site] - | YesodSpecItem String (YesodExample site ()) - --- | Get the foundation value used for the current test. --- --- Since 1.2.0 -getTestYesod :: YesodExample site site -getTestYesod = fmap yedSite ST.get - --- | Get the most recently provided response value, if available. --- --- Since 1.2.0 -getResponse :: YesodExample site (Maybe SResponse) -getResponse = fmap yedResponse ST.get - -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 - --- | Request parts let us discern regular key/values from files sent in the request. -data RequestPart - = ReqKvPart T.Text T.Text - | ReqFilePart T.Text FilePath BSL8.ByteString T.Text - --- | The 'RequestBuilder' state monad constructs a URL encoded string of arguments --- to send with your requests. Some of the functions that run on it use the current --- response to analyze the forms that the server is expecting to receive. -type RequestBuilder site = ST.StateT (RequestBuilderData site) IO - --- | Start describing a Tests suite keeping cookies and a reference to the tested 'Application' --- and 'ConnectionPool' -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 - ST.evalStateT y YesodExampleData - { yedApp = app - , yedSite = site - , yedCookies = M.empty - , yedResponse = Nothing - } - --- | Same as yesodSpec, but instead of taking already built site it --- takes an action which produces site for each test. -yesodSpecWithSiteGenerator :: YesodDispatch site - => IO site - -> YesodSpec site - -> Hspec.Spec -yesodSpecWithSiteGenerator 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 $ do - site <- getSiteAction' - app <- toWaiAppPlain site - ST.evalStateT y YesodExampleData - { yedApp = app - , yedSite = site - , yedCookies = M.empty - , yedResponse = Nothing - } - --- | Same as yesodSpec, but instead of taking a site it --- takes an action which produces the 'Application' for each test. --- This lets you use your middleware from makeApplication -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 - ST.evalStateT y YesodExampleData - { yedApp = app - , yedSite = site - , yedCookies = M.empty - , yedResponse = Nothing - } - --- | Describe a single test that keeps cookies, and a reference to the last response. -yit :: String -> YesodExample site () -> YesodSpec site -yit label example = tell [YesodSpecItem label example] - --- Performs a given action using the last response. Use this to create --- response-level assertions -withResponse' :: MonadIO m - => (state -> Maybe SResponse) - -> [T.Text] - -> (SResponse -> ST.StateT state m a) - -> ST.StateT state m a -withResponse' getter errTrace f = maybe err f . getter =<< ST.get - 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 - --- | Performs a given action using the last response. Use this to create --- response-level assertions -withResponse :: (SResponse -> YesodExample site a) -> YesodExample site a -withResponse = withResponse' yedResponse [] - --- | Use HXT to parse a value from an HTML tag. --- Check for usage examples in this module's source. -parseHTML :: HtmlLBS -> Cursor -parseHTML html = fromDocument $ HD.parseLBS html - --- | Query the last response using CSS selectors, returns a list of matched fragments -htmlQuery' :: MonadIO m - => (state -> Maybe SResponse) - -> [T.Text] - -> Query - -> ST.StateT state m [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 - --- | Query the last response using CSS selectors, returns a list of matched fragments -htmlQuery :: Query -> YesodExample site [HtmlLBS] -htmlQuery = htmlQuery' yedResponse [] - --- | Asserts that the two given values are equal. --- --- In case they are not equal, error message includes the two values. --- --- @since 1.5.2 -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" - --- | Asserts that the two given values are not equal. --- --- In case they are equal, error mesasge includes the values. --- --- @since 1.5.6 -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 - --- | Asserts that the two given values are equal. --- --- @since 1.5.2 -assertEqualNoShow :: (HasCallStack, Eq a) => String -> a -> a -> YesodExample site () -assertEqualNoShow msg a b = liftIO $ HUnit.assertBool msg (a == b) - --- | Assert the last response status is as expected. -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 - ] - --- | Assert the given header key/value pair was returned. -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' - ] - --- | Assert the given header was not included in the response. -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 - ] - --- | Assert the last response is exactly equal to the given text. This is --- useful for testing API responses. -bodyEquals :: HasCallStack => String -> YesodExample site () -bodyEquals text = withResponse $ \ res -> - liftIO $ HUnit.assertBool ("Expected body to equal " ++ text) $ - (simpleBody res) == encodeUtf8 (TL.pack text) - --- | Assert the last response has the given text. The check is performed using the response --- body in full text form. -bodyContains :: HasCallStack => String -> YesodExample site () -bodyContains text = withResponse $ \ res -> - liftIO $ HUnit.assertBool ("Expected body to contain " ++ text) $ - (simpleBody res) `contains` text - --- | Assert the last response doesn't have the given text. The check is performed using the response --- body in full text form. --- @since 1.5.3 -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) - --- | Queries the HTML using a CSS selector, and all matched elements must contain --- the given string. -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) - --- | Queries the HTML using a CSS selector, and passes if any matched --- element contains the given string. --- --- Since 0.3.5 -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) - --- | Queries the HTML using a CSS selector, and fails if any matched --- element contains the given string (in other words, it is the logical --- inverse of htmlAnyContains). --- --- Since 1.2.2 -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" - --- | Performs a CSS query on the last response and asserts the matched elements --- are as many as expected. -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)) - --- | Outputs the last response body to stderr (So it doesn't get captured by HSpec) -printBody :: YesodExample site () -printBody = withResponse $ \ SResponse { simpleBody = b } -> - liftIO $ BSL8.hPutStrLn stderr b - --- | Performs a CSS query and print the matches to stderr. -printMatches :: Query -> YesodExample site () -printMatches query = do - matches <- htmlQuery query - liftIO $ hPutStrLn stderr $ show matches - --- | Add a parameter with the given name and value to the request body. -addPostParam :: T.Text -> T.Text -> RequestBuilder site () -addPostParam name value = - ST.modify $ \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 - --- | Add a parameter with the given name and value to the query string. -addGetParam :: T.Text -> T.Text -> RequestBuilder site () -addGetParam name value = ST.modify $ \rbd -> rbd - { rbdGets = (TE.encodeUtf8 name, Just $ TE.encodeUtf8 value) - : rbdGets 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. --- --- ==== __Examples__ --- --- > request $ do --- > addFile "profile_picture" "static/img/picture.png" "img/png" -addFile :: T.Text -- ^ The parameter name for the file. - -> FilePath -- ^ The path to the file. - -> T.Text -- ^ The MIME type of the file, e.g. "image/png". - -> RequestBuilder site () -addFile name path mimetype = do - contents <- liftIO $ BSL8.readFile path - ST.modify $ \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 - --- | --- This looks up the name of a field based on the contents of the label pointing to it. -genericNameFromLabel :: (T.Text -> T.Text -> Bool) -> T.Text -> RequestBuilder site T.Text -genericNameFromLabel match label = do - mres <- fmap rbdResponse ST.get - 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 - -(<>) :: T.Text -> T.Text -> T.Text -(<>) = T.append - -byLabelWithMatch :: (T.Text -> T.Text -> Bool) -- ^ The matching method which is used to find labels (i.e. exact, contains) - -> T.Text -- ^ The text contained in the @\