This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "snap-core".
The branch, master has been updated
via ee81a41392d678202b506ec6b27c021ecbd7aa13 (commit)
from f3274739e7e9a79686050065f7c2eb04702fe2c0 (commit)
Summary of changes:
src/Snap/Internal/Types.hs | 17 +++++++++++++++++
src/Snap/Types.hs | 1 +
test/suite/Snap/Types/Tests.hs | 21 +++++++++++++++++++++
3 files changed, 39 insertions(+), 0 deletions(-)
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit ee81a41392d678202b506ec6b27c021ecbd7aa13
Author: Gregory Collins <[email protected]>
Date: Tue Jan 18 22:41:12 2011 +0100
Add 'catchFinishWith' call to the Snap monad.
diff --git a/src/Snap/Internal/Types.hs b/src/Snap/Internal/Types.hs
index ad4df81..e4009b0 100644
--- a/src/Snap/Internal/Types.hs
+++ b/src/Snap/Internal/Types.hs
@@ -276,6 +276,23 @@ finishWith = liftSnap . Snap . return . Just . Left
------------------------------------------------------------------------------
+-- | Capture the flow of control in case a handler calls 'finishWith'.
+--
+-- /WARNING/: in the event of a call to 'transformRequestBody' it is possible
+-- to violate HTTP protocol safety when using this function. If you call
+-- 'catchFinishWith' it is suggested that you do not modify the body of the
+-- 'Response' which was passed to the 'finishWith' call.
+catchFinishWith :: Snap a -> Snap (Either Response a)
+catchFinishWith (Snap m) = Snap $ do
+ eth <- m
+ maybe (return Nothing)
+ (either (\resp -> return $ Just $ Right $ Left resp)
+ (\a -> return $ Just $ Right $ Right a))
+ eth
+{-# INLINE catchFinishWith #-}
+
+
+------------------------------------------------------------------------------
-- | Fails out of a 'Snap' monad action. This is used to indicate
-- that you choose not to handle the given request within the given
-- handler.
diff --git a/src/Snap/Types.hs b/src/Snap/Types.hs
index 9de20e5..a343b3f 100644
--- a/src/Snap/Types.hs
+++ b/src/Snap/Types.hs
@@ -15,6 +15,7 @@ module Snap.Types
-- ** Functions for control flow and early termination
, bracketSnap
, finishWith
+ , catchFinishWith
, pass
-- ** Routing
diff --git a/test/suite/Snap/Types/Tests.hs b/test/suite/Snap/Types/Tests.hs
index 6493053..9f2435a 100644
--- a/test/suite/Snap/Types/Tests.hs
+++ b/test/suite/Snap/Types/Tests.hs
@@ -37,6 +37,7 @@ tests :: [Test]
tests = [ testFail
, testAlternative
, testEarlyTermination
+ , testCatchFinishWith
, testRqBody
, testTrivials
, testMethod
@@ -209,6 +210,26 @@ testEarlyTermination = testCase "types/earlyTermination" $
do
assertEqual "foo" (Just ["Quux"]) $ getHeaders "Foo" resp
+testCatchFinishWith :: Test
+testCatchFinishWith = testCase "types/catchFinishWith" $ do
+ rq <- mkZomgRq
+ x <- run_ $ evalSnap (catchFinishWith $ finishWith emptyResponse)
+ (const $ return ())
+ rq
+ assertBool "catchFinishWith" $ isLeft x
+ y <- run_ $ evalSnap (catchFinishWith $ return ())
+ (const $ return ())
+ rq
+ assertBool "catchFinishWith" $ isRight y
+
+ where
+ isLeft (Left _) = True
+ isLeft _ = False
+
+ isRight (Right _) = True
+ isRight _ = False
+
+
testRqBody :: Test
testRqBody = testCase "types/requestBodies" $ do
mvar1 <- newEmptyMVar
-----------------------------------------------------------------------
hooks/post-receive
--
snap-core
_______________________________________________
Snap mailing list
[email protected]
http://mailman-mail5.webfaction.com/listinfo/snap
