diff --git a/yesod-test/ChangeLog.md b/yesod-test/ChangeLog.md index a343b366..1f641f2f 100644 --- a/yesod-test/ChangeLog.md +++ b/yesod-test/ChangeLog.md @@ -1,5 +1,9 @@ # ChangeLog for yesod-test +## 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) diff --git a/yesod-test/Yesod/Test.hs b/yesod-test/Yesod/Test.hs index eced072c..f2adff40 100644 --- a/yesod-test/Yesod/Test.hs +++ b/yesod-test/Yesod/Test.hs @@ -243,10 +243,7 @@ import Data.CaseInsensitive (CI) import qualified Data.CaseInsensitive as 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 qualified Control.Monad.State.Class as MS import System.IO import Yesod.Core.Unsafe (runFakeHandler) import Yesod.Test.TransversingCSS @@ -257,7 +254,6 @@ 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 @@ -281,6 +277,7 @@ import Data.Aeson (FromJSON, eitherDecode') import Control.Monad (unless) import Yesod.Test.Internal (getBodyTextPreview, contentTypeHeaderIsUtf8) +import Yesod.Test.Internal.SIO {-# 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" #-} @@ -431,7 +428,7 @@ yit :: String -> YesodExample site () -> YesodSpec site yit label example = tell [YesodSpecItem label example] -- | Modifies the site ('yedSite') of the test, and creates a new WAI app ('yedApp') for it. --- +-- -- yesod-test allows sending requests to your application to test that it handles them correctly. -- In rare cases, you may wish to modify that application in the middle of a test. -- This may be useful if you wish to, for example, test your application under a certain configuration, @@ -455,7 +452,7 @@ testModifySite :: YesodDispatch site => (site -> IO (site, Middleware)) -- ^ A function from the existing site, to a new site and middleware for a WAI app. -> YesodExample site () testModifySite newSiteFn = do - currentSite <- getTestYesod + currentSite <- getTestYesod (newSite, middleware) <- liftIO $ newSiteFn currentSite app <- liftIO $ toWaiAppPlain newSite modifySIO $ \yed -> yed { yedSite = newSite, yedApp = middleware app } @@ -812,7 +809,7 @@ printMatches query = do matches <- htmlQuery query liftIO $ hPutStrLn stderr $ show matches --- | Add a parameter with the given name and value to the request body. +-- | Add a parameter with the given name and value to the request body. -- This function can be called multiple times to add multiple parameters, and be mixed with calls to 'addFile'. -- -- "Post parameter" is an informal description of what is submitted by making an HTTP POST with an HTML @\@. @@ -1367,7 +1364,7 @@ setUrl url' = do -- > get "/foobar" -- > clickOn "a#idofthelink" -- --- @since 1.5.7 +-- @since 1.5.7 clickOn :: (HasCallStack, Yesod site) => Query -> YesodExample site () clickOn query = do withResponse' yedResponse ["Tried to invoke clickOn in order to read HTML of a previous response."] $ \ res -> @@ -1596,32 +1593,3 @@ instance YesodDispatch site => Hspec.Example (SIO (YesodExampleData site) a) whe 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) - -instance MS.MonadState s (SIO s) - where - get = getSIO - put = putSIO - -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 diff --git a/yesod-test/Yesod/Test/Internal/SIO.hs b/yesod-test/Yesod/Test/Internal/SIO.hs new file mode 100644 index 00000000..1f80deba --- /dev/null +++ b/yesod-test/Yesod/Test/Internal/SIO.hs @@ -0,0 +1,88 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ImplicitParams #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +-- | The 'SIO' type is used by "Yesod.Test" to provide exception-safe +-- environment between requests and assertions. +-- +-- This module is internal. Breaking changes to this module will not be +-- reflected in the major version of this package. +-- +-- @since 1.6.13 +module Yesod.Test.Internal.SIO where + +import Control.Monad.Trans.Reader (ReaderT (..)) +import Conduit (MonadThrow) +import qualified Control.Monad.State.Class as MS +import Yesod.Core +import Data.IORef + +-- | State + IO +-- +-- @since 1.6.0 +newtype SIO s a = SIO (ReaderT (IORef s) IO a) + deriving (Functor, Applicative, Monad, MonadIO, MonadThrow, MonadUnliftIO) + +instance MS.MonadState s (SIO s) + where + get = getSIO + put = putSIO + +-- | Retrieve the current state in the 'SIO' type. +-- +-- Equivalent to 'MS.get' +-- +-- @since 1.6.13 +getSIO :: SIO s s +getSIO = SIO $ ReaderT readIORef + +-- | Put the given @s@ into the 'SIO' state for later retrieval. +-- +-- Equivalent to 'MS.put', but the value is evaluated to weak head normal +-- form. +-- +-- @since 1.6.13 +putSIO :: s -> SIO s () +putSIO s = SIO $ ReaderT $ \ref -> writeIORef ref $! s + +-- | Modify the underlying @s@ state. +-- +-- This is strict in the function used, and is equivalent to 'MS.modify''. +-- +-- @since 1.6.13 +modifySIO :: (s -> s) -> SIO s () +modifySIO f = SIO $ ReaderT $ \ref -> modifyIORef' ref f + +-- | Run an 'SIO' action with the intial state @s@ provided, returning the +-- result, and discard the final state. +-- +-- @since 1.6.13 +evalSIO :: SIO s a -> s -> IO a +evalSIO action = + fmap snd . runSIO action + +-- | Run an 'SIO' action with the initial state @s@ provided, returning the +-- final state, and discarding the result. +-- +-- @since 1.6.13 +execSIO :: SIO s () -> s -> IO s +execSIO action = + fmap fst . runSIO action + +-- | Run an 'SIO' action with the initial state provided, returning both +-- the result of the computation as well as the final state. +-- +-- @since 1.6.13 +runSIO :: SIO s a -> s -> IO (s, a) +runSIO (SIO (ReaderT f)) s = do + ref <- newIORef s + a <- f ref + s' <- readIORef ref + pure (s', a) diff --git a/yesod-test/yesod-test.cabal b/yesod-test/yesod-test.cabal index e49f2541..2eb8491d 100644 --- a/yesod-test/yesod-test.cabal +++ b/yesod-test/yesod-test.cabal @@ -1,5 +1,5 @@ name: yesod-test -version: 1.6.12 +version: 1.6.13 license: MIT license-file: LICENSE author: Nubis @@ -46,6 +46,7 @@ library Yesod.Test.CssQuery Yesod.Test.TransversingCSS Yesod.Test.Internal + Yesod.Test.Internal.SIO ghc-options: -Wall test-suite test