From 60d074883447e6fc16a4cf4e7ed990f1511a8593 Mon Sep 17 00:00:00 2001 From: parsonsmatt Date: Wed, 13 Apr 2022 16:27:01 -0600 Subject: [PATCH 1/2] Expose SIO type --- yesod-test/ChangeLog.md | 4 ++ yesod-test/Yesod/Test.hs | 42 +++------------------ yesod-test/Yesod/Test/Internal/SIO.hs | 54 +++++++++++++++++++++++++++ yesod-test/yesod-test.cabal | 1 + 4 files changed, 64 insertions(+), 37 deletions(-) create mode 100644 yesod-test/Yesod/Test/Internal/SIO.hs diff --git a/yesod-test/ChangeLog.md b/yesod-test/ChangeLog.md index a343b366..03460acc 100644 --- a/yesod-test/ChangeLog.md +++ b/yesod-test/ChangeLog.md @@ -1,5 +1,9 @@ # ChangeLog for yesod-test +## TODO + +* 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..5f6df528 --- /dev/null +++ b/yesod-test/Yesod/Test/Internal/SIO.hs @@ -0,0 +1,54 @@ +{-# 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 TODO +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 + +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.cabal b/yesod-test/yesod-test.cabal index e49f2541..1c93f246 100644 --- a/yesod-test/yesod-test.cabal +++ b/yesod-test/yesod-test.cabal @@ -46,6 +46,7 @@ library Yesod.Test.CssQuery Yesod.Test.TransversingCSS Yesod.Test.Internal + Yesod.Test.Internal.SIO ghc-options: -Wall test-suite test From ef4178f4c878d328662fd0444a82384acb1ffdc4 Mon Sep 17 00:00:00 2001 From: parsonsmatt Date: Thu, 14 Apr 2022 08:50:41 -0600 Subject: [PATCH 2/2] Add runSIO, changelog, version bump --- yesod-test/ChangeLog.md | 2 +- yesod-test/Yesod/Test/Internal/SIO.hs | 46 +++++++++++++++++++++++---- yesod-test/yesod-test.cabal | 2 +- 3 files changed, 42 insertions(+), 8 deletions(-) diff --git a/yesod-test/ChangeLog.md b/yesod-test/ChangeLog.md index 03460acc..1f641f2f 100644 --- a/yesod-test/ChangeLog.md +++ b/yesod-test/ChangeLog.md @@ -1,6 +1,6 @@ # ChangeLog for yesod-test -## TODO +## 1.6.13 * Add `Yesod.Test.Internal.SIO` module to expose the `SIO` type. diff --git a/yesod-test/Yesod/Test/Internal/SIO.hs b/yesod-test/Yesod/Test/Internal/SIO.hs index 5f6df528..1f80deba 100644 --- a/yesod-test/Yesod/Test/Internal/SIO.hs +++ b/yesod-test/Yesod/Test/Internal/SIO.hs @@ -15,7 +15,7 @@ -- This module is internal. Breaking changes to this module will not be -- reflected in the major version of this package. -- --- @since TODO +-- @since 1.6.13 module Yesod.Test.Internal.SIO where import Control.Monad.Trans.Reader (ReaderT (..)) @@ -35,20 +35,54 @@ instance MS.MonadState s (SIO s) 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 (SIO (ReaderT f)) s = newIORef s >>= f +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 (SIO (ReaderT f)) s = do - ref <- newIORef s - f ref - readIORef ref +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 1c93f246..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