diff --git a/src/Snap/Util/GZip.hs b/src/Snap/Util/GZip.hs index 16ef15a4..804055a8 100644 --- a/src/Snap/Util/GZip.hs +++ b/src/Snap/Util/GZip.hs @@ -6,7 +6,8 @@ module Snap.Util.GZip ( withCompression -, withCompression' ) where +, withCompression' +, noCompression ) where import Blaze.ByteString.Builder import qualified Codec.Zlib.Enum as Z @@ -122,6 +123,13 @@ withCompression' mimeTable action = do chooseType (_:xs) = chooseType xs +------------------------------------------------------------------------------ +-- | Turn off compression by setting \"Content-Encoding: identity\" in the +-- response headers. +noCompression :: MonadSnap m => m () +noCompression = modifyResponse $ setHeader "Content-Encoding" "identity" + + ------------------------------------------------------------------------------ -- private following ------------------------------------------------------------------------------ diff --git a/test/suite/Snap/Util/GZip/Tests.hs b/test/suite/Snap/Util/GZip/Tests.hs index 3e30c463..bcba5fbd 100644 --- a/test/suite/Snap/Util/GZip/Tests.hs +++ b/test/suite/Snap/Util/GZip/Tests.hs @@ -50,6 +50,7 @@ tests = [ testIdentity1 , testNopWhenContentEncodingSet , testCompositionDoesn'tExplode , testGzipLotsaChunks + , testNoCompression , testBadHeaders ] @@ -401,3 +402,24 @@ testGzipLotsaChunks = testCase "gzip/lotsOfChunks" prop frobnicate s = let s' = encode $ md5 $ L.fromChunks [s] in (s:frobnicate s') + +------------------------------------------------------------------------------ +testNoCompression :: Test +testNoCompression = testProperty "gzip/noCompression" $ + monadicIO $ forAllM arbitrary prop + where + prop :: L.ByteString -> PropertyM IO () + prop s = do + (!_,!rsp) <- liftQ $ goGZip (seqSnap $ withCompression $ + (noCompression >> textPlain s)) + assert $ getHeader "Content-Encoding" rsp == Just "identity" + let body = rspBodyToEnum $ rspBody rsp + + s1 <- liftQ $ + runIteratee stream2stream >>= run_ . body + + assert $ s == s1 + + + +