diff --git a/snap.cabal b/snap.cabal --- a/snap.cabal +++ b/snap.cabal @@ -1,5 +1,5 @@ name: snap -version: 0.13.0.4 +version: 0.13.1 synopsis: Top-level package for the Snap Web Framework description: This is the top-level package for the official Snap Framework libraries. diff --git a/src/Snap/Snaplet/Auth/Types.hs b/src/Snap/Snaplet/Auth/Types.hs --- a/src/Snap/Snaplet/Auth/Types.hs +++ b/src/Snap/Snaplet/Auth/Types.hs @@ -182,7 +182,7 @@ ------------------------------------------------------------------------------ --- | Authetication settings defined at initialization time +-- | Authentication settings defined at initialization time data AuthSettings = AuthSettings { asMinPasswdLen :: Int -- ^ Currently not used/checked diff --git a/src/Snap/Snaplet/Heist.hs b/src/Snap/Snaplet/Heist.hs --- a/src/Snap/Snaplet/Heist.hs +++ b/src/Snap/Snaplet/Heist.hs @@ -19,6 +19,7 @@ , addTemplates , addTemplatesAt , Unclassed.addConfig + , getHeistState , modifyHeistState , withHeistState @@ -121,6 +122,13 @@ -> Initializer b v () addTemplatesAt h pfx p = withTop' heistLens (Unclassed.addTemplatesAt h pfx p) + + +------------------------------------------------------------------------------ +-- | More general function allowing arbitrary HeistState modification. +getHeistState :: (HasHeist b) + => Handler b v (HeistState (Handler b b)) +getHeistState = Unclassed.getHeistState heistLens ------------------------------------------------------------------------------ diff --git a/src/Snap/Snaplet/Heist/Compiled.hs b/src/Snap/Snaplet/Heist/Compiled.hs --- a/src/Snap/Snaplet/Heist/Compiled.hs +++ b/src/Snap/Snaplet/Heist/Compiled.hs @@ -20,6 +20,7 @@ , H.addTemplates , H.addTemplatesAt , H.addConfig + , H.getHeistState , H.modifyHeistState , H.withHeistState diff --git a/src/Snap/Snaplet/Heist/Generic.hs b/src/Snap/Snaplet/Heist/Generic.hs --- a/src/Snap/Snaplet/Heist/Generic.hs +++ b/src/Snap/Snaplet/Heist/Generic.hs @@ -18,6 +18,7 @@ , addTemplates , addTemplatesAt , addConfig + , getHeistState , modifyHeistState , withHeistState diff --git a/src/Snap/Snaplet/Heist/Interpreted.hs b/src/Snap/Snaplet/Heist/Interpreted.hs --- a/src/Snap/Snaplet/Heist/Interpreted.hs +++ b/src/Snap/Snaplet/Heist/Interpreted.hs @@ -19,6 +19,7 @@ , addTemplates , addTemplatesAt , addConfig + , getHeistState , modifyHeistState , withHeistState diff --git a/src/Snap/Snaplet/HeistNoClass.hs b/src/Snap/Snaplet/HeistNoClass.hs --- a/src/Snap/Snaplet/HeistNoClass.hs +++ b/src/Snap/Snaplet/HeistNoClass.hs @@ -26,6 +26,7 @@ , addTemplates , addTemplatesAt + , getHeistState , modifyHeistState , modifyHeistState' , withHeistState @@ -219,6 +220,12 @@ Running _ _ _ _ -> error "Can't get HeistConfig after heist is initialized." + +------------------------------------------------------------------------------ +getHeistState :: SnapletLens (Snaplet b) (Heist b) + -> Handler b v (HeistState (Handler b b)) +getHeistState heist = withTop' heist $ gets _heistState + ------------------------------------------------------------------------------ modifyHeistState' :: SnapletLens (Snaplet b) (Heist b) diff --git a/src/Snap/Snaplet/Test.hs b/src/Snap/Snaplet/Test.hs --- a/src/Snap/Snaplet/Test.hs +++ b/src/Snap/Snaplet/Test.hs @@ -16,6 +16,7 @@ import qualified Control.Exception as E import Control.Monad.IO.Class import Data.Maybe (fromMaybe) +import Data.IORef import Data.Text import System.Directory import System.IO.Error @@ -50,6 +51,27 @@ ------------------------------------------------------------------------------ +-- | Helper to keep "runHandler" and "evalHandler" DRY. +execHandlerComputation :: MonadIO m + => (RequestBuilder m () -> Snap v -> m a) + -> Maybe String + -> RequestBuilder m () + -> Handler b b v + -> SnapletInit b b + -> m (Either Text a) +execHandlerComputation f env rq h s = do + app <- getSnaplet env s + case app of + (Left e) -> return $ Left e + (Right (a, is)) -> do + res <- f rq $ runPureBase h a + -- Run the cleanup action + liftIO $ do + cleanupAction <- readIORef $ _cleanup is + cleanupAction + return $ Right res + +------------------------------------------------------------------------------ -- | Given a Snaplet Handler and a 'RequestBuilder' defining -- a test request, runs the Handler, producing an HTTP 'Response'. -- @@ -59,16 +81,10 @@ runHandler :: MonadIO m => Maybe String -> RequestBuilder m () - -> Handler b b a + -> Handler b b v -> SnapletInit b b -> m (Either Text Response) -runHandler env rq h s = do - app <- getSnaplet env s - case app of - (Left e) -> return $ Left e - (Right (a,_)) -> do - res <- ST.runHandler rq $ runPureBase h a - return $ Right res +runHandler = execHandlerComputation ST.runHandler ------------------------------------------------------------------------------ @@ -88,13 +104,7 @@ -> Handler b b a -> SnapletInit b b -> m (Either Text a) -evalHandler env rq h s = do - app <- getSnaplet env s - case app of - (Left e) -> return $ Left e - (Right (a,_)) -> do - res <- ST.evalHandler rq $ runPureBase h a - return $ Right res +evalHandler = execHandlerComputation ST.evalHandler ------------------------------------------------------------------------------ diff --git a/test/snap-testsuite.cabal b/test/snap-testsuite.cabal --- a/test/snap-testsuite.cabal +++ b/test/snap-testsuite.cabal @@ -16,13 +16,13 @@ HUnit >= 1.2 && < 2, QuickCheck >= 2.3.0.2, blaze-builder >= 0.3 && < 0.4, - http-streams >= 0.4.0.1 && < 0.5, + http-streams >= 0.4.0.1 && < 0.8, process == 1.*, - smallcheck >= 0.6 && < 0.7, - test-framework >= 0.6 && < 0.7, - test-framework-hunit >= 0.2.7 && < 0.3, - test-framework-quickcheck2 >= 0.2.12.1 && < 0.3, - test-framework-smallcheck >= 0.1 && < 0.2, + smallcheck >= 0.6 && < 1.1, + test-framework >= 0.6 && < 0.9, + test-framework-hunit >= 0.2.7 && < 0.4, + test-framework-quickcheck2 >= 0.2.12.1 && < 0.4, + test-framework-smallcheck >= 0.1 && < 0.3, unix >= 2.2.0.0 && < 2.7, MonadCatchIO-transformers >= 0.2 && < 0.4, @@ -42,7 +42,7 @@ -- Blacklist bad versions of hashable hashable (>= 1.1 && < 1.2) || (>= 1.2.0.6 && <1.3), heist >= 0.13 && < 0.14, - logict >= 0.4.2 && < 0.6, + logict >= 0.4.2 && < 0.7, mtl > 2.0 && < 2.2, mwc-random >= 0.8 && < 0.14, pwstore-fast >= 2.2 && < 2.5, @@ -114,7 +114,7 @@ -- Blacklist bad versions of hashable hashable (>= 1.1 && < 1.2) || (>= 1.2.0.6 && <1.3), heist >= 0.13 && < 0.14, - logict >= 0.4.2 && < 0.6, + logict >= 0.4.2 && < 0.7, mtl > 2.0 && < 2.2, mwc-random >= 0.8 && < 0.14, pwstore-fast >= 2.2 && < 2.5, @@ -170,13 +170,13 @@ Glob >= 0.5 && < 0.8, HUnit >= 1.2 && < 2, QuickCheck >= 2.3.0.2, - http-streams >= 0.4.0.1 && < 0.5, + http-streams >= 0.4.0.1 && < 0.8, process == 1.*, - smallcheck >= 0.6 && < 0.7, - test-framework >= 0.6 && < 0.7, - test-framework-hunit >= 0.2.7 && < 0.3, - test-framework-quickcheck2 >= 0.2.12.1 && < 0.3, - test-framework-smallcheck >= 0.1 && < 0.2, + smallcheck >= 0.6 && < 1.1, + test-framework >= 0.6 && < 0.9, + test-framework-hunit >= 0.2.7 && < 0.4, + test-framework-quickcheck2 >= 0.2.12.1 && < 0.4, + test-framework-smallcheck >= 0.1 && < 0.3, unix >= 2.2.0.0 && < 2.7, MonadCatchIO-transformers >= 0.2 && < 0.4, @@ -196,7 +196,7 @@ -- Blacklist bad versions of hashable hashable (>= 1.1 && < 1.2) || (>= 1.2.0.6 && <1.3), heist >= 0.13 && < 0.14, - logict >= 0.4.2 && < 0.6, + logict >= 0.4.2 && < 0.7, mtl > 2.0 && < 2.2, mwc-random >= 0.8 && < 0.14, pwstore-fast >= 2.2 && < 2.5,