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 324331b23420578970c9c7faa009349aa1c9be67 (commit)
via 6e76622c65b3c11a91139ebaf6c2763ae91ac9db (commit)
from a792abe9dbf20de3dadb2a7e1b5eb944a3fc00ed (commit)
Summary of changes:
src/Snap/Iteratee.hs | 7 ---
test/suite/Snap/Iteratee/Tests.hs | 12 ++++-
test/suite/Snap/Test/Common.hs | 64 ++++++++++++++++++++++-
test/suite/Snap/Types/Tests.hs | 105 ++++++++++++++++++++++++++++++++-----
4 files changed, 165 insertions(+), 23 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 324331b23420578970c9c7faa009349aa1c9be67
Author: Gregory Collins <[email protected]>
Date: Sat Apr 30 16:47:59 2011 +0200
Increase test coverage; tests for bracketSnap, cover some autoderived
instances, etc
diff --git a/test/suite/Snap/Iteratee/Tests.hs
b/test/suite/Snap/Iteratee/Tests.hs
index ed2c3ee..28e9930 100644
--- a/test/suite/Snap/Iteratee/Tests.hs
+++ b/test/suite/Snap/Iteratee/Tests.hs
@@ -32,7 +32,7 @@ import qualified Test.HUnit as H
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 @@ tests = [ testEnumBS
, testKillIfTooSlow1
, testKillIfTooSlow2
, testBMH
+ , testBMHTrivials
, testCatchIO
]
@@ -430,6 +431,15 @@ testCountBytes2 = testProperty "iteratee/countBytes2" $
------------------------------------------------------------------------------
+testBMHTrivials :: Test
+testBMHTrivials = testCase "iteratee/BoyerMooreHorspoolTrivial" prop
+ where
+ prop = do
+ coverShowInstance $ Match ""
+ coverShowInstance $ NoMatch ""
+
+
+------------------------------------------------------------------------------
testBMH :: Test
testBMH = testProperty "iteratee/BoyerMooreHorspool" $
monadicIO $ forAllM arbitrary prop
diff --git a/test/suite/Snap/Test/Common.hs b/test/suite/Snap/Test/Common.hs
index 8556c17..adccc41 100644
--- 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 @@ instance Arbitrary L.ByteString where
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
index 2ed23de..6abded8 100644
--- a/test/suite/Snap/Types/Tests.hs
+++ b/test/suite/Snap/Types/Tests.hs
@@ -8,7 +8,8 @@ module Snap.Types.Tests
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 Control.Parallel.Strategies
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 Test.HUnit hiding (Test, path)
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 @@ tests = [ testFail
, testRqBody
, testTrivials
, testMethod
+ , testMethods
, testDir
, testCatchIO
, testWrites
@@ -52,7 +56,8 @@ tests = [ testFail
, testMZero404
, testEvalSnap
, testLocalRequest
- , testRedirect ]
+ , testRedirect
+ , testBracketSnap ]
expectException :: IO () -> IO ()
@@ -63,6 +68,17 @@ expectException m = do
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 @@ testEarlyTermination = testCase "types/earlyTermination" $
do
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,13 +298,6 @@ testCatchFinishWith = testCase "types/catchFinishWith" $ do
rq
assertBool "catchFinishWith" $ isRight y
- where
- isLeft (Left _) = True
- isLeft _ = False
-
- isRight (Right _) = True
- isRight _ = False
-
testRqBody :: Test
testRqBody = testCase "types/requestBodies" $ do
@@ -293,14 +352,23 @@ testTrivials = testCase "types/trivials" $ do
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,6 +379,14 @@ testMethod = testCase "types/method" $ do
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
@@ -441,6 +517,9 @@ testRedirect :: Test
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
commit 6e76622c65b3c11a91139ebaf6c2763ae91ac9db
Author: Gregory Collins <[email protected]>
Date: Sat Apr 30 16:47:04 2011 +0200
Remove superfluous (and likely incorrect) clause in takeExactly. Closes #68.
diff --git a/src/Snap/Iteratee.hs b/src/Snap/Iteratee.hs
index 283338d..3b801b5 100644
--- a/src/Snap/Iteratee.hs
+++ b/src/Snap/Iteratee.hs
@@ -470,13 +470,6 @@ take' !n st@(Continue k) = do
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
-----------------------------------------------------------------------
hooks/post-receive
--
snap-core
_______________________________________________
Snap mailing list
[email protected]
http://mailman-mail5.webfaction.com/listinfo/snap
