Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

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.
...
Checking mergeability… Don't worry, you can still create the pull request.
  • 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.