Add a 'noCompression' function to the gzip utilities.

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
 ------------------------------------------------------------------------------

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
+
+
+
+