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 cee0c99786c24353d671475af1273d3a15c44873 (commit)
from 5f88abb8db9d6012a0686141f8f686ee3b2c557e (commit)
Summary of changes:
src/Snap/Internal/Types.hs | 89 ++++++++++++++++++++++++++++----------------
src/Snap/Iteratee.hs | 9 ++--
2 files changed, 62 insertions(+), 36 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 cee0c99786c24353d671475af1273d3a15c44873
Author: Gregory Collins <[email protected]>
Date: Sun Jun 12 11:48:32 2011 -0400
Flatten snap monad return type
diff --git a/src/Snap/Internal/Types.hs b/src/Snap/Internal/Types.hs
index 22b3755..8a6b1ec 100644
--- a/src/Snap/Internal/Types.hs
+++ b/src/Snap/Internal/Types.hs
@@ -112,10 +112,14 @@ class (Monad m, MonadIO m, MonadCatchIO m, MonadPlus m,
Functor m,
------------------------------------------------------------------------------
+data SnapResult a = PassOnProcessing
+ | EarlyTermination Response
+ | SnapValue a
+
+------------------------------------------------------------------------------
newtype Snap a = Snap {
- unSnap :: StateT SnapState (Iteratee ByteString IO)
- (Maybe (Either Response a))
-}
+ unSnap :: StateT SnapState (Iteratee ByteString IO) (SnapResult a)
+ }
------------------------------------------------------------------------------
@@ -128,6 +132,10 @@ data SnapState = SnapState
------------------------------------------------------------------------------
instance Monad Snap where
+ (>>=) = snapBind
+ return = snapReturn
+ fail = snapFail
+{-
(Snap m) >>= f =
Snap $ do
eth <- m
@@ -138,11 +146,33 @@ instance Monad Snap where
return = Snap . return . Just . Right
fail = const $ Snap $ return Nothing
+-}
+
+------------------------------------------------------------------------------
+snapBind :: Snap a -> (a -> Snap b) -> Snap b
+snapBind (Snap m) f = Snap $ do
+ res <- m
+
+ case res of
+ SnapValue a -> unSnap $ f a
+ PassOnProcessing -> return PassOnProcessing
+ EarlyTermination r -> return $! EarlyTermination r
+{-# INLINE snapBind #-}
+
+
+snapReturn :: a -> Snap a
+snapReturn = Snap . return . SnapValue
+{-# INLINE snapReturn #-}
+
+
+snapFail :: String -> Snap a
+snapFail _ = Snap $ return PassOnProcessing
+{-# INLINE snapFail #-}
------------------------------------------------------------------------------
instance MonadIO Snap where
- liftIO m = Snap $ liftM (Just . Right) $ liftIO m
+ liftIO m = Snap $ liftM SnapValue $ liftIO m
------------------------------------------------------------------------------
@@ -159,12 +189,14 @@ instance MonadCatchIO Snap where
------------------------------------------------------------------------------
instance MonadPlus Snap where
- mzero = Snap $ return Nothing
+ mzero = Snap $ return PassOnProcessing
a `mplus` b =
Snap $ do
- mb <- unSnap a
- if isJust mb then return mb else unSnap b
+ r <- unSnap a
+ case r of
+ PassOnProcessing -> unSnap b
+ _ -> return r
------------------------------------------------------------------------------
@@ -203,7 +235,7 @@ instance Typeable1 Snap where
------------------------------------------------------------------------------
liftIter :: MonadSnap m => Iteratee ByteString IO a -> m a
-liftIter i = liftSnap $ Snap (lift i >>= return . Just . Right)
+liftIter i = liftSnap $ Snap (lift i >>= return . SnapValue)
------------------------------------------------------------------------------
@@ -278,7 +310,7 @@ transformRequestBody trans = do
-- | Short-circuits a 'Snap' monad action early, storing the given
-- 'Response' value in its state.
finishWith :: MonadSnap m => Response -> m a
-finishWith = liftSnap . Snap . return . Just . Left
+finishWith = liftSnap . Snap . return . EarlyTermination
{-# INLINE finishWith #-}
@@ -291,11 +323,11 @@ finishWith = liftSnap . Snap . return . Just . Left
-- '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
+ r <- m
+ case r of
+ PassOnProcessing -> return PassOnProcessing
+ EarlyTermination resp -> return $! SnapValue $! Left resp
+ SnapValue a -> return $! SnapValue $! Right a
{-# INLINE catchFinishWith #-}
@@ -399,14 +431,14 @@ ifTop = path ""
------------------------------------------------------------------------------
-- | Local Snap version of 'get'.
sget :: Snap SnapState
-sget = Snap $ liftM (Just . Right) get
+sget = Snap $ liftM SnapValue get
{-# INLINE sget #-}
------------------------------------------------------------------------------
-- | Local Snap monad version of 'modify'.
smodify :: (SnapState -> SnapState) -> Snap ()
-smodify f = Snap $ modify f >> return (Just $ Right ())
+smodify f = Snap $ modify f >> return (SnapValue ())
{-# INLINE smodify #-}
@@ -487,7 +519,7 @@ redirect' target status = do
-- | Log an error message in the 'Snap' monad
logError :: MonadSnap m => ByteString -> m ()
logError s = liftSnap $ Snap $ gets _snapLogError >>= (\l -> liftIO $ l s)
- >> return (Just $ Right ())
+ >> return (SnapValue ())
{-# INLINE logError #-}
@@ -712,14 +744,10 @@ runSnap :: Snap a
runSnap (Snap m) logerr timeoutAction req = do
(r, ss') <- runStateT m ss
- e <- maybe (return $ Left fourohfour)
- return
- r
-
- -- is this a case of early termination?
- let resp = case e of
- Left x -> x
- Right _ -> _snapResponse ss'
+ let resp = case r of
+ PassOnProcessing -> fourohfour
+ EarlyTermination x -> x
+ SnapValue _ -> _snapResponse ss'
return (_snapRequest ss', resp)
@@ -745,14 +773,11 @@ evalSnap :: Snap a
evalSnap (Snap m) logerr timeoutAction req = do
(r, _) <- runStateT m ss
- e <- maybe (liftIO $ throwIO NoHandlerException)
- return
- r
+ case r of
+ PassOnProcessing -> liftIO $ throwIO NoHandlerException
+ EarlyTermination _ -> liftIO $ throwIO $ ErrorCall "no value"
+ SnapValue x -> return x
- -- is this a case of early termination?
- case e of
- Left _ -> liftIO $ throwIO $ ErrorCall "no value"
- Right x -> return x
where
dresp = emptyResponse { rspHttpVersion = rqVersion req }
ss = SnapState req dresp logerr timeoutAction
diff --git a/src/Snap/Iteratee.hs b/src/Snap/Iteratee.hs
index 3b801b5..793952e 100644
--- a/src/Snap/Iteratee.hs
+++ b/src/Snap/Iteratee.hs
@@ -85,7 +85,7 @@ module Snap.Iteratee
, concatEnums
-- *** Enumeratees
, checkDone
- , Data.Enumerator.map
+ , Data.Enumerator.List.map
, Data.Enumerator.sequence
, joinI
@@ -113,6 +113,7 @@ import Data.Enumerator hiding (consume, drop,
head)
import qualified Data.Enumerator as I
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.Time.Clock.POSIX (getPOSIXTime)
@@ -137,7 +138,7 @@ instance (Functor m, MonadCatchIO m) =>
where
insideCatch !mm = Iteratee $ do
ee <- try $ runIteratee mm
- case ee of
+ case ee of
(Left e) -> runIteratee $ handler e
(Right v) -> step v
@@ -643,10 +644,10 @@ mapEnum :: (Monad m) =>
-> Enumerator aIn m a
-> Enumerator aOut m a
mapEnum f g enum outStep = do
- let z = I.map g outStep
+ let z = IL.map g outStep
let p = joinI z
let q = enum $$ p
- (I.joinI . I.map f) $$ q
+ (I.joinI . IL.map f) $$ q
------------------------------------------------------------------------------
-----------------------------------------------------------------------
hooks/post-receive
--
snap-core
_______________________________________________
Snap mailing list
[email protected]
https://mailman-mail5.webfaction.com/listinfo/snap
