snap-core 0.4.1 → 0.4.2
raw patch · 14 files changed
+277/−120 lines, 14 filesdep ~blaze-builderdep ~bytestring-mmap
Dependency ranges changed: blaze-builder, bytestring-mmap
Files
- README.SNAP.md +1/−1
- snap-core.cabal +6/−7
- src/Snap/Internal/Debug.hs +4/−1
- src/Snap/Internal/Http/Types.hs +1/−2
- src/Snap/Internal/Iteratee/BoyerMooreHorspool.hs +73/−68
- src/Snap/Internal/Types.hs +11/−0
- src/Snap/Iteratee.hs +4/−16
- src/Snap/Types.hs +1/−0
- src/Snap/Util/FileUploads.hs +3/−5
- test/snap-core-testsuite.cabal +2/−2
- test/suite/Snap/Iteratee/Tests.hs +11/−1
- test/suite/Snap/Test/Common.hs +62/−2
- test/suite/Snap/Types/Tests.hs +92/−13
- test/suite/Snap/Util/FileUploads/Tests.hs +6/−2
README.SNAP.md view
@@ -9,7 +9,7 @@ Snap Status and Features ------------------------ -This developer prerelease contains only the Snap core system, namely:+The Snap core system consists of: * a high-speed HTTP server, with an optional high-concurrency backend using the [libev](http://software.schmorp.de/pkg/libev.html) library
snap-core.cabal view
@@ -1,12 +1,11 @@ name: snap-core-version: 0.4.1+version: 0.4.2 synopsis: Snap: A Haskell Web Framework (Core) description:- This is the first developer prerelease of the Snap framework. Snap is a- simple and fast web development framework and server written in Haskell. For- more information or to download the latest version, you can visit the Snap- project website at <http://snapframework.com/>.+ Snap is a simple and fast web development framework and server written in+ Haskell. For more information or to download the latest version, you can+ visit the Snap project website at <http://snapframework.com/>. . This library contains the core definitions and types for the Snap framework, including:@@ -106,7 +105,7 @@ else c-sources: cbits/timefuncs.c include-dirs: cbits- build-depends: bytestring-mmap >= 0.2.1 && <0.3+ build-depends: bytestring-mmap >= 0.2.2 && <0.3 exposed-modules: Data.CIByteString,@@ -131,7 +130,7 @@ attoparsec >= 0.8.0.2 && < 0.9, attoparsec-enumerator >= 0.2.0.3, base >= 4 && < 5,- blaze-builder >= 0.2.1.4 && <0.3,+ blaze-builder >= 0.2.1.4 && <0.4, bytestring, bytestring-nums, containers,
src/Snap/Internal/Debug.hs view
@@ -16,10 +16,12 @@ module Snap.Internal.Debug where ------------------------------------------------------------------------------+import Control.Monad.Trans++#ifndef NODEBUG import Control.Concurrent import Control.DeepSeq import Control.Exception-import Control.Monad.Trans import Data.Char import Data.List import Data.Maybe@@ -28,6 +30,7 @@ import System.IO import System.IO.Unsafe import Text.Printf+#endif ------------------------------------------------------------------------------ debug, debugErrno :: forall m . (MonadIO m => String -> m ())
src/Snap/Internal/Http/Types.hs view
@@ -204,8 +204,7 @@ -- | Returns the HTTP server's idea of its local hostname. , rqLocalHostname :: !ByteString - -- | Returns @True@ if this is an @HTTPS@ session (currently always- -- @False@).+ -- | Returns @True@ if this is an @HTTPS@ session. , rqIsSecure :: !Bool , rqHeaders :: Headers , rqBody :: IORef SomeEnumerator
src/Snap/Internal/Iteratee/BoyerMooreHorspool.hs view
@@ -19,10 +19,10 @@ import Prelude hiding (head, last) -{-# INLINE debug #-}-debug :: MonadIO m => String -> m ()+--{-# INLINE debug #-}+--debug :: MonadIO m => String -> m () --debug s = liftIO $ putStrLn s-debug _ = return ()+--debug _ = return () ------------------------------------------------------------------------------ data MatchInfo = Match !ByteString@@ -41,8 +41,8 @@ EL.head >>= maybe (do let !ls = S.concat $ dlist []- debug $ "lookahead " ++ show n- ++ " failing, returning " ++ show ls+ -- debug $ "lookahead " ++ show n+ -- ++ " failing, returning " ++ show ls return $ Left ls) (\x -> do@@ -53,9 +53,9 @@ if r <= 0 then do let !ls = S.concat $ d' []- debug $ "lookahead " ++ show n- ++ " successfully returning "- ++ show ls+ -- debug $ "lookahead " ++ show n+ -- ++ " successfully returning "+ -- ++ show ls return $ Right $ ls else go d' r) {-# INLINE lookahead #-}@@ -73,8 +73,8 @@ go !nend !hend = if nend < nstart || hend < hstart then True- else let !nc = S.index needle nend -- FIXME: use unsafeIndex- !hc = S.index haystack hend+ else let !nc = S.unsafeIndex needle nend+ !hc = S.unsafeIndex haystack hend in if nc /= hc then False else go (nend-1) (hend-1)@@ -86,7 +86,7 @@ -> Step MatchInfo m a -> Iteratee ByteString m (Step MatchInfo m a) bmhEnumeratee needle _step = do- debug $ "boyermoore: needle=" ++ show needle+ -- debug $ "boyermoore: needle=" ++ show needle cDone _step iter where {-# INLINE cDone #-}@@ -99,14 +99,14 @@ (startSearch k) finishAndEOF k xs = {-# SCC "finishAndEOF" #-} do- debug $ "finishAndEOF, returning NoMatch for " ++ show xs+ -- debug $ "finishAndEOF, returning NoMatch for " ++ show xs step <- lift $ runIteratee $ k $ Chunks (map NoMatch $ filter (not . S.null) xs) cDone step (\k' -> lift $ runIteratee $ k' EOF) startSearch !k !haystack = {-# SCC "startSearch" #-} do- debug $ "startsearch: " ++ show haystack+ -- debug $ "startsearch: " ++ show haystack if S.null haystack then lookahead nlen >>= either (\s -> finishAndEOF k [s])@@ -119,8 +119,8 @@ | hend >= hlen = crossBound hidx | otherwise = {-# SCC "go" #-} do let match = matches needle 0 last haystack hidx hend- debug $ "go " ++ show hidx ++ ", hend=" ++ show hend- ++ ", match was " ++ show match+ -- debug $ "go " ++ show hidx ++ ", hend=" ++ show hend+ -- ++ ", match was " ++ show match if match then {-# SCC "go/match" #-} do let !nomatch = S.take hidx haystack@@ -135,73 +135,78 @@ cDone step' $ \k'' -> startSearch k'' aftermatch else {-# SCC "go/nomatch" #-} do -- skip ahead- let c = S.index haystack hend+ let c = S.unsafeIndex haystack hend let !skip = V.unsafeIndex table $ fromEnum c go (hidx + skip) where !hend = hidx + nlen - 1++ mkCoeff hidx = let !ll = hlen - hidx+ !nm = nlen - ll+ in (ll,nm) - crossBound !hidx = {-# SCC "crossBound" #-} do- let !leftLen = hlen - hidx- let !needMore = nlen - leftLen- debug $ "crossbound " ++ show hidx ++ ", leftlen=" ++ show leftLen- ++ ", needmore=" ++ show needMore + crossBound !hidx0 = {-# SCC "crossBound" #-} do+ let (!leftLen, needMore) = mkCoeff hidx0+ lookahead needMore >>=- either- (\s -> finishAndEOF k [haystack, s])- (\nextHaystack -> do- let match1 = matches needle leftLen last- nextHaystack 0 (needMore-1)- let match2 = matches needle 0 (leftLen-1)- haystack hidx (hlen-1)+ either (\s -> finishAndEOF k [haystack, s])+ (runNext hidx0 leftLen needMore)+ where+ runNext !hidx !leftLen !needMore !nextHaystack = do+ let match1 = matches needle leftLen last+ nextHaystack 0 (needMore-1)+ let match2 = matches needle 0 (leftLen-1)+ haystack hidx (hlen-1) - debug $ "crossbound match1=" ++ show match1- ++ " match2=" ++ show match2+ -- debug $ "crossbound match1=" ++ show match1+ -- ++ " match2=" ++ show match2 - if match1 && match2- then {-# SCC "crossBound/match" #-} do- let !nomatch = S.take hidx haystack- let !aftermatch = S.drop needMore nextHaystack+ if match1 && match2+ then {-# SCC "crossBound/match" #-} do+ let !nomatch = S.take hidx haystack+ let !aftermatch = S.drop needMore nextHaystack - -- FIXME: merge this code w/ above- step <- if not $ S.null nomatch- then lift $ runIteratee $ k $- Chunks [NoMatch nomatch]- else return $ Continue k+ -- FIXME: merge this code w/ above+ step <- if not $ S.null nomatch+ then lift $ runIteratee $ k $+ Chunks [NoMatch nomatch]+ else return $ Continue k - debug $ "matching"- cDone step $ \k' -> do- step' <- lift $ runIteratee $ k' $- Chunks [Match needle]- cDone step' $ \k'' ->- startSearch k'' aftermatch+ -- debug $ "matching"+ cDone step $ \k' -> do+ step' <- lift $ runIteratee $ k' $+ Chunks [Match needle]+ cDone step' $ \k'' ->+ startSearch k'' aftermatch - else {-# SCC "crossBound/nomatch" #-} do- let c = S.index nextHaystack $ needMore-1- let p = V.unsafeIndex table (fromEnum c)+ else {-# SCC "crossBound/nomatch" #-} do+ let c = S.unsafeIndex nextHaystack $ needMore-1+ let p = V.unsafeIndex table (fromEnum c) - debug $ "p was " ++ show p ++ ", ll=" ++ show leftLen- if p < leftLen+ -- debug $ "p was " ++ show p ++ ", ll=" ++ show leftLen+ if p < leftLen+ then do+ let !hidx' = hidx+p+ let (!leftLen', needMore') = mkCoeff hidx'+ let !nextlen = S.length nextHaystack+ if (nextlen < needMore') then do- let (!nomatch, !crumb) = S.splitAt (hidx + p)- haystack- let !rest = S.append crumb nextHaystack- step <- lift $ runIteratee $ k $- Chunks $ map NoMatch $- filter (not . S.null) [nomatch]-- cDone step $ flip startSearch rest-- else do- let sidx = p - leftLen- let (!crumb, !rest) = S.splitAt sidx nextHaystack- step <- lift $ runIteratee $ k $- Chunks $ map NoMatch $- filter (not . S.null) [haystack, crumb]-- cDone step $ flip startSearch rest- )+ -- this should be impossibly rare+ lookahead (needMore' - nextlen) >>=+ either (\s -> finishAndEOF k [ haystack+ , nextHaystack+ , s ])+ (\s -> runNext hidx' leftLen' needMore' $+ S.append nextHaystack s)+ else runNext hidx' leftLen' needMore' nextHaystack+ else do+ let sidx = p - leftLen+ let (!crumb, !rest) = S.splitAt sidx nextHaystack+ step <- lift $ runIteratee $ k $+ Chunks $ map NoMatch $+ filter (not . S.null) [haystack, crumb] + cDone step $ flip startSearch rest !nlen = S.length needle
src/Snap/Internal/Types.hs view
@@ -319,6 +319,17 @@ ------------------------------------------------------------------------------+-- | Runs a 'Snap' monad action only if the request's HTTP method matches+-- one of the given methods.+methods :: MonadSnap m => [Method] -> m a -> m a+methods ms action = do+ req <- getRequest+ unless (rqMethod req `elem` ms) pass+ action+{-# INLINE methods #-}+++------------------------------------------------------------------------------ -- Appends n bytes of the path info to the context path with a -- trailing slash. updateContextPath :: Int -> Request -> Request
src/Snap/Iteratee.hs view
@@ -129,7 +129,6 @@ import System.PosixCompat.Types #endif - ------------------------------------------------------------------------------ instance (Functor m, MonadCatchIO m) => MonadCatchIO (Iteratee s m) where@@ -139,11 +138,7 @@ insideCatch !mm = Iteratee $ do ee <- try $ runIteratee mm case ee of - -- if we got an async exception here then the iteratee workflow is- -- all messed up, we have no reasonable choice but to send EOF to the- -- handler, because the unparsed input got lost. If the enumerator- -- sends more chunks we can possibly recover later.- (Left e) -> runIteratee (enumEOF $$ handler e)+ (Left e) -> runIteratee $ handler e (Right v) -> step v step (Continue !k) = do@@ -475,13 +470,6 @@ takeExactly :: (Monad m) => Int64 -> Enumeratee ByteString ByteString m a-takeExactly 0 s = do- s' <- lift $ runIteratee $ enumEOF s- case s' of- (Continue _) -> error "divergent iteratee"- (Error e) -> throwError e- (Yield v _) -> yield (Yield v EOF) EOF- takeExactly !n y@(Yield _ _ ) = drop' n >> return y takeExactly _ (Error e ) = throwError e takeExactly !n st@(Continue !k) = do@@ -591,7 +579,7 @@ enumFile = _enumFile enumFilePartial fp rng@(start,end) iter = do- when (end < start) $ throw InvalidRangeException+ when (end < start) $ throwError InvalidRangeException _enumFilePartial fp rng iter #else@@ -718,7 +706,7 @@ proc !nb (Continue !k) = continue $ cont nb k proc _ !z = returnI z - cont !nBytesRead !k EOF = k EOF+ cont _ !k EOF = k EOF cont !nBytesRead !k !stream = do let !slen = toEnum $ streamLength stream now <- liftIO getTime@@ -726,7 +714,7 @@ let !newBytes = nBytesRead + slen when (delta > minSeconds+1 && fromIntegral newBytes / (delta-minSeconds) < minRate) $- throw RateTooSlowException+ throwError RateTooSlowException -- otherwise bump the timeout and continue running the iteratee !_ <- lift bump
src/Snap/Types.hs view
@@ -20,6 +20,7 @@ -- ** Routing , method+ , methods , path , dir , ifTop
src/Snap/Util/FileUploads.hs view
@@ -256,19 +256,17 @@ "got multipart/form-data without boundary" let boundary = fromJust mbBoundary- captures <- runRequestBody (iter bumpTimeout boundary partHandler `catch`- errHandler)+ captures <- runRequestBody (iter bumpTimeout boundary partHandler) procCaptures [] captures where- iter bump boundary ph = killIfTooSlow+ iter bump boundary ph = iterateeDebugWrapper "killIfTooSlow" $+ killIfTooSlow bump (minimumUploadRate uploadPolicy) (minimumUploadSeconds uploadPolicy) (internalHandleMultipart boundary ph)-- errHandler (e :: SomeException) = skipToEof >> (lift $ throw e) ins k v = Map.insertWith' (\a b -> Prelude.head a : b) k [v]
test/snap-core-testsuite.cabal view
@@ -17,7 +17,7 @@ else c-sources: ../cbits/timefuncs.c include-dirs: ../cbits- build-depends: bytestring-mmap >= 0.2.1 && <0.3+ build-depends: bytestring-mmap >= 0.2.2 && <0.3 build-depends: QuickCheck >= 2.3.0.2,@@ -25,7 +25,7 @@ attoparsec-enumerator >= 0.2.0.3, base >= 4 && < 5, base16-bytestring == 0.1.*,- blaze-builder >= 0.2.1.4 && <0.3,+ blaze-builder >= 0.2.1.4 && <0.4, bytestring, bytestring-nums, cereal == 0.3.*,
test/suite/Snap/Iteratee/Tests.hs view
@@ -32,7 +32,7 @@ import Snap.Iteratee import Snap.Internal.Iteratee.BoyerMooreHorspool-import Snap.Test.Common ()+import Snap.Test.Common (coverShowInstance) import Snap.Internal.Iteratee.Debug @@ -79,6 +79,7 @@ , testKillIfTooSlow1 , testKillIfTooSlow2 , testBMH+ , testBMHTrivials , testCatchIO ] @@ -427,6 +428,15 @@ (!_,m) <- countBytes $ drop' 4 x <- liftM L.fromChunks consume return (m,x)+++------------------------------------------------------------------------------+testBMHTrivials :: Test+testBMHTrivials = testCase "iteratee/BoyerMooreHorspoolTrivial" prop+ where+ prop = do+ coverShowInstance $ Match ""+ coverShowInstance $ NoMatch "" ------------------------------------------------------------------------------
test/suite/Snap/Test/Common.hs view
@@ -1,13 +1,26 @@-{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -module Snap.Test.Common where+module Snap.Test.Common+ ( coverEqInstance+ , coverOrdInstance+ , coverReadInstance+ , coverShowInstance+ , coverTypeableInstance+ , forceSameType+ ) where +import Control.DeepSeq+import Control.Exception import Control.Monad+import Control.Monad.Trans import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L import Data.ByteString.Internal (c2w)+import Data.Typeable+import Prelude hiding (catch) import Test.QuickCheck @@ -20,3 +33,50 @@ chunks <- replicateM n arbitrary return $ L.fromChunks chunks ++-- | Kill the false negative on derived show instances.+coverShowInstance :: (Monad m, Show a) => a -> m ()+coverShowInstance x = a `deepseq` b `deepseq` c `deepseq` return ()+ where+ a = showsPrec 0 x ""+ b = show x+ c = showList [x] ""+++eatException :: IO a -> IO ()+eatException a = (a >> return ()) `catch` handler+ where+ handler :: SomeException -> IO ()+ handler _ = return ()++forceSameType :: a -> a -> a+forceSameType _ a = a+++coverReadInstance :: (MonadIO m, Read a) => a -> m ()+coverReadInstance x = do+ liftIO $ eatException $ evaluate $ forceSameType [(x,"")] $ readsPrec 0 ""+ liftIO $ eatException $ evaluate $ forceSameType [([x],"")] $ readList ""+++coverEqInstance :: (Monad m, Eq a) => a -> m ()+coverEqInstance x = a `seq` b `seq` return ()+ where+ a = x == x+ b = x /= x+++coverOrdInstance :: (Monad m, Ord a) => a -> m ()+coverOrdInstance x = a `deepseq` b `deepseq` return ()+ where+ a = [ x < x+ , x >= x+ , x > x+ , x <= x + , compare x x == EQ ]++ b = min a $ max a a+++coverTypeableInstance :: (Monad m, Typeable a) => a -> m ()+coverTypeableInstance a = typeOf a `seq` return ()
test/suite/Snap/Types/Tests.hs view
@@ -8,7 +8,8 @@ import Blaze.ByteString.Builder import Control.Applicative import Control.Concurrent.MVar-import Control.Exception (SomeException)+import Control.DeepSeq+import Control.Exception (ErrorCall(..), SomeException, throwIO) import Control.Monad import Control.Monad.CatchIO import Control.Monad.Trans (liftIO)@@ -16,7 +17,9 @@ import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as S import qualified Data.ByteString.Lazy.Char8 as L+import qualified Data.IntMap as IM import Data.IORef+import Data.Maybe (isJust) import Data.Monoid import Data.Text () import Data.Text.Lazy ()@@ -30,7 +33,7 @@ import Snap.Internal.Types import Snap.Internal.Http.Types import Snap.Iteratee-import Snap.Test.Common ()+import Snap.Test.Common tests :: [Test]@@ -41,6 +44,7 @@ , testRqBody , testTrivials , testMethod+ , testMethods , testDir , testCatchIO , testWrites@@ -52,7 +56,8 @@ , testMZero404 , testEvalSnap , testLocalRequest- , testRedirect ]+ , testRedirect+ , testBracketSnap ] expectException :: IO () -> IO ()@@ -63,6 +68,17 @@ assertBool "expected exception" b +expectSpecificException :: Exception e => e -> IO () -> IO ()+expectSpecificException e0 m = do+ r <- (try m :: IO (Either SomeException ()))++ let b = either (\se -> isJust $+ forceSameType (Just e0) (fromException se))+ (const False)+ r+ assertBool ("expected specific exception: " ++ show e0) b++ expect404 :: IO (Request,Response) -> IO () expect404 m = do (_,r) <- m@@ -218,6 +234,56 @@ assertEqual "foo" (Just ["Quux"]) $ getHeaders "Foo" resp +isLeft :: Either a b -> Bool+isLeft (Left _) = True+isLeft _ = False++isRight :: Either a b -> Bool+isRight (Right _) = True+isRight _ = False+++testBracketSnap :: Test+testBracketSnap = testCase "types/bracketSnap" $ do+ rq <- mkZomgRq++ ref <- newIORef 0++ expectSpecificException NoHandlerException $+ run_ $ evalSnap (act ref) (const $ return ()) (const $ return ()) rq++ y <- readIORef ref+ assertEqual "bracketSnap/after1" (1::Int) y++ expectSpecificException (ErrorCall "no value") $+ run_ $ evalSnap (act ref <|> finishWith emptyResponse)+ (const $ return ())+ (const $ return ())+ rq+ + y' <- readIORef ref+ assertEqual "bracketSnap/after" 2 y'+++ expectSpecificException (ErrorCall "foo") $+ run_ $ evalSnap (act2 ref)+ (const $ return ())+ (const $ return ())+ rq+ + y'' <- readIORef ref+ assertEqual "bracketSnap/after" 3 y''++ where+ act ref = bracketSnap (liftIO $ readIORef ref)+ (\z -> liftIO $ writeIORef ref $! z+1)+ (\z -> z `seq` mzero)++ act2 ref = bracketSnap (liftIO $ readIORef ref)+ (\z -> liftIO $ writeIORef ref $! z+1)+ (\z -> z `seq` liftIO $ throwIO $ ErrorCall "foo")++ testCatchFinishWith :: Test testCatchFinishWith = testCase "types/catchFinishWith" $ do rq <- mkZomgRq@@ -232,14 +298,7 @@ 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@@ -293,14 +352,23 @@ withRequest $ return . (`seq` ()) withResponse $ return . (`seq` ()) - return () b <- getBody rsp- let !_ = show b `using` rdeepseq+ coverShowInstance b+ coverShowInstance NoHandlerException+ coverShowInstance GET+ coverReadInstance GET+ coverEqInstance GET+ coverEqInstance NoHandlerException+ coverOrdInstance GET + Prelude.map (\(x,y) -> (x,show y)) (IM.toList statusReasonMap)+ `deepseq` return () - let !_ = show NoHandlerException `seq` ()+ let cookie = Cookie "" "" Nothing Nothing Nothing+ coverEqInstance cookie+ coverShowInstance cookie assertEqual "rq secure" True $ rqIsSecure rq assertEqual "rsp status" 333 $ rspStatus rsp@@ -311,7 +379,15 @@ expect404 $ go (method POST $ return ()) expectNo404 $ go (method GET $ return ()) +testMethods :: Test+testMethods = testCase "types/methods" $ do+ expect404 $ go (methods [POST,PUT] $ return ())+ expectNo404 $ go (methods [GET] $ return ())+ expectNo404 $ go (methods [POST,GET] $ return ())+ expectNo404 $ go (methods [PUT,GET] $ return ())+ expectNo404 $ go (methods [GET,PUT,DELETE] $ return ()) + testDir :: Test testDir = testCase "types/dir" $ do expect404 $ goPath "foo/bar" (dir "zzz" $ return ())@@ -441,6 +517,9 @@ testRedirect = testCase "types/redirect" $ do (_,rsp) <- go (redirect "/foo/bar") + b <- getBody rsp+ assertEqual "no response body" "" b+ assertEqual "response content length" (Just 0) $ rspContentLength rsp assertEqual "redirect path" (Just "/foo/bar") $ getHeader "Location" rsp assertEqual "redirect status" 302 $ rspStatus rsp assertEqual "status description" "Found" $ rspStatusReason rsp
test/suite/Snap/Util/FileUploads/Tests.hs view
@@ -27,6 +27,8 @@ import Test.HUnit hiding (Test, path) ------------------------------------------------------------------------------ import Snap.Internal.Http.Types+import Snap.Internal.Debug+import Snap.Internal.Iteratee.Debug import Snap.Internal.Types import Snap.Util.FileUploads import Snap.Iteratee hiding (map)@@ -354,7 +356,7 @@ goSlowEnumerator m s = do rq <- mkRequest s writeIORef (rqBody rq) $ SomeEnumerator slowEnum- mx <- timeout (6*seconds) (liftM snd (run_ $ runIt m rq))+ mx <- timeout (20*seconds) (liftM snd (run_ $ runIt m rq)) maybe (error "timeout") return mx where@@ -364,9 +366,11 @@ goo (Continue k) [] = k EOF goo (Continue k) (x:xs) = do+ debug $ "goSlowEnumerator: sending " ++ show x step <- lift $ runIteratee $ k $ Chunks [ S.pack (x:[]) ] liftIO waitabit goo step xs+ goo (Error e) _ = throwError e goo _ _ = error "impossible" @@ -381,7 +385,7 @@ ------------------------------------------------------------------------------ runIt :: Snap a -> Request -> Iteratee ByteString IO (Request, Response)-runIt m rq = runSnap m d d rq+runIt m rq = iterateeDebugWrapper "test" $ runSnap m d d rq where d :: forall a . Show a => a -> IO () d = \x -> show x `deepseq` return ()