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, faster-snap-monad has been updated
via a39fc1eb30c3db63ed47551818e70d13722dd053 (commit)
via feb031cf26a63e33e5d5514288c25460c83bf11f (commit)
via 6b80792497464d8606789fd16d76c9a9213d44cf (commit)
via cb1a3940863872a5231bc77593168ba2b66fc319 (commit)
via a66d2f473a73b323eb869d47f7a35ef35bb64c30 (commit)
via 098b424b4305cebc9671ef6495a2f6f3dc8fff6c (commit)
via 46ec8ee04c81d11eada727398d65de2ee6af3f25 (commit)
via c9e0d10ed2272cededb8f5936b9a130cb6710f3b (commit)
via 2e98e583878146f5e81bf887ada8cc34d787a44e (commit)
via d6ac45b33e5f167a3fdabd6961cc085704a37621 (commit)
via 91d07caf7e9889a05d1a04c59683234b546f887f (commit)
via 367ae078f0af5409469f2e61f1373e697169ed8e (commit)
via e242ffc13e25de10417402d2d56a0e3f26ba3c31 (commit)
via 5aeb76386ab2ee90f13c278ed81c4f76b4206c6f (commit)
via 54587694d7c7a042144700a5b7590d0e75831f7d (commit)
via d6b77605032fbdff428632125c7216da99528063 (commit)
via b7bedd66c5945b9a03a9f1a1e60c786e987ec063 (commit)
via a47384a4550509daebc3046dc1210902ddad0745 (commit)
via 9f1bf3dc566a2144478e8eb82a71bf4b391f1af4 (commit)
via 4aeba1cdb7ff2cb48433398baffe223ff1ba20de (commit)
via 96f0c7191fc7ab0c35fd53c478fc0219c3fe0109 (commit)
via 3fee627e0d65171c97e8f1994d536051da3c997e (commit)
via cc86118ec0093fe810899eeec2c4e01a97aa4299 (commit)
via e1ea73099e26dd1d7f08dc5644e8c186f0ca96f6 (commit)
via d2075bb1fe8cf061ada86cd42239e4dd4bb21fa9 (commit)
via 3cba6da2735a87673856ed0b6f3ec732979b9b60 (commit)
via 02b55ac1416a5e1bf20d93122c9201b40611f016 (commit)
via 0847b5fd442bdc298d255cba08b884e6112b602d (commit)
via d32e8d28e77b8077d2d2ea06efc46c9a9698c5ba (commit)
via 08fcf875751e70dad114ff09fa8ebc082abf93ab (commit)
via 1bb3ed52fe2b2d35794a6f796922d3dcaddfa346 (commit)
via 7a558c9fe0362451ffd61910632190813d3f74c6 (commit)
via 21ecab3f49ea6daed5b171369fa0188c114d2808 (commit)
via 97c281338a2075f1c4867c908ead122c7650ff84 (commit)
via bd519849f294ad1be9e3b1dd75c1b185e1c5c35c (commit)
via 371831cd66e68e0174cffcefb8b723cdd384879b (commit)
via 588046129b4b5ce7f4a9f64ed9ada0457f39b74c (commit)
via 51433a4aa5546c2f36342c35d0425fa619e4658b (commit)
via bd5fbdcfe39e32e80889df201bbf1701406d511b (commit)
via 49338b70afe3db65ce650c21be747c629e56eb45 (commit)
via 21e5ad9896ac107a510f267717279ae3e2e7b8ea (commit)
via 9845541171505672a87ed036751204162dcd4dfc (commit)
via add79b65cf33d98b03192f69fedc43c26359684d (commit)
via 7fde1b831d8252c19e925ddd11b479ed29e73134 (commit)
via 6664c75e3fc09c1546977862bc2eebeda98c6c6e (commit)
via bc2b98d6a23bff418d3ff5f206b4bcb3814c9fa8 (commit)
via 36885c4a501fb33cb993026b007ed2d583645e51 (commit)
via a1c53efd40747890c5cae296779d0618e438c54e (commit)
via ae5ea7a86a87e261d6cbe0bba094f61c6956f67c (commit)
via d0eef4403035c0acc9d645618bb3a82e8007dca5 (commit)
via 0fb6c66afbb3e35f25f7a5fc91aeb80da1169436 (commit)
via 35cad8bec54e62943b5d7f4361d28711dd0e1026 (commit)
via ba8770a7d21ee6279d5e0bb94de3e028a47fa263 (commit)
via 76ee6887827eb34e7654d2a08742e2fa7b94ea57 (commit)
via 0ce8bb393cd23cdb8bdefc64191c79c3f204f7fe (commit)
via 1b4ea719a186a0130f633e38b6d87e6310f71d3e (commit)
via 6cb92b72ad06bc1132347b5a9983372426f30414 (commit)
via 86794947a86fa4f01326f8511b0fdd3be7bd9151 (commit)
from 2eace5999d442c63a6a1c23b818e675c443a0ec5 (commit)
Summary of changes:
README.SNAP.md | 6 +-
README.md | 4 +-
RELEASE-CHECKLIST | 14 ++-
Setup.hs | 3 +
TODO | 117 +++++-------------
cbits/timefuncs.c | 1 +
extra/haddock.css | 2 +-
snap-core.cabal | 76 +++++++++++-
src/Data/CIByteString.hs | 4 +
src/Snap/Internal/Debug.hs | 53 +++++++--
src/Snap/Internal/Http/Types.hs | 81 +++++++++----
src/Snap/Internal/Iteratee/Debug.hs | 3 +
src/Snap/Internal/Routing.hs | 68 +++++++----
src/Snap/Internal/Types.hs | 195 ++++++++++++++++++++++++-----
src/Snap/Iteratee.hs | 83 ++++++++++++-
src/Snap/Starter.hs | 104 +++++++++++-----
src/Snap/Types.hs | 73 ++++++-----
src/Snap/Util/FileServe.hs | 19 +---
src/Snap/Util/GZip.hs | 14 ++-
test/runTestsAndCoverage.sh | 2 +-
test/snap-core-testsuite.cabal | 81 +++++++-----
test/suite/Snap/Internal/Routing/Tests.hs | 173 ++++++++++++++++++++++++--
test/suite/Snap/Iteratee/Tests.hs | 56 ++++++++
test/suite/Snap/Test/Common.hs | 7 +
test/suite/Snap/Types/Tests.hs | 49 ++++++-
test/suite/Snap/Util/FileServe/Tests.hs | 4 +-
test/suite/Snap/Util/GZip/Tests.hs | 8 +-
27 files changed, 971 insertions(+), 329 deletions(-)
create mode 100644 Setup.hs
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 a39fc1eb30c3db63ed47551818e70d13722dd053
Merge: 2eace59 feb031c
Author: Leon P Smith <[email protected]>
Date: Mon May 24 23:43:12 2010 -0400
Merge branch 'master' into faster-snap-monad
Conflicts:
src/Snap/Internal/Types.hs
diff --cc src/Snap/Internal/Types.hs
index 9729b3f,31a173e..3cad541
--- a/src/Snap/Internal/Types.hs
+++ b/src/Snap/Internal/Types.hs
@@@ -6,12 -6,12 +6,14 @@@
module Snap.Internal.Types where
------------------------------------------------------------------------------
++import Prelude hiding (catch)
import Control.Applicative
- import Control.Exception
+ import Control.Exception (throwIO, ErrorCall(..))
+ import Control.Monad.CatchIO
-import Control.Monad.State.Strict
+import Control.Monad
+import Control.Monad.Trans
import Data.ByteString.Char8 (ByteString)
- import qualified Data.ByteString.Char8 as B
+ import qualified Data.ByteString.Char8 as S
import qualified Data.ByteString.Lazy.Char8 as L
import Data.IORef
import qualified Data.Iteratee as Iter
@@@ -81,33 -80,62 +82,51 @@@ import Snap.Internal.Http.Typ
> a = liftIO fireTheMissiles
-}
++------------------------------------------------------------------------------
+type Cont r a = r -> (Response -> r) -> (a -> r) -> r
+ ------------------------------------------------------------------------------
newtype Snap a = Snap {
- unSnap :: StateT SnapState (Iteratee IO) (Maybe (Either Response a))
+ unSnap :: forall r. Cont (SnapState -> Iteratee IO r) a
}
+ ------------------------------------------------------------------------------
data SnapState = SnapState
{ _snapRequest :: Request
- , _snapResponse :: Response }
+ , _snapResponse :: Response
+ , _snapLogError :: ByteString -> IO () }
+ ------------------------------------------------------------------------------
instance Monad Snap where
- (Snap m) >>= f =
- Snap $ do
- eth <- m
- maybe (return Nothing)
- (either (return . Just . Left)
- (unSnap . f))
- eth
+ m >>= f = Snap (\nk rk ak -> unSnap m nk rk (\a -> unSnap (f a) nk rk
ak))
+ return v = Snap (\_nk _rk ak -> ak v)
+ fail _ = Snap (\nk _rk _ak -> nk)
- return = Snap . return . Just . Right
- fail = const $ Snap $ return Nothing
+
+ ------------------------------------------------------------------------------
instance MonadIO Snap where
- liftIO m = Snap $ liftM (Just . Right) $ liftIO m
+ liftIO m = Snap (\_nk _rk ak st -> liftIO m >>= (\a -> ak a st))
+ ------------------------------------------------------------------------------
+ instance MonadCatchIO Snap where
- catch (Snap m) handler = Snap $ do
- x <- try m
- case x of
- (Left e) -> let (Snap z) = handler e in z
- (Right y) -> return y
++ catch m handler = Snap $ \nk rk ak st ->
++ unSnap m nk rk ak st `catch` \e -> unSnap (handler e) nk rk ak st
+
- block (Snap m) = Snap $ block m
- unblock (Snap m) = Snap $ unblock m
++ block m = Snap $ \nk rk ak st -> block (unSnap m nk rk ak st)
++ unblock m = Snap $ \nk rk ak st -> unblock (unSnap m nk rk ak st)
+
+
+ ------------------------------------------------------------------------------
instance MonadPlus Snap where
- mzero = Snap $ return Nothing
-
- a `mplus` b =
- Snap $ do
- mb <- unSnap a
- if isJust mb then return mb else unSnap b
+ mzero = Snap (\nk _rk _ak -> nk)
+ a `mplus` b = Snap (\nk rk ak -> unSnap a (unSnap b nk rk ak) rk ak)
+ ------------------------------------------------------------------------------
instance Functor Snap where
fmap = liftM
@@@ -124,8 -154,10 +145,10 @@@ instance Alternative Snap wher
------------------------------------------------------------------------------
liftIter :: Iteratee IO a -> Snap a
-liftIter i = Snap (lift i >>= return . Just . Right)
+liftIter i = Snap (\_nk _rk ak st -> i >>= (\a -> ak a st))
+
+ ------------------------------------------------------------------------------
-- | Sends the request body through an iteratee (data consumer) and
-- returns the result.
runRequestBody :: Iteratee IO a -> Snap a
@@@ -178,9 -214,11 +205,11 @@@ unsafeDetachRequestBody = d
-- | Short-circuits a 'Snap' monad action early, storing the given
-- 'Response' value in its state.
finishWith :: Response -> Snap ()
-finishWith = Snap . return . Just . Left
+finishWith v = Snap (\_nk rk _ak -> rk v)
{-# INLINE finishWith #-}
+
+ ------------------------------------------------------------------------------
-- | 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.
@@@ -255,16 -301,21 +292,21 @@@ ifTop = path "
{-# INLINE ifTop #-}
+ ------------------------------------------------------------------------------
-- | Local Snap version of 'get'.
sget :: Snap SnapState
- sget = Snap (\_nk _rk ak st -> ak st st)
-sget = Snap $ liftM (Just . Right) get
++sget = Snap $ \_nk _rk ak st -> ak st st
{-# INLINE sget #-}
+
+ ------------------------------------------------------------------------------
-- | Local Snap monad version of 'modify'.
smodify :: (SnapState -> SnapState) -> Snap ()
- smodify f = Snap (\_nk _rk ak st -> ak () (f st))
-smodify f = Snap $ modify f >> return (Just $ Right ())
++smodify f = Snap $ \_nk _rk ak st -> ak () (f st)
{-# INLINE smodify #-}
+
+ ------------------------------------------------------------------------------
-- | Grabs the 'Request' object out of the 'Snap' monad.
getRequest :: Snap Request
getRequest = liftM _snapRequest sget
@@@ -290,12 -349,23 +340,22 @@@ modifyRequest :: (Request -> Request) -
modifyRequest f = smodify $ \ss -> ss { _snapRequest = f $ _snapRequest ss }
{-# INLINE modifyRequest #-}
+
+ ------------------------------------------------------------------------------
-- | Modifes the 'Response' object stored in a 'Snap' monad.
-modifyResponse :: (Response -> Response) -> Snap ()
+modifyResponse :: (Response -> Response) -> Snap ()
modifyResponse f = smodify $ \ss -> ss { _snapResponse = f $ _snapResponse ss
}
{-# INLINE modifyResponse #-}
+ ------------------------------------------------------------------------------
+ -- | Log an error message in the 'Snap' monad
+ logError :: ByteString -> Snap ()
-logError s = Snap $ gets _snapLogError >>= (\l -> liftIO $ l s)
- >> return (Just $ Right ())
++logError s = Snap $ \_nk _rk ak st -> liftIO (_snapLogError st s) >> ak () st
+ {-# INLINE logError #-}
+
+
+ ------------------------------------------------------------------------------
-- | Adds the output from the given enumerator to the 'Response'
-- stored in the 'Snap' monad state.
addToOutput :: (forall a . Enumerator a) -- ^ output to add
@@@ -351,14 -463,27 +453,18 @@@ instance Show NoHandlerException wher
instance Exception NoHandlerException
+ ------------------------------------------------------------------------------
-- | Runs a 'Snap' monad action in the 'Iteratee IO' monad.
- runSnap :: Snap a -> Request -> Iteratee IO (Request,Response)
- runSnap m req = unSnap m nk rk ak ss
+ runSnap :: Snap a
+ -> (ByteString -> IO ())
+ -> Request
+ -> Iteratee IO (Request,Response)
-runSnap (Snap m) logerr 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'
-
- return (_snapRequest ss', resp)
-
++runSnap m logerr req = unSnap m nk rk ak ss
where
+ nk ss' = return (_snapRequest ss', fourohfour )
+ rk x ss' = return (_snapRequest ss', x )
+ ak r ss' = return (_snapRequest ss', _snapResponse ss')
+
fourohfour = setContentLength 3 $
setResponseStatus 404 "Not Found" $
modifyResponseBody (>. enumBS "404") $
@@@ -370,13 -495,40 +476,34 @@@
{-# INLINE runSnap #-}
- evalSnap :: Snap a -> Request -> Iteratee IO a
- evalSnap m req = unSnap m nk rk ak ss
+ ------------------------------------------------------------------------------
+ evalSnap :: Snap a
+ -> (ByteString -> IO ())
+ -> Request
+ -> Iteratee IO a
-evalSnap (Snap m) logerr req = do
- (r, _) <- runStateT m ss
-
- e <- maybe (liftIO $ throwIO NoHandlerException)
- return
- r
-
- -- is this a case of early termination?
- case e of
- Left _ -> liftIO $ throwIO $ ErrorCall "no value"
- Right x -> return x
++evalSnap m logerr req = unSnap m nk rk ak ss
where
+ nk _ = liftIO $ throwIO NoHandlerException
+ rk _ _ = liftIO $ throwIO $ ErrorCall "no value"
+ ak a _ = return a
+
dresp = emptyResponse { rspHttpVersion = rqVersion req }
- ss = SnapState req dresp
+ ss = SnapState req dresp logerr
{-# INLINE evalSnap #-}
+
+
+
+ ------------------------------------------------------------------------------
+ -- | See 'rqParam'. Looks up a value for the given named parameter in the
+ -- 'Request'. If more than one value was entered for the given parameter name,
+ -- 'getParam' gloms the values together with:
+ --
+ -- @ 'S.intercalate' \" \"@
+ --
+ getParam :: ByteString -- ^ parameter name to look up
+ -> Snap (Maybe ByteString)
+ getParam k = do
+ rq <- getRequest
+ return $ liftM (S.intercalate " ") $ rqParam k rq
+
+
-----------------------------------------------------------------------
hooks/post-receive
--
snap-core
_______________________________________________
Snap mailing list
[email protected]
http://mailman-mail5.webfaction.com/listinfo/snap
