snap-core 0.2.8.1 → 0.2.9
raw patch · 12 files changed
+379/−62 lines, 12 filesdep +deepseqdep ~cereal
Dependencies added: deepseq
Dependency ranges changed: cereal
Files
- project_template/default/foo.cabal +1/−1
- snap-core.cabal +8/−3
- src/Snap/Internal/Debug.hs +3/−2
- src/Snap/Internal/Http/Types.hs +6/−6
- src/Snap/Util/GZip.hs +10/−10
- test/runTestsAndCoverage.sh +3/−0
- test/snap-core-testsuite.cabal +4/−2
- test/suite/Snap/Internal/Http/Types/Tests.hs +56/−6
- test/suite/Snap/Iteratee/Tests.hs +8/−6
- test/suite/Snap/Types/Tests.hs +143/−4
- test/suite/Snap/Util/FileServe/Tests.hs +25/−2
- test/suite/Snap/Util/GZip/Tests.hs +112/−20
project_template/default/foo.cabal view
@@ -22,7 +22,7 @@ snap-core >= 0.2 && <0.3, snap-server >= 0.2 && <0.3, heist >= 0.2.2 && <0.3,- hexpat == 0.16,+ hexpat >= 0.18.2 && <0.19, xhtml-combinators, unix, text,
snap-core.cabal view
@@ -1,5 +1,5 @@ name: snap-core-version: 0.2.8.1+version: 0.2.9 synopsis: Snap: A Haskell Web Framework (Core) description:@@ -120,6 +120,7 @@ if flag(testsuite) cpp-options: -DDEBUG_TEST+ build-depends: deepseq >= 1.1 && <1.2 if flag(portable) || os(windows) cpp-options: -DPORTABLE@@ -147,7 +148,7 @@ base >= 4 && < 5, bytestring, bytestring-nums,- cereal >= 0.2 && < 0.3,+ cereal >= 0.3 && < 0.4, containers, directory, dlist >= 0.5 && < 0.6,@@ -173,6 +174,10 @@ 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 @@ -183,7 +188,7 @@ base >= 4 && < 5, bytestring, bytestring-nums,- cereal >= 0.2 && < 0.3,+ cereal >= 0.3 && < 0.4, containers, directory, directory-tree,
src/Snap/Internal/Debug.hs view
@@ -13,13 +13,14 @@ 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)
src/Snap/Internal/Http/Types.hs view
@@ -305,8 +305,8 @@ version = concat [ "version: " , show $ rqVersion r ]- cookies' = " " ++ (concat $ intersperse "\n " $- map show $ rqCookies r)+ cookies' = " " ++ (concat $ intersperse "\n " $+ map show $ rqCookies r) cookies = concat [ "cookies:\n" , " ========================================\n" , cookies'@@ -316,10 +316,10 @@ contextpath = concat [ "contextpath: ", toStr $ rqContextPath r ] snapletpath = concat [ "snapletpath: ", toStr $ rqSnapletPath r ] uri = concat [ "URI: ", toStr $ rqURI r ]- params' = " " ++- (concat $ intersperse "\n " $- map (\ (a,b) -> B.unpack a ++ ": " ++ show b) $- Map.toAscList $ rqParams r)+ params' = " " +++ (concat $ intersperse "\n " $+ map (\ (a,b) -> B.unpack a ++ ": " ++ show b) $+ Map.toAscList $ rqParams r) params = concat [ "params:\n" , " ========================================\n" , params'
src/Snap/Util/GZip.hs view
@@ -111,10 +111,10 @@ 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 @@ -------------------------------------------------------------------------------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
test/runTestsAndCoverage.sh view
@@ -4,6 +4,9 @@ SUITE=./dist/build/testsuite/testsuite +export LC_ALL=C+export LANG=C+ rm -f testsuite.tix if [ ! -f $SUITE ]; then
test/snap-core-testsuite.cabal view
@@ -10,7 +10,7 @@ Flag testsuite Description: Are we running the testsuite? Causes arguments to \"debug\" to be evaluated but not printed.- Default: False+ Default: True Flag portable Description: Compile in cross-platform mode. No platform-specific code or@@ -40,8 +40,9 @@ base >= 4 && < 5, bytestring, bytestring-nums,- cereal >= 0.2 && < 0.3,+ cereal >= 0.3 && < 0.4, containers,+ deepseq >= 1.1 && <1.2, directory, dlist >= 0.5 && < 0.6, filepath,@@ -53,6 +54,7 @@ old-locale, old-time, parallel >= 2.2 && <2.3,+ regex-posix >= 0.94.4 && <0.95, test-framework >= 0.3.1 && <0.4, test-framework-hunit >= 0.2.5 && < 0.3, test-framework-quickcheck2 >= 0.2.6 && < 0.3,
test/suite/Snap/Internal/Http/Types/Tests.hs view
@@ -5,9 +5,11 @@ import Control.Monad import Control.Parallel.Strategies+import Data.ByteString.Char8 (ByteString) import Data.ByteString.Lazy.Char8 () import Data.IORef import Data.Iteratee (stream2stream, run)+import Data.List (sort) import qualified Data.Map as Map import Data.Time.Calendar import Data.Time.Clock@@ -15,13 +17,16 @@ import Test.Framework import Test.Framework.Providers.HUnit import Test.HUnit hiding (Test, path)-+import Text.Regex.Posix import Snap.Internal.Http.Types import Snap.Iteratee (enumBS, fromWrap) tests :: [Test]-tests = [ testTypes ]+tests = [ testTypes+ , testUrlDecode+ , testFormatLogTime+ , testAddHeader ] mkRq :: IO Request@@ -31,6 +36,33 @@ enum Nothing GET (1,1) [] "" "/" "/" "/" "" Map.empty +testFormatLogTime :: Test+testFormatLogTime = testCase "formatLogTime" $ do+ b <- formatLogTime 3804938++ let re = ("^[0-9]{1,2}/[A-Za-z]{3}/[0-9]{4}:[0-9]{2}:[0-9]{2}:[0-9]{2} -[0-9]{4}$"+ :: ByteString)++ assertBool "formatLogTime" $ b =~ re+++testAddHeader :: Test+testAddHeader = testCase "addHeader" $ do+ defReq <- mkRq++ let req = addHeader "foo" "bar" $+ addHeader "foo" "baz" defReq+++ let x = getHeader "foo" req+ assertEqual "addHeader x 2" (Just "bar baz") x+++testUrlDecode :: Test+testUrlDecode = testCase "urlDecode" $ do+ assertEqual "bad hex" Nothing $ urlDecode "%qq"++ testTypes :: Test testTypes = testCase "show" $ do defReq <- mkRq@@ -40,7 +72,10 @@ rqSetParam "foo" ["bar"] $ defReq + let req2 = (addHeader "zomg" "1234" req) { rqCookies = [ cook, cook2 ] }+ let !a = show req `using` rdeepseq+ let !_ = show req2 `using` rdeepseq -- we don't care about the show instance really, we're just trying to shut -- up hpc@@ -48,8 +83,12 @@ assertEqual "rqParam" (Just ["bar"]) (rqParam "foo" req) assertEqual "lookup" (Just ["bbb"]) (Map.lookup "zzz" $ rqParams req) assertEqual "lookup 2" (Just ["bbb"]) (Map.lookup "zzz" $ headers req)- assertEqual "cookie" (Just ["foo=bar; path=/; expires=Sat, 30-Jan-2010 00:00:00 GMT; domain=.foo.com"]) cook'+ assertEqual "cookie" (Just ["foo=bar; path=/; expires=Sat, 30-Jan-2010 00:00:00 GMT; domain=.foo.com"]) cookieHeader + assertEqual "cookie2" (Just ["foo=bar; path=/; expires=Sat, 30-Jan-2010 00:00:00 GMT; domain=.foo.com", "foo=baz; path=/; expires=Sat, 30-Jan-2010 00:00:00 GMT; domain=.foo.com"]) (liftM sort cookieHeader2)++ assertEqual "cookie3" (Just ["foo=baz"]) cookieHeader3+ assertEqual "response status" 555 $ rspStatus resp assertEqual "response status reason" "bogus" $ rspStatusReason resp assertEqual "content-length" (Just 4) $ rspContentLength resp@@ -61,7 +100,9 @@ let !_ = GET == POST let !_ = headers $ headers defReq + let !_ = show resp2 `using` rdeepseq + return () where@@ -74,7 +115,16 @@ emptyResponse !b = show resp `using` rdeepseq - utc = UTCTime (ModifiedJulianDay 55226) 0- cook = Cookie "foo" "bar" (Just utc) (Just ".foo.com") (Just "/")- cook' = Map.lookup "Set-Cookie" $ headers resp+ resp2 = addCookie cook2 resp+ resp3 = addCookie cook3 emptyResponse+++ utc = UTCTime (ModifiedJulianDay 55226) 0+ cook = Cookie "foo" "bar" (Just utc) (Just ".foo.com") (Just "/")+ cook2 = Cookie "foo" "baz" (Just utc) (Just ".foo.com") (Just "/")+ cook3 = Cookie "foo" "baz" Nothing Nothing Nothing++ cookieHeader = Map.lookup "Set-Cookie" $ headers resp+ cookieHeader2 = Map.lookup "Set-Cookie" $ headers resp2+ cookieHeader3 = Map.lookup "Set-Cookie" $ headers resp3
test/suite/Snap/Iteratee/Tests.hs view
@@ -338,7 +338,8 @@ assert $ e == s where- doIter = enumLBS s (joinI (takeNoMoreThan n stream2stream))+ doIter = enumLBS (L.concat ["", s])+ (joinI (takeNoMoreThan n stream2stream)) n = fromIntegral $ L.length s @@ -354,7 +355,7 @@ if (L.null s || m == 0) then liftQ $ do- !v <- doIter >>= run+ !_ <- doIter >>= run return () else expectException $ doIter >>= run >>= return . fromWrap @@ -394,13 +395,14 @@ prop :: L.ByteString -> PropertyM IO () prop s = do pre $ L.length s > 4- n1 <- f iter+ (n1,s') <- f iter assert $ n1 == 4+ assert $ fromWrap s' == L.drop 4 s where f i = liftQ $ enumLBS s i >>= run iter = do- (!_,m) <- countBytes $ drop 4- stream2stream- return m+ (!_,m) <- countBytes $ drop' 4+ x <- stream2stream+ return (m,x)
test/suite/Snap/Types/Tests.hs view
@@ -7,14 +7,20 @@ import Control.Applicative import Control.Concurrent.MVar+import Control.Exception (SomeException) import Control.Monad+import Control.Monad.CatchIO import Control.Monad.Trans (liftIO)+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 Data.IORef import Data.Iteratee+import Data.Text ()+import Data.Text.Lazy () import qualified Data.Map as Map+import Prelude hiding (catch) import Test.Framework import Test.Framework.Providers.HUnit import Test.Framework.Providers.QuickCheck2@@ -34,17 +40,32 @@ , testTrivials , testMethod , testDir+ , testCatchIO , testWrites , testParam , testURLEncode1- , testURLEncode2 ]+ , testURLEncode2+ , testDir2+ , testIpHeaderFilter+ , testMZero404+ , testEvalSnap+ , testLocalRequest ] +expectException :: IO () -> IO ()+expectException m = do+ r <- (try m :: IO (Either SomeException ()))+ let b = either (\e -> show e `using` rdeepseq `seq` True)+ (const False) r+ assertBool "expected exception" b++ expect404 :: IO (Request,Response) -> IO () expect404 m = do (_,r) <- m assertBool "expected 404" (rspStatus r == 404) + expectNo404 :: IO (Request,Response) -> IO () expectNo404 m = do (_,r) <- m@@ -56,7 +77,7 @@ mkRequest uri = do enum <- newIORef $ SomeEnumerator return - return $ Request "foo" 80 "foo" 999 "foo" 1000 "foo" False Map.empty+ return $ Request "foo" 80 "127.0.0.1" 999 "foo" 1000 "foo" False Map.empty enum Nothing GET (1,1) [] "" uri "/" (S.concat ["/",uri]) "" Map.empty @@ -76,10 +97,16 @@ mkZomgRq = do enum <- newIORef $ SomeEnumerator return - return $ Request "foo" 80 "foo" 999 "foo" 1000 "foo" False Map.empty+ return $ Request "foo" 80 "127.0.0.1" 999 "foo" 1000 "foo" False Map.empty enum Nothing GET (1,1) [] "" "/" "/" "/" "" Map.empty +mkIpHeaderRq :: IO Request+mkIpHeaderRq = do+ rq <- mkZomgRq+ return $ setHeader "X-Forwarded-For" "1.2.3.4" rq++ mkRqWithBody :: IO Request mkRqWithBody = do enum <- newIORef $ SomeEnumerator (enumBS "zazzle")@@ -88,12 +115,36 @@ Map.empty +testCatchIO :: Test+testCatchIO = testCase "catchIO" $ do+ (_,rsp) <- go f+ (_,rsp2) <- go g++ assertEqual "catchIO 1" (Just "bar") $ getHeader "foo" rsp+ assertEqual "catchIO 2" Nothing $ getHeader "foo" rsp2++ where+ f :: Snap ()+ f = (block $ unblock $ throw NoHandlerException) `catch` h++ g :: Snap ()+ g = return () `catch` h++ h :: SomeException -> Snap ()+ h e = e `seq` modifyResponse $ addHeader "foo" "bar"+ go :: Snap a -> IO (Request,Response) go m = do zomgRq <- mkZomgRq- run $ runSnap m (const $ return ()) zomgRq+ run $ runSnap m (\x -> return $! (show x `using` rdeepseq) `seq` ()) zomgRq +goIP :: Snap a -> IO (Request,Response)+goIP m = do+ rq <- mkIpHeaderRq+ run $ runSnap m (const $ return ()) rq++ goPath :: ByteString -> Snap a -> IO (Request,Response) goPath s m = do rq <- mkRequest s@@ -200,8 +251,27 @@ q <- getRequest liftIO $ assertEqual "localrq" False $ rqIsSecure q return ()++ logError "foo"+ writeText "zzz"+ writeLazyText "zzz"++ let req' = updateContextPath 0 req+ let cp1 = rqContextPath req+ let cp2 = rqContextPath req'++ liftIO $ assertEqual "updateContextPath 0" cp1 cp2++ withRequest $ return . (`seq` ())+ withResponse $ return . (`seq` ())++ return () + b <- getBody rsp+ let !_ = show b `using` rdeepseq++ let !_ = show NoHandlerException `seq` () assertEqual "rq secure" True $ rqIsSecure rq@@ -265,3 +335,72 @@ testURLEncode2 = testProperty "url encoding 2" prop where prop s = (urlDecode $ urlEncode s) == Just s+++testDir2 :: Test+testDir2 = testCase "dir2" $ do+ (_,resp) <- goPath "foo/bar" f+ b <- getBody resp+ assertEqual "context path" "/foo/bar/" b++ where+ f = dir "foo" $ dir "bar" $ do+ p <- liftM rqContextPath getRequest+ addToOutput $ enumBS p+++testIpHeaderFilter :: Test+testIpHeaderFilter = testCase "ipHeaderFilter" $ do+ (_,r) <- goIP f+ b <- getBody r+ assertEqual "ipHeaderFilter" "1.2.3.4" b+++ (_,r2) <- go f+ b2 <- getBody r2+ assertEqual "ipHeaderFilter" "127.0.0.1" b2++ where+ f = do+ ipHeaderFilter+ ip <- liftM rqRemoteAddr getRequest+ writeBS ip+++testMZero404 :: Test+testMZero404 = testCase "mzero 404" $ do+ (_,r) <- go mzero+ let l = rspContentLength r+ b <- getBody r+ assertEqual "mzero 404" "404" b+ assertEqual "mzero 404 length" (Just 3) l+++testEvalSnap :: Test+testEvalSnap = testCase "evalSnap exception" $ do+ rq <- mkZomgRq+ expectException (run $ evalSnap f+ (const $ return ())+ rq >> return ())+ where+ f = do+ logError "zzz"+ v <- withResponse (return . rspHttpVersion)+ liftIO $ assertEqual "evalSnap rsp version" (1,1) v+ finishWith emptyResponse+++testLocalRequest :: Test+testLocalRequest = testCase "localRequest" $ do+ rq1 <- mkZomgRq+ rq2 <- mkRequest "zzz/zz/z"++ let h = localRequest (const rq2) mzero++ (rq',_) <- go (h <|> return ())++ let u1 = rqURI rq1+ let u2 = rqURI rq'++ assertEqual "localRequest backtrack" u1 u2+
test/suite/Snap/Util/FileServe/Tests.hs view
@@ -23,7 +23,8 @@ import Snap.Iteratee tests :: [Test]-tests = [ testFs ]+tests = [ testFs+ , testFsSingle ] expect404 :: IO Response -> IO ()@@ -56,8 +57,16 @@ (B.concat ["/",uri]) "" Map.empty fs :: Snap ()-fs = fileServe "data/fileServe"+fs = do+ x <- fileServe "data/fileServe"+ return $! x `seq` () +fsSingle :: Snap ()+fsSingle = do+ x <- fileServeSingle "data/fileServe/foo.html"+ return $! x `seq` ()++ testFs :: Test testFs = testCase "fileServe" $ do r1 <- go fs "foo.bin"@@ -111,6 +120,20 @@ expect404 $ go fs "/etc/password" 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 ()
test/suite/Snap/Util/GZip/Tests.hs view
@@ -31,6 +31,9 @@ tests = [ testIdentity1 , testIdentity2 , testIdentity3+ , testIdentity4+ , testIdentity5+ , testNopWhenContentEncodingSet , testCompositionDoesn'tExplode , testBadHeaders ] @@ -50,13 +53,16 @@ -------------------------------------------------------------------------------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 + ------------------------------------------------------------------------------ mkGzipRq :: IO Request mkGzipRq = do@@ -65,7 +71,15 @@ 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 mkCompressRq = do@@ -74,7 +88,15 @@ 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 mkBadRq = do@@ -84,7 +106,7 @@ 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 @@ 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,23 +149,7 @@ prop :: L.ByteString -> PropertyM IO () prop s = do (_,rsp) <- liftQ $ goGZip (withCompression $ textPlain s)- let body = rspBodyToEnum $ rspBody rsp-- c <- liftQ $- body stream2stream >>= run >>= return . fromWrap-- 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)+ assert $ getHeader "Content-Encoding" rsp == Just "gzip" let body = rspBodyToEnum $ rspBody rsp c <- liftQ $@@ -144,13 +159,15 @@ 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 @@ assert $ s == s2 +------------------------------------------------------------------------------ testIdentity3 :: Test testIdentity3 = testProperty "identity3" $ monadicIO $ forAllM arbitrary prop where@@ -174,8 +192,42 @@ 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 testBadHeaders = testProperty "bad headers" $ monadicIO $ forAllM arbitrary prop where@@ -185,3 +237,43 @@ 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