yesod-test 1.6.16 → 1.6.19
raw patch · 4 files changed
+268/−13 lines, 4 filesnew-uploader
Files
- ChangeLog.md +11/−0
- Yesod/Test.hs +183/−10
- test/main.hs +73/−2
- yesod-test.cabal +1/−1
ChangeLog.md view
@@ -1,5 +1,16 @@ # ChangeLog for yesod-test +## 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
Yesod/Test.hs view
@@ -177,6 +177,9 @@ , fileByLabelContain , fileByLabelPrefix , fileByLabelSuffix+ , chooseByLabel+ , checkByLabel+ , selectByLabel -- *** CSRF Tokens -- | In order to prevent CSRF exploits, yesod-form adds a hidden input@@ -265,7 +268,6 @@ 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)@@ -277,7 +279,7 @@ #endif import Data.ByteArray.Encoding (convertToBase, Base(..)) import Network.HTTP.Types.Header (hContentType)-import Data.Aeson (FromJSON, eitherDecode')+import Data.Aeson (eitherDecode') import Control.Monad (unless) import Yesod.Test.Internal (getBodyTextPreview, contentTypeHeaderIsUtf8)@@ -546,7 +548,11 @@ -- In case they are not equal, the error message includes the two values. -- -- @since 1.5.2-assertEq :: (HasCallStack, Eq a, Show a) => String -> a -> a -> YesodExample site ()+assertEq :: (HasCallStack, Eq a, Show a)+ => String -- ^ The message prefix+ -> a -- ^ The expected value+ -> a -- ^ The actual value+ -> YesodExample site () assertEq m a b = liftIO $ HUnit.assertEqual msg a b where msg = "Assertion: " ++ m ++ "\n"@@ -857,7 +863,7 @@ -- parameter and no other parameters. -- -- @since 1.6.16--- +-- -- ==== __Examples__ -- -- > {-# LANGUAGE OverloadedStrings #-}@@ -904,12 +910,7 @@ -- This looks up the name of a field based on a CSS selector and the contents of the label pointing to it. genericNameFromSelectorLabel :: HasCallStack => (T.Text -> T.Text -> Bool) -> T.Text -> T.Text -> RequestBuilder site T.Text genericNameFromSelectorLabel match selector label = do- mres <- fmap rbdResponse getSIO- res <-- case mres of- Nothing -> failure "genericNameSelectorFromLabel: No response available"- Just res -> return res- let body = simpleBody res+ body <- htmlBody "genericNameSelectorFromLabel" html <- case findBySelector body selector of Left parseError -> failure $ "genericNameFromSelectorLabel: Parse error" <> T.pack parseError@@ -1665,3 +1666,175 @@ return ()) params ($ ())++-- | Finds the @\<label>@ with the given value, finds its corresponding @\<input>@, then make this input checked.+-- It is assumed the @\<input>@ has @type=radio@.+--+-- ==== __Examples__+--+-- Given this HTML, we want to submit @f1=2@ (i.e. radio button with "Blue" label) to the server:+--+-- > <form method="POST">+-- > <label for="hident2">Color</label>+-- > <div id="hident2">+-- > <div class="radio">+-- > <input id="hident2-none" type="radio" name="f1" value="none" checked>+-- > <label for="hident2-none"><None></label>+-- > </div>+-- > <div class="radio">+-- > <input id="hident2-1" type="radio" name="f1" value="1">+-- > <label for="hident2-1">Red</label>+-- > </div>+-- > <div class="radio">+-- > <input id="hident2-2" type="radio" name="f1" value="2">+-- > <label for="hident2-2">Blue</label>+-- > </div>+-- > <div class="radio">+-- > <input id="hident2-3" type="radio" name="f1" value="3">+-- > <label for="hident2-3">Gray</label>+-- > </div>+-- > <div class="radio">+-- > <input id="hident2-4" type="radio" name="f1" value="4">+-- > <label for="hident2-4">Black</label>+-- > </div>+-- > </div>+-- > </form>+--+-- You can set this parameter like so:+--+-- > request $ do+-- > chooseByLabel "Blue"+--+-- @since 1.6.17+chooseByLabel :: T.Text -> RequestBuilder site ()+chooseByLabel label = do+ name <- genericNameFromLabel (==) label+ value <- genericValueFromLabel (==) label+ addPostParam name value++-- | Finds the @\<label>@ with the given value, finds its corresponding @\<input>@, then make this input checked.+-- It is assumed the @\<input>@ has @type=checkbox@.+--+-- ==== __Examples__+--+-- Given this HTML, we want to submit @f1=2@ and @f1=4@ (i.e. checked checkboxes are "Blue" and "Black") to the server:+--+-- > <form method="POST">+-- > <label for="hident2">Colors</label>+-- > <span id="hident2">+-- > <input id="hident2-1" type="checkbox" name="f1" value="1">+-- > <label for="hident2-1">Red</label>+-- > <input id="hident2-2" type="checkbox" name="f1" value="2" checked>+-- > <label for="hident2-2">Blue</label>+-- > <input id="hident2-3" type="checkbox" name="f1" value="3">+-- > <label for="hident2-3">Gray</label>+-- > <input id="hident2-4" type="checkbox" name="f1" value="4" checked>+-- > <label for="hident2-4">Black</label>+-- > </span>+-- > </form>+--+-- You can set this parameter like so:+--+-- > request $ do+-- > checkByLabel "Blue"+-- > checkByLabel "Black"+--+-- @since 1.6.18+checkByLabel :: T.Text -> RequestBuilder site ()+checkByLabel label = do+ name <- genericNameFromLabel (==) label+ value <- genericValueFromLabel (==) label+ addPostParam name value++-- | Finds the @\<label>@ with the given value, finds its corresponding @\<select>@,+-- then finds corresponding @\<option>@ and make this options selected.+--+-- ==== __Examples__+--+-- Given this HTML, we want to submit @f1=2@ (i.e. selected option is "Blue") to the server:+--+-- > <form method="post" action="labels-select">+-- > <label for="hident2">Selection List</label>+-- > <select id="hident2" name="f1">+-- > <option value="1">Red</option>+-- > <option value="2">Blue</option>+-- > <option value="3">Gray</option>+-- > <option value="4">Black</option>+-- > </select>+-- > </form>+--+-- You can set this parameter like so:+--+-- > request $ do+-- > setMethod "POST"+-- > selectByLabel "Selection List" "Blue"+--+-- @since 1.6.19+selectByLabel :: T.Text -> T.Text -> RequestBuilder site ()+selectByLabel label option = do+ name <- genericNameFromLabel (==) label+ parsedHtml <- parseHTML <$> htmlBody "selectByLabel"+ let values = parsedHtml $// C.element "select"+ >=> attributeIs "name" name+ &/ C.element "option"+ >=> isContentMatch option+ >=> attribute "value"+ case values of+ [] -> failure $ T.concat ["selectByLabel: option '" , option, "' not found in select '", label, "'"]+ [value] -> addPostParam name value+ _ -> failure $ T.concat ["selectByLabel: too many options '", option, "' found in select '", label, "'"]+ where isContentMatch x c+ | x == T.concat (c $// content) = [c]+ | otherwise = []++-- |+-- This looks up the value of a field based on the contents of the label pointing to it.+genericValueFromLabel :: HasCallStack => (T.Text -> T.Text -> Bool) -> T.Text -> RequestBuilder site T.Text+genericValueFromLabel match label = do+ body <- htmlBody "genericValueFromLabel"+ case genericValueFromHTML match label body of+ Left e -> failure e+ Right x -> pure x++genericValueFromHTML :: (T.Text -> T.Text -> Bool) -> T.Text -> HtmlLBS -> Either T.Text T.Text+genericValueFromHTML match label html =+ let+ parsedHTML = parseHTML html+ mlabel = parsedHTML+ $// C.element "label"+ >=> isContentMatch label+ mfor = mlabel >>= attribute "for"++ isContentMatch x c+ | x `match` T.concat (c $// content) = [c]+ | otherwise = []++ in case mfor of+ for:[] -> do+ let mvalue = parsedHTML+ $// attributeIs "id" for+ >=> attribute "value"+ case mvalue of+ "":_ -> Left $ T.concat+ [ "Label "+ , label+ , " resolved to id "+ , for+ , " which was not found. "+ ]+ value:_ -> Right value+ [] -> Left $ "No input with id " <> for+ [] ->+ case filter (/= "") $ mlabel >>= (child >=> C.element "input" >=> attribute "value") of+ [] -> Left $ "No label contained: " <> label+ value:_ -> Right value+ _ -> Left $ "More than one label contained " <> label++htmlBody :: String -> RequestBuilder site BSL8.ByteString+htmlBody funcName = do+ mres <- fmap rbdResponse getSIO+ res <-+ case mres of+ Nothing -> failure $ T.pack $ funcName ++ ": No response available"+ Just res -> return res+ return $ simpleBody res
test/main.hs view
@@ -35,7 +35,7 @@ import Network.Wai (pathInfo, rawQueryString, requestHeaders) import Network.Wai.Test (SResponse(simpleBody)) import Numeric (showHex)-import Data.Maybe (fromMaybe)+import Data.Maybe (fromMaybe, isNothing) import Data.Either (isLeft, isRight) import Test.HUnit.Lang@@ -46,7 +46,6 @@ import UnliftIO.Exception (tryAny, SomeException, try, Exception) import Control.Monad.IO.Unlift (toIO) import qualified Web.Cookie as Cookie-import Data.Maybe (isNothing) import qualified Data.Text as T import qualified Data.ByteString.Char8 as B8 import Yesod.Test.Internal (contentTypeHeaderIsUtf8)@@ -314,6 +313,32 @@ setMethod "POST" setUrl ("/labels" :: Text) byLabel "Foo Bar" "yes"+ yit "can click radio button" $ do+ get ("/labels-radio-buttons" :: Text)+ request $ do+ setMethod "POST"+ setUrl ("/labels-radio-buttons" :: Text)+ chooseByLabel "Blue"+ addToken+ bodyContains "colorRadioButton = Just Blue"+ yit "can click check boxes" $ do+ get ("/labels-checkboxes" :: Text)+ request $ do+ setMethod "POST"+ setUrl ("/labels-checkboxes" :: Text)+ checkByLabel "Red"+ checkByLabel "Gray"+ addToken+ bodyContains "colorCheckBoxes = [Gray,Red]"+ yit "can select from select list" $ do+ get ("/labels-select" :: Text)+ request $ do+ setMethod "POST"+ setUrl ("/labels-select" :: Text)+ addToken+ selectByLabel "Selection List" "Blue"+ bodyContains "SelectionForm {colorSelection = Blue}"+ ydescribe "byLabel-related tests" $ do yit "fails with \"More than one label contained\" error" $ do get ("/labels2" :: Text)@@ -654,6 +679,52 @@ (sendStatusJSON status200 ([1] :: [Integer])) :: LiteHandler Value onStatic "get-json-wrong-content-type" $ dispatchTo $ do return ("[1]" :: Text)++ onStatic "labels-radio-buttons" $ dispatchTo $ do+ ((result, widget), _) <- runFormPost+ $ renderDivs+ $ RadioButtonForm <$> aopt (radioField' optionsEnum) "Color" Nothing+ case result of+ FormSuccess color -> return $ toHtml $ show color+ _ -> defaultLayout [whamlet|$newline never+ <p>+ ^{toHtml $ show result}+ <form method=post action="labels-radio-buttons">+ ^{widget}+ |]++ onStatic "labels-checkboxes" $ dispatchTo $ do+ ((result, widget), _) <- runFormPost+ $ renderDivs+ $ CheckboxesForm <$> areq (checkboxesField' optionsEnum) "Checkboxes" (Just [Blue, Black])+ case result of+ FormSuccess color -> return $ toHtml $ show color+ _ -> defaultLayout [whamlet|$newline never+ <p>+ ^{toHtml $ show result}+ <form method=post action="labels-checkboxes">+ ^{widget}+ |]++ onStatic "labels-select" $ dispatchTo $ do+ ((result, widget), _) <- runFormPost+ $ renderDivs+ $ SelectionForm <$> areq (selectField optionsEnum) "Selection List" Nothing+ case result of+ FormSuccess color -> return $ toHtml $ show color+ _ -> defaultLayout [whamlet|$newline never+ <p>+ ^{toHtml $ show result}+ <form method=post action="labels-checkboxes">+ ^{widget}+ |]++data Color = Red | Blue | Gray | Black+ deriving (Show, Eq, Enum, Bounded)++newtype RadioButtonForm = RadioButtonForm { colorRadioButton :: Maybe Color } deriving Show+newtype CheckboxesForm = CheckboxesForm { colorCheckBoxes :: [Color] } deriving Show+newtype SelectionForm = SelectionForm {colorSelection :: Color } deriving Show cookieApp :: LiteApp cookieApp = liteApp $ do
yesod-test.cabal view
@@ -1,5 +1,5 @@ name: yesod-test-version: 1.6.16+version: 1.6.19 license: MIT license-file: LICENSE author: Nubis <nubis@woobiz.com.ar>