snap-core 0.6.0 → 0.6.0.1
raw patch · 11 files changed
+139/−25 lines, 11 files
Files
- CONTRIBUTORS +1/−0
- snap-core.cabal +19/−1
- src/Snap/Core.hs +2/−0
- src/Snap/Internal/Http/Types.hs +3/−2
- src/Snap/Internal/Iteratee/BoyerMooreHorspool.hs +1/−1
- src/Snap/Internal/Routing.hs +1/−1
- src/Snap/Internal/Test/RequestBuilder.hs +1/−1
- src/Snap/Internal/Types.hs +78/−16
- test/snap-core-testsuite.cabal +19/−1
- test/suite/Snap/Core/Tests.hs +13/−1
- test/suite/Snap/Util/GZip/Tests.hs +1/−1
CONTRIBUTORS view
@@ -7,3 +7,4 @@ Jacob Stanley <jystic@jystic.com> Jonas Kramer <jkramer@nex.scrapping.cc> Jurriën Stutterheim <j.stutterheim@me.com>+Jasper Van der Jeugt <m@jaspervdj.be>
snap-core.cabal view
@@ -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
src/Snap/Core.hs view
@@ -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
src/Snap/Internal/Http/Types.hs view
@@ -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) ------------------------------------------------------------------------------
src/Snap/Internal/Iteratee/BoyerMooreHorspool.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE Rank2Types #-} module Snap.Internal.Iteratee.BoyerMooreHorspool ( bmhEnumeratee
src/Snap/Internal/Routing.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE Rank2Types #-} {-# LANGUAGE FlexibleContexts #-} module Snap.Internal.Routing where
src/Snap/Internal/Test/RequestBuilder.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE Rank2Types #-} module Snap.Internal.Test.RequestBuilder ( RequestBuilder
src/Snap/Internal/Types.hs view
@@ -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 ------------------------------------------------------------------------------
test/snap-core-testsuite.cabal view
@@ -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
test/suite/Snap/Core/Tests.hs view
@@ -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
test/suite/Snap/Util/GZip/Tests.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE Rank2Types #-} {-# LANGUAGE ScopedTypeVariables #-} module Snap.Util.GZip.Tests