Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP

Comparing changes

Choose two branches to see what's changed or to start a new pull request. If you need to, you can also compare across forks.

Open a pull request

Create a new pull request by comparing changes across two branches. If you need to, you can also compare across forks.
...
  • 10 commits
  • 17 files changed
  • 0 commit comments
  • 1 contributor
View
2  snap-core.cabal
@@ -152,7 +152,7 @@ Library
enumerator >= 0.4.13.1 && < 0.5,
filepath,
HUnit >= 1.2 && < 2,
- MonadCatchIO-transformers >= 0.2.1 && < 0.3,
+ monad-control >= 0.2,
mtl == 2.0.*,
mwc-random >= 0.10 && <0.11,
old-locale,
View
2  src/Snap/Core.hs
@@ -10,10 +10,10 @@ module Snap.Core
Snap
, runSnap
, MonadSnap(..)
+ , MonadCatchControl(..)
, NoHandlerException(..)
-- ** Functions for control flow and early termination
- , bracketSnap
, finishWith
, catchFinishWith
, pass
View
2  src/Snap/Internal/Debug.hs
@@ -21,7 +21,7 @@ import Control.Monad.Trans
#ifndef NODEBUG
import Control.Concurrent
import Control.DeepSeq
-import Control.Exception
+import Control.Exception.Control
import Data.Char
import Data.List
import Data.Maybe
View
1  src/Snap/Internal/Http/Types.hs
@@ -23,7 +23,6 @@ import Data.ByteString (ByteString)
import qualified Data.ByteString.Char8 as B
import Data.ByteString.Internal (c2w,w2c)
import qualified Data.ByteString as S
-import Data.Char
import Data.Int
import qualified Data.IntMap as IM
import Data.IORef
View
19 src/Snap/Internal/Instances.hs
@@ -4,7 +4,7 @@
module Snap.Internal.Instances where
import Control.Applicative
-import Control.Monad.CatchIO ()
+import Control.Exception.Control ()
import Control.Monad.Cont
import Control.Monad.Error
import Control.Monad.List
@@ -34,9 +34,9 @@ instance MonadPlus m => Alternative (ContT c m) where
------------------------------------------------------------------------------
-instance MonadSnap m => MonadSnap (ContT c m) where
- liftSnap = lift . liftSnap
-
+{- instance MonadSnap m => MonadSnap (ContT c m) where-}
+ {- liftSnap = lift . liftSnap-}
+ -- TODO: Re-enable
------------------------------------------------------------------------------
instance (MonadSnap m, Error e) => MonadSnap (ErrorT e m) where
@@ -81,3 +81,14 @@ instance (MonadSnap m, Monoid w) => MonadSnap (WriterT w m) where
------------------------------------------------------------------------------
instance (MonadSnap m, Monoid w) => MonadSnap (LWriter.WriterT w m) where
liftSnap = lift . liftSnap
+
+
+instance (Error e, MonadCatchControl m) => MonadCatchControl (ErrorT e m)
+instance (MonadCatchControl m) => MonadCatchControl (ListT m)
+instance (MonadCatchControl m) => MonadCatchControl (StateT s m)
+instance (MonadCatchControl m) => MonadCatchControl (ReaderT r m)
+instance (Monoid w, MonadCatchControl m) => MonadCatchControl (RWST r w s m)
+instance (Monoid w, MonadCatchControl m) => MonadCatchControl (LRWS.RWST r w s m)
+instance (Monoid w, MonadCatchControl m) => MonadCatchControl (WriterT w m)
+instance (Monoid w, MonadCatchControl m) => MonadCatchControl (LWriter.WriterT w m)
+
View
80 src/Snap/Internal/Types.hs
@@ -15,9 +15,10 @@ module Snap.Internal.Types where
import Blaze.ByteString.Builder
import Blaze.ByteString.Builder.Char.Utf8
import Control.Applicative
-import Control.Exception (SomeException, throwIO, ErrorCall(..))
+import Control.Exception.Control hiding (catch, catches)
+import qualified Control.Exception.Control as CEC
import Control.Monad
-import Control.Monad.CatchIO
+import Control.Monad.IO.Control
import qualified Control.Monad.Error.Class as EC
import Control.Monad.State
import Data.ByteString.Char8 (ByteString)
@@ -100,7 +101,7 @@ import Snap.Iteratee
> a :: Snap ()
> a = setTimeout 30
-8. throw and catch exceptions using a 'MonadCatchIO' instance:
+8. throw and catch exceptions using a 'MonadControlIO' instance:
> foo :: Snap ()
> foo = bar `catch` \(e::SomeException) -> baz
@@ -125,8 +126,8 @@ transformers ('ReaderT', 'WriterT', 'StateT', etc.).
------------------------------------------------------------------------------
-- | 'MonadSnap' is a type class, analogous to 'MonadIO' for 'IO', that makes
-- it easy to wrap 'Snap' inside monad transformers.
-class (Monad m, MonadIO m, MonadCatchIO m, MonadPlus m, Functor m,
- Applicative m, Alternative m) => MonadSnap m where
+class (Monad m, MonadIO m, MonadCatchControl m, MonadControlIO m, MonadPlus m,
+ Functor m, Applicative m, Alternative m) => MonadSnap m where
liftSnap :: Snap a -> m a
@@ -184,21 +185,39 @@ instance MonadIO Snap where
------------------------------------------------------------------------------
-instance MonadCatchIO Snap where
- catch (Snap m) handler = Snap $ m `catch` h
- where
- h e = do
- rethrowIfTermination $ fromException e
- maybe (throw e)
- (\e' -> let (Snap z) = handler e' in z)
- (fromException e)
+instance MonadControlIO Snap where
+ liftControlIO f = liftIO (f return)
- block (Snap m) = Snap $ block m
- unblock (Snap m) = Snap $ unblock m
+class (MonadControlIO m) => MonadCatchControl m where
+ catch :: (Exception e)
+ => m a -- ^ The computation to run
+ -> (e -> m a) -- ^ Handler to invoke if an exception is raised
+ -> m a
+ catch = CEC.catch
-------------------------------------------------------------------------------
-rethrowIfTermination :: (MonadCatchIO m) =>
+ catches :: m a -> [CEC.Handler m a] -> m a
+ catches = CEC.catches
+
+instance (MonadCatchControl m) => MonadCatchControl (Iteratee a m)
+instance (MonadCatchControl m) => MonadCatchControl (StateT s m)
+
+instance MonadCatchControl IO
+
+instance MonadCatchControl Snap where
+ catch (Snap m) handler = Snap $ m `catch` h
+ where
+ h e = do
+ rethrowIfTermination $ fromException e
+ maybe (throw e)
+ (\e' -> let (Snap z) = handler e' in z)
+ (fromException e)
+ catches a handlers = a `catch` handler where
+ handler e = foldr tryH (throw e) handlers where
+ tryH (CEC.Handler h) res = maybe res h $ fromException e
+
+------------------------------------------------------------------------------
+rethrowIfTermination :: (MonadIO m) =>
Maybe ConnectionTerminatedException ->
m ()
rethrowIfTermination Nothing = return ()
@@ -286,8 +305,8 @@ runRequestBody iter = do
let (SomeEnumerator enum) = senum
-- make sure the iteratee consumes all of the output
- let iter' = handle bumpTimeout req
- (iter >>= \a -> skipToEnd bumpTimeout >> return a)
+ let iter' = handle' bumpTimeout req
+ (iter >>= \a -> skipToEnd bumpTimeout >> return a)
-- run the iteratee
step <- liftIO $ runIteratee iter'
@@ -306,7 +325,7 @@ runRequestBody iter = do
skipToEnd bump = killIfTooSlow bump 500 5 skipToEof `catchError` \e ->
throwError $ ConnectionTerminatedException e
- handle bump req =
+ handle' bump req =
(`catches` [
Handler $ \(e :: ConnectionTerminatedException) -> do
let en = SomeEnumerator $ const $ throwError e
@@ -781,7 +800,7 @@ ipHeaderFilter' header = do
------------------------------------------------------------------------------
-- | This function brackets a Snap action in resource acquisition and
--- release. This is provided because MonadCatchIO's 'bracket' function
+-- release. This is provided because MonadControlIO's 'bracket' function
-- doesn't work properly in the case of a short-circuit return from
-- the action being bracketed.
--
@@ -798,14 +817,15 @@ ipHeaderFilter' header = do
-- 2. Short-circuit completion, either from calling 'fail' or 'finishWith'
--
-- 3. An exception being thrown.
-bracketSnap :: IO a -> (a -> IO b) -> (a -> Snap c) -> Snap c
-bracketSnap before after thing = block . Snap $ do
- a <- liftIO before
- let after' = liftIO $ after a
- (Snap thing') = thing a
- r <- unblock thing' `onException` after'
- _ <- after'
- return r
+-- TODO: Remove
+{- bracketSnap :: IO a -> (a -> IO b) -> (a -> Snap c) -> Snap c-}
+{- bracketSnap before after thing = block . Snap $ do-}
+{- a <- liftIO before-}
+{- let after' = liftIO $ after a-}
+{- (Snap thing') = thing a-}
+{- r <- unblock thing' `onException` after'-}
+{- _ <- after'-}
+{- return r-}
------------------------------------------------------------------------------
@@ -840,7 +860,7 @@ instance Exception ConnectionTerminatedException
------------------------------------------------------------------------------
-- | Terminate the HTTP session with the given exception.
-terminateConnection :: (Exception e, MonadCatchIO m) => e -> m a
+terminateConnection :: (Exception e, MonadIO m) => e -> m a
terminateConnection = throw . ConnectionTerminatedException . toException
View
40 src/Snap/Iteratee.hs
@@ -107,9 +107,9 @@ module Snap.Iteratee
import Blaze.ByteString.Builder
import Blaze.ByteString.Builder.Enumerator
import Control.DeepSeq
-import Control.Exception (SomeException, assert)
+import Control.Exception.Control
import Control.Monad
-import Control.Monad.CatchIO
+import Control.Monad.IO.Control
import Control.Monad.Trans (MonadIO, lift, liftIO)
import Data.ByteString (ByteString)
import qualified Data.ByteString.Char8 as S
@@ -121,7 +121,7 @@ import Data.Enumerator.Binary (enumHandle)
import Data.Enumerator.List hiding (take, drop)
import qualified Data.Enumerator.List as IL
import qualified Data.List as List
-import Data.Monoid (mappend)
+import Data.Monoid (mappend )
import Data.Time.Clock.POSIX (getPOSIXTime)
import Data.Typeable
import Foreign hiding (peek)
@@ -137,38 +137,8 @@ import System.PosixCompat.Types
#endif
------------------------------------------------------------------------------
-instance (Functor m, MonadCatchIO m) =>
- MonadCatchIO (Iteratee s m) where
- --catch :: Exception e => m a -> (e -> m a) -> m a
- catch m handler = insideCatch (m `catchError` h)
- where
- insideCatch !mm = Iteratee $ do
- ee <- try $ runIteratee mm
- case ee of
- (Left e) -> runIteratee $ handler e
- (Right v) -> step v
-
- step (Continue !k) = do
- return $ Continue (\s -> insideCatch $ k s)
- -- don't worry about Error here because the error had to come from the
- -- handler (because of 'catchError' above)
- step y = return y
-
- -- we can only catch iteratee errors if "e" matches "SomeException"
- h e = maybe (throwError e)
- (handler)
- (fromException e)
-
- --block :: m a -> m a
- block m = Iteratee $ block $ (runIteratee m >>= step)
- where
- step (Continue k) = return $ Continue (\s -> block (k s))
- step y = return y
-
- unblock m = Iteratee $ unblock $ (runIteratee m >>= step)
- where
- step (Continue k) = return $ Continue (\s -> unblock (k s))
- step y = return y
+instance (MonadControlIO m) => MonadControlIO (Iteratee s m) where
+ liftControlIO f = liftIO (f return)
------------------------------------------------------------------------------
View
4 src/Snap/Util/FileServe.hs
@@ -28,9 +28,9 @@ module Snap.Util.FileServe
import Blaze.ByteString.Builder
import Blaze.ByteString.Builder.Char8
import Control.Applicative
-import Control.Exception (SomeException, evaluate)
+import Control.Exception.Control hiding (catch)
import Control.Monad
-import Control.Monad.CatchIO
+import Control.Monad.IO.Control ()
import Control.Monad.Trans
import Data.Attoparsec.Char8 hiding (Done)
import qualified Data.ByteString.Char8 as S
View
6 src/Snap/Util/FileUploads.hs
@@ -67,9 +67,9 @@ module Snap.Util.FileUploads
import Control.Arrow
import Control.Applicative
import Control.Concurrent.MVar
-import Control.Exception (SomeException(..))
+import Control.Exception.Control hiding (catch, catches)
import Control.Monad
-import Control.Monad.CatchIO
+import Control.Monad.IO.Control
import Control.Monad.Trans
import qualified Data.Attoparsec.Char8 as Atto
import Data.Attoparsec.Char8 hiding (many, Result(..))
@@ -924,7 +924,7 @@ closeActiveFile (UploadedFiles stateRef _) = liftIO $ do
------------------------------------------------------------------------------
-eatException :: (MonadCatchIO m) => m a -> m ()
+eatException :: (MonadCatchControl m, MonadControlIO m) => m a -> m ()
eatException m =
(m >> return ()) `catch` (\(_ :: SomeException) -> return ())
View
4 src/Snap/Util/GZip.hs
@@ -11,13 +11,11 @@ module Snap.Util.GZip
import Blaze.ByteString.Builder
import qualified Codec.Zlib.Enum as Z
-import Control.Concurrent
import Control.Applicative hiding (many)
-import Control.Exception
+import Control.Exception.Control
import Control.Monad
import Control.Monad.Trans
import Data.Attoparsec.Char8 hiding (Done)
-import qualified Data.ByteString.Lazy.Char8 as L
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as S
import qualified Data.Char as Char
View
2  test/snap-core-testsuite.cabal
@@ -40,7 +40,7 @@ Executable testsuite
filepath,
HUnit >= 1.2 && < 2,
enumerator >= 0.4.13.1 && < 0.5,
- MonadCatchIO-transformers >= 0.2 && < 0.3,
+ monad-control >= 0.2,
mtl >= 2 && <3,
mwc-random >= 0.10 && <0.11,
old-locale,
View
67 test/suite/Snap/Core/Tests.hs
@@ -10,9 +10,8 @@ import Blaze.ByteString.Builder
import Control.Applicative
import Control.Concurrent.MVar
import Control.DeepSeq
-import Control.Exception (ErrorCall(..), SomeException, throwIO)
import Control.Monad
-import Control.Monad.CatchIO
+import Control.Exception.Control hiding (catch)
import Control.Monad.Trans (liftIO)
import Control.Parallel.Strategies
import Data.ByteString.Char8 (ByteString)
@@ -30,7 +29,7 @@ import Test.Framework
import Test.Framework.Providers.HUnit
import Test.Framework.Providers.QuickCheck2
import Test.HUnit hiding (Test, path)
-
+
import Snap.Internal.Http.Types
import Snap.Internal.Parsing
import Snap.Internal.Types
@@ -53,7 +52,6 @@ tests = [ testFail
, testMethod
, testMethods
, testDir
- , testCatchIO
, testWrites
, testParam
, testURLEncode1
@@ -63,8 +61,7 @@ tests = [ testFail
, testMZero404
, testEvalSnap
, testLocalRequest
- , testRedirect
- , testBracketSnap ]
+ , testRedirect ]
expectSpecificException :: Exception e => e -> IO a -> IO ()
@@ -138,23 +135,6 @@ mkRqWithEnum e = do
enum Nothing GET (1,1) [] "" "/" "/" "/" ""
Map.empty
-testCatchIO :: Test
-testCatchIO = testCase "types/catchIO" $ do
- (_,rsp) <- go f
- (_,rsp2) <- go g
-
- assertEqual "catchIO 1" (Just "bar") $ getHeader "foo" rsp
- assertEqual "catchIO 2" Nothing $ getHeader "foo" rsp2
-
- where
- f :: Snap ()
- f = (block $ unblock $ throw $ NoHandlerException "") `catch` h
-
- g :: Snap ()
- g = return () `catch` h
-
- h :: SomeException -> Snap ()
- h e = e `seq` modifyResponse $ addHeader "foo" "bar"
go :: Snap a -> IO (Request,Response)
go m = do
@@ -255,47 +235,6 @@ isRight (Right _) = True
isRight _ = False
-testBracketSnap :: Test
-testBracketSnap = testCase "types/bracketSnap" $ do
- rq <- mkZomgRq
-
- ref <- newIORef 0
-
- expectSpecificException (NoHandlerException "") $
- run_ $ evalSnap (act ref) (const $ return ()) (const $ return ()) rq
-
- y <- readIORef ref
- assertEqual "bracketSnap/after1" (1::Int) y
-
- expectSpecificException (ErrorCall "no value") $
- run_ $ evalSnap (act ref <|> finishWith emptyResponse)
- (const $ return ())
- (const $ return ())
- rq
-
- y' <- readIORef ref
- assertEqual "bracketSnap/after" 2 y'
-
-
- expectSpecificException (ErrorCall "foo") $
- run_ $ evalSnap (act2 ref)
- (const $ return ())
- (const $ return ())
- rq
-
- y'' <- readIORef ref
- assertEqual "bracketSnap/after" 3 y''
-
- where
- act ref = bracketSnap (liftIO $ readIORef ref)
- (\z -> liftIO $ writeIORef ref $! z+1)
- (\z -> z `seq` mzero)
-
- act2 ref = bracketSnap (liftIO $ readIORef ref)
- (\z -> liftIO $ writeIORef ref $! z+1)
- (\z -> z `seq` liftIO $ throwIO $ ErrorCall "foo")
-
-
testCatchFinishWith :: Test
testCatchFinishWith = testCase "types/catchFinishWith" $ do
rq <- mkZomgRq
View
2  test/suite/Snap/Internal/Routing/Tests.hs
@@ -5,7 +5,7 @@
module Snap.Internal.Routing.Tests
( tests ) where
-import Control.Exception
+import Control.Exception.Control
import Control.Monad
import Data.ByteString (ByteString)
import qualified Data.ByteString as B
View
24 test/suite/Snap/Iteratee/Tests.hs
@@ -7,10 +7,8 @@ module Snap.Iteratee.Tests
( tests ) where
import Control.Concurrent (threadDelay)
-import qualified Control.Exception as E
-import Control.Exception hiding (try, assert, throw, catch)
import Control.Monad
-import Control.Monad.CatchIO
+import Control.Exception.Control hiding (assert)
import Control.Monad.Identity
import Control.Monad.Trans
import qualified Data.ByteString.Base16 as B16
@@ -24,7 +22,6 @@ import System.Timeout
import Test.Framework
import Test.Framework.Providers.QuickCheck2
import Test.QuickCheck
-import Test.QuickCheck.Gen
import qualified Test.QuickCheck.Monadic as QC
import Test.QuickCheck.Monadic hiding (run)
import Test.Framework.Providers.HUnit
@@ -60,7 +57,6 @@ tests = [ testEnumBS
, testKillIfTooSlow2
, testBMH
, testBMHTrivials
- , testCatchIO
]
testEnumBS :: Test
@@ -497,24 +493,6 @@ testKillIfTooSlow2 = testCase "iteratee/killIfTooSlow2" $ do
H.assertEqual "testKillIfTooSlow2" (S.replicate 300 'f') m
-
-------------------------------------------------------------------------------
-testCatchIO :: Test
-testCatchIO = testCase "iteratee/monadCatchIO" $ do
- e <- run_ $ enumList 1 ["1", "2", "3", "4", "5"] $$ iter 0
- H.assertBool "handled exception" $ isJust e
-
- where
- iter !i = (continue $ k (i::Int)) `catch` h
-
- k _ EOF = return Nothing
- k i _ = if i >= 2
- then throw $ ErrorCall "should not escape!"
- else iter (i+1)
-
- h :: SomeException -> Iteratee ByteString IO (Maybe String)
- h e = return $ Just $ show e
-
------------------------------------------------------------------------------
tooSlowEnum :: Int -> Enumerator ByteString IO a
tooSlowEnum ntimes (Continue k) = do
View
9 test/suite/Snap/Test/Common.hs
@@ -17,15 +17,16 @@ module Snap.Test.Common
) where
import Control.DeepSeq
-import Control.Exception (SomeException(..), evaluate)
import Control.Monad
-import Control.Monad.CatchIO
+import Control.Exception.Control hiding (catch)
import Control.Monad.Trans
+import Control.Monad.IO.Control
import qualified Data.ByteString as S
import qualified Data.ByteString.Lazy as L
import Data.ByteString.Internal (c2w)
import Data.Typeable
import Prelude hiding (catch)
+import Snap.Core
import Test.QuickCheck
import qualified Test.QuickCheck.Monadic as QC
import Test.QuickCheck.Monadic
@@ -50,10 +51,10 @@ coverShowInstance x = a `deepseq` b `deepseq` c `deepseq` return ()
c = showList [x] ""
-eatException :: (MonadCatchIO m) => m a -> m ()
+eatException :: (MonadCatchControl m, MonadControlIO m) => m a -> m ()
eatException a = (a >> return ()) `catch` handler
where
- handler :: (MonadCatchIO m) => SomeException -> m ()
+ handler :: (MonadIO m) => SomeException -> m ()
handler _ = return ()
View
3  test/suite/Snap/Util/FileUploads/Tests.hs
@@ -10,9 +10,8 @@ module Snap.Util.FileUploads.Tests
import Control.Applicative
import Control.Concurrent (threadDelay)
import Control.DeepSeq
-import Control.Exception (Exception(..), SomeException(..))
import Control.Monad
-import Control.Monad.CatchIO
+import Control.Exception.Control hiding (catch)
import Control.Monad.Trans
import Data.ByteString (ByteString)
import qualified Data.ByteString.Char8 as S
View
2  test/suite/Snap/Util/GZip/Tests.hs
@@ -9,7 +9,7 @@ module Snap.Util.GZip.Tests
import Blaze.ByteString.Builder
import qualified Codec.Compression.GZip as GZip
import qualified Codec.Compression.Zlib as Zlib
-import Control.Exception hiding (assert)
+import Control.Exception.Control hiding (assert)
import Control.Monad (liftM)
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Lazy.Char8 as L

No commit comments for this range

Something went wrong with that request. Please try again.