Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

master2central december 2024 #1352

Merged
merged 10 commits into from
Dec 30, 2024
Prev Previous commit
Next Next commit
[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 <$>
MangoIV committed Nov 24, 2024
commit a3f72295d79f2e10b4eb4005dadb5c40c914fae3
18 changes: 10 additions & 8 deletions src/Distribution/Server/Features/Documentation.hs
Original file line number Diff line number Diff line change
@@ -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
12 changes: 1 addition & 11 deletions src/Distribution/Server/Framework/RequestContentTypes.hs
Original file line number Diff line number Diff line change
@@ -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