diff --git a/Distribution/Server/Features/HoogleData.hs b/Distribution/Server/Features/HoogleData.hs index 1f6915eef..92c7da76f 100644 --- 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 index 89430d01e..70e340c61 100644 --- 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 index b1b66ea24..181369b38 100644 --- 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