diff --git a/CONTRIBUTORS b/CONTRIBUTORS --- a/CONTRIBUTORS +++ b/CONTRIBUTORS @@ -7,3 +7,4 @@ Jacob Stanley Jonas Kramer Jurriën Stutterheim +Jasper Van der Jeugt diff --git a/snap-core.cabal b/snap-core.cabal --- a/snap-core.cabal +++ b/snap-core.cabal @@ -1,5 +1,5 @@ name: snap-core -version: 0.6.0 +version: 0.6.0.1 synopsis: Snap: A Haskell Web Framework (Core) description: @@ -164,6 +164,24 @@ unordered-containers >= 0.1.4.3 && <0.2, vector >= 0.6 && <0.10, zlib-enum >= 0.2.1 && <0.3 + + extensions: + BangPatterns, + CPP, + PackageImports, + ScopedTypeVariables, + EmptyDataDecls, + ForeignFunctionInterface, + OverloadedStrings, + Rank2Types, + TypeSynonymInstances, + FlexibleInstances, + ExistentialQuantification, + OverloadedStrings, + FlexibleContexts, + GeneralizedNewtypeDeriving, + DeriveDataTypeable, + MultiParamTypeClasses ghc-prof-options: -prof -auto-all diff --git a/src/Snap/Core.hs b/src/Snap/Core.hs --- a/src/Snap/Core.hs +++ b/src/Snap/Core.hs @@ -11,6 +11,7 @@ , runSnap , MonadSnap(..) , NoHandlerException(..) + , EscapeHttpException(..) -- ** Functions for control flow and early termination , bracketSnap @@ -18,6 +19,7 @@ , catchFinishWith , pass , terminateConnection + , escapeHttp -- ** Routing , method diff --git a/src/Snap/Internal/Http/Types.hs b/src/Snap/Internal/Http/Types.hs --- a/src/Snap/Internal/Http/Types.hs +++ b/src/Snap/Internal/Http/Types.hs @@ -9,9 +9,10 @@ {-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE ForeignFunctionInterface #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE Rank2Types #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ExistentialQuantification #-} module Snap.Internal.Http.Types where @@ -178,7 +179,7 @@ ------------------------------------------------------------------------------ -- | An existential wrapper for the 'Enumerator ByteString IO a' type -data SomeEnumerator = SomeEnumerator (forall a . Enumerator ByteString IO a) +newtype SomeEnumerator = SomeEnumerator (forall a . Enumerator ByteString IO a) ------------------------------------------------------------------------------ diff --git a/src/Snap/Internal/Iteratee/BoyerMooreHorspool.hs b/src/Snap/Internal/Iteratee/BoyerMooreHorspool.hs --- a/src/Snap/Internal/Iteratee/BoyerMooreHorspool.hs +++ b/src/Snap/Internal/Iteratee/BoyerMooreHorspool.hs @@ -1,6 +1,6 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE Rank2Types #-} module Snap.Internal.Iteratee.BoyerMooreHorspool ( bmhEnumeratee diff --git a/src/Snap/Internal/Routing.hs b/src/Snap/Internal/Routing.hs --- a/src/Snap/Internal/Routing.hs +++ b/src/Snap/Internal/Routing.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE Rank2Types #-} {-# LANGUAGE FlexibleContexts #-} module Snap.Internal.Routing where diff --git a/src/Snap/Internal/Test/RequestBuilder.hs b/src/Snap/Internal/Test/RequestBuilder.hs --- a/src/Snap/Internal/Test/RequestBuilder.hs +++ b/src/Snap/Internal/Test/RequestBuilder.hs @@ -1,6 +1,6 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE Rank2Types #-} module Snap.Internal.Test.RequestBuilder ( RequestBuilder diff --git a/src/Snap/Internal/Types.hs b/src/Snap/Internal/Types.hs --- a/src/Snap/Internal/Types.hs +++ b/src/Snap/Internal/Types.hs @@ -1,13 +1,14 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE EmptyDataDecls #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PackageImports #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PackageImports #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeSynonymInstances #-} module Snap.Internal.Types where @@ -188,7 +189,7 @@ catch (Snap m) handler = Snap $ m `catch` h where h e = do - rethrowIfTermination $ fromException e + rethrowIfUncatchable $ fromException e maybe (throw e) (\e' -> let (Snap z) = handler e' in z) (fromException e) @@ -198,11 +199,11 @@ ------------------------------------------------------------------------------ -rethrowIfTermination :: (MonadCatchIO m) => - Maybe ConnectionTerminatedException -> +rethrowIfUncatchable :: (MonadCatchIO m) => + Maybe UncatchableException -> m () -rethrowIfTermination Nothing = return () -rethrowIfTermination (Just e) = throw e +rethrowIfUncatchable Nothing = return () +rethrowIfUncatchable (Just e) = throw e ------------------------------------------------------------------------------ @@ -824,6 +825,34 @@ ------------------------------------------------------------------------------ +-- | An exception hierarchy for exceptions that cannot be caught by +-- user-defined error handlers +data UncatchableException = forall e. Exception e => UncatchableException e + deriving (Typeable) + + +------------------------------------------------------------------------------ +instance Show UncatchableException where + show (UncatchableException e) = "Uncatchable exception: " ++ show e + + +------------------------------------------------------------------------------ +instance Exception UncatchableException + + +------------------------------------------------------------------------------ +uncatchableExceptionToException :: Exception e => e -> SomeException +uncatchableExceptionToException = toException . UncatchableException + + +------------------------------------------------------------------------------ +uncatchableExceptionFromException :: Exception e => SomeException -> Maybe e +uncatchableExceptionFromException e = do + UncatchableException ue <- fromException e + cast ue + + +------------------------------------------------------------------------------ data ConnectionTerminatedException = ConnectionTerminatedException SomeException deriving (Typeable) @@ -836,13 +865,46 @@ ------------------------------------------------------------------------------ -instance Exception ConnectionTerminatedException +instance Exception ConnectionTerminatedException where + toException = uncatchableExceptionToException + fromException = uncatchableExceptionFromException ------------------------------------------------------------------------------ -- | Terminate the HTTP session with the given exception. terminateConnection :: (Exception e, MonadCatchIO m) => e -> m a terminateConnection = throw . ConnectionTerminatedException . toException + + +-- | This is exception is thrown if the handler chooses to escape regular HTTP +-- traffic. +data EscapeHttpException = EscapeHttpException + ((Int -> IO ()) -> Iteratee ByteString IO () -> Iteratee ByteString IO ()) + deriving (Typeable) + + +------------------------------------------------------------------------------ +instance Show EscapeHttpException where + show = const "HTTP traffic was escaped" + + +------------------------------------------------------------------------------ +instance Exception EscapeHttpException where + toException = uncatchableExceptionToException + fromException = uncatchableExceptionFromException + + +------------------------------------------------------------------------------ +-- | Terminate the HTTP session and hand control to some external handler, +-- escaping all further HTTP traffic. +-- +-- The external handler takes two arguments: a function to tickle the timeout +-- manager, and a write end to the socket. +escapeHttp :: MonadCatchIO m + => ((Int -> IO ()) -> Iteratee ByteString IO () -> + Iteratee ByteString IO ()) + -> m () +escapeHttp = throw . EscapeHttpException ------------------------------------------------------------------------------ diff --git a/test/snap-core-testsuite.cabal b/test/snap-core-testsuite.cabal --- a/test/snap-core-testsuite.cabal +++ b/test/snap-core-testsuite.cabal @@ -59,6 +59,24 @@ vector >= 0.6 && <0.10, zlib, zlib-enum >= 0.2.1 && <0.3 - + + extensions: + BangPatterns, + CPP, + PackageImports, + ScopedTypeVariables, + EmptyDataDecls, + ForeignFunctionInterface, + OverloadedStrings, + Rank2Types, + TypeSynonymInstances, + FlexibleInstances, + ExistentialQuantification, + OverloadedStrings, + FlexibleContexts, + GeneralizedNewtypeDeriving, + DeriveDataTypeable, + MultiParamTypeClasses + ghc-options: -O2 -Wall -fhpc -fwarn-tabs -funbox-strict-fields -threaded -fno-warn-unused-do-bind diff --git a/test/suite/Snap/Core/Tests.hs b/test/suite/Snap/Core/Tests.hs --- a/test/suite/Snap/Core/Tests.hs +++ b/test/suite/Snap/Core/Tests.hs @@ -1,6 +1,6 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE Rank2Types #-} {-# LANGUAGE ScopedTypeVariables #-} module Snap.Core.Tests @@ -44,6 +44,7 @@ tests = [ testFail , testAlternative , testEarlyTermination + , testEscapeHttp , testCatchFinishWith , testRqBody , testRqBodyTooLong @@ -244,6 +245,17 @@ testEarlyTermination = testCase "types/earlyTermination" $ do (_,resp) <- go (finishWith sampleResponse >>= \_ -> setFoo "Bar") assertEqual "foo" (Just ["Quux"]) $ getHeaders "Foo" resp + + +testEscapeHttp :: Test +testEscapeHttp = testCase "types/escapeHttp" $ flip catch catchEscape $ do + (_, _) <- go (escapeHttp escaper) + assertFailure "HTTP escape was ignored" + where + escaper _ _ = liftIO $ assert True + tickle _ = return () + + catchEscape (EscapeHttpException iter) = run_ $ iter tickle (return ()) isLeft :: Either a b -> Bool diff --git a/test/suite/Snap/Util/GZip/Tests.hs b/test/suite/Snap/Util/GZip/Tests.hs --- a/test/suite/Snap/Util/GZip/Tests.hs +++ b/test/suite/Snap/Util/GZip/Tests.hs @@ -1,6 +1,6 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE Rank2Types #-} {-# LANGUAGE ScopedTypeVariables #-} module Snap.Util.GZip.Tests