diff --git a/README.SNAP.md b/README.SNAP.md
--- a/README.SNAP.md
+++ b/README.SNAP.md
@@ -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
diff --git a/snap-core.cabal b/snap-core.cabal
--- a/snap-core.cabal
+++ b/snap-core.cabal
@@ -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 .
+ 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 .
.
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,
diff --git a/src/Snap/Internal/Debug.hs b/src/Snap/Internal/Debug.hs
--- a/src/Snap/Internal/Debug.hs
+++ b/src/Snap/Internal/Debug.hs
@@ -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 ())
diff --git a/src/Snap/Internal/Http/Types.hs b/src/Snap/Internal/Http/Types.hs
--- a/src/Snap/Internal/Http/Types.hs
+++ b/src/Snap/Internal/Http/Types.hs
@@ -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
diff --git a/src/Snap/Internal/Iteratee/BoyerMooreHorspool.hs b/src/Snap/Internal/Iteratee/BoyerMooreHorspool.hs
--- a/src/Snap/Internal/Iteratee/BoyerMooreHorspool.hs
+++ b/src/Snap/Internal/Iteratee/BoyerMooreHorspool.hs
@@ -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
diff --git a/src/Snap/Internal/Types.hs b/src/Snap/Internal/Types.hs
--- a/src/Snap/Internal/Types.hs
+++ b/src/Snap/Internal/Types.hs
@@ -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
diff --git a/src/Snap/Iteratee.hs b/src/Snap/Iteratee.hs
--- a/src/Snap/Iteratee.hs
+++ b/src/Snap/Iteratee.hs
@@ -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
diff --git a/src/Snap/Types.hs b/src/Snap/Types.hs
--- a/src/Snap/Types.hs
+++ b/src/Snap/Types.hs
@@ -20,6 +20,7 @@
-- ** Routing
, method
+ , methods
, path
, dir
, ifTop
diff --git a/src/Snap/Util/FileUploads.hs b/src/Snap/Util/FileUploads.hs
--- a/src/Snap/Util/FileUploads.hs
+++ b/src/Snap/Util/FileUploads.hs
@@ -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]
diff --git a/test/snap-core-testsuite.cabal b/test/snap-core-testsuite.cabal
--- a/test/snap-core-testsuite.cabal
+++ b/test/snap-core-testsuite.cabal
@@ -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.*,
diff --git a/test/suite/Snap/Iteratee/Tests.hs b/test/suite/Snap/Iteratee/Tests.hs
--- a/test/suite/Snap/Iteratee/Tests.hs
+++ b/test/suite/Snap/Iteratee/Tests.hs
@@ -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 ""
------------------------------------------------------------------------------
diff --git a/test/suite/Snap/Test/Common.hs b/test/suite/Snap/Test/Common.hs
--- a/test/suite/Snap/Test/Common.hs
+++ b/test/suite/Snap/Test/Common.hs
@@ -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 ()
diff --git a/test/suite/Snap/Types/Tests.hs b/test/suite/Snap/Types/Tests.hs
--- a/test/suite/Snap/Types/Tests.hs
+++ b/test/suite/Snap/Types/Tests.hs
@@ -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
diff --git a/test/suite/Snap/Util/FileUploads/Tests.hs b/test/suite/Snap/Util/FileUploads/Tests.hs
--- a/test/suite/Snap/Util/FileUploads/Tests.hs
+++ b/test/suite/Snap/Util/FileUploads/Tests.hs
@@ -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 ()