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 dba39fa1201ba7c19c79f99d4fe6ab5611e23d46 (commit)
from ee81a41392d678202b506ec6b27c021ecbd7aa13 (commit)
Summary of changes:
src/Snap/Internal/Types.hs | 37 +++++++++++++++++++++++-----
test/suite/Snap/Internal/Routing/Tests.hs | 5 ++-
test/suite/Snap/Types/Tests.hs | 25 ++++++++++++++-----
test/suite/Snap/Util/FileServe/Tests.hs | 19 +++++++++-----
test/suite/Snap/Util/GZip/Tests.hs | 5 +++-
5 files changed, 67 insertions(+), 24 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 dba39fa1201ba7c19c79f99d4fe6ab5611e23d46
Author: Gregory Collins <[email protected]>
Date: Thu Jan 27 20:36:13 2011 +0100
Add timeout support to the Snap interface (closes #26)
diff --git a/src/Snap/Internal/Types.hs b/src/Snap/Internal/Types.hs
index e4009b0..4b3dd4a 100644
--- a/src/Snap/Internal/Types.hs
+++ b/src/Snap/Internal/Types.hs
@@ -87,6 +87,12 @@ import Snap.Internal.Iteratee.Debug
> a :: Snap ()
> a = liftIO fireTheMissiles
+7. the ability to set a timeout which will kill the handler thread after @N@
+ seconds of inactivity:
+
+ > a :: Snap ()
+ > a = setTimeout 30
+
You may notice that most of the type signatures in this module contain a
@(MonadSnap m) => ...@ typeclass constraint. 'MonadSnap' is a typeclass which,
in essence, says \"you can get back to the 'Snap' monad from here\". Using
@@ -114,9 +120,10 @@ newtype Snap a = Snap {
------------------------------------------------------------------------------
data SnapState = SnapState
- { _snapRequest :: Request
- , _snapResponse :: Response
- , _snapLogError :: ByteString -> IO () }
+ { _snapRequest :: Request
+ , _snapResponse :: Response
+ , _snapLogError :: ByteString -> IO ()
+ , _snapSetTimeout :: Int -> IO () }
------------------------------------------------------------------------------
@@ -688,9 +695,10 @@ instance Exception NoHandlerException
-- | Runs a 'Snap' monad action in the 'Iteratee IO' monad.
runSnap :: Snap a
-> (ByteString -> IO ())
+ -> (Int -> IO ())
-> Request
-> Iteratee ByteString IO (Request,Response)
-runSnap (Snap m) logerr req = do
+runSnap (Snap m) logerr timeoutAction req = do
(r, ss') <- runStateT m ss
e <- maybe (return $ Left fourohfour)
@@ -712,16 +720,17 @@ runSnap (Snap m) logerr req = do
dresp = emptyResponse { rspHttpVersion = rqVersion req }
- ss = SnapState req dresp logerr
+ ss = SnapState req dresp logerr timeoutAction
{-# INLINE runSnap #-}
------------------------------------------------------------------------------
evalSnap :: Snap a
-> (ByteString -> IO ())
+ -> (Int -> IO ())
-> Request
-> Iteratee ByteString IO a
-evalSnap (Snap m) logerr req = do
+evalSnap (Snap m) logerr timeoutAction req = do
(r, _) <- runStateT m ss
e <- maybe (liftIO $ throwIO NoHandlerException)
@@ -734,7 +743,7 @@ evalSnap (Snap m) logerr req = do
Right x -> return x
where
dresp = emptyResponse { rspHttpVersion = rqVersion req }
- ss = SnapState req dresp logerr
+ ss = SnapState req dresp logerr timeoutAction
{-# INLINE evalSnap #-}
@@ -770,3 +779,17 @@ getCookie name = withRequest $
return . listToMaybe . filter (\c -> cookieName c == name) . rqCookies
+------------------------------------------------------------------------------
+-- | Causes the handler thread to be killed @n@ seconds from now.
+setTimeout :: MonadSnap m
+ => Int -> m ()
+setTimeout n = do
+ t <- getTimeoutAction
+ liftIO $ t n
+
+
+------------------------------------------------------------------------------
+-- | Returns an 'IO' action which you can use to reset the handling thread's
+-- timeout value.
+getTimeoutAction :: MonadSnap m => m (Int -> IO ())
+getTimeoutAction = liftSnap $ liftM _snapSetTimeout sget
diff --git a/test/suite/Snap/Internal/Routing/Tests.hs
b/test/suite/Snap/Internal/Routing/Tests.hs
index b0a5229..b90d10c 100644
--- a/test/suite/Snap/Internal/Routing/Tests.hs
+++ b/test/suite/Snap/Internal/Routing/Tests.hs
@@ -72,8 +72,9 @@ mkRequest uri = do
go :: Snap a -> ByteString -> IO a
go m s = do
req <- mkRequest s
- run_ $ evalSnap m (const $ return ()) req
-
+ run_ $ evalSnap m dummy dummy req
+ where
+ dummy = const $ return ()
routes :: Snap ByteString
routes = route [ ("foo" , topFoo )
diff --git a/test/suite/Snap/Types/Tests.hs b/test/suite/Snap/Types/Tests.hs
index 9f2435a..2ed23de 100644
--- a/test/suite/Snap/Types/Tests.hs
+++ b/test/suite/Snap/Types/Tests.hs
@@ -141,19 +141,23 @@ testCatchIO = testCase "types/catchIO" $ do
go :: Snap a -> IO (Request,Response)
go m = do
zomgRq <- mkZomgRq
- run_ $ runSnap m (\x -> return $! (show x `using` rdeepseq) `seq` ())
zomgRq
-
+ run_ $ runSnap m dummy dummy zomgRq
+ where
+ dummy !x = return $! (show x `using` rdeepseq) `seq` ()
goIP :: Snap a -> IO (Request,Response)
goIP m = do
rq <- mkIpHeaderRq
- run_ $ runSnap m (const $ return ()) rq
-
+ run_ $ runSnap m dummy dummy rq
+ where
+ dummy = const $ return ()
goPath :: ByteString -> Snap a -> IO (Request,Response)
goPath s m = do
rq <- mkRequest s
- run_ $ runSnap m (const $ return ()) rq
+ run_ $ runSnap m dummy dummy rq
+ where
+ dummy = const $ return ()
goPathQuery :: ByteString
@@ -163,13 +167,17 @@ goPathQuery :: ByteString
-> IO (Request,Response)
goPathQuery s k v m = do
rq <- mkRequestQuery s k v
- run_ $ runSnap m (const $ return ()) rq
+ run_ $ runSnap m dummy dummy rq
+ where
+ dummy = const $ return ()
goBody :: Snap a -> IO (Request,Response)
goBody m = do
rq <- mkRqWithBody
- run_ $ runSnap m (const $ return ()) rq
+ run_ $ runSnap m dummy dummy rq
+ where
+ dummy = const $ return ()
testFail :: Test
@@ -215,10 +223,12 @@ testCatchFinishWith = testCase "types/catchFinishWith" $
do
rq <- mkZomgRq
x <- run_ $ evalSnap (catchFinishWith $ finishWith emptyResponse)
(const $ return ())
+ (const $ return ())
rq
assertBool "catchFinishWith" $ isLeft x
y <- run_ $ evalSnap (catchFinishWith $ return ())
(const $ return ())
+ (const $ return ())
rq
assertBool "catchFinishWith" $ isRight y
@@ -401,6 +411,7 @@ testEvalSnap = testCase "types/evalSnap-exception" $ do
rq <- mkZomgRq
expectException (run_ $ evalSnap f
(const $ return ())
+ (const $ return ())
rq >> return ())
where
f = do
diff --git a/test/suite/Snap/Util/FileServe/Tests.hs
b/test/suite/Snap/Util/FileServe/Tests.hs
index c13917a..53a6dfc 100644
--- a/test/suite/Snap/Util/FileServe/Tests.hs
+++ b/test/suite/Snap/Util/FileServe/Tests.hs
@@ -55,17 +55,22 @@ getBody r = do
liftM (toLazyByteString . mconcat) (runIteratee consume >>= run_ . benum)
+runIt :: Snap a -> Request -> Iteratee ByteString IO (Request, Response)
+runIt m rq = runSnap m d d rq
+ where
+ d = const $ return ()
+
go :: Snap a -> ByteString -> IO Response
go m s = do
rq <- mkRequest s
- liftM snd (run_ $ runSnap m (const $ return ()) rq)
+ liftM snd (run_ $ runIt m rq)
goIfModifiedSince :: Snap a -> ByteString -> ByteString -> IO Response
goIfModifiedSince m s lm = do
rq <- mkRequest s
let r = setHeader "if-modified-since" lm rq
- liftM snd (run_ $ runSnap m (const $ return ()) r)
+ liftM snd (run_ $ runIt m r)
goIfRange :: Snap a -> ByteString -> (Int,Int) -> ByteString -> IO Response
@@ -75,7 +80,7 @@ goIfRange m s (start,end) lm = do
setHeader "Range"
(S.pack $ "bytes=" ++ show start ++ "-" ++ show end)
rq
- liftM snd (run_ $ runSnap m (const $ return ()) r)
+ liftM snd (run_ $ runIt m r)
goRange :: Snap a -> ByteString -> (Int,Int) -> IO Response
@@ -84,7 +89,7 @@ goRange m s (start,end) = do
let rq = setHeader "Range"
(S.pack $ "bytes=" ++ show start ++ "-" ++ show end)
rq'
- liftM snd (run_ $ runSnap m (const $ return ()) rq)
+ liftM snd (run_ $ runIt m rq)
goMultiRange :: Snap a -> ByteString -> (Int,Int) -> (Int,Int) -> IO Response
@@ -94,7 +99,7 @@ goMultiRange m s (start,end) (start2,end2) = do
(S.pack $ "bytes=" ++ show start ++ "-" ++ show end
++ "," ++ show start2 ++ "-" ++ show end2)
rq'
- liftM snd (run_ $ runSnap m (const $ return ()) rq)
+ liftM snd (run_ $ runIt m rq)
goRangePrefix :: Snap a -> ByteString -> Int -> IO Response
@@ -103,7 +108,7 @@ goRangePrefix m s start = do
let rq = setHeader "Range"
(S.pack $ "bytes=" ++ show start ++ "-")
rq'
- liftM snd (run_ $ runSnap m (const $ return ()) rq)
+ liftM snd (run_ $ runIt m rq)
goRangeSuffix :: Snap a -> ByteString -> Int -> IO Response
@@ -112,7 +117,7 @@ goRangeSuffix m s end = do
let rq = setHeader "Range"
(S.pack $ "bytes=-" ++ show end)
rq'
- liftM snd (run_ $ runSnap m (const $ return ()) rq)
+ liftM snd (run_ $ runIt m rq)
mkRequest :: ByteString -> IO Request
diff --git a/test/suite/Snap/Util/GZip/Tests.hs
b/test/suite/Snap/Util/GZip/Tests.hs
index 3247d12..f2d65b2 100644
--- a/test/suite/Snap/Util/GZip/Tests.hs
+++ b/test/suite/Snap/Util/GZip/Tests.hs
@@ -137,7 +137,10 @@ seqSnap m = do
goGeneric :: IO Request -> Snap a -> IO (Request, Response)
goGeneric mkRq m = do
rq <- mkRq
- run_ $! runSnap (seqSnap m) (const $ return ()) rq
+ run_ $! runSnap (seqSnap m) d d rq
+ where
+ d = (const $ return ())
+
goGZip, goCompress, goXGZip :: Snap a -> IO (Request,Response)
goNoHeaders, goXCompress, goBad :: Snap a -> IO (Request,Response)
-----------------------------------------------------------------------
hooks/post-receive
--
snap-core
_______________________________________________
Snap mailing list
[email protected]
http://mailman-mail5.webfaction.com/listinfo/snap
