Merge pull request #1352 from haskell/master

master2central december 2024

Author: gbaz

.github/workflows/update-flake-lock.yml

@@ -0,0 +1,22 @@
+# https://github.com/DeterminateSystems/update-flake-lock
+name: update-flake-lock
+on:
+  workflow_dispatch: # allows manual triggering
+  schedule:
+    - cron: '0 0 1 * *' # runs on first day of the month
+
+jobs:
+  lockfile:
+    runs-on: ubuntu-latest
+    steps:
+      - name: Checkout repository
+        uses: actions/checkout@v4
+      - name: Install Nix
+        uses: DeterminateSystems/nix-installer-action@main
+      - name: Update flake.lock
+        uses: DeterminateSystems/update-flake-lock@main
+        with:
+          pr-title: "Update flake.lock" # Title of PR to be created
+          pr-labels: |                  # Labels to be set on the PR
+            dependencies
+            automated

datafiles/static/hackage.css

@@ -147,6 +147,10 @@ table {
   font:100%;
 }
 
+pre {
+  border-radius: 3px;
+}
+
 pre, code, kbd, samp, .src {
   font-family: monospace;
 }

datafiles/templates/Html/package-page.html.st

@@ -5,6 +5,8 @@
   <link href="$doc.baseUrl$/quick-jump.css" rel="stylesheet" type="text/css" title="QuickJump" />
   $endif$
   $hackageCssTheme()$
+  <link rel="stylesheet" href="https://cdn.jsdelivr.net/npm/[email protected]/themes/prism-solarizedlight.min.css" media="(prefers-color-scheme: light)" />
+  <link rel="stylesheet" href="https://cdn.jsdelivr.net/npm/[email protected]/themes/prism-tomorrow.min.css" media="(prefers-color-scheme: dark)" />
   <title>
     $package.name$$if(package.optional.hasSynopsis)$: $package.optional.synopsis$$endif$
   </title>
@@ -292,6 +294,8 @@
       [<a href="#description">back to package description</a>]
       $package.optional.readme$
     </div>
+    <script src="https://cdn.jsdelivr.net/npm/[email protected]/components/prism-core.min.js"></script>
+    <script src="https://cdn.jsdelivr.net/npm/[email protected]/plugins/autoloader/prism-autoloader.min.js"></script>
     $endif$
   </div> <!-- /content -->
 

flake.nix

@@ -37,7 +37,7 @@
             echo 'Copying packages from real Hackage Server into local Hackage Server.'
             echo 'This assumes the local Hackage Server uses default credentials;'
             echo 'otherwise, override in nix-default-servers.cfg'
-            hackage-mirror nix-default-servers.cfg
+            hackage-mirror nix-default-servers.cfg "$@"
           '';
         };
         packages.default = config.packages.hackage-server;

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

src/Distribution/Server/Features/PackageInfoJSON.hs

@@ -85,7 +85,9 @@ initPackageInfoJSONFeature env = do
   return $ \core preferred -> do
 
     let coreR = coreResource core
-        info = "Get basic package information"
+        info = "Get basic package information: \
+               \The response contains a JSON object where the keys are version numbers as strings, \
+               \and the values are whether the version is preferred or not"
         vInfo = "Get basic package information at a specific metadata revision"
 
         jsonResources = [

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

src/Distribution/Server/Packages/Unpack.hs

@@ -219,9 +219,11 @@ specVersionChecks specVerOk specVer = do
   when (specVer < CabalSpecV1_10) $
     throwError "'cabal-version' must be at least 1.10"
 
-  -- To keep people from uploading packages most users cannot use.
+  -- To keep people from uploading packages most users cannot use. Disabled for now.
+{-  
   unless (specVer <= CabalSpecV3_6) $
     throwError "'cabal-version' must be at most 3.6"
+-}
 
 -- | The issue is that browsers can upload the file name using either unix
 -- or windows convention, so we need to take the basename using either