Merge pull request #814 from phadej/zlib-0.6

Use zlib-0.6
haskell · Apr 1, 2019 · 3d0207e · 3d0207e
2 parents 39c08a5 + 4224341
commit 3d0207e
Show file tree

Hide file tree

Showing 3 changed files with 28 additions and 14 deletions.
diff --git a/Distribution/Server/Features/HoogleData.hs b/Distribution/Server/Features/HoogleData.hs
@@ -212,15 +212,14 @@ hoogleDataFeature docsUpdatedState hoogleBundleUpdateJob
             -- miss a few entries from the tarball 'til next time its updated.
             oldEntries <- case mhOldTar of
               Nothing      -> return []
-              Just hOldTar -> 
+              Just hOldTar -> do
+                contents <- BS.hGetContents hOldTar
                 return . Tar.foldEntries (:) [] (const [])
                        . Tar.read
                        . BS.fromChunks
-                       . Zlib.foldDecompressStream (:) [] (\_ _ -> [])
-                       . Zlib.decompressWithErrors
-                           Zlib.gzipFormat
-                           Zlib.defaultDecompressParams
-                     =<< BS.hGetContents hOldTar
+                       . Zlib.foldDecompressStreamWithInput (:) (\_ -> []) (\_ -> [])
+                         (Zlib.decompressST Zlib.gzipFormat Zlib.defaultDecompressParams)
+                       $ contents
 
             -- Write out the cached ones
             sequence_

diff --git a/Distribution/Server/Framework/RequestContentTypes.hs b/Distribution/Server/Framework/RequestContentTypes.hs
@@ -31,9 +31,11 @@ module Distribution.Server.Framework.RequestContentTypes (
 import Happstack.Server
 import Distribution.Server.Framework.HappstackUtils
 import Distribution.Server.Framework.Error
-import qualified Data.ByteString.Char8 as BS (ByteString, unpack) -- Used for content-type headers only
-import qualified Data.ByteString.Lazy as LBS (ByteString)
+import qualified Data.ByteString.Char8 as BS (ByteString, empty, unpack) -- Used for content-type headers only
+import qualified Data.ByteString.Lazy as LBS (ByteString, empty)
+import qualified Data.ByteString.Lazy.Internal as LBS (ByteString (..))
 import qualified Codec.Compression.Zlib.Internal as GZip
+import Control.Monad.IO.Class (liftIO)
 import qualified Data.Aeson as Aeson
 
 -- | Expect the request body to have the given mime type (exact match),
@@ -67,12 +69,25 @@ expectContentType expected = do
         [MText $ "The only content-encodings supported are gzip, or none at all."]
 
 gzipDecompress :: LBS.ByteString -> ServerPartE LBS.ByteString
-gzipDecompress content =
-    case GZip.decompressWithErrors
-           GZip.gzipFormat GZip.defaultDecompressParams content of
-      GZip.StreamError errkind _ -> errDecompress errkind
-      stream                     -> return (GZip.fromDecompressStream stream)
+gzipDecompress content = go content decompressor
   where
+    decompressor :: GZip.DecompressStream IO
+    decompressor = GZip.decompressIO GZip.gzipFormat GZip.defaultDecompressParams
+
+    go :: LBS.ByteString -> GZip.DecompressStream IO -> ServerPartE LBS.ByteString
+    go cs (GZip.DecompressOutputAvailable bs k) = do
+        stream <- liftIO k
+        LBS.Chunk bs `fmap` go cs stream
+    go _  (GZip.DecompressStreamEnd      _bs)   = return LBS.empty
+    go _  (GZip.DecompressStreamError err)      = errDecompress err
+    go cs (GZip.DecompressInputRequired      k) = do
+        let ~(c, cs') = uncons cs
+        liftIO (k c) >>= go cs'
+
+    uncons :: LBS.ByteString -> (BS.ByteString, LBS.ByteString)
+    uncons LBS.Empty        = (BS.empty, LBS.Empty)
+    uncons (LBS.Chunk c cs) = (c, cs)
+
     errDecompress GZip.TruncatedInput =
       errBadRequest "Truncated data upload"
         [MText $ "The uploaded data (gzip-compressed) is truncated. Check "

diff --git a/hackage-server.cabal b/hackage-server.cabal
@@ -121,7 +121,7 @@ common defaults
     , text                  ^>= 1.2.2
     , unordered-containers  ^>= 0.2.3.0
     , vector                ^>= 0.12
-    , zlib                  ^>= 0.5.3
+    , zlib                  ^>= 0.6.2
 
   ghc-options: -Wall -fwarn-tabs -fno-warn-unused-do-bind -fno-warn-deprecated-flags -funbox-strict-fields