Skip to content
This repository
Browse code

Flatten snap monad return type

  • Loading branch information...
commit cee0c99786c24353d671475af1273d3a15c44873 1 parent 5f88abb
Gregory Collins gregorycollins authored

Showing 2 changed files with 62 additions and 36 deletions. Show diff stats Hide diff stats

  1. +57 32 src/Snap/Internal/Types.hs
  2. +5 4 src/Snap/Iteratee.hs
89 src/Snap/Internal/Types.hs
@@ -112,10 +112,14 @@ class (Monad m, MonadIO m, MonadCatchIO m, MonadPlus m, Functor m,
112 112
113 113
114 114 ------------------------------------------------------------------------------
  115 +data SnapResult a = PassOnProcessing
  116 + | EarlyTermination Response
  117 + | SnapValue a
  118 +
  119 +------------------------------------------------------------------------------
115 120 newtype Snap a = Snap {
116   - unSnap :: StateT SnapState (Iteratee ByteString IO)
117   - (Maybe (Either Response a))
118   -}
  121 + unSnap :: StateT SnapState (Iteratee ByteString IO) (SnapResult a)
  122 + }
119 123
120 124
121 125 ------------------------------------------------------------------------------
@@ -128,6 +132,10 @@ data SnapState = SnapState
128 132
129 133 ------------------------------------------------------------------------------
130 134 instance Monad Snap where
  135 + (>>=) = snapBind
  136 + return = snapReturn
  137 + fail = snapFail
  138 +{-
131 139 (Snap m) >>= f =
132 140 Snap $ do
133 141 eth <- m
@@ -138,11 +146,33 @@ instance Monad Snap where
138 146
139 147 return = Snap . return . Just . Right
140 148 fail = const $ Snap $ return Nothing
  149 +-}
  150 +
  151 +------------------------------------------------------------------------------
  152 +snapBind :: Snap a -> (a -> Snap b) -> Snap b
  153 +snapBind (Snap m) f = Snap $ do
  154 + res <- m
  155 +
  156 + case res of
  157 + SnapValue a -> unSnap $ f a
  158 + PassOnProcessing -> return PassOnProcessing
  159 + EarlyTermination r -> return $! EarlyTermination r
  160 +{-# INLINE snapBind #-}
  161 +
  162 +
  163 +snapReturn :: a -> Snap a
  164 +snapReturn = Snap . return . SnapValue
  165 +{-# INLINE snapReturn #-}
  166 +
  167 +
  168 +snapFail :: String -> Snap a
  169 +snapFail _ = Snap $ return PassOnProcessing
  170 +{-# INLINE snapFail #-}
141 171
142 172
143 173 ------------------------------------------------------------------------------
144 174 instance MonadIO Snap where
145   - liftIO m = Snap $ liftM (Just . Right) $ liftIO m
  175 + liftIO m = Snap $ liftM SnapValue $ liftIO m
146 176
147 177
148 178 ------------------------------------------------------------------------------
@@ -159,12 +189,14 @@ instance MonadCatchIO Snap where
159 189
160 190 ------------------------------------------------------------------------------
161 191 instance MonadPlus Snap where
162   - mzero = Snap $ return Nothing
  192 + mzero = Snap $ return PassOnProcessing
163 193
164 194 a `mplus` b =
165 195 Snap $ do
166   - mb <- unSnap a
167   - if isJust mb then return mb else unSnap b
  196 + r <- unSnap a
  197 + case r of
  198 + PassOnProcessing -> unSnap b
  199 + _ -> return r
168 200
169 201
170 202 ------------------------------------------------------------------------------
@@ -203,7 +235,7 @@ instance Typeable1 Snap where
203 235
204 236 ------------------------------------------------------------------------------
205 237 liftIter :: MonadSnap m => Iteratee ByteString IO a -> m a
206   -liftIter i = liftSnap $ Snap (lift i >>= return . Just . Right)
  238 +liftIter i = liftSnap $ Snap (lift i >>= return . SnapValue)
207 239
208 240
209 241 ------------------------------------------------------------------------------
@@ -278,7 +310,7 @@ transformRequestBody trans = do
278 310 -- | Short-circuits a 'Snap' monad action early, storing the given
279 311 -- 'Response' value in its state.
280 312 finishWith :: MonadSnap m => Response -> m a
281   -finishWith = liftSnap . Snap . return . Just . Left
  313 +finishWith = liftSnap . Snap . return . EarlyTermination
282 314 {-# INLINE finishWith #-}
283 315
284 316
@@ -291,11 +323,11 @@ finishWith = liftSnap . Snap . return . Just . Left
291 323 -- 'Response' which was passed to the 'finishWith' call.
292 324 catchFinishWith :: Snap a -> Snap (Either Response a)
293 325 catchFinishWith (Snap m) = Snap $ do
294   - eth <- m
295   - maybe (return Nothing)
296   - (either (\resp -> return $ Just $ Right $ Left resp)
297   - (\a -> return $ Just $ Right $ Right a))
298   - eth
  326 + r <- m
  327 + case r of
  328 + PassOnProcessing -> return PassOnProcessing
  329 + EarlyTermination resp -> return $! SnapValue $! Left resp
  330 + SnapValue a -> return $! SnapValue $! Right a
299 331 {-# INLINE catchFinishWith #-}
300 332
301 333
@@ -399,14 +431,14 @@ ifTop = path ""
399 431 ------------------------------------------------------------------------------
400 432 -- | Local Snap version of 'get'.
401 433 sget :: Snap SnapState
402   -sget = Snap $ liftM (Just . Right) get
  434 +sget = Snap $ liftM SnapValue get
403 435 {-# INLINE sget #-}
404 436
405 437
406 438 ------------------------------------------------------------------------------
407 439 -- | Local Snap monad version of 'modify'.
408 440 smodify :: (SnapState -> SnapState) -> Snap ()
409   -smodify f = Snap $ modify f >> return (Just $ Right ())
  441 +smodify f = Snap $ modify f >> return (SnapValue ())
410 442 {-# INLINE smodify #-}
411 443
412 444
@@ -487,7 +519,7 @@ redirect' target status = do
487 519 -- | Log an error message in the 'Snap' monad
488 520 logError :: MonadSnap m => ByteString -> m ()
489 521 logError s = liftSnap $ Snap $ gets _snapLogError >>= (\l -> liftIO $ l s)
490   - >> return (Just $ Right ())
  522 + >> return (SnapValue ())
491 523 {-# INLINE logError #-}
492 524
493 525
@@ -712,14 +744,10 @@ runSnap :: Snap a
712 744 runSnap (Snap m) logerr timeoutAction req = do
713 745 (r, ss') <- runStateT m ss
714 746
715   - e <- maybe (return $ Left fourohfour)
716   - return
717   - r
718   -
719   - -- is this a case of early termination?
720   - let resp = case e of
721   - Left x -> x
722   - Right _ -> _snapResponse ss'
  747 + let resp = case r of
  748 + PassOnProcessing -> fourohfour
  749 + EarlyTermination x -> x
  750 + SnapValue _ -> _snapResponse ss'
723 751
724 752 return (_snapRequest ss', resp)
725 753
@@ -745,14 +773,11 @@ evalSnap :: Snap a
745 773 evalSnap (Snap m) logerr timeoutAction req = do
746 774 (r, _) <- runStateT m ss
747 775
748   - e <- maybe (liftIO $ throwIO NoHandlerException)
749   - return
750   - r
  776 + case r of
  777 + PassOnProcessing -> liftIO $ throwIO NoHandlerException
  778 + EarlyTermination _ -> liftIO $ throwIO $ ErrorCall "no value"
  779 + SnapValue x -> return x
751 780
752   - -- is this a case of early termination?
753   - case e of
754   - Left _ -> liftIO $ throwIO $ ErrorCall "no value"
755   - Right x -> return x
756 781 where
757 782 dresp = emptyResponse { rspHttpVersion = rqVersion req }
758 783 ss = SnapState req dresp logerr timeoutAction
9 src/Snap/Iteratee.hs
@@ -85,7 +85,7 @@ module Snap.Iteratee
85 85 , concatEnums
86 86 -- *** Enumeratees
87 87 , checkDone
88   - , Data.Enumerator.map
  88 + , Data.Enumerator.List.map
89 89 , Data.Enumerator.sequence
90 90 , joinI
91 91
@@ -113,6 +113,7 @@ import Data.Enumerator hiding (consume, drop, head)
113 113 import qualified Data.Enumerator as I
114 114 import Data.Enumerator.Binary (enumHandle)
115 115 import Data.Enumerator.List hiding (take, drop)
  116 +import qualified Data.Enumerator.List as IL
116 117 import qualified Data.List as List
117 118 import Data.Monoid (mappend)
118 119 import Data.Time.Clock.POSIX (getPOSIXTime)
@@ -137,7 +138,7 @@ instance (Functor m, MonadCatchIO m) =>
137 138 where
138 139 insideCatch !mm = Iteratee $ do
139 140 ee <- try $ runIteratee mm
140   - case ee of
  141 + case ee of
141 142 (Left e) -> runIteratee $ handler e
142 143 (Right v) -> step v
143 144
@@ -643,10 +644,10 @@ mapEnum :: (Monad m) =>
643 644 -> Enumerator aIn m a
644 645 -> Enumerator aOut m a
645 646 mapEnum f g enum outStep = do
646   - let z = I.map g outStep
  647 + let z = IL.map g outStep
647 648 let p = joinI z
648 649 let q = enum $$ p
649   - (I.joinI . I.map f) $$ q
  650 + (I.joinI . IL.map f) $$ q
650 651
651 652
652 653 ------------------------------------------------------------------------------

0 comments on commit cee0c99

Please sign in to comment.
Something went wrong with that request. Please try again.