diff --git a/.github/workflows/dependabot-auto-approve.yml b/.github/workflows/dependabot-auto-approve.yml new file mode 100644 index 000000000..6e7e31f8d --- /dev/null +++ b/.github/workflows/dependabot-auto-approve.yml @@ -0,0 +1,22 @@ +# https://docs.github.com/en/code-security/dependabot/working-with-dependabot/automating-dependabot-with-github-actions#approve-a-pull-request +name: Dependabot auto-approve +on: pull_request + +permissions: + pull-requests: write + +jobs: + dependabot: + runs-on: ubuntu-latest + if: github.actor == 'dependabot[bot]' + steps: + - name: Dependabot metadata + id: metadata + uses: dependabot/fetch-metadata@v2 + with: + github-token: "${{ secrets.GITHUB_TOKEN }}" + - name: Approve a PR + run: gh pr review --approve "$PR_URL" + env: + PR_URL: ${{github.event.pull_request.html_url}} + GH_TOKEN: ${{secrets.GITHUB_TOKEN}} diff --git a/.github/workflows/haskell-ci.yml b/.github/workflows/haskell-ci.yml index 7385d546c..4f95ed230 100644 --- a/.github/workflows/haskell-ci.yml +++ b/.github/workflows/haskell-ci.yml @@ -8,9 +8,9 @@ # # For more information, see https://github.com/andreasabel/haskell-ci # -# version: 0.17.20231012 +# version: 0.19.20240630 # -# REGENDATA ("0.17.20231012",["github","hackage-server.cabal"]) +# REGENDATA ("0.19.20240630",["github","hackage-server.cabal"]) # name: Haskell-CI on: @@ -32,19 +32,24 @@ jobs: strategy: matrix: include: - - compiler: ghc-9.8.1 + - compiler: ghc-9.10.1 compilerKind: ghc - compilerVersion: 9.8.1 + compilerVersion: 9.10.1 setup-method: ghcup allow-failure: false - - compiler: ghc-9.6.3 + - compiler: ghc-9.8.2 compilerKind: ghc - compilerVersion: 9.6.3 + compilerVersion: 9.8.2 setup-method: ghcup allow-failure: false - - compiler: ghc-9.4.7 + - compiler: ghc-9.6.5 compilerKind: ghc - compilerVersion: 9.4.7 + compilerVersion: 9.6.5 + setup-method: ghcup + allow-failure: false + - compiler: ghc-9.4.8 + compilerKind: ghc + compilerVersion: 9.4.8 setup-method: ghcup allow-failure: false - compiler: ghc-9.2.8 @@ -74,11 +79,10 @@ jobs: apt-get update apt-get install -y --no-install-recommends gnupg ca-certificates dirmngr curl git software-properties-common libtinfo5 mkdir -p "$HOME/.ghcup/bin" - curl -sL https://downloads.haskell.org/ghcup/0.1.19.5/x86_64-linux-ghcup-0.1.19.5 > "$HOME/.ghcup/bin/ghcup" + curl -sL https://downloads.haskell.org/ghcup/0.1.20.0/x86_64-linux-ghcup-0.1.20.0 > "$HOME/.ghcup/bin/ghcup" chmod a+x "$HOME/.ghcup/bin/ghcup" - "$HOME/.ghcup/bin/ghcup" config add-release-channel https://raw.githubusercontent.com/haskell/ghcup-metadata/master/ghcup-prereleases-0.0.7.yaml; "$HOME/.ghcup/bin/ghcup" install ghc "$HCVER" || (cat "$HOME"/.ghcup/logs/*.* && false) - "$HOME/.ghcup/bin/ghcup" install cabal 3.10.1.0 || (cat "$HOME"/.ghcup/logs/*.* && false) + "$HOME/.ghcup/bin/ghcup" install cabal 3.12.1.0 || (cat "$HOME"/.ghcup/logs/*.* && false) apt-get update apt-get install -y libbrotli-dev libgd-dev env: @@ -98,7 +102,7 @@ jobs: echo "HC=$HC" >> "$GITHUB_ENV" echo "HCPKG=$HCPKG" >> "$GITHUB_ENV" echo "HADDOCK=$HADDOCK" >> "$GITHUB_ENV" - echo "CABAL=$HOME/.ghcup/bin/cabal-3.10.1.0 -vnormal+nowrap" >> "$GITHUB_ENV" + echo "CABAL=$HOME/.ghcup/bin/cabal-3.12.1.0 -vnormal+nowrap" >> "$GITHUB_ENV" HCNUMVER=$(${HC} --numeric-version|perl -ne '/^(\d+)\.(\d+)\.(\d+)(\.(\d+))?$/; print(10000 * $1 + 100 * $2 + ($3 == 0 ? $5 != 1 : $3))') echo "HCNUMVER=$HCNUMVER" >> "$GITHUB_ENV" if [ $((HCNUMVER >= 90400)) -ne 0 ] ; then echo "ARG_TESTS=--enable-tests" >> "$GITHUB_ENV" ; else echo "ARG_TESTS=--disable-tests" >> "$GITHUB_ENV" ; fi @@ -183,7 +187,7 @@ jobs: echo " ghc-options: -Werror=missing-methods" >> cabal.project cat >> cabal.project <> cabal.project.local + $HCPKG list --simple-output --names-only | perl -ne 'for (split /\s+/) { print "constraints: any.$_ installed\n" unless /^(Cabal|Cabal-syntax|hackage-server|parsec|process|text)$/; }' >> cabal.project.local cat cabal.project cat cabal.project.local - name: dump install plan @@ -191,7 +195,7 @@ jobs: $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH --dry-run all cabal-plan - name: restore cache - uses: actions/cache/restore@v3 + uses: actions/cache/restore@v4 with: key: ${{ runner.os }}-${{ matrix.compiler }}-${{ github.sha }} path: ~/.cabal/store @@ -221,7 +225,7 @@ jobs: rm -f cabal.project.local $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks all - name: save cache - uses: actions/cache/save@v3 + uses: actions/cache/save@v4 if: always() with: key: ${{ runner.os }}-${{ matrix.compiler }}-${{ github.sha }} diff --git a/.github/workflows/nix-flake.yml b/.github/workflows/nix-flake.yml index e036875cc..9c31aa48d 100644 --- a/.github/workflows/nix-flake.yml +++ b/.github/workflows/nix-flake.yml @@ -9,7 +9,7 @@ on: jobs: nix: strategy: - fail-fast: false + fail-fast: true matrix: os: - ubuntu-latest @@ -18,16 +18,23 @@ jobs: runs-on: ${{ matrix.os }} steps: - uses: actions/checkout@v4 - - uses: cachix/install-nix-action@v23 + - uses: cachix/install-nix-action@v30 with: extra_nix_config: | - trusted-public-keys = hydra.iohk.io:f/Ea+s+dFdN+3Y/G+FDgSq+a5NEWhJGzdjvKNGv0/EQ= cache.nixos.org-1:6NCHdD59X431o0gWypbMrAURkbJ16ZPMQFGspcDShjY= hackage-server.cachix.org-1:iw0iRh6+gsFIrxROFaAt5gKNgIHejKjIfyRdbpPYevY= - substituters = https://hydra.iohk.io https://cache.nixos.org/ https://hackage-server.cachix.org/ - - uses: cachix/cachix-action@v12 + trusted-public-keys = cache.nixos.org-1:6NCHdD59X431o0gWypbMrAURkbJ16ZPMQFGspcDShjY= hackage-server.cachix.org-1:iw0iRh6+gsFIrxROFaAt5gKNgIHejKjIfyRdbpPYevY= + substituters = https://cache.nixos.org/ https://hackage-server.cachix.org/ + - uses: cachix/cachix-action@v15 with: # https://nix.dev/tutorials/continuous-integration-github-actions#setting-up-github-actions name: hackage-server authToken: '${{ secrets.CACHIX_AUTH_TOKEN }}' + + - name: "Check `nix develop` shell" + run: nix develop --check + + - name: "Check `nix develop` shell can run command" + run: nix develop --command "echo" + - run: nix build - continue-on-error: false diff --git a/README.md b/README.md index 057aa536a..71d3a5245 100644 --- a/README.md +++ b/README.md @@ -1,10 +1,2 @@ central-server branch: the hackage.haskell.org instance ======================================================= - -This is the branch for the "official" Hackage server at hackage.haskell.org. Most changes should not be here, but should be made to master. - -# General Documentation -======= -[![Build Status](https://travis-ci.org/haskell/hackage-server.png?branch=master)](https://travis-ci.org/haskell/hackage-server) -[![Build status](https://github.com/haskell/hackage-server/actions/workflows/haskell-ci.yml/badge.svg)](https://github.com/haskell/hackage-server/actions/workflows/haskell-ci.yml) -[![Build status](https://github.com/haskell/hackage-server/actions/workflows/nix-shell.yml/badge.svg)](https://github.com/haskell/hackage-server/actions/workflows/nix-shell.yml) diff --git a/cabal.project b/cabal.project index f387f2c52..d236fab8b 100644 --- a/cabal.project +++ b/cabal.project @@ -6,26 +6,6 @@ packages: -- This project config requires cabal 2.4 or later --- If in doubt, use GHC 8.8 to build hackage-server; see --- 'tested-with' in 'hackage-server.cabal' for a list of currently --- CI-validated GHC versions --- --- with-compiler: ghc-8.8 - - -allow-newer: rss:time, rss:base - --- Andreas, 2022-10-28: `Cabal-3.8.1.0` wants `process >= 1.6.14` --- which is too new for the `ghc < 9.4` package that is pulled in --- by `doctest-parallel`. --- Since, Cabal-3.8.1.0 has no reason to want such a new version --- of process, we can solve the conflict here by allowing --- `Cabal` to use the shipped version of `process`. --- This workaround can be removed once `Cabal-3.8` drops --- its (unreasonable) constraint on `process`. --- See: https://github.com/haskell/cabal/issues/8554 -allow-older: Cabal:process - ----------------------------------------------------------------------------- -- Anti-constraints diff --git a/datafiles/static/hackage.css b/datafiles/static/hackage.css index 42e3f1b1c..2c6e0fe0f 100644 --- a/datafiles/static/hackage.css +++ b/datafiles/static/hackage.css @@ -117,10 +117,28 @@ h4 { font-size: 100%; /* 13px */ } h5 { font-size: 100%; /* 13px */ } h6 { font-size: 100%; /* 13px */ } -select, input, button, textarea { +select, input, button, textarea, input::file-selector-button { font-size: 1rem; margin: 0.5em; - padding: 0.1em; + padding: 0.5em 0.8em; + border: 1px solid #444; + border-radius: 3px; + background: #eee; +} + +select:hover, input:hover, button:hover, textarea:hover, input::file-selector-button:hover { + background: #dcdcdc; +} + +input[type=file] { + background: none; + border: 0; +} + +@media (prefers-color-scheme: dark) { + select, input, button, textarea, input::file-selector-button { + border: 0; + } } table { @@ -267,9 +285,21 @@ pre + pre { margin-top: 0.5em; } +@media (prefers-color-scheme: dark) { + blockquote { + border-left: 3px solid #2f2842; + background-color: #4c4771; + } +} + +@media (prefers-color-scheme: light) { + blockquote { + border-left: 3px solid #c7a5d3; + background-color: #eee4f1; + } +} + blockquote { - border-left: 3px solid #c7a5d3; - background-color: #eee4f1; margin: 0.5em; padding: 0.0005em 0.3em 0.5em 0.5em; } @@ -1147,6 +1177,14 @@ a.deprecated[href]:visited { color: #61B01E; } +.lib-contents { + margin-left: 20px; +} + +.lib-contents > h3 { + margin: 0.7em 0; +} + /* Paginator */ #paginatorContainer { display: flex; diff --git a/datafiles/templates/Html/package-page.html.st b/datafiles/templates/Html/package-page.html.st index 8fdebe86b..fdb305443 100644 --- a/datafiles/templates/Html/package-page.html.st +++ b/datafiles/templates/Html/package-page.html.st @@ -32,6 +32,7 @@
[ $tags$ ] [ Propose Tags ] + [ Report a vulnerability ]
$if(isDeprecated)$ @@ -139,6 +140,15 @@ $package.buildDepends$ + $if(package.optional.hasTestedWith)$ + + Tested with + + $package.optional.testedWith$ + + + $endif$ + License $package.license$ diff --git a/exes/Main.hs b/exes/Main.hs index c81346317..b3ee4605d 100644 --- a/exes/Main.hs +++ b/exes/Main.hs @@ -1,4 +1,7 @@ +{-# LANGUAGE CPP #-} + {-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-} + module Main where import qualified Distribution.Server as Server @@ -65,7 +68,11 @@ main :: IO () main = topHandler $ do hSetBuffering stdout LineBuffering args <- getArgs +#if !MIN_VERSION_Cabal(3,12,0) case commandsRun (globalCommand commands) commands args of +#else + commandsRun (globalCommand commands) commands args >>= \case +#endif CommandHelp help -> printHelp help CommandList opts -> printOptionsList opts CommandErrors errs -> printErrors errs @@ -79,6 +86,7 @@ main = topHandler $ do where printHelp help = getProgName >>= putStr . help + printOptionsList :: [String] -> IO () printOptionsList = putStr . unlines printErrors errs = do putStr (intercalate "\n" errs) @@ -154,7 +162,11 @@ optionVerbosity getter setter = "Control verbosity (n is 0--3, default verbosity level is 1)" getter setter (optArg "n" (fmap Flag Verbosity.flagToVerbosity) - (Flag Verbosity.verbose) + ( +#if MIN_VERSION_Cabal(3,12,0) + show Verbosity.verbose, +#endif + Flag Verbosity.verbose) (fmap (Just . showForCabal) . flagToList)) optionStateDir :: (a -> Flag FilePath) diff --git a/flake.lock b/flake.lock index 7903bf046..a5c503a1f 100644 --- a/flake.lock +++ b/flake.lock @@ -7,11 +7,11 @@ ] }, "locked": { - "lastModified": 1693611461, - "narHash": "sha256-aPODl8vAgGQ0ZYFIRisxYG5MOGSkIczvu2Cd8Gb9+1Y=", + "lastModified": 1719994518, + "narHash": "sha256-pQMhCCHyQGRzdfAkdJ4cIWiw+JNuWsTX7f0ZYSyz0VY=", "owner": "hercules-ci", "repo": "flake-parts", - "rev": "7f53fdb7bdc5bb237da7fefef12d099e4fd611ca", + "rev": "9227223f6d922fee3c7b190b2cc238a99527bbb7", "type": "github" }, "original": { @@ -22,11 +22,11 @@ }, "flake-root": { "locked": { - "lastModified": 1692742795, - "narHash": "sha256-f+Y0YhVCIJ06LemO+3Xx00lIcqQxSKJHXT/yk1RTKxw=", + "lastModified": 1713493429, + "narHash": "sha256-ztz8JQkI08tjKnsTpfLqzWoKFQF4JGu2LRz8bkdnYUk=", "owner": "srid", "repo": "flake-root", - "rev": "d9a70d9c7a5fd7f3258ccf48da9335e9b47c3937", + "rev": "bc748b93b86ee76e2032eecda33440ceb2532fcd", "type": "github" }, "original": { @@ -37,11 +37,11 @@ }, "haskell-flake": { "locked": { - "lastModified": 1694478711, - "narHash": "sha256-zW/saV4diypxwP56b8l93Nw8fR7tXLbOFku2I+xYCxU=", + "lastModified": 1721530802, + "narHash": "sha256-eUMmQKXjt4WQq+IBscftg/Y9bXWiOYhasfeH5Yb9Psc=", "owner": "srid", "repo": "haskell-flake", - "rev": "ddc704f3f62d3d3569ced794b534e8fd065c379c", + "rev": "f8f38ecd259338167cc0c85fd541479297a315af", "type": "github" }, "original": { @@ -52,11 +52,11 @@ }, "nixpkgs": { "locked": { - "lastModified": 1694736714, - "narHash": "sha256-5xqXf2CfPiIHg2W7f+6odQ9c09L+jTVqGmxLB6qxPLc=", + "lastModified": 1721952842, + "narHash": "sha256-B6Fm/e+2Iq1LB0ITtdaVS/lxkckCwPNpgBuduuv1HzY=", "owner": "nixos", "repo": "nixpkgs", - "rev": "8b1c1ca2feb87ae8b7d9455d8dfe5361f249e4cf", + "rev": "574f1a6205e63e9870c6e6132c393f9082d58d2a", "type": "github" }, "original": { diff --git a/flake.nix b/flake.nix index 3d79ffd0d..222b19245 100644 --- a/flake.nix +++ b/flake.nix @@ -15,30 +15,45 @@ inputs.flake-root.flakeModule ]; perSystem = { self', system, lib, config, pkgs, ... }: { - # The "main" project. You can have multiple projects, but this template - # has only one. + apps.default.program = pkgs.writeShellApplication { + name = "run-hackage-server"; + runtimeInputs = [ config.packages.default ]; + text = '' + if [ ! -d "state" ]; then + hackage-server init --static-dir=datafiles --state-dir=state + else + echo "'state' state-dir already exists" + fi + hackage-server run \ + --static-dir=datafiles \ + --state-dir=state \ + --base-uri=http://127.0.0.1:8080 + ''; + }; + apps.mirror-hackage-server.program = pkgs.writeShellApplication { + name = "mirror-hackage-server"; + runtimeInputs = [ config.packages.default ]; + text = '' + 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 + ''; + }; packages.default = config.packages.hackage-server; haskellProjects.default = { settings = { hackage-server.check = false; - heist.check = false; - fourmolu.check = false; - hw-prim.jailbreak = true; - hw-hspec-hedgehog.jailbreak = true; - hw-fingertree.jailbreak = true; + ap-normalize.check = false; + # https://community.flake.parts/haskell-flake/dependency#nixpkgs + tar = { super, ... }: + { custom = _: super.tar_0_6_3_0; }; + hackage-security = { super, ... }: + { custom = _: super.hackage-security_0_6_2_6; }; }; packages = { - Cabal.source = "3.10.1.0"; - Cabal-syntax.source = "3.10.1.0"; - attoparsec-aeson.source = "2.1.0.0"; - hedgehog.source = "1.4"; - ormolu.source = "0.7.2.0"; - fourmolu.source = "0.13.1.0"; - tasty-hedgehog.source = "1.4.0.2"; - ghc-lib-parser.source = "9.6.2.20230523"; - ghc-lib-parser-ex.source = "9.6.0.2"; - hlint.source = "3.6.1"; - stylish-haskell.source = "0.14.5.0"; + # https://community.flake.parts/haskell-flake/dependency#path + # tls.source = "1.9.0"; }; devShell = { tools = hp: { diff --git a/hackage-server.cabal b/hackage-server.cabal index 48a6d8ff1..1a97d268f 100644 --- a/hackage-server.cabal +++ b/hackage-server.cabal @@ -28,9 +28,10 @@ license: BSD-3-Clause license-file: LICENSE tested-with: - GHC == 9.8.1 - GHC == 9.6.3 - GHC == 9.4.7 + GHC == 9.10.1 + GHC == 9.8.2 + GHC == 9.6.5 + GHC == 9.4.8 GHC == 9.2.8 GHC == 9.0.2 GHC == 8.10.7 @@ -129,13 +130,13 @@ common defaults -- see `cabal.project.local-ghc-${VERSION}` files build-depends: , array >= 0.5 && < 0.6 - , base >= 4.13 && < 4.20 + , base >= 4.13 && < 4.21 , binary >= 0.8 && < 0.9 , bytestring >= 0.10 && < 0.13 , containers >= 0.6.0 && < 0.8 , deepseq >= 1.4 && < 1.6 , directory >= 1.3 && < 1.4 - , filepath >= 1.4 && < 1.5 + , filepath >= 1.4 && < 1.6 , mtl >= 2.2.1 && < 2.4 , pretty >= 1.1 && < 1.2 , process >= 1.6 && < 1.7 @@ -147,32 +148,33 @@ common defaults -- other dependencies shared by most components build-depends: , aeson >= 2.1.0.0 && < 2.3 - , Cabal >= 3.10.1.0 && < 3.12 - , Cabal-syntax >= 3.10.1.0 && < 3.12 + , Cabal >= 3.12.1.0 && < 3.14 + , Cabal-syntax >= 3.12.1.0 && < 3.14 -- Cabal-syntax needs to be bound to constrain hackage-security -- see https://github.com/haskell/hackage-server/issues/1130 , fail ^>= 4.9.0 - , network >= 3 && < 3.2 + , network >= 3 && < 3.3 , network-bsd ^>= 2.8 , network-uri ^>= 2.6 , parsec ^>= 3.1.13 - , tar ^>= 0.5 + , tar ^>= 0.6 , unordered-containers ^>= 0.2.10 , vector ^>= 0.12 || ^>= 0.13.0.0 - , zlib ^>= 0.6.2 + , zlib ^>= 0.6.2 || ^>= 0.7.0.0 - ghc-options: -Wall -fwarn-tabs -fno-warn-unused-do-bind -fno-warn-deprecated-flags -funbox-strict-fields - - if impl(ghc >= 8.2) - ghc-options: -Werror=incomplete-patterns -Werror=missing-methods + ghc-options: + -funbox-strict-fields + -Wall -fwarn-tabs -fno-warn-unused-do-bind -fno-warn-deprecated-flags + -Werror=incomplete-patterns -Werror=missing-methods if impl(ghc >= 8.10) ghc-options: -Wno-unused-record-wildcards + default-extensions: LambdaCase, TupleSections other-extensions: CPP, TemplateHaskell -library lib-server +library import: defaults hs-source-dirs: src @@ -406,7 +408,7 @@ library lib-server build-depends: , HStringTemplate ^>= 0.8 , HTTP ^>= 4000.3.16 || ^>= 4000.4.1 - , QuickCheck ^>= 2.14 + , QuickCheck >= 2.14 && < 2.16 , acid-state ^>= 0.16 , async ^>= 2.2.1 -- requires bumping http-io-streams @@ -437,7 +439,7 @@ library lib-server , haddock-library ^>= 1.11.0 -- haddock-library-1.11.0 changed type of markupOrderedList -- see https://github.com/haskell/hackage-server/issues/1128 - , happstack-server ^>= 7.7.1 || ^>= 7.8.0 + , happstack-server ^>= 7.7.1 || ^>= 7.8.0 || ^>= 7.9.0 , hashable ^>= 1.3 || ^>= 1.4 , hs-captcha ^>= 1.0 , hslogger ^>= 1.3.1 @@ -451,7 +453,7 @@ library lib-server , stm ^>= 2.5.0 , stringsearch ^>= 0.3.6.6 , tagged ^>= 0.8.5 - , xhtml ^>= 3000.2.0.0 + , xhtml >= 3000.2.0.0 && < 3000.4 , xmlgen ^>= 0.6 , xss-sanitize ^>= 0.3.6 @@ -471,7 +473,7 @@ library lib-server common exe-defaults import: defaults - build-depends: lib-server + build-depends: hackage-server hs-source-dirs: exes ghc-options: -threaded -rtsopts @@ -492,7 +494,7 @@ executable hackage-mirror main-is: MirrorClient.hs build-depends: - -- version constraints inherited from lib-server + -- version constraints inherited from hackage-server , HTTP , hackage-security @@ -502,7 +504,7 @@ executable hackage-build main-is: BuildClient.hs build-depends: - -- version constraints inherited from lib-server + -- version constraints inherited from hackage-server , HTTP -- Runtime dependency only; @@ -522,7 +524,7 @@ executable hackage-import main-is: ImportClient.hs build-depends: - -- version constraints inherited from lib-server + -- version constraints inherited from hackage-server , HTTP , async , csv @@ -532,7 +534,7 @@ executable hackage-import common test-defaults import: defaults - build-depends: lib-server + build-depends: hackage-server hs-source-dirs: tests ghc-options: -threaded -rtsopts -fno-warn-orphans @@ -562,9 +564,9 @@ test-suite HighLevelTest -- so if this works, it's accidental! build-tool-depends: hackage-server:hackage-server - -- NOTE: lib-server is not a real dependency; it's only used to inherit version constraints + -- NOTE: hackage-server is not a real dependency; it's only used to inherit version constraints build-depends: - -- version constraints inherited from lib-server + -- version constraints inherited from hackage-server , HTTP , attoparsec-aeson >= 2.1.0.0 && < 2.3 , base64-bytestring @@ -610,6 +612,9 @@ benchmark RevDeps build-depends: , random ^>= 1.2 , gauge + -- gauge does not support base-4.20 + if impl(ghc >= 9.10) + buildable: False ghc-options: -with-rtsopts=-s other-modules: RevDepCommon @@ -639,9 +644,9 @@ test-suite CreateUserTest -- see note in 'Test-Suite HighLevelTest' build-tool-depends: hackage-server:hackage-server - -- NOTE: lib-server is not a real dependency; it's only used to inherit version constraints + -- NOTE: hackage-server is not a real dependency; it's only used to inherit version constraints build-depends: - -- version constraints inherited from lib-server + -- version constraints inherited from hackage-server , HTTP , base64-bytestring , random @@ -656,7 +661,7 @@ test-suite PackageTests other-modules: Distribution.Server.Packages.UnpackTest build-depends: - -- version constraints inherited from lib-server + -- version constraints inherited from hackage-server -- component-specific dependencies , tasty ^>= 1.5 , tasty-hunit ^>= 0.10 @@ -669,7 +674,7 @@ test-suite HashTests main-is: HashTestMain.hs build-depends: - -- version constraints inherited from lib-server + -- version constraints inherited from hackage-server , base16-bytestring , cereal , cryptohash-md5 @@ -685,7 +690,7 @@ test-suite DocTests type: exitcode-stdio-1.0 main-is: DocTestMain.hs build-depends: - , lib-server + , hackage-server , doctest-parallel ^>= 0.3.0 -- doctest-parallel-0.2.2 is the first to filter out autogen-modules diff --git a/nix-default-servers.cfg b/nix-default-servers.cfg new file mode 100644 index 000000000..b61d4382f --- /dev/null +++ b/nix-default-servers.cfg @@ -0,0 +1,9 @@ +source "hackage" + uri: http://hackage.haskell.org + type: secure + +target "mirror" + uri: http://admin:admin@localhost:8080 + type: hackage2 + + post-mirror-hook: "shell command to execute" diff --git a/src/Data/TarIndex.hs b/src/Data/TarIndex.hs index 4541e605f..cd111d962 100644 --- a/src/Data/TarIndex.hs +++ b/src/Data/TarIndex.hs @@ -18,7 +18,7 @@ module Data.TarIndex ( import Data.SafeCopy (base, deriveSafeCopy) import Data.Typeable (Typeable) -import Codec.Archive.Tar (Entry(..), EntryContent(..), Entries(..), entryPath) +import Codec.Archive.Tar (Entry, GenEntry(..), GenEntryContent(..), Entries, GenEntries(..), entryPath) import qualified Data.StringTable as StringTable import Data.StringTable (StringTable) import qualified Data.IntTrie as IntTrie diff --git a/src/Distribution/Client/Index.hs b/src/Distribution/Client/Index.hs index daf3eb274..8d0ed9992 100644 --- a/src/Distribution/Client/Index.hs +++ b/src/Distribution/Client/Index.hs @@ -16,9 +16,6 @@ module Distribution.Client.Index ( ) where import qualified Codec.Archive.Tar as Tar - ( read, Entries(..) ) -import qualified Codec.Archive.Tar.Entry as Tar - ( Entry(..), entryPath ) import Distribution.Package import Distribution.Text diff --git a/src/Distribution/Server/Features/Documentation.hs b/src/Distribution/Server/Features/Documentation.hs index c73135903..511a8ddb3 100644 --- a/src/Distribution/Server/Features/Documentation.hs +++ b/src/Distribution/Server/Features/Documentation.hs @@ -27,6 +27,7 @@ import Distribution.Server.Features.BuildReports.BuildReport (PkgDetails(..), Bu import Data.TarIndex (TarIndex) import qualified Codec.Archive.Tar as Tar import qualified Codec.Archive.Tar.Check as Tar +import qualified Codec.Archive.Tar.Entry as Tar import Distribution.Text import Distribution.Package @@ -448,17 +449,20 @@ documentationFeature name checkDocTarball :: PackageId -> BSL.ByteString -> Either String () checkDocTarball pkgid = checkEntries - . fmapErr (either id show) . Tar.checkTarbomb (display pkgid ++ "-docs") - . fmapErr (either id show) . Tar.checkSecurity - . fmapErr (either id show) . Tar.checkPortability + . fmapErr (either id show) . chainChecks (Tar.checkEntryTarbomb (display pkgid ++ "-docs")) + . fmapErr (either id show) . chainChecks Tar.checkEntrySecurity + . fmapErr (either id show) . chainChecks Tar.checkEntryPortability + . fmapErr (either id show) . Tar.decodeLongNames . fmapErr show . Tar.read where fmapErr f = Tar.foldEntries Tar.Next Tar.Done (Tar.Fail . f) + chainChecks check = Tar.mapEntries (\entry -> maybe (Right entry) Left (check entry)) + checkEntries = Tar.foldEntries checkEntry (Right ()) Left checkEntry entry remainder - | Tar.entryPath entry == docMetaPath = checkDocMeta entry remainder - | otherwise = remainder + | Tar.entryTarPath entry == docMetaPath = checkDocMeta entry remainder + | otherwise = remainder checkDocMeta entry remainder = case Tar.entryContent entry of diff --git a/src/Distribution/Server/Features/Html.hs b/src/Distribution/Server/Features/Html.hs index 694093dc5..bea915425 100644 --- a/src/Distribution/Server/Features/Html.hs +++ b/src/Distribution/Server/Features/Html.hs @@ -1461,7 +1461,7 @@ mkHtmlCandidates ServerEnv{..} utilities@HtmlUtilities{..} dependenciesPage :: Bool -> PackageRender -> URL -> Resource.XHtml dependenciesPage isCandidate render docURL = Resource.XHtml $ hackagePage (pkg ++ ": dependencies") $ - [h2 << heading, Pages.renderDetailedDependencies render] + [h1 << heading, Pages.renderDetailedDependencies render] ++ Pages.renderPackageFlags render docURL where pkg = display $ rendPkgId render diff --git a/src/Distribution/Server/Features/Tags/State.hs b/src/Distribution/Server/Features/Tags/State.hs index 0d7af5063..f92a67346 100644 --- a/src/Distribution/Server/Features/Tags/State.hs +++ b/src/Distribution/Server/Features/Tags/State.hs @@ -20,8 +20,9 @@ import Control.Monad (liftM2) import Data.SafeCopy (base, deriveSafeCopy) import Data.Typeable (Typeable) import qualified Data.Char as Char +import Data.Functor ( (<&>) ) import Data.Maybe (fromMaybe) -import Data.List (foldl') +import Data.List (find, foldl') import Control.Monad.State (get, put, modify) import Control.Monad.Reader (ask, asks) import Control.DeepSeq @@ -87,13 +88,9 @@ lookupTagAlias tag return (Map.lookup tag m) getTagAlias :: Tag -> Query TagAlias Tag -getTagAlias tag - = do TagAlias m <- ask - if tag `elem` Map.keys m - then return tag - else if tag `Set.member` foldr Set.union Set.empty (Map.elems m) - then return $ head (Map.keys $ Map.filter (tag `Set.member`) m) - else return tag +getTagAlias tag = ask <&> \ (TagAlias m) -> + if Map.member tag m then tag + else maybe tag fst $ find (Set.member tag . snd) $ Map.toList m emptyPackageTags :: PackageTags emptyPackageTags = PackageTags Map.empty Map.empty Map.empty @@ -279,4 +276,3 @@ $(makeAcidic ''PackageTags ['tagsForPackage ,'lookupReviewTags ,'clearReviewTags ]) - diff --git a/src/Distribution/Server/Framework/Instances.hs b/src/Distribution/Server/Framework/Instances.hs index 273278664..2e12816b2 100644 --- a/src/Distribution/Server/Framework/Instances.hs +++ b/src/Distribution/Server/Framework/Instances.hs @@ -117,6 +117,7 @@ instance SafeCopy VersionRange where 10 -> majorBoundVersion <$> safeGet -- since Cabal-2.0 _ -> fail "VersionRange.getCopy: bad tag" +-- !! KEEP IN SYNC with instance Arbitrary OS instance SafeCopy OS where errorTypeName _ = "OS" @@ -173,6 +174,7 @@ instance SafeCopy OS where #endif _ -> fail "SafeCopy OS getCopy: unexpected tag" +-- !! KEEP IN SYNC with instance Arbitrary Arch instance SafeCopy Arch where errorTypeName _ = "Arch" @@ -196,6 +198,12 @@ instance SafeCopy Arch where putCopy AArch64 = contain $ putWord8 17 putCopy S390X = contain $ putWord8 18 putCopy Wasm32 = contain $ putWord8 19 +#if MIN_VERSION_Cabal_syntax(3,12,0) + putCopy PPC64LE = contain $ putWord8 20 + putCopy Sparc64 = contain $ putWord8 21 + putCopy RISCV64 = contain $ putWord8 22 + putCopy LoongArch64 = contain $ putWord8 23 +#endif getCopy = contain $ do tag <- getWord8 @@ -220,8 +228,15 @@ instance SafeCopy Arch where 17 -> return AArch64 18 -> return S390X 19 -> return Wasm32 +#if MIN_VERSION_Cabal_syntax(3,12,0) + 20 -> return PPC64LE + 21 -> return Sparc64 + 22 -> return RISCV64 + 23 -> return LoongArch64 +#endif _ -> fail "SafeCopy Arch getCopy: unexpected tag" +-- !! KEEP IN SYNC with instance Arbitrary CompilerFlavor instance SafeCopy CompilerFlavor where errorTypeName _ = "CompilerFlavor" @@ -238,6 +253,9 @@ instance SafeCopy CompilerFlavor where putCopy (HaskellSuite s) = contain $ putWord8 10 >> safePut s putCopy GHCJS = contain $ putWord8 11 putCopy Eta = contain $ putWord8 12 +#if MIN_VERSION_Cabal_syntax(3,12,1) + putCopy MHS = contain $ putWord8 13 +#endif getCopy = contain $ do tag <- getWord8 @@ -255,6 +273,9 @@ instance SafeCopy CompilerFlavor where 10 -> return HaskellSuite <*> safeGet 11 -> return GHCJS 12 -> return Eta +#if MIN_VERSION_Cabal_syntax(3,12,1) + 13 -> return MHS +#endif _ -> fail "SafeCopy CompilerFlavor getCopy: unexpected tag" @@ -363,6 +384,7 @@ instance Parsec UTCTime where Just t -> return t where digit2 = replicateM 2 P.digit + ------------------- -- Arbitrary instances -- @@ -376,31 +398,88 @@ instance Arbitrary Version where instance Arbitrary PackageIdentifier where arbitrary = PackageIdentifier <$> arbitrary <*> arbitrary +-- !! KEEP IN SYNC with instance SafeCopy CompilerFlavor instance Arbitrary CompilerFlavor where - arbitrary = oneof [ pure OtherCompiler <*> vectorOf 3 (choose ('A', 'Z')) - , pure GHC, pure NHC, pure YHC, pure Hugs, pure HBC - , pure Helium, pure JHC, pure LHC, pure UHC ] + arbitrary = oneof + [ pure OtherCompiler <*> vectorOf 3 (choose ('A', 'Z')) + , pure GHC + , pure NHC + , pure YHC + , pure Hugs + , pure HBC + , pure Helium + , pure JHC + , pure LHC + , pure UHC + , pure HaskellSuite <*> vectorOf 3 (choose ('A', 'Z')) + , pure GHCJS + , pure Eta +#if MIN_VERSION_Cabal_syntax(3,12,1) + , pure MHS +#endif + ] instance Arbitrary CompilerId where arbitrary = CompilerId <$> arbitrary <*> arbitrary +-- !! KEEP IN SYNC with instance SafeCopy Arch instance Arbitrary Arch where - arbitrary = oneof [ pure OtherArch <*> vectorOf 3 (choose ('A', 'Z')) - , pure I386, pure X86_64, pure PPC, pure PPC64, pure Sparc - , pure Arm, pure Mips, pure SH, pure IA64, pure S390 - , pure Alpha, pure Hppa, pure Rs6000, pure M68k, pure Vax ] + arbitrary = oneof + [ pure OtherArch <*> vectorOf 3 (choose ('A', 'Z')) + , pure I386 + , pure X86_64 + , pure PPC + , pure PPC64 + , pure Sparc + , pure Arm + , pure Mips + , pure SH + , pure IA64 + , pure S390 + , pure Alpha + , pure Hppa + , pure Rs6000 + , pure M68k + , pure Vax + , pure JavaScript + , pure AArch64 + , pure S390X + , pure Wasm32 +#if MIN_VERSION_Cabal_syntax(3,12,0) + , pure PPC64LE + , pure Sparc64 + , pure RISCV64 + , pure LoongArch64 +#endif + ] +-- !! KEEP IN SYNC with instance SafeCopy OS instance Arbitrary OS where - arbitrary = oneof [ pure OtherOS <*> vectorOf 3 (choose ('A', 'Z')) - , pure Linux, pure Windows, pure OSX, pure FreeBSD - , pure OpenBSD, pure NetBSD, pure Solaris, pure AIX - , pure HPUX, pure IRIX, pure HaLVM, pure IOS + arbitrary = oneof + [ pure OtherOS <*> vectorOf 3 (choose ('A', 'Z')) + , pure Linux + , pure Windows + , pure OSX + , pure FreeBSD + , pure OpenBSD + , pure NetBSD + , pure Solaris + , pure AIX + , pure HPUX + , pure IRIX + , pure HaLVM + , pure IOS + , pure DragonFly + , pure Ghcjs + , pure Hurd + , pure Android + , pure Wasi #if MIN_VERSION_Cabal_syntax(3,11,0) - , pure Haiku + , pure Haiku #else - , pure $ OtherOS "haiku" + , pure $ OtherOS "haiku" #endif - ] + ] instance Arbitrary FlagName where arbitrary = mkFlagName <$> vectorOf 4 (choose ('a', 'z')) diff --git a/src/Distribution/Server/Packages/Index.hs b/src/Distribution/Server/Packages/Index.hs index 4adaf0b3c..a822b3250 100644 --- a/src/Distribution/Server/Packages/Index.hs +++ b/src/Distribution/Server/Packages/Index.hs @@ -10,9 +10,7 @@ module Distribution.Server.Packages.Index ( ) where import qualified Codec.Archive.Tar as Tar - ( write ) import qualified Codec.Archive.Tar.Entry as Tar - ( Entry(..), fileEntry, toTarPath, Ownership(..) ) import Distribution.Server.Packages.PackageIndex (PackageIndex) import qualified Distribution.Server.Packages.PackageIndex as PackageIndex import Distribution.Server.Framework.MemSize diff --git a/src/Distribution/Server/Packages/Render.hs b/src/Distribution/Server/Packages/Render.hs index 8b40303e5..f57f81a1a 100644 --- a/src/Distribution/Server/Packages/Render.hs +++ b/src/Distribution/Server/Packages/Render.hs @@ -1,6 +1,7 @@ -- TODO: Review and possibly move elsewhere. This code was part of the -- RecentPackages (formerly "Check") feature, but that caused some cyclic -- dependencies. +{-# LANGUAGE TupleSections #-} module Distribution.Server.Packages.Render ( -- * Package render PackageRender(..) @@ -53,6 +54,7 @@ import Distribution.Utils.ShortText (fromShortText) import qualified Data.TarIndex as TarIndex import Data.TarIndex (TarIndex, TarEntryOffset) +import Data.Bifunctor (first, Bifunctor (..)) data ModSigIndex = ModSigIndex { modIndex :: ModuleForest, @@ -64,11 +66,12 @@ data ModSigIndex = ModSigIndex { -- This is why some fields of PackageDescription are preprocessed, and others aren't. data PackageRender = PackageRender { rendPkgId :: PackageIdentifier, + rendLibName :: LibraryName -> String, + rendComponentName :: ComponentName -> String, rendDepends :: [Dependency], rendExecNames :: [String], - rendLibraryDeps :: Maybe DependencyTree, - rendSublibraryDeps :: [(String, DependencyTree)], - rendExecutableDeps :: [(String, DependencyTree)], + rendLibraryDeps :: [(LibraryName, DependencyTree)], + rendExecutableDeps :: [(ComponentName, DependencyTree)], rendLicenseName :: String, rendLicenseFiles :: [FilePath], rendMaintainer :: Maybe String, @@ -78,7 +81,7 @@ data PackageRender = PackageRender { -- to test if a module actually has a corresponding documentation HTML -- file we can link to. If no 'TarIndex' is provided, it is assumed -- all links are dead. - rendModules :: Maybe TarIndex -> Maybe ModSigIndex, + rendModules :: Maybe TarIndex -> [(LibraryName, ModSigIndex)], rendHasTarball :: Bool, rendChangeLog :: Maybe (FilePath, ETag, TarEntryOffset, FilePath), rendReadme :: Maybe (FilePath, ETag, TarEntryOffset, FilePath), @@ -95,14 +98,14 @@ data PackageRender = PackageRender { doPackageRender :: Users.Users -> PkgInfo -> PackageRender doPackageRender users info = PackageRender - { rendPkgId = pkgInfoId info + { rendPkgId = packageId' , rendDepends = flatDependencies genDesc + , rendLibName = renderLibName + , rendComponentName = renderComponentName , rendExecNames = map (unUnqualComponentName . exeName) (executables flatDesc) - , rendLibraryDeps = depTree libBuildInfo `fmap` condLibrary genDesc - , rendExecutableDeps = (unUnqualComponentName *** depTree buildInfo) + , rendExecutableDeps = (CExeName *** depTree buildInfo) `map` condExecutables genDesc - , rendSublibraryDeps = (unUnqualComponentName *** depTree libBuildInfo) - `map` condSubLibraries genDesc + , rendLibraryDeps = second (depTree libBuildInfo) <$> allCondLibs genDesc , rendLicenseName = prettyShow (license desc) -- maybe make this a bit more human-readable , rendLicenseFiles = map getSymbolicPath $ licenseFiles desc , rendMaintainer = case fromShortText $ maintainer desc of @@ -144,17 +147,15 @@ doPackageRender users info = PackageRender then Buildable else NotBuildable - renderModules docindex - | Just lib <- library flatDesc - = let mod_ix = mkForest $ exposedModules lib + renderModules :: Maybe TarIndex -> [(LibraryName, ModSigIndex)] + renderModules docindex = flip fmap (allLibraries flatDesc) $ \lib -> + let mod_ix = mkForest $ exposedModules lib -- Assumes that there is an HTML per reexport ++ map moduleReexportName (reexportedModules lib) ++ virtualModules (libBuildInfo lib) - sig_ix = mkForest $ signatures lib - mkForest = moduleForest . map (\m -> (m, moduleHasDocs docindex m)) - in Just (ModSigIndex { modIndex = mod_ix, sigIndex = sig_ix }) - | otherwise - = Nothing + sig_ix = mkForest $ signatures lib + mkForest = moduleForest . map (\m -> (m, moduleHasDocs docindex m)) + in (libName lib, ModSigIndex { modIndex = mod_ix, sigIndex = sig_ix }) moduleHasDocs :: Maybe TarIndex -> ModuleName -> Bool moduleHasDocs Nothing = const False @@ -172,6 +173,25 @@ doPackageRender users info = PackageRender loc <- repoLocation r return (ty, loc, r) + packageId' :: PackageIdentifier + packageId' = pkgInfoId info + + packageName' :: String + packageName' = unPackageName $ pkgName packageId' + + renderLibName :: LibraryName -> String + renderLibName LMainLibName = packageName' + renderLibName (LSubLibName name) = + packageName' ++ ":" ++ unUnqualComponentName name + + renderComponentName :: ComponentName -> String + renderComponentName (CLibName name) = renderLibName name + renderComponentName name@(CNotLibName _) = componentNameRaw name + +allCondLibs :: GenericPackageDescription -> [(LibraryName, CondTree ConfVar [Dependency] Library)] +allCondLibs desc = maybeToList ((LMainLibName,) <$> condLibrary desc) + ++ (first LSubLibName <$> condSubLibraries desc) + type DependencyTree = CondTree ConfVar [Dependency] IsBuildable data IsBuildable = Buildable diff --git a/src/Distribution/Server/Packages/Unpack.hs b/src/Distribution/Server/Packages/Unpack.hs index 4440b2d79..f7c363df7 100644 --- a/src/Distribution/Server/Packages/Unpack.hs +++ b/src/Distribution/Server/Packages/Unpack.hs @@ -142,10 +142,10 @@ tarPackageChecks lax now tarGzFile contents = do expectedDir = display pkgid selectEntry entry = case Tar.entryContent entry of - Tar.NormalFile bs _ -> Just (normalise (Tar.entryPath entry), NormalFile bs) - Tar.Directory -> Just (normalise (Tar.entryPath entry), Directory) - Tar.SymbolicLink linkTarget -> Just (normalise (Tar.entryPath entry), Link (Tar.fromLinkTarget linkTarget)) - Tar.HardLink linkTarget -> Just (normalise (Tar.entryPath entry), Link (Tar.fromLinkTarget linkTarget)) + Tar.NormalFile bs _ -> Just (normalise (Tar.entryTarPath entry), NormalFile bs) + Tar.Directory -> Just (normalise (Tar.entryTarPath entry), Directory) + Tar.SymbolicLink linkTarget -> Just (normalise (Tar.entryTarPath entry), Link linkTarget) + Tar.HardLink linkTarget -> Just (normalise (Tar.entryTarPath entry), Link linkTarget) _ -> Nothing files <- selectEntries explainTarError selectEntry entries return (pkgid, files) @@ -303,18 +303,19 @@ extraChecks :: GenericPackageDescription -> UploadMonad () extraChecks genPkgDesc pkgId tarIndex = do let pkgDesc = flattenPackageDescription genPkgDesc - fileChecks <- checkPackageContent (tarOps pkgId tarIndex) pkgDesc - - - -- this path info check is just until we can depend on cabal 3.12 for PathInfo autogen modules. - -- https://github.com/haskell/cabal/issues/9331 - checkPathInfo pkgDesc - - let pureChecks = checkPackage genPkgDesc (Just pkgDesc) + fileChecks <- checkPackageContent (tarOps pkgId tarIndex) +-- The API change of checkPackage happened somewhere between 3.10 and 3.12. +#if !MIN_VERSION_Cabal(3,12,0) + pkgDesc +#else + genPkgDesc +#endif + let pureChecks = checkPackage genPkgDesc +#if !MIN_VERSION_Cabal(3,12,0) + (Just pkgDesc) +#endif checks = pureChecks ++ fileChecks - - isDistError (PackageDistSuspicious {}) = False -- just a warning isDistError (PackageDistSuspiciousWarn {}) = False -- just a warning isDistError _ = True @@ -350,14 +351,14 @@ warn msg = tell [msg] runUploadMonad :: UploadMonad a -> Either String (a, [String]) runUploadMonad (UploadMonad m) = runIdentity . runExceptT . runWriterT $ m -selectEntries :: forall err a. +selectEntries :: forall tarPath linkTarget err a. (err -> String) - -> (Tar.Entry -> Maybe a) - -> Tar.Entries err + -> (Tar.GenEntry tarPath linkTarget -> Maybe a) + -> Tar.GenEntries tarPath linkTarget err -> UploadMonad [a] selectEntries formatErr select = extract [] where - extract :: [a] -> Tar.Entries err -> UploadMonad [a] + extract :: [a] -> Tar.GenEntries tarPath linkTarget err -> UploadMonad [a] extract _ (Tar.Fail err) = throwError (formatErr err) extract selected Tar.Done = return selected extract selected (Tar.Next entry entries) = @@ -371,18 +372,20 @@ data CombinedTarErrs = | TarBombError FilePath FilePath | FutureTimeError FilePath UTCTime UTCTime | PermissionsError FilePath Tar.Permissions + | LongNamesError Tar.DecodeLongNamesError tarballChecks :: Bool -> UTCTime -> FilePath -> Tar.Entries Tar.FormatError - -> Tar.Entries CombinedTarErrs + -> Tar.GenEntries FilePath FilePath CombinedTarErrs tarballChecks lax now expectedDir = (if not lax then checkFutureTimes now else id) . checkTarbomb expectedDir . (if not lax then checkUselessPermissions else id) . (if lax then ignoreShortTrailer else fmapTarError (either id PortabilityError) - . Tar.checkPortability) - . fmapTarError FormatError + . Tar.mapEntries (\entry -> maybe (Right entry) Left (Tar.checkEntryPortability entry))) + . fmapTarError (either FormatError LongNamesError) + . Tar.decodeLongNames where ignoreShortTrailer = Tar.foldEntries Tar.Next Tar.Done @@ -392,32 +395,39 @@ tarballChecks lax now expectedDir = fmapTarError f = Tar.foldEntries Tar.Next Tar.Done (Tar.Fail . f) checkFutureTimes :: UTCTime - -> Tar.Entries CombinedTarErrs - -> Tar.Entries CombinedTarErrs + -> Tar.GenEntries FilePath linkTarget CombinedTarErrs + -> Tar.GenEntries FilePath linkTarget CombinedTarErrs checkFutureTimes now = checkEntries checkEntry where -- Allow 30s for client clock skew now' = addUTCTime 30 now + + checkEntry :: Tar.GenEntry FilePath linkTarget -> Maybe CombinedTarErrs checkEntry entry | entryUTCTime > now' = Just (FutureTimeError posixPath entryUTCTime now') where entryUTCTime = posixSecondsToUTCTime (realToFrac (Tar.entryTime entry)) - posixPath = Tar.fromTarPathToPosixPath (Tar.entryTarPath entry) + posixPath = Tar.entryTarPath entry checkEntry _ = Nothing -checkTarbomb :: FilePath -> Tar.Entries CombinedTarErrs -> Tar.Entries CombinedTarErrs +checkTarbomb + :: FilePath + -> Tar.GenEntries FilePath linkTarget CombinedTarErrs + -> Tar.GenEntries FilePath linkTarget CombinedTarErrs checkTarbomb expectedTopDir = checkEntries checkEntry where checkEntry entry = - case splitDirectories (Tar.entryPath entry) of + case splitDirectories (Tar.entryTarPath entry) of (topDir:_) | topDir == expectedTopDir -> Nothing - _ -> Just $ TarBombError (Tar.entryPath entry) expectedTopDir + _ -> Just $ TarBombError (Tar.entryTarPath entry) expectedTopDir -checkUselessPermissions :: Tar.Entries CombinedTarErrs -> Tar.Entries CombinedTarErrs +checkUselessPermissions + :: Tar.GenEntries FilePath linkTarget CombinedTarErrs + -> Tar.GenEntries FilePath linkTarget CombinedTarErrs checkUselessPermissions = checkEntries checkEntry where @@ -429,11 +439,14 @@ checkUselessPermissions = where checkPermissions expected actual = if expected .&. actual /= expected - then Just $ PermissionsError (Tar.entryPath entry) actual + then Just $ PermissionsError (Tar.entryTarPath entry) actual else Nothing -checkEntries :: (Tar.Entry -> Maybe e) -> Tar.Entries e -> Tar.Entries e +checkEntries + :: (Tar.GenEntry tarPath linkTarget -> Maybe e) + -> Tar.GenEntries tarPath linkTarget e + -> Tar.GenEntries tarPath linkTarget e checkEntries checkEntry = Tar.foldEntries (\entry rest -> maybe (Tar.Next entry rest) Tar.Fail (checkEntry entry)) @@ -487,6 +500,10 @@ explainTarError (PermissionsError entryname mode) = where showMode :: Tar.Permissions -> String showMode m = printf "%.3o" (fromIntegral m :: Int) +explainTarError (LongNamesError err) = + "There is an error in the format of entries with long names in the tar file: " ++ show err + ++ ". Check that it is a valid tar file (e.g. 'tar -xtf thefile.tar'). " + ++ "You may need to re-create the package tarball and try again." quote :: String -> String quote s = "'" ++ s ++ "'" @@ -522,6 +539,8 @@ isAcceptableLicense = either goSpdx goLegacy . licenseRaw goSimple (SPDX.ELicenseRef _) = False -- don't allow referenced licenses goSimple (SPDX.ELicenseIdPlus _) = False -- don't allow + licenses (use GPL-3.0-or-later e.g.) goSimple (SPDX.ELicenseId SPDX.CC0_1_0) = True -- CC0 isn't OSI approved, but we allow it as "PublicDomain", this is eg. PublicDomain in http://hackage.haskell.org/package/string-qq-0.0.2/src/LICENSE + goSimple (SPDX.ELicenseId SPDX.Bzip2_1_0_5) = True -- not OSI approved, but make an exception: https://github.com/haskell/hackage-server/issues/1294 + goSimple (SPDX.ELicenseId SPDX.Bzip2_1_0_6) = True -- same as above goSimple (SPDX.ELicenseId lid) = SPDX.licenseIsOsiApproved lid || SPDX.LId.licenseIsFsfLibre lid -- allow only OSI or FSF approved licenses. -- pre `cabal-version: 2.2` diff --git a/src/Distribution/Server/Pages/Package.hs b/src/Distribution/Server/Pages/Package.hs index 5813355e1..b58991edc 100644 --- a/src/Distribution/Server/Pages/Package.hs +++ b/src/Distribution/Server/Pages/Package.hs @@ -34,9 +34,10 @@ import Distribution.Utils.ShortText (fromShortText, ShortText) import Text.XHtml.Strict hiding (p, name, title, content) import qualified Text.XHtml.Strict -import Data.Maybe (fromMaybe, maybeToList, isJust, mapMaybe, catMaybes) +import Data.Bool (bool) +import Data.Maybe (fromMaybe, isJust, mapMaybe, catMaybes) import Data.List (intersperse, intercalate, partition) -import Control.Arrow (second) +import Control.Arrow (Arrow (..)) import System.FilePath.Posix ((), (<.>)) import qualified Documentation.Haddock.Markup as Haddock @@ -152,15 +153,19 @@ renderPackageFlags render docURL = whenNotNull xs a = if null xs then [] else a moduleSection :: PackageRender -> Maybe TarIndex -> URL -> Maybe PackageId -> Bool -> [Html] -moduleSection render mdocIndex docURL mPkgId quickNav = - maybeToList $ fmap msect (rendModules render mdocIndex) - where msect ModSigIndex{ modIndex = m, sigIndex = s } = toHtml $ +moduleSection render mdocIndex docURL mPkgId quickNav = case renderedModules of + [(LMainLibName, mods)] -> [msect mods] + renderedLibs -> concatMap renderNamedLib renderedLibs + + where msect (ModSigIndex{ modIndex = m, sigIndex = s }) = + let heading = bool h3 h2 containsSubLibraries in + toHtml $ (if not (null s) - then [ h2 << "Signatures" + then [ heading << "Signatures" , renderModuleForest docURL s ] else []) ++ (if not (null m) - then [ h2 << "Modules"] ++ + then [ heading << "Modules"] ++ [renderDocIndexLink] ++ [renderModuleForest docURL m ] else []) @@ -184,10 +189,17 @@ moduleSection render mdocIndex docURL mPkgId quickNav = concatLinks [h] = Just h concatLinks (h:hs) = (h +++) . ("] [" +++) <$> concatLinks hs -tabulate :: [(String, Html)] -> Html -tabulate items = table ! [theclass "properties"] << - [tr << [th << t, td << d] | (t, d) <- items] + renderNamedLib :: (LibraryName, ModSigIndex) -> [Html] + renderNamedLib (name, mods) = + [ h2 << ("library " ++ rendLibName render name) + , thediv ! [theclass "lib-contents"] << msect mods + ] + + containsSubLibraries :: Bool + containsSubLibraries = map fst renderedModules == [LMainLibName] + renderedModules :: [(LibraryName, ModSigIndex)] + renderedModules = rendModules render mdocIndex renderDependencies :: PackageRender -> (String, Html) renderDependencies render = @@ -219,15 +231,23 @@ nonbreakingSpan :: Html -> Html nonbreakingSpan str = thespan ! [thestyle "white-space: nowrap"] << str renderDetailedDependencies :: PackageRender -> Html -renderDetailedDependencies pkgRender = - tabulate $ map (second (fromMaybe noDeps . render)) targets +renderDetailedDependencies pkgRender + = mconcat (mapMaybe renderComponentType componentsByType) + where - targets :: [(String, DependencyTree)] - targets = maybeToList library - ++ rendSublibraryDeps pkgRender - ++ rendExecutableDeps pkgRender - where - library = (\lib -> ("library", lib)) `fmap` rendLibraryDeps pkgRender + componentsByType :: [(String, [(ComponentName, DependencyTree)])] + componentsByType = + [ ("Libraries", first CLibName <$> rendLibraryDeps pkgRender) + , ("Executables", rendExecutableDeps pkgRender) + ] + + renderComponentType :: (String, [(ComponentName, DependencyTree)]) -> Maybe Html + renderComponentType (_, []) = Nothing + renderComponentType (componentType, items) = Just $ mconcat + [ h2 << componentType + , flip foldMap items $ \(componentName, deptree) -> + h3 << rendComponentName pkgRender componentName +++ fromMaybe noDeps (render deptree) + ] noDeps = list [toHtml "No dependencies"] @@ -243,7 +263,7 @@ renderDetailedDependencies pkgRender = NotBuildable -> [strong << "buildable:" +++ " False"] list :: [Html] -> Html - list items = thediv ! [identifier "detailed-dependencies"] << unordList items + list items = unordList items ! [identifier "detailed-dependencies"] renderComponent :: CondBranch ConfVar [Dependency] IsBuildable -> Maybe Html diff --git a/src/Distribution/Server/Pages/PackageFromTemplate.hs b/src/Distribution/Server/Pages/PackageFromTemplate.hs index 6cf3e2624..82ac34744 100644 --- a/src/Distribution/Server/Pages/PackageFromTemplate.hs +++ b/src/Distribution/Server/Pages/PackageFromTemplate.hs @@ -33,7 +33,7 @@ import Text.XHtml.Strict hiding (p, name, title, content) import qualified Text.XHtml.Strict as XHtml import Data.Maybe (maybeToList, fromMaybe, isJust) -import Data.List (intersperse) +import Data.List (intercalate, intersperse) import System.FilePath.Posix ((), takeFileName, dropTrailingPathSeparator) import Data.Time.Format (defaultTimeLocale, formatTime) @@ -228,6 +228,12 @@ packagePageTemplate render (vList $ map sourceRepositoryToHtml (sourceRepos desc)) ] ++ + [ templateVal "hasTestedWith" + (not $ null pkgTestedWith) + , templateVal "testedWith" + (intercalate ", " pkgTestedWith) + ] ++ + [ templateVal "hasSynopsis" (not . Short.null $ synopsis (rendOther render)) , templateVal "synopsis" @@ -238,6 +244,10 @@ packagePageTemplate render pkgid = rendPkgId render pkgVer = display $ pkgVersion pkgid pkgName = display $ packageName pkgid + pkgTestedWith = + [ display compilerFlavor ++ " " ++ display versionRange + | (compilerFlavor, versionRange) <- testedWith desc + ] desc = rendOther render diff --git a/src/Distribution/Server/Util/CabalRevisions.hs b/src/Distribution/Server/Util/CabalRevisions.hs index 9036cf9c8..479f0c41c 100644 --- a/src/Distribution/Server/Util/CabalRevisions.hs +++ b/src/Distribution/Server/Util/CabalRevisions.hs @@ -178,12 +178,19 @@ checkCabalFileRevision checkXRevision old new = do checkPackageChecks :: Check GenericPackageDescription checkPackageChecks pkg pkg' = - let checks = checkPackage pkg Nothing - checks' = filter notUpperBounds $ checkPackage pkg' Nothing + let checks = checkPackage pkg +-- The API change of checkPackage happened somewhere between 3.10 and 3.12. +#if !MIN_VERSION_Cabal(3,12,0) + Nothing +#endif + checks' = filter notUpperBounds $ checkPackage pkg' +#if !MIN_VERSION_Cabal(3,12,0) + Nothing +#endif -- if multiple upper bounds are missing, then the simple set subtraction might detect a change to -- just one, and fail. Ideally we'd perform a set subtraction directly on just the missing bounds -- warning contents. A simple second best is to discard this check for now. - notUpperBounds (PackageDistSuspiciousWarn (MissingUpperBounds _)) = False + notUpperBounds (PackageDistSuspiciousWarn MissingUpperBounds{}) = False notUpperBounds _ = True in case checks' \\ checks of [] -> return () diff --git a/tests/Distribution/Server/Packages/UnpackTest.hs b/tests/Distribution/Server/Packages/UnpackTest.hs index 1d0fd0e64..5d9a0471c 100644 --- a/tests/Distribution/Server/Packages/UnpackTest.hs +++ b/tests/Distribution/Server/Packages/UnpackTest.hs @@ -19,10 +19,14 @@ deriving instance Eq CombinedTarErrs -- | Test that check permissions does the right thing testPermissions :: FilePath -- ^ .tar.gz file to test - -> (Tar.Entry -> Maybe CombinedTarErrs) -- ^ Converter to create errors if necessary + -> (Tar.GenEntry FilePath FilePath -> Maybe CombinedTarErrs) -- ^ Converter to create errors if necessary -> Assertion testPermissions tarPath mangler = do entries <- Tar.read . GZip.decompress <$> BL.readFile tarPath - let mappedEntries = Tar.foldEntries Tar.Next Tar.Done (Tar.Fail . FormatError) entries + let mappedEntries = Tar.foldEntries + Tar.Next + Tar.Done + (Tar.Fail . either FormatError LongNamesError) + (Tar.decodeLongNames entries) when (checkEntries mangler mappedEntries /= checkUselessPermissions mappedEntries) $ assertFailure ("Permissions check did not match expected for: " ++ tarPath) diff --git a/tests/DocTestMain.hs b/tests/DocTestMain.hs index 5cb58708c..94aa8c591 100644 --- a/tests/DocTestMain.hs +++ b/tests/DocTestMain.hs @@ -14,5 +14,5 @@ main = do args <- getArgs pkg <- findCabalPackage "hackage-server" -- Need to give the library name, otherwise the parser does not find it. - lib <- extractSpecificCabalLibrary (Just "lib-server") pkg + lib <- extractSpecificCabalLibrary Nothing pkg mainFromLibrary lib args diff --git a/tests/PackageTestMain.hs b/tests/PackageTestMain.hs index ec4f38656..bd5aecc16 100644 --- a/tests/PackageTestMain.hs +++ b/tests/PackageTestMain.hs @@ -9,6 +9,7 @@ import Data.Time (getCurrentTime) import Data.List (isInfixOf) import qualified Codec.Archive.Tar as Tar +import qualified Codec.Archive.Tar.Entry as Tar import qualified Codec.Compression.GZip as GZip import Distribution.Server.Packages.Unpack @@ -42,19 +43,19 @@ tarPermissions = (testPermissions "tests/permissions-tarballs/bad-dir-perms.tar.gz" badDirMangler) ] -goodMangler :: (Tar.Entry -> Maybe CombinedTarErrs) +goodMangler :: (Tar.GenEntry tarPath linkTarget -> Maybe CombinedTarErrs) goodMangler = const Nothing -badFileMangler :: (Tar.Entry -> Maybe CombinedTarErrs) +badFileMangler :: (Tar.GenEntry FilePath linkTarget -> Maybe CombinedTarErrs) badFileMangler entry = case Tar.entryContent entry of - (Tar.NormalFile _ _) -> Just $ PermissionsError (Tar.entryPath entry) 0o600 + (Tar.NormalFile _ _) -> Just $ PermissionsError (Tar.entryTarPath entry) 0o600 _ -> Nothing -badDirMangler :: (Tar.Entry -> Maybe CombinedTarErrs) +badDirMangler :: (Tar.GenEntry FilePath linkTarget -> Maybe CombinedTarErrs) badDirMangler entry = case Tar.entryContent entry of - Tar.Directory -> Just $ PermissionsError (Tar.entryPath entry) 0o700 + Tar.Directory -> Just $ PermissionsError (Tar.entryTarPath entry) 0o700 _ -> Nothing ---------------------------------------------------------------------------