diff --git a/project_template/default/foo.cabal b/project_template/default/foo.cabal --- a/project_template/default/foo.cabal +++ b/project_template/default/foo.cabal @@ -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, diff --git a/snap-core.cabal b/snap-core.cabal --- a/snap-core.cabal +++ b/snap-core.cabal @@ -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, 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 @@ -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) 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 @@ -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' diff --git a/src/Snap/Util/GZip.hs b/src/Snap/Util/GZip.hs --- a/src/Snap/Util/GZip.hs +++ b/src/Snap/Util/GZip.hs @@ -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 diff --git a/test/runTestsAndCoverage.sh b/test/runTestsAndCoverage.sh --- a/test/runTestsAndCoverage.sh +++ b/test/runTestsAndCoverage.sh @@ -4,6 +4,9 @@ SUITE=./dist/build/testsuite/testsuite +export LC_ALL=C +export LANG=C + rm -f testsuite.tix if [ ! -f $SUITE ]; then 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 @@ -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, diff --git a/test/suite/Snap/Internal/Http/Types/Tests.hs b/test/suite/Snap/Internal/Http/Types/Tests.hs --- a/test/suite/Snap/Internal/Http/Types/Tests.hs +++ b/test/suite/Snap/Internal/Http/Types/Tests.hs @@ -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 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 @@ -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) 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 @@ -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 + diff --git a/test/suite/Snap/Util/FileServe/Tests.hs b/test/suite/Snap/Util/FileServe/Tests.hs --- a/test/suite/Snap/Util/FileServe/Tests.hs +++ b/test/suite/Snap/Util/FileServe/Tests.hs @@ -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 () diff --git a/test/suite/Snap/Util/GZip/Tests.hs b/test/suite/Snap/Util/GZip/Tests.hs --- a/test/suite/Snap/Util/GZip/Tests.hs +++ b/test/suite/Snap/Util/GZip/Tests.hs @@ -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