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 c0d76f6c7f9f3124f76c29d0a4d53a546dc22c14 (commit)
from a5f0b60ddfc27f0531e2a432e6e03878206b3fab (commit)
Summary of changes:
snap-core.cabal | 5 +
src/Snap/Internal/Debug.hs | 5 +-
src/Snap/Util/GZip.hs | 20 +++---
test/snap-core-testsuite.cabal | 2 +
test/suite/Snap/Util/FileServe/Tests.hs | 21 +++++-
test/suite/Snap/Util/GZip/Tests.hs | 132 ++++++++++++++++++++++++++-----
6 files changed, 152 insertions(+), 33 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 c0d76f6c7f9f3124f76c29d0a4d53a546dc22c14
Author: Gregory Collins <[email protected]>
Date: Sun Jul 25 16:02:18 2010 -0400
Bump snap-core test coverage
diff --git a/snap-core.cabal b/snap-core.cabal
index 84711f7..cd4f183 100644
--- a/snap-core.cabal
+++ b/snap-core.cabal
@@ -120,6 +120,7 @@ Library
if flag(testsuite)
cpp-options: -DDEBUG_TEST
+ build-depends: deepseq >= 1.1 && <1.2
if flag(portable) || os(windows)
cpp-options: -DPORTABLE
@@ -173,6 +174,10 @@ Library
ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2
Executable snap
+ if flag(testsuite)
+ cpp-options: -DDEBUG_TEST
+ build-depends: deepseq >= 1.1 && <1.2
+
hs-source-dirs: src
main-is: Snap/Starter.hs
diff --git a/src/Snap/Internal/Debug.hs b/src/Snap/Internal/Debug.hs
index 8c94e8e..aeaf875 100644
--- a/src/Snap/Internal/Debug.hs
+++ b/src/Snap/Internal/Debug.hs
@@ -13,13 +13,14 @@ module Snap.Internal.Debug where
import Control.Monad.Trans
#ifdef DEBUG_TEST
+import Control.DeepSeq
debug :: (MonadIO m) => String -> m ()
-debug !s = return $ s `seq` ()
+debug !s = let !s' = rnf s in return $! s' `deepseq` ()
{-# INLINE debug #-}
debugErrno :: (MonadIO m) => String -> m ()
-debugErrno !s = return $ s `seq` ()
+debugErrno !s = let !s' = rnf s in return $! s' `deepseq` ()
#elif defined(DEBUG)
diff --git a/src/Snap/Util/GZip.hs b/src/Snap/Util/GZip.hs
index 9a6d2dc..53666f6 100644
--- a/src/Snap/Util/GZip.hs
+++ b/src/Snap/Util/GZip.hs
@@ -111,10 +111,10 @@ withCompression' mimeTable action = do
chooseType [] = return ()
- chooseType ("gzip":_) = gzipCompression
- chooseType ("compress":_) = compressCompression
- chooseType ("x-gzip":_) = gzipCompression
- chooseType ("x-compress":_) = compressCompression
+ chooseType ("gzip":_) = gzipCompression "gzip"
+ chooseType ("compress":_) = compressCompression "compress"
+ chooseType ("x-gzip":_) = gzipCompression "x-gzip"
+ chooseType ("x-compress":_) = compressCompression "x-compress"
chooseType (_:xs) = chooseType xs
@@ -137,19 +137,19 @@ compressibleMimeTypes = Set.fromList [
"application/x-font-truetype"
------------------------------------------------------------------------------
-gzipCompression :: Snap ()
-gzipCompression = modifyResponse f
+gzipCompression :: ByteString -> Snap ()
+gzipCompression ce = modifyResponse f
where
- f = setHeader "Content-Encoding" "gzip" .
+ f = setHeader "Content-Encoding" ce .
clearContentLength .
modifyResponseBody gcompress
------------------------------------------------------------------------------
-compressCompression :: Snap ()
-compressCompression = modifyResponse f
+compressCompression :: ByteString -> Snap ()
+compressCompression ce = modifyResponse f
where
- f = setHeader "Content-Encoding" "compress" .
+ f = setHeader "Content-Encoding" ce .
clearContentLength .
modifyResponseBody ccompress
diff --git a/test/snap-core-testsuite.cabal b/test/snap-core-testsuite.cabal
index b267f02..911d036 100644
--- a/test/snap-core-testsuite.cabal
+++ b/test/snap-core-testsuite.cabal
@@ -26,6 +26,7 @@ Executable testsuite
if flag(testsuite)
cpp-options: -DDEBUG_TEST
+ build-depends: deepseq >= 1.1 && <1.2
if flag(portable) || os(windows)
cpp-options: -DPORTABLE
@@ -42,6 +43,7 @@ Executable testsuite
bytestring-nums,
cereal >= 0.2 && < 0.3,
containers,
+ deepseq >= 1.1 && <1.2,
directory,
dlist >= 0.5 && < 0.6,
filepath,
diff --git a/test/suite/Snap/Util/FileServe/Tests.hs
b/test/suite/Snap/Util/FileServe/Tests.hs
index 94eb756..1274a9a 100644
--- a/test/suite/Snap/Util/FileServe/Tests.hs
+++ b/test/suite/Snap/Util/FileServe/Tests.hs
@@ -23,7 +23,8 @@ import Snap.Util.FileServe
import Snap.Iteratee
tests :: [Test]
-tests = [ testFs ]
+tests = [ testFs
+ , testFsSingle ]
expect404 :: IO Response -> IO ()
@@ -58,6 +59,10 @@ mkRequest uri = do
fs :: Snap ()
fs = fileServe "data/fileServe"
+fsSingle :: Snap ()
+fsSingle = fileServeSingle "data/fileServe/foo.html"
+
+
testFs :: Test
testFs = testCase "fileServe" $ do
r1 <- go fs "foo.bin"
@@ -113,6 +118,20 @@ testFs = testCase "fileServe" $ do
coverMimeMap
+testFsSingle :: Test
+testFsSingle = testCase "fileServeSingle" $ do
+ r1 <- go fsSingle "foo.html"
+ b1 <- getBody r1
+
+ assertEqual "foo.html" "FOO\n" b1
+ assertEqual "foo.html content-type"
+ (Just "text/html")
+ (getHeader "content-type" r1)
+
+ assertEqual "foo.html size" (Just 4) (rspContentLength r1)
+
+
+
coverMimeMap :: (Monad m) => m ()
coverMimeMap = mapM_ f $ Map.toList defaultMimeTypes
where
diff --git a/test/suite/Snap/Util/GZip/Tests.hs
b/test/suite/Snap/Util/GZip/Tests.hs
index 92e249d..568986a 100644
--- a/test/suite/Snap/Util/GZip/Tests.hs
+++ b/test/suite/Snap/Util/GZip/Tests.hs
@@ -31,6 +31,9 @@ tests :: [Test]
tests = [ testIdentity1
, testIdentity2
, testIdentity3
+ , testIdentity4
+ , testIdentity5
+ , testNopWhenContentEncodingSet
, testCompositionDoesn'tExplode
, testBadHeaders ]
@@ -50,11 +53,14 @@ liftQ = QC.run
------------------------------------------------------------------------------
-gzipHdrs, badHdrs, compressHdrs, emptyHdrs :: Headers
+gzipHdrs, xGzipHdrs, badHdrs, compressHdrs, xCompressHdrs, emptyHdrs :: Headers
emptyHdrs = Map.empty
gzipHdrs = setHeader "Accept-Encoding" "froz,gzip, x-gzip" emptyHdrs
+xGzipHdrs = setHeader "Accept-Encoding" "x-gzip;q=1.0" emptyHdrs
badHdrs = setHeader "Accept-Encoding" "*&%^&^$%&%&*^\023" emptyHdrs
compressHdrs = setHeader "Accept-Encoding" "compress" emptyHdrs
+xCompressHdrs = setHeader "Accept-Encoding" "x-compress" emptyHdrs
+
------------------------------------------------------------------------------
@@ -65,6 +71,14 @@ mkGzipRq = do
return $ Request "foo" 80 "foo" 999 "foo" 1000 "foo" False gzipHdrs
enum Nothing GET (1,1) [] "" "/" "/" "/" "" Map.empty
+mkXGzipRq :: IO Request
+mkXGzipRq = do
+ enum <- newIORef $ SomeEnumerator return
+
+ return $ Request "foo" 80 "foo" 999 "foo" 1000 "foo" False xGzipHdrs
+ enum Nothing GET (1,1) [] "" "/" "/" "/" "" Map.empty
+
+
------------------------------------------------------------------------------
mkCompressRq :: IO Request
@@ -74,6 +88,14 @@ mkCompressRq = do
return $ Request "foo" 80 "foo" 999 "foo" 1000 "foo" False compressHdrs
enum Nothing GET (1,1) [] "" "/" "/" "/" "" Map.empty
+mkXCompressRq :: IO Request
+mkXCompressRq = do
+ enum <- newIORef $ SomeEnumerator return
+
+ return $ Request "foo" 80 "foo" 999 "foo" 1000 "foo" False xCompressHdrs
+ enum Nothing GET (1,1) [] "" "/" "/" "/" "" Map.empty
+
+
------------------------------------------------------------------------------
mkBadRq :: IO Request
@@ -84,7 +106,7 @@ mkBadRq = do
enum Nothing GET (1,1) [] "" "/" "/" "/" "" Map.empty
------------------------------------------------------------------------------
-goGZip, goCompress, goBad :: Snap a -> IO (Request,Response)
+goGZip, goCompress, goXGZip, goXCompress, goBad :: Snap a -> IO
(Request,Response)
goGZip m = do
gzipRq <- mkGzipRq
run $ runSnap m (const $ return ()) gzipRq
@@ -93,6 +115,15 @@ goCompress m = do
compressRq <- mkCompressRq
run $ runSnap m (const $ return ()) compressRq
+goXGZip m = do
+ gzipRq <- mkXGzipRq
+ run $ runSnap m (const $ return ()) gzipRq
+
+goXCompress m = do
+ compressRq <- mkXCompressRq
+ run $ runSnap m (const $ return ()) compressRq
+
+
goBad m = do
badRq <- mkBadRq
run $ runSnap m (const $ return ()) badRq
@@ -118,6 +149,7 @@ testIdentity1 = testProperty "identity1" $ monadicIO $
forAllM arbitrary prop
prop :: L.ByteString -> PropertyM IO ()
prop s = do
(_,rsp) <- liftQ $ goGZip (withCompression $ textPlain s)
+ assert $ getHeader "Content-Encoding" rsp == Just "gzip"
let body = rspBodyToEnum $ rspBody rsp
c <- liftQ $
@@ -126,31 +158,16 @@ testIdentity1 = testProperty "identity1" $ monadicIO $
forAllM arbitrary prop
let s1 = GZip.decompress c
assert $ s == s1
-testCompositionDoesn'tExplode :: Test
-testCompositionDoesn'tExplode =
- testProperty "testCompositionDoesn'tExplode" $
- monadicIO $
- forAllM arbitrary prop
- where
- prop :: L.ByteString -> PropertyM IO ()
- prop s = do
- (_,rsp) <- liftQ $ goGZip (withCompression $ withCompression $
textPlain s)
- let body = rspBodyToEnum $ rspBody rsp
-
- c <- liftQ $
- body stream2stream >>= run >>= return . fromWrap
-
- let s1 = GZip.decompress c
- assert $ s == s1
-
-
+------------------------------------------------------------------------------
testIdentity2 :: Test
testIdentity2 = testProperty "identity2" $ monadicIO $ forAllM arbitrary prop
where
prop :: L.ByteString -> PropertyM IO ()
prop s = do
(_,rsp2) <- liftQ $ goCompress (withCompression $ textPlain s)
+
+ assert $ getHeader "Content-Encoding" rsp2 == Just "compress"
let body2 = rspBodyToEnum $ rspBody rsp2
c2 <- liftQ $
@@ -160,6 +177,7 @@ testIdentity2 = testProperty "identity2" $ monadicIO $
forAllM arbitrary prop
assert $ s == s2
+------------------------------------------------------------------------------
testIdentity3 :: Test
testIdentity3 = testProperty "identity3" $ monadicIO $ forAllM arbitrary prop
where
@@ -174,6 +192,40 @@ testIdentity3 = testProperty "identity3" $ monadicIO $
forAllM arbitrary prop
assert $ s == s3
+------------------------------------------------------------------------------
+testIdentity4 :: Test
+testIdentity4 = testProperty "identity4" $ monadicIO $ forAllM arbitrary prop
+ where
+ prop :: L.ByteString -> PropertyM IO ()
+ prop s = do
+ (_,rsp) <- liftQ $ goXGZip (withCompression $ textPlain s)
+ assert $ getHeader "Content-Encoding" rsp == Just "x-gzip"
+ let body = rspBodyToEnum $ rspBody rsp
+
+ c <- liftQ $
+ body stream2stream >>= run >>= return . fromWrap
+
+ let s1 = GZip.decompress c
+ assert $ s == s1
+
+
+------------------------------------------------------------------------------
+testIdentity5 :: Test
+testIdentity5 = testProperty "identity5" $ monadicIO $ forAllM arbitrary prop
+ where
+ prop :: L.ByteString -> PropertyM IO ()
+ prop s = do
+ (_,rsp2) <- liftQ $ goXCompress (withCompression $ textPlain s)
+
+ assert $ getHeader "Content-Encoding" rsp2 == Just "x-compress"
+ let body2 = rspBodyToEnum $ rspBody rsp2
+
+ c2 <- liftQ $
+ body2 stream2stream >>= run >>= return . fromWrap
+
+ let s2 = Zlib.decompress c2
+ assert $ s == s2
+
------------------------------------------------------------------------------
testBadHeaders :: Test
@@ -185,3 +237,43 @@ testBadHeaders = testProperty "bad headers" $ monadicIO $
forAllM arbitrary prop
let body = rspBodyToEnum $ rspBody rsp
body stream2stream >>= run >>= return . fromWrap
+
+
+------------------------------------------------------------------------------
+testNopWhenContentEncodingSet :: Test
+testNopWhenContentEncodingSet = testProperty "testNopWhenContentEncodingSet" $
+ monadicIO $
+ forAllM arbitrary prop
+ where
+ prop :: L.ByteString -> PropertyM IO ()
+ prop s = do
+ (_,rsp) <- liftQ $ goGZip $ f s
+ assert $ getHeader "Content-Encoding" rsp == Just "identity"
+
+ f s = withCompression $ do
+ modifyResponse $ setHeader "Content-Encoding" "identity"
+ textPlain s
+
+
+------------------------------------------------------------------------------
+testCompositionDoesn'tExplode :: Test
+testCompositionDoesn'tExplode =
+ testProperty "testCompositionDoesn'tExplode" $
+ monadicIO $
+ forAllM arbitrary prop
+ where
+ prop :: L.ByteString -> PropertyM IO ()
+ prop s = do
+ (_,rsp) <- liftQ $ goGZip (withCompression $
+ withCompression $
+ withCompression $ textPlain s)
+
+ assert $ getHeader "Content-Encoding" rsp == Just "gzip"
+
+ let body = rspBodyToEnum $ rspBody rsp
+
+ c <- liftQ $
+ body stream2stream >>= run >>= return . fromWrap
+
+ let s1 = GZip.decompress c
+ assert $ s == s1
-----------------------------------------------------------------------
hooks/post-receive
--
snap-core
_______________________________________________
Snap mailing list
[email protected]
http://mailman-mail5.webfaction.com/listinfo/snap
