From a3f72295d79f2e10b4eb4005dadb5c40c914fae3 Mon Sep 17 00:00:00 2001
From: mangoiv <contact@mangoiv.com>
Date: Sun, 24 Nov 2024 21:42:34 +0100
Subject: [PATCH] [fix] fix expected content-types for documentation tarballs

- documentation tarballs produced by cabal haddock are compressed
- their mimetype is application/gzip
- keeps the applicatoin/x-tar and applicatoin/x-gzip even though there
  is no tar mimetype and there's now (since 2014) a gzip mimetype,
  according to RFC6713
- remove the expectUncompressedTarball function as it is now dead code
- remove a pair of redundant paren and replace infix `liftM` with <$>
---
 .../Server/Features/Documentation.hs           | 18 ++++++++++--------
 .../Server/Framework/RequestContentTypes.hs    | 12 +-----------
 2 files changed, 11 insertions(+), 19 deletions(-)

diff --git a/src/Distribution/Server/Features/Documentation.hs b/src/Distribution/Server/Features/Documentation.hs
index 511a8ddb3..9222024b8 100644
--- a/src/Distribution/Server/Features/Documentation.hs
+++ b/src/Distribution/Server/Features/Documentation.hs
@@ -23,6 +23,7 @@ import Distribution.Server.Framework.BlobStorage (BlobId)
 import qualified Distribution.Server.Framework.BlobStorage as BlobStorage
 import qualified Distribution.Server.Util.ServeTarball as ServerTarball
 import qualified Distribution.Server.Util.DocMeta as DocMeta
+import qualified Distribution.Server.Util.GZip as Gzip
 import Distribution.Server.Features.BuildReports.BuildReport (PkgDetails(..), BuildStatus(..))
 import Data.TarIndex (TarIndex)
 import qualified Codec.Archive.Tar       as Tar
@@ -46,7 +47,6 @@ import Data.Time.Clock (NominalDiffTime, diffUTCTime, getCurrentTime)
 import System.Directory (getModificationTime)
 import Control.Applicative
 import Distribution.Server.Features.PreferredVersions
-import Distribution.Server.Features.PreferredVersions.State (getVersionStatus)
 import Distribution.Server.Packages.Types
 -- TODO:
 -- 1. Write an HTML view for organizing uploads
@@ -327,8 +327,10 @@ documentationFeature name
       -- \* Generate the new index
       -- \* Drop the index for the old tar-file
       -- \* Link the new documentation to the package
-      fileContents <- expectUncompressedTarball
-      mres <- liftIO $ BlobStorage.addWith store fileContents
+      fileContents <- expectCompressedTarball
+      let filename = display pkgid ++ "-docs" <.> "tar.gz"
+          unpacked = Gzip.decompressNamed filename fileContents
+      mres <- liftIO $ BlobStorage.addWith store unpacked 
                          (\content -> return (checkDocTarball pkgid content))
       case mres of
         Left  err -> errBadRequest "Invalid documentation tarball" [MText err]
@@ -377,15 +379,15 @@ documentationFeature name
         helper (pkg:pkgs) = do
           hasDoc <- queryHasDocumentation (pkgInfoId pkg)
           let status = getVersionStatus prefInfo (packageVersion pkg)
-          if hasDoc && status == NormalVersion 
-              then pure (Just (packageId pkg)) 
+          if hasDoc && status == NormalVersion
+              then pure (Just (packageId pkg))
               else helper pkgs
 
         helper2 [] = pure Nothing
         helper2 (pkg:pkgs) = do
           hasDoc <- queryHasDocumentation (pkgInfoId pkg)
           if hasDoc
-              then pure (Just (packageId pkg)) 
+              then pure (Just (packageId pkg))
               else helper2 pkgs
 
     withDocumentation :: Resource -> DynamicPath
@@ -400,7 +402,7 @@ documentationFeature name
                 then (var, unPackageName $ pkgName pkgid)
                 else e
             | e@(var, _) <- dpath ]
-          basePkgPath   = (renderResource' self basedpath)
+          basePkgPath   = renderResource' self basedpath
           canonicalLink = show serverBaseURI ++ basePkgPath
           canonicalHeader = "<" ++ canonicalLink ++ ">; rel=\"canonical\""
 
@@ -484,7 +486,7 @@ checkDocTarball pkgid =
 ------------------------------------------------------------------------------}
 
 mapParaM :: Monad m => (a -> m b) -> [a] -> m [(a, b)]
-mapParaM f = mapM (\x -> (,) x `liftM` f x)
+mapParaM f = mapM (\x -> (,) x <$> f x)
 
 getFileAge :: FilePath -> IO NominalDiffTime
 getFileAge file = diffUTCTime <$> getCurrentTime <*> getModificationTime file
diff --git a/src/Distribution/Server/Framework/RequestContentTypes.hs b/src/Distribution/Server/Framework/RequestContentTypes.hs
index d3a0311dc..94ec435bc 100644
--- a/src/Distribution/Server/Framework/RequestContentTypes.hs
+++ b/src/Distribution/Server/Framework/RequestContentTypes.hs
@@ -19,7 +19,6 @@ module Distribution.Server.Framework.RequestContentTypes (
 
     -- * various specific content types
     expectTextPlain,
-    expectUncompressedTarball,
     expectCompressedTarball,
     expectAesonContent,
     expectCSV,
@@ -102,15 +101,6 @@ gzipDecompress content = go content decompressor
 expectTextPlain :: ServerPartE LBS.ByteString
 expectTextPlain = expectContentType "text/plain"
 
--- | Expect an uncompressed @.tar@ file.
---
--- The tar file is not validated.
---
--- A content-encoding of \"gzip\" is handled transparently.
---
-expectUncompressedTarball :: ServerPartE LBS.ByteString
-expectUncompressedTarball = expectContentType "application/x-tar"
-
 -- | Expect a compressed @.tar.gz@ file.
 --
 -- Neither the gzip encoding nor the tar format are validated.
@@ -128,7 +118,7 @@ expectCompressedTarball = do
       Just actual
         | actual == "application/x-tar"
         , contentEncoding == Just "gzip" -> consumeRequestBody
-        | actual == "application/x-gzip"
+        | actual == "application/gzip" || actual == "application/x-gzip" 
         , contentEncoding == Nothing     -> consumeRequestBody
       _                                  -> errExpectedTarball
   where