yesod-test 1.5.9.1 → 1.6.0
raw patch · 4 files changed
+73/−40 lines, 4 filesdep +conduitdep +unliftiodep −lifted-basedep −monad-controldep ~yesod-coredep ~yesod-form
Dependencies added: conduit, unliftio
Dependencies removed: lifted-base, monad-control
Dependency ranges changed: yesod-core, yesod-form
Files
- ChangeLog.md +5/−1
- Yesod/Test.hs +58/−32
- test/main.hs +5/−2
- yesod-test.cabal +5/−5
ChangeLog.md view
@@ -1,6 +1,10 @@+## 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
Yesod/Test.hs view
@@ -6,6 +6,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ImplicitParams #-} {-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-| Yesod.Test is a pragmatic framework for testing web applications built@@ -63,6 +64,7 @@ , addFile , setRequestBody , RequestBuilder+ , SIO , setUrl , clickOn @@ -135,7 +137,8 @@ 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.Trans.Reader (ReaderT (..))+import Conduit (MonadThrow) import Control.Monad.IO.Class import System.IO import Yesod.Core.Unsafe (runFakeHandler)@@ -147,6 +150,7 @@ 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@@ -180,7 +184,7 @@ -- | A single test case, to be run with 'yit'. -- -- Since 1.2.0-type YesodExample site = ST.StateT (YesodExampleData site) IO+type YesodExample site = SIO (YesodExampleData site) -- | Mapping from cookie name to value. --@@ -203,13 +207,13 @@ -- -- Since 1.2.0 getTestYesod :: YesodExample site site-getTestYesod = fmap yedSite ST.get+getTestYesod = fmap yedSite getSIO -- | Get the most recently provided response value, if available. -- -- Since 1.2.0 getResponse :: YesodExample site (Maybe SResponse)-getResponse = fmap yedResponse ST.get+getResponse = fmap yedResponse getSIO data RequestBuilderData site = RequestBuilderData { rbdPostData :: RBDPostData@@ -232,7 +236,7 @@ -- | 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+type RequestBuilder site = SIO (RequestBuilderData site) -- | Start describing a Tests suite keeping cookies and a reference to the tested 'Application' -- and 'ConnectionPool'@@ -249,7 +253,7 @@ 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+ evalSIO y YesodExampleData { yedApp = app , yedSite = site , yedCookies = M.empty@@ -269,7 +273,7 @@ unYesod getSiteAction' (YesodSpecItem x y) = Hspec.specItem x $ do site <- getSiteAction' app <- toWaiAppPlain site- ST.evalStateT y YesodExampleData+ evalSIO y YesodExampleData { yedApp = app , yedSite = site , yedCookies = M.empty@@ -290,7 +294,7 @@ unYesod (YesodSpecGroup x y) = Hspec.specGroup x $ map unYesod y unYesod (YesodSpecItem x y) = Hspec.specItem x $ do app <- getApp- ST.evalStateT y YesodExampleData+ evalSIO y YesodExampleData { yedApp = app , yedSite = site , yedCookies = M.empty@@ -303,12 +307,11 @@ -- Performs a given action using the last response. Use this to create -- response-level assertions-withResponse' :: MonadIO m- => (state -> Maybe SResponse)+withResponse' :: (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+ -> (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."@@ -327,11 +330,10 @@ 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)+htmlQuery' :: (state -> Maybe SResponse) -> [T.Text] -> Query- -> ST.StateT state m [HtmlLBS]+ -> 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)@@ -496,14 +498,14 @@ -- | 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)) }+ 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 -- | 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+addGetParam name value = modifySIO $ \rbd -> rbd { rbdGets = (TE.encodeUtf8 name, Just $ TE.encodeUtf8 value) : rbdGets rbd }@@ -522,7 +524,7 @@ -> RequestBuilder site () addFile name path mimetype = do contents <- liftIO $ BSL8.readFile path- ST.modify $ \rbd -> rbd { rbdPostData = (addPostData (rbdPostData rbd) contents) }+ 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@@ -531,7 +533,7 @@ -- 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+ mres <- fmap rbdResponse getSIO res <- case mres of Nothing -> failure "genericNameFromLabel: No response available"@@ -798,7 +800,7 @@ -- Since 1.4.3.2 getRequestCookies :: RequestBuilder site Cookies getRequestCookies = do- requestBuilderData <- ST.get+ 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."@@ -906,7 +908,7 @@ -- > request $ do -- > setMethod methodPut setMethod :: H.Method -> RequestBuilder site ()-setMethod m = ST.modify $ \rbd -> rbd { rbdMethod = m }+setMethod m = modifySIO $ \rbd -> rbd { rbdMethod = m } -- | Sets the URL used by the request. --@@ -921,7 +923,7 @@ => url -> RequestBuilder site () setUrl url' = do- site <- fmap rbdSite ST.get+ site <- fmap rbdSite getSIO eurl <- Yesod.Core.Unsafe.runFakeHandler M.empty (const $ error "Yesod.Test: No logger available")@@ -929,7 +931,7 @@ (toTextUrl url') url <- either (error . show) return eurl let (urlPath, urlQuery) = T.break (== '?') url- ST.modify $ \rbd -> rbd+ modifySIO $ \rbd -> rbd { rbdPath = case DL.filter (/="") $ H.decodePathSegments $ TE.encodeUtf8 urlPath of ("http:":_:rest) -> rest@@ -968,7 +970,7 @@ -- > request $ do -- > setRequestBody $ encode $ object ["age" .= (1 :: Integer)] setRequestBody :: BSL8.ByteString -> RequestBuilder site ()-setRequestBody body = ST.modify $ \rbd -> rbd { rbdPostData = BinaryPostData body }+setRequestBody body = modifySIO $ \rbd -> rbd { rbdPostData = BinaryPostData body } -- | Adds the given header to the request; see "Network.HTTP.Types.Header" for creating 'Header's. --@@ -978,7 +980,7 @@ -- > request $ do -- > addRequestHeader (hUserAgent, "Chrome/41.0.2228.0") addRequestHeader :: H.Header -> RequestBuilder site ()-addRequestHeader header = ST.modify $ \rbd -> rbd+addRequestHeader header = modifySIO $ \rbd -> rbd { rbdHeaders = header : rbdHeaders rbd } @@ -998,9 +1000,9 @@ request :: RequestBuilder site () -> YesodExample site () request reqBuilder = do- YesodExampleData app site oldCookies mRes <- ST.get+ YesodExampleData app site oldCookies mRes <- getSIO - RequestBuilderData {..} <- liftIO $ ST.execStateT reqBuilder RequestBuilderData+ RequestBuilderData {..} <- liftIO $ execSIO reqBuilder RequestBuilderData { rbdPostData = MultipleItemsPostData [] , rbdResponse = mRes , rbdMethod = "GET"@@ -1040,7 +1042,7 @@ }) app let newCookies = parseSetCookies $ simpleHeaders response cookies' = M.fromList [(Cookie.setCookieName c, c) | c <- newCookies] `M.union` cookies- ST.put $ YesodExampleData app site cookies' (Just response)+ putSIO $ YesodExampleData app site cookies' (Just response) where isFile (ReqFilePart _ _ _ _) = True isFile _ = False@@ -1144,14 +1146,14 @@ testApp site middleware = (site, middleware) type YSpec site = Hspec.SpecWith (TestApp site) -instance YesodDispatch site => Hspec.Example (ST.StateT (YesodExampleData site) IO a) where- type Arg (ST.StateT (YesodExampleData site) IO a) = 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- _ <- ST.evalStateT example YesodExampleData+ _ <- evalSIO example YesodExampleData { yedApp = middleware app , yedSite = site , yedCookies = M.empty@@ -1160,3 +1162,27 @@ return ()) params ($ ())++-- | State + IO+--+-- @since 1.6.0+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
test/main.hs view
@@ -1,3 +1,6 @@+-- Ignore warnings about using deprecated byLabel/fileByLabel functions+{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}+ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE CPP #-}@@ -34,7 +37,7 @@ import qualified Data.Map as Map import qualified Text.HTML.DOM as HD import Network.HTTP.Types.Status (status301, status303, unsupportedMediaType415)-import Control.Exception.Lifted(SomeException, try)+import UnliftIO.Exception (tryAny, SomeException, try) parseQuery_ :: Text -> [[SelectorGroup]] parseQuery_ = either error id . parseQuery@@ -189,7 +192,7 @@ bodyEquals "<html><head><title>Hello</title></head><body><p>Hello World</p><p>Hello Moon</p></body></html>" get ("/htmlWithLink" :: Text)- (bad :: Either SomeException ()) <- try (clickOn "a#nonexistentlink")+ bad <- tryAny (clickOn "a#nonexistentlink") assertEq "bad link" (isLeft bad) True
yesod-test.cabal view
@@ -1,5 +1,5 @@ name: yesod-test-version: 1.5.9.1+version: 1.6.0 license: MIT license-file: LICENSE author: Nubis <nubis@woobiz.com.ar>@@ -27,7 +27,6 @@ , hspec-core == 2.* , html-conduit >= 0.1 , http-types >= 0.7- , monad-control , network >= 2.2 , persistent >= 1.0 , pretty-show >= 1.6@@ -38,7 +37,8 @@ , wai-extra , xml-conduit >= 1.0 , xml-types >= 0.3- , yesod-core >= 1.4.14+ , yesod-core >= 1.6+ , conduit exposed-modules: Yesod.Test Yesod.Test.CssQuery@@ -58,11 +58,11 @@ , containers , html-conduit , yesod-core- , yesod-form >= 1.4.14+ , yesod-form >= 1.6 , text , wai- , lifted-base , http-types+ , unliftio source-repository head type: git