diff --git a/.github/workflows/cabal.off b/.github/workflows/cabal.off new file mode 100644 index 000000000..491a24ad7 --- /dev/null +++ b/.github/workflows/cabal.off @@ -0,0 +1,60 @@ +on: + push: + branches: + - master + pull_request: + branches: + - master +name: Cabal +jobs: + build: + runs-on: ${{ matrix.os }} + strategy: + fail-fast: false + matrix: + ghc: ['9.8', '9.6', '9.4', '9.2'] + cabal: ['latest'] + os: [ubuntu-latest] + name: Cabal with GHC ${{ matrix.ghc }} + steps: + - uses: actions/checkout@v4 + - name: Setup Haskell + uses: haskell-actions/setup@v2 + with: + ghc-version: ${{ matrix.ghc }} + cabal-version: ${{ matrix.cabal }} + - name: Install dependencies + run: sudo apt install -y libbrotli-dev libgd-dev + - name: Build + run: cabal build all --enable-tests + - name: Test + run: cabal test all --enable-tests + - name: Haddock + run: cabal haddock all + + ## Andreas, 2023-08-03: mtl-2.3 is covered by GHC 9.6 + # + # build_with_mtl_2_3: + # runs-on: ${{ matrix.os }} + # strategy: + # fail-fast: false + # matrix: + # ghc: ['9.4.4'] + # cabal: ['3.8.1.0'] + # os: [ubuntu-latest] + # name: Cabal with GHC ${{ matrix.ghc }} and mtl >= 2.3.1 + # steps: + # - uses: actions/checkout@v4 + # - name: Setup Haskell + # uses: haskell/actions/setup@v2 + # with: + # ghc-version: ${{ matrix.ghc }} + # cabal-version: ${{ matrix.cabal }} + # - name: Install dependencies + # run: sudo apt install -y libbrotli-dev libgd-dev + # - name: Build dependencies with mtl >= 2.3.1 + # # 2022-12-30: 'transformers >= 0.6' is needed because of happstack-server + # run: cabal build all --disable-tests --dependencies-only -O0 --constraint 'mtl >= 2.3.1' --constraint 'transformers >= 0.6' --allow-newer='Cabal:mtl' --allow-newer='Cabal:transformers' + # - name: Build with mtl >= 2.3.1 + # # 2022-12-30: 'transformers >= 0.6' is needed because of happstack-server + # run: cabal build all --disable-tests -O0 --constraint 'mtl >= 2.3.1' --constraint 'transformers >= 0.6' --allow-newer='Cabal:mtl' --allow-newer='Cabal:transformers' diff --git a/.github/workflows/cabal.yml b/.github/workflows/cabal.yml deleted file mode 100644 index 2f49c5b5b..000000000 --- a/.github/workflows/cabal.yml +++ /dev/null @@ -1,59 +0,0 @@ -on: - push: - branches: - - master - - ci* - pull_request: - branches: - - master - - ci* -name: Cabal -jobs: - build: - runs-on: ${{ matrix.os }} - strategy: - fail-fast: false - matrix: - ghc: ['9.4.4', '9.2.7', '9.0.2'] - cabal: ['3.8.1.0'] - os: [ubuntu-latest] - name: Cabal with GHC ${{ matrix.ghc }} - steps: - - uses: actions/checkout@v3 - - name: Setup Haskell - uses: haskell/actions/setup@v2 - with: - ghc-version: ${{ matrix.ghc }} - cabal-version: ${{ matrix.cabal }} - - name: Install dependencies - run: sudo apt install -y libbrotli-dev libgd-dev - - name: Build - run: cabal build all --enable-tests - - name: Test - run: cabal test all --enable-tests - - name: Haddock - run: cabal haddock all - build_with_mtl_2_3: - runs-on: ${{ matrix.os }} - strategy: - fail-fast: false - matrix: - ghc: ['9.4.4'] - cabal: ['3.8.1.0'] - os: [ubuntu-latest] - name: Cabal with GHC ${{ matrix.ghc }} and mtl >= 2.3.1 - steps: - - uses: actions/checkout@v3 - - name: Setup Haskell - uses: haskell/actions/setup@v2 - with: - ghc-version: ${{ matrix.ghc }} - cabal-version: ${{ matrix.cabal }} - - name: Install dependencies - run: sudo apt install -y libbrotli-dev libgd-dev - - name: Build dependencies with mtl >= 2.3.1 - # 2022-12-30: 'transformers >= 0.6' is needed because of happstack-server - run: cabal build all --disable-tests --dependencies-only -O0 --constraint 'mtl >= 2.3.1' --constraint 'transformers >= 0.6' --allow-newer='Cabal:mtl' --allow-newer='Cabal:transformers' - - name: Build with mtl >= 2.3.1 - # 2022-12-30: 'transformers >= 0.6' is needed because of happstack-server - run: cabal build all --disable-tests -O0 --constraint 'mtl >= 2.3.1' --constraint 'transformers >= 0.6' --allow-newer='Cabal:mtl' --allow-newer='Cabal:transformers' diff --git a/.github/workflows/haskell-ci.yml b/.github/workflows/haskell-ci.yml index 6a7215dfe..7385d546c 100644 --- a/.github/workflows/haskell-ci.yml +++ b/.github/workflows/haskell-ci.yml @@ -6,22 +6,20 @@ # # haskell-ci regenerate # -# For more information, see https://github.com/haskell-CI/haskell-ci +# For more information, see https://github.com/andreasabel/haskell-ci # -# version: 0.15.20230321 +# version: 0.17.20231012 # -# REGENDATA ("0.15.20230321",["github","hackage-server.cabal"]) +# REGENDATA ("0.17.20231012",["github","hackage-server.cabal"]) # name: Haskell-CI on: push: branches: - master - - ci* pull_request: branches: - master - - ci* jobs: linux: name: Haskell-CI - Linux - ${{ matrix.compiler }} @@ -34,19 +32,24 @@ jobs: strategy: matrix: include: - - compiler: ghc-9.6.1 + - compiler: ghc-9.8.1 compilerKind: ghc - compilerVersion: 9.6.1 + compilerVersion: 9.8.1 setup-method: ghcup allow-failure: false - - compiler: ghc-9.4.4 + - compiler: ghc-9.6.3 compilerKind: ghc - compilerVersion: 9.4.4 + compilerVersion: 9.6.3 setup-method: ghcup allow-failure: false - - compiler: ghc-9.2.7 + - compiler: ghc-9.4.7 compilerKind: ghc - compilerVersion: 9.2.7 + compilerVersion: 9.4.7 + setup-method: ghcup + allow-failure: false + - compiler: ghc-9.2.8 + compilerKind: ghc + compilerVersion: 9.2.8 setup-method: ghcup allow-failure: false - compiler: ghc-9.0.2 @@ -71,8 +74,9 @@ 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.2/x86_64-linux-ghcup-0.1.19.2 > "$HOME/.ghcup/bin/ghcup" + curl -sL https://downloads.haskell.org/ghcup/0.1.19.5/x86_64-linux-ghcup-0.1.19.5 > "$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) apt-get update @@ -88,10 +92,12 @@ jobs: echo "CABAL_DIR=$HOME/.cabal" >> "$GITHUB_ENV" echo "CABAL_CONFIG=$HOME/.cabal/config" >> "$GITHUB_ENV" HCDIR=/opt/$HCKIND/$HCVER - HC=$HOME/.ghcup/bin/$HCKIND-$HCVER + HC=$("$HOME/.ghcup/bin/ghcup" whereis ghc "$HCVER") + HCPKG=$(echo "$HC" | sed 's#ghc$#ghc-pkg#') + HADDOCK=$(echo "$HC" | sed 's#ghc$#haddock#') echo "HC=$HC" >> "$GITHUB_ENV" - echo "HCPKG=$HOME/.ghcup/bin/$HCKIND-pkg-$HCVER" >> "$GITHUB_ENV" - echo "HADDOCK=$HOME/.ghcup/bin/haddock-$HCVER" >> "$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" 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" @@ -142,14 +148,14 @@ jobs: - name: install cabal-plan run: | mkdir -p $HOME/.cabal/bin - curl -sL https://github.com/haskell-hvr/cabal-plan/releases/download/v0.6.2.0/cabal-plan-0.6.2.0-x86_64-linux.xz > cabal-plan.xz - echo 'de73600b1836d3f55e32d80385acc055fd97f60eaa0ab68a755302685f5d81bc cabal-plan.xz' | sha256sum -c - + curl -sL https://github.com/haskell-hvr/cabal-plan/releases/download/v0.7.3.0/cabal-plan-0.7.3.0-x86_64-linux.xz > cabal-plan.xz + echo 'f62ccb2971567a5f638f2005ad3173dba14693a45154c1508645c52289714cb2 cabal-plan.xz' | sha256sum -c - xz -d < cabal-plan.xz > $HOME/.cabal/bin/cabal-plan rm -f cabal-plan.xz chmod a+x $HOME/.cabal/bin/cabal-plan cabal-plan --version - name: checkout - uses: actions/checkout@v3 + uses: actions/checkout@v4 with: path: source - name: initial cabal.project for sdist diff --git a/.github/workflows/nix-flake.yml b/.github/workflows/nix-flake.yml index ebb68cb58..e036875cc 100644 --- a/.github/workflows/nix-flake.yml +++ b/.github/workflows/nix-flake.yml @@ -9,16 +9,16 @@ on: jobs: nix: strategy: - fail-fast: true + fail-fast: false matrix: os: - ubuntu-latest - # - macos-latest + - macos-latest name: Nix on ${{ matrix.os }} runs-on: ${{ matrix.os }} steps: - - uses: actions/checkout@v3.1.0 - - uses: cachix/install-nix-action@v21 + - uses: actions/checkout@v4 + - uses: cachix/install-nix-action@v23 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= @@ -29,4 +29,6 @@ jobs: name: hackage-server authToken: '${{ secrets.CACHIX_AUTH_TOKEN }}' - run: nix build - # - run: nix flake check + + - continue-on-error: false + run: nix flake check diff --git a/cabal.haskell-ci b/cabal.haskell-ci index 8f39d5cf4..391b2ebbf 100644 --- a/cabal.haskell-ci +++ b/cabal.haskell-ci @@ -1,4 +1,4 @@ -branches: master ci* +branches: master installed: +all -Cabal -Cabal-syntax -text -parsec -process diff --git a/cabal.project b/cabal.project index c3e6d24b7..f387f2c52 100644 --- a/cabal.project +++ b/cabal.project @@ -1,3 +1,9 @@ +packages: + . + +-- This comment moved below "packages" to fix parsing of this file +-- by flake.nix + -- This project config requires cabal 2.4 or later -- If in doubt, use GHC 8.8 to build hackage-server; see @@ -6,8 +12,7 @@ -- -- with-compiler: ghc-8.8 -packages: . - + allow-newer: rss:time, rss:base -- Andreas, 2022-10-28: `Cabal-3.8.1.0` wants `process >= 1.6.14` diff --git a/datafiles/static/browse.js b/datafiles/static/browse.js index 868768a44..4c79adcbe 100644 --- a/datafiles/static/browse.js +++ b/datafiles/static/browse.js @@ -133,7 +133,7 @@ const replaceRows = (response) => { tr.appendChild(createSimpleText(row.description)); tr.appendChild(createTags(row.tags)); tr.appendChild(createLastUpload(row.lastUpload)); - tr.appendChild(createSimpleText(row.lastVersion)); + tr.appendChild(createSimpleText(row.referenceVersion)); tr.appendChild(createMaintainers(row.maintainers)); l.appendChild(tr); } diff --git a/datafiles/templates/Html/browse.html.st b/datafiles/templates/Html/browse.html.st index 8f79ce634..ddc240e75 100644 --- a/datafiles/templates/Html/browse.html.st +++ b/datafiles/templates/Html/browse.html.st @@ -212,7 +212,7 @@ Description Tags Last U/L - Last Version + Reference Version Maintainers diff --git a/datafiles/templates/Html/candidate-page.html.st b/datafiles/templates/Html/candidate-page.html.st index 412591585..c7006d9c0 100644 --- a/datafiles/templates/Html/candidate-page.html.st +++ b/datafiles/templates/Html/candidate-page.html.st @@ -14,6 +14,8 @@ + + diff --git a/datafiles/templates/Html/revisions.html.st b/datafiles/templates/Html/revisions.html.st index 72fd5acc4..ed8587275 100644 --- a/datafiles/templates/Html/revisions.html.st +++ b/datafiles/templates/Html/revisions.html.st @@ -28,7 +28,7 @@ refer to the $revisions:{revision| - -r$revision.number$ + -r$revision.number$ ($pkgid$-r$revision.number$) $revision.htmltime$ $revision.user$ $revision.sha256$ diff --git a/datafiles/templates/Html/vouch.html.st b/datafiles/templates/Html/vouch.html.st new file mode 100644 index 000000000..cb34cd855 --- /dev/null +++ b/datafiles/templates/Html/vouch.html.st @@ -0,0 +1,27 @@ + + + +$hackageCssTheme()$ +Endorse user | Hackage + + + +$hackagePageHeader()$ + +
+

Endorse user

+ +

$msg$

+ +
+ +
+ +

Endorsing cannot be undone! When the user has $requiredNumber$ endorsements, the user +will be added to the uploaders group, and allowed to upload packages. Only endorse people who you trust to upload packages responsibly.

+ + +
+ diff --git a/datafiles/templates/UserSignupReset/SignupConfirm.html.st b/datafiles/templates/UserSignupReset/SignupConfirm.html.st index bc3fff397..d3a4d1a52 100644 --- a/datafiles/templates/UserSignupReset/SignupConfirm.html.st +++ b/datafiles/templates/UserSignupReset/SignupConfirm.html.st @@ -13,7 +13,9 @@ $hackagePageHeader()$

Email confirmation done! -

Now you can set your password and create the account. +

Now you can set your password and use the account. If you wish to + upload a package, please request to be added to the uploader group + by one of the mechanisms described in the email you were sent.

@@ -31,4 +33,3 @@ $hackagePageHeader()$ - diff --git a/datafiles/templates/UserSignupReset/SignupConfirmation.email.st b/datafiles/templates/UserSignupReset/SignupConfirmation.email.st index a187fe221..5a1e87fd4 100644 --- a/datafiles/templates/UserSignupReset/SignupConfirmation.email.st +++ b/datafiles/templates/UserSignupReset/SignupConfirmation.email.st @@ -6,11 +6,19 @@ this link: $confirmlink$ -After your account is created, you will need to email the Hackage -Trustees at hackage-trustees@haskell.org requesting addition to the -uploader group. In this email, please include your Hackage username -and a link to the package you'd like to upload (on a host like gitlab -or github). This measure is unfortunately necessary to prevent spam +After your account is created, you will need to be added to the +uploaders group in order to upload packages. + +The easiest way to be added to the uploaders group is to ask two other +confirmed uploaders to endorse you, sending them the following link: + + $endorselink$ + +Alternately, you can email the Hackage Trustees at +hackage-trustees@haskell.org requesting addition to the uploader +group. In this email, please include your Hackage username and a link +to the package you'd like to upload (on a host like gitlab or +github). This measure is unfortunately necessary to prevent spam accounts. For storage and bandwidth reasons, we ask uploaders to only upload diff --git a/datafiles/templates/UserSignupReset/SignupEmailSent.html.st b/datafiles/templates/UserSignupReset/SignupEmailSent.html.st index 95bc5f943..eb7342fd2 100644 --- a/datafiles/templates/UserSignupReset/SignupEmailSent.html.st +++ b/datafiles/templates/UserSignupReset/SignupEmailSent.html.st @@ -14,7 +14,10 @@ $hackagePageHeader()$

An email has been sent to $useremail$

The email will contain a link to a page where -you can set your password and activate your account. + you can set your password and activate your account. + +

It will also contain information on how to be authorized + as a hackage uploader.

Note that these activation links do eventually expire, so don't leave it too long! diff --git a/datafiles/templates/UserSignupReset/SignupRequest.html.st b/datafiles/templates/UserSignupReset/SignupRequest.html.st index 21b3265f7..6556e2603 100644 --- a/datafiles/templates/UserSignupReset/SignupRequest.html.st +++ b/datafiles/templates/UserSignupReset/SignupRequest.html.st @@ -58,12 +58,18 @@ such people choose a name (and username) that looks at home among a collection of real names; we will be unwilling to add Kittenlover97 to the package uploader group. -

-After your account is created, you cannot upload until you -contact the hackage trustees at hackage-trustees@haskell.org and -send an email (including your login username) requesting to be added to the uploader group. -(This measure is unfortunately necessary to prevent spam accounts). -

+

After your account is created, you +cannot upload until you are added to the uploaders group. You can be +added to the uploaders group by asking two confirmed uploaders to +endorse you (information will be provided in the email). + +

+ +Alternately, you can contact the hackage trustees at +hackage-trustees@haskell.org and send an email (including your +login username and the package you intend to upload) requesting to be +added to the uploader group. (This measure is unfortunately necessary +to prevent spam accounts).

@@ -112,7 +118,7 @@ var hash = document.getElementById("hash"); function changeCaptcha() { var xmlHttp = new XMLHttpRequest(); - xmlHttp.onreadystatechange = function() { + xmlHttp.onreadystatechange = function() { if (xmlHttp.readyState == 4 && xmlHttp.status == 200) { var res = JSON.parse(xmlHttp.responseText); if (typeof res == "object" && typeof res.timestamp == "string" && typeof res.hash == "string" && typeof res.base64image == "string") { diff --git a/exes/MirrorClient.hs b/exes/MirrorClient.hs index 5cf0cc548..7008ea0e3 100644 --- a/exes/MirrorClient.hs +++ b/exes/MirrorClient.hs @@ -4,7 +4,9 @@ module Main (main) where import Control.Exception import Control.Monad import Control.Monad.Trans +import Data.Function (on) import Data.List +import qualified Data.List.NonEmpty as NonEmpty import Data.Version import Network.Browser import System.Directory @@ -118,10 +120,14 @@ mirrorOnce verbosity opts | null (selectedPkgs opts) = pkgsMissingFromDest | otherwise = subsetIndex (selectedPkgs opts) pkgsMissingFromDest - pkgsToMirror' = filter (\(PkgIndexInfo pkg _ _ _) -> - pkg `Set.notMember` missingPkgs - && pkg `Set.notMember` unmirrorablePkgs ) - pkgsToMirror + byPkgId cmp = on cmp (\(PkgIndexInfo pkg _ _ _) -> pkg) + pkgsToMirror' + -- Remove any duplicates in the index from metadata revisions + = map NonEmpty.head . NonEmpty.groupBy (byPkgId (==)) . sortBy (byPkgId compare) + $ filter (\(PkgIndexInfo pkg _ _ _) -> + pkg `Set.notMember` missingPkgs + && pkg `Set.notMember` unmirrorablePkgs) + pkgsToMirror mirrorCount = length pkgsToMirror' ignoreCount = length pkgsToMirror - mirrorCount diff --git a/flake.lock b/flake.lock index 113d672e4..7903bf046 100644 --- a/flake.lock +++ b/flake.lock @@ -2,14 +2,16 @@ "nodes": { "flake-parts": { "inputs": { - "nixpkgs-lib": "nixpkgs-lib" + "nixpkgs-lib": [ + "nixpkgs" + ] }, "locked": { - "lastModified": 1680392223, - "narHash": "sha256-n3g7QFr85lDODKt250rkZj2IFS3i4/8HBU2yKHO3tqw=", + "lastModified": 1693611461, + "narHash": "sha256-aPODl8vAgGQ0ZYFIRisxYG5MOGSkIczvu2Cd8Gb9+1Y=", "owner": "hercules-ci", "repo": "flake-parts", - "rev": "dcc36e45d054d7bb554c9cdab69093debd91a0b5", + "rev": "7f53fdb7bdc5bb237da7fefef12d099e4fd611ca", "type": "github" }, "original": { @@ -20,11 +22,11 @@ }, "flake-root": { "locked": { - "lastModified": 1680964220, - "narHash": "sha256-dIdTYcf+KW9a4pKHsEbddvLVSfR1yiAJynzg2x0nfWg=", + "lastModified": 1692742795, + "narHash": "sha256-f+Y0YhVCIJ06LemO+3Xx00lIcqQxSKJHXT/yk1RTKxw=", "owner": "srid", "repo": "flake-root", - "rev": "f1c0b93d05bdbea6c011136ba1a135c80c5b326c", + "rev": "d9a70d9c7a5fd7f3258ccf48da9335e9b47c3937", "type": "github" }, "original": { @@ -35,11 +37,11 @@ }, "haskell-flake": { "locked": { - "lastModified": 1682000949, - "narHash": "sha256-yWu5/pR7WWuXgVFDEGe6rrsHwnSAHeMGo8wGZ1jVwzs=", + "lastModified": 1694478711, + "narHash": "sha256-zW/saV4diypxwP56b8l93Nw8fR7tXLbOFku2I+xYCxU=", "owner": "srid", "repo": "haskell-flake", - "rev": "1f801ee0bf776ae3f34e8942004fa5639c79b3a7", + "rev": "ddc704f3f62d3d3569ced794b534e8fd065c379c", "type": "github" }, "original": { @@ -48,240 +50,28 @@ "type": "github" } }, - "hls-floskell-plugin": { - "flake": false, - "locked": { - "dir": "plugins/hls-floskell-plugin", - "lastModified": 1682176345, - "narHash": "sha256-WmkHsjI0HgdAK+EY45pHsPUAOAoyDSTj+bpB3v3T+/g=", - "owner": "haskell", - "repo": "haskell-language-server", - "rev": "6640ebf33eeb8a62ccd094e2f47f69106acfd200", - "type": "github" - }, - "original": { - "dir": "plugins/hls-floskell-plugin", - "owner": "haskell", - "repo": "haskell-language-server", - "type": "github" - } - }, - "hls-graph": { - "flake": false, - "locked": { - "dir": "hls-graph", - "lastModified": 1682176345, - "narHash": "sha256-WmkHsjI0HgdAK+EY45pHsPUAOAoyDSTj+bpB3v3T+/g=", - "owner": "haskell", - "repo": "haskell-language-server", - "rev": "6640ebf33eeb8a62ccd094e2f47f69106acfd200", - "type": "github" - }, - "original": { - "dir": "hls-graph", - "owner": "haskell", - "repo": "haskell-language-server", - "type": "github" - } - }, - "hls-hlint-plugin": { - "flake": false, - "locked": { - "dir": "plugins/hls-hlint-plugin", - "lastModified": 1682176345, - "narHash": "sha256-WmkHsjI0HgdAK+EY45pHsPUAOAoyDSTj+bpB3v3T+/g=", - "owner": "haskell", - "repo": "haskell-language-server", - "rev": "6640ebf33eeb8a62ccd094e2f47f69106acfd200", - "type": "github" - }, - "original": { - "dir": "plugins/hls-hlint-plugin", - "owner": "haskell", - "repo": "haskell-language-server", - "type": "github" - } - }, - "hls-ormolu-plugin": { - "flake": false, - "locked": { - "dir": "plugins/hls-ormolu-plugin", - "lastModified": 1682176345, - "narHash": "sha256-WmkHsjI0HgdAK+EY45pHsPUAOAoyDSTj+bpB3v3T+/g=", - "owner": "haskell", - "repo": "haskell-language-server", - "rev": "6640ebf33eeb8a62ccd094e2f47f69106acfd200", - "type": "github" - }, - "original": { - "dir": "plugins/hls-ormolu-plugin", - "owner": "haskell", - "repo": "haskell-language-server", - "type": "github" - } - }, - "linear-generics": { - "flake": false, - "locked": { - "lastModified": 1679794303, - "narHash": "sha256-2PtZRHVvS0aP2xKV68VE5NmwjK7g/xVIW7gZ0jiulgg=", - "owner": "linear-generics", - "repo": "linear-generics", - "rev": "b3ed84a5c2438f6c000496322a4aa707363c4c7d", - "type": "github" - }, - "original": { - "owner": "linear-generics", - "repo": "linear-generics", - "type": "github" - } - }, - "mission-control": { - "locked": { - "lastModified": 1682001320, - "narHash": "sha256-cXxEhjdJjWw1n8d14+PR8h/i0gLVLG2xq4kw5sJeuxg=", - "owner": "Platonic-Systems", - "repo": "mission-control", - "rev": "c2f3f0a8dce770c46bfa217270ee5592f3a5ebf5", - "type": "github" - }, - "original": { - "owner": "Platonic-Systems", - "repo": "mission-control", - "type": "github" - } - }, "nixpkgs": { "locked": { - "lastModified": 1682109806, - "narHash": "sha256-d9g7RKNShMLboTWwukM+RObDWWpHKaqTYXB48clBWXI=", - "owner": "nixos", - "repo": "nixpkgs", - "rev": "2362848adf8def2866fabbffc50462e929d7fffb", - "type": "github" - }, - "original": { - "owner": "nixos", - "ref": "nixpkgs-unstable", - "repo": "nixpkgs", - "type": "github" - } - }, - "nixpkgs-140774-workaround": { - "locked": { - "lastModified": 1681394207, - "narHash": "sha256-hk9RUPnChwKjCtm/YzixAak5wIzIw+b1avp7I3vg3dQ=", - "owner": "srid", - "repo": "nixpkgs-140774-workaround", - "rev": "a3c6d0622758e5d3da3d63100547f400ce6cb376", - "type": "github" - }, - "original": { - "owner": "srid", - "repo": "nixpkgs-140774-workaround", - "type": "github" - } - }, - "nixpkgs-lib": { - "locked": { - "dir": "lib", - "lastModified": 1680213900, - "narHash": "sha256-cIDr5WZIj3EkKyCgj/6j3HBH4Jj1W296z7HTcWj1aMA=", - "owner": "NixOS", - "repo": "nixpkgs", - "rev": "e3652e0735fbec227f342712f180f4f21f0594f2", - "type": "github" - }, - "original": { - "dir": "lib", - "owner": "NixOS", - "ref": "nixos-unstable", - "repo": "nixpkgs", - "type": "github" - } - }, - "nixpkgs_2": { - "locked": { - "lastModified": 1680945546, - "narHash": "sha256-8FuaH5t/aVi/pR1XxnF0qi4WwMYC+YxlfdsA0V+TEuQ=", + "lastModified": 1694736714, + "narHash": "sha256-5xqXf2CfPiIHg2W7f+6odQ9c09L+jTVqGmxLB6qxPLc=", "owner": "nixos", "repo": "nixpkgs", - "rev": "d9f759f2ea8d265d974a6e1259bd510ac5844c5d", + "rev": "8b1c1ca2feb87ae8b7d9455d8dfe5361f249e4cf", "type": "github" }, "original": { "owner": "nixos", - "ref": "nixos-unstable", + "ref": "haskell-updates", "repo": "nixpkgs", "type": "github" } }, - "nothunks": { - "flake": false, - "locked": { - "lastModified": 1680263759, - "narHash": "sha256-LhEmrkKcUk84PoKmeS4HhZjwTbRbKKEZB0O2hAxLkEQ=", - "owner": "input-output-hk", - "repo": "nothunks", - "rev": "006536813c1bfbd1db8f2755734540e654baca05", - "type": "github" - }, - "original": { - "owner": "input-output-hk", - "repo": "nothunks", - "type": "github" - } - }, "root": { "inputs": { "flake-parts": "flake-parts", "flake-root": "flake-root", "haskell-flake": "haskell-flake", - "hls-floskell-plugin": "hls-floskell-plugin", - "hls-graph": "hls-graph", - "hls-hlint-plugin": "hls-hlint-plugin", - "hls-ormolu-plugin": "hls-ormolu-plugin", - "linear-generics": "linear-generics", - "mission-control": "mission-control", - "nixpkgs": "nixpkgs", - "nixpkgs-140774-workaround": "nixpkgs-140774-workaround", - "nothunks": "nothunks", - "stylish-haskell": "stylish-haskell", - "treefmt-nix": "treefmt-nix" - } - }, - "stylish-haskell": { - "flake": false, - "locked": { - "lastModified": 1678437708, - "narHash": "sha256-XO4HCG1hWwEVr765GjfJwvLOCwICOZ/MkCj1xP2b/w8=", - "owner": "haskell", - "repo": "stylish-haskell", - "rev": "13f1db77f28b62ac6da6abb3c82244d5e740503b", - "type": "github" - }, - "original": { - "owner": "haskell", - "repo": "stylish-haskell", - "type": "github" - } - }, - "treefmt-nix": { - "inputs": { - "nixpkgs": "nixpkgs_2" - }, - "locked": { - "lastModified": 1681486253, - "narHash": "sha256-EjiQZvXQH9tUPCyLC6lQpfGnoq4+kI9v59bDJWPicYo=", - "owner": "numtide", - "repo": "treefmt-nix", - "rev": "b25d1a3c2c7554d0462ab1dfddf2f13128638b90", - "type": "github" - }, - "original": { - "owner": "numtide", - "repo": "treefmt-nix", - "type": "github" + "nixpkgs": "nixpkgs" } } }, diff --git a/flake.nix b/flake.nix index cbac13ae7..3d79ffd0d 100644 --- a/flake.nix +++ b/flake.nix @@ -1,140 +1,71 @@ { inputs = { - nixpkgs.url = "github:nixos/nixpkgs/nixpkgs-unstable"; + nixpkgs.url = "github:nixos/nixpkgs/haskell-updates"; flake-parts.url = "github:hercules-ci/flake-parts"; haskell-flake.url = "github:srid/haskell-flake"; - treefmt-nix.url = "github:numtide/treefmt-nix"; flake-root.url = "github:srid/flake-root"; - mission-control.url = "github:Platonic-Systems/mission-control"; - - linear-generics = { - url = "github:linear-generics/linear-generics"; - flake = false; - }; - - stylish-haskell = { - url = "github:haskell/stylish-haskell"; - flake = false; - }; - - nothunks = { - url = "github:input-output-hk/nothunks"; - flake = false; - }; - - hls-hlint-plugin = { - url = "github:haskell/haskell-language-server?dir=plugins/hls-hlint-plugin"; - flake = false; - }; - hls-floskell-plugin = { - url = "github:haskell/haskell-language-server?dir=plugins/hls-floskell-plugin"; - flake = false; - }; - hls-ormolu-plugin = { - url = "github:haskell/haskell-language-server?dir=plugins/hls-ormolu-plugin"; - flake = false; - }; - hls-graph = { - url = "github:haskell/haskell-language-server?dir=hls-graph"; - flake = false; - }; - nixpkgs-140774-workaround.url = "github:srid/nixpkgs-140774-workaround"; + flake-parts.inputs.nixpkgs-lib.follows = "nixpkgs"; }; outputs = inputs@{ self, nixpkgs, flake-parts, ... }: flake-parts.lib.mkFlake { inherit inputs; } { - systems = [ "x86_64-linux" "x86_64-darwin" "aarch64-darwin" ]; + systems = [ "x86_64-linux" "x86_64-darwin" "aarch64-linux" "aarch64-darwin" ]; imports = [ inputs.haskell-flake.flakeModule inputs.flake-root.flakeModule - inputs.mission-control.flakeModule ]; perSystem = { self', system, lib, config, pkgs, ... }: { # The "main" project. You can have multiple projects, but this template # has only one. - haskellProjects.main = { - # basePackages = pkgs.haskell.packages.ghc927; - # basePackages = pkgs.haskell.packages.ghc944; - imports = [ - inputs.nixpkgs-140774-workaround.haskellFlakeProjectModules.default - ]; - packages.hackage-server.root = ./.; # Auto-discovered by haskell-flake - overrides = self: super: { - Cabal = super.Cabal_3_10_1_0; - Cabal-syntax = super.Cabal-syntax_3_10_1_0; - doctest-parallel = super.doctest-parallel_0_3_0_1; - - ghc-lib-parser = super.ghc-lib-parser_9_4_4_20221225; - ghc-lib-parser-ex = super.ghc-lib-parser-ex_9_4_0_0; - text = super.text_2_0_2; - parsec = self.callHackage "parsec" "3.1.16.1" {}; - - chell = pkgs.haskell.lib.doJailbreak (self.callHackage "chell" "0.5.0.1" {}); - ghc-boot-th = self.callHackage "ghc-boot-th" "9.2.1" {}; - hedgehog = self.callHackage "hedgehog" "1.2" {}; - tasty-hedgehog = self.callHackage "tasty-hedgehog" "1.4.0.0" {}; - optparse-applicative = pkgs.haskell.lib.doJailbreak (super.optparse-applicative_0_15_1_0); - haddock-library = pkgs.haskell.lib.doJailbreak (self.callHackage "haddock-library" "1.11.0" {}); - - th-abstraction = self.callHackage "th-abstraction" "0.4.5.0" {}; - stylish-haskell = super.callCabal2nix "stylish-haskell" inputs.stylish-haskell {}; - - nothunks = super.callCabal2nix "nothunks" inputs.nothunks {}; - - # requirements of HLS - # TODO: fix HLS https://github.com/haskell/haskell-language-server/issues/3518 - ormolu = self.callHackage "ormolu" "0.5.3.0" {}; - fourmolu = pkgs.haskell.lib.dontCheck (self.callHackage "fourmolu" "0.10.1.0" {}); - # hls-floskell-plugin = pkgs.haskell.lib.dontCheck (self.callHackage "hls-floskell-plugin" "1.0.2.0" {}); - # hls-floskell-plugin = self.callCabal2nix "hls-floskell-plugin" inputs.hls-floskell-plugin {}; - # hls-graph = self.callCabal2nix "hls-graph" inputs.hls-graph {}; - # hls-graph = self.callHackage "hls-graph" "1.9.0.0" {}; - # hls-hlint-plugin = self.callCabal2nix "hls-hlint-plugin" inputs.hls-hlint-plugin {}; - # hls-hlint-plugin = self.callHackage "hls-hlint-plugin" "1.1.2.0" {}; - # hls-ormolu-plugin = self.callCabal2nix "hls-ormolu-plugin" inputs.hls-ormolu-plugin {}; - # hls-ormolu-plugin = self.callHackage "hls-ormolu-plugin" "1.0.2.2" {}; - # hls-ormolu-plugin = self.callHackage "hls-ormolu-plugin" "1.0.3.0" {}; - # hls-plugin-api = self.callHackage "hls-plugin-api" "1.6.0.0" {}; - # hls-test-utils = self.callHackage "hls-test-utils" "1.5.0.0" {}; - - hlint = self.callHackage "hlint" "3.5" {}; - - ghcide = pkgs.haskell.lib.dontCheck (self.callHackage "ghcide" "1.9.0.0" {}); + 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; + }; + 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"; }; devShell = { + tools = hp: { + inherit (pkgs) + cabal-install + ghc + + # https://github.com/haskell/hackage-server/pull/1219#issuecomment-1597140858 + # glibc + icu67 + zlib + openssl + # cryptodev + pkg-config + brotli + + gd + libpng + libjpeg + fontconfig + freetype + expat + ; + }; hlsCheck.enable = false; }; }; - - packages.default = pkgs.haskell.lib.dontCheck (self'.packages.main-hackage-server); - - # TODO: fix HLS https://github.com/haskell/haskell-language-server/issues/3518 - # Default shell. - # devShells.default = - # config.mission-control.installToDevShell self'.devShells.main; - devShells.default = pkgs.mkShell { - buildInputs = - with pkgs; - [ cabal-install - ghc - - glibc - icu67 - zlib - openssl - cryptodev - pkg-config - brotli - - gd - libpng - libjpeg - fontconfig - freetype - expat - - ]; - }; }; }; diff --git a/hackage-server.cabal b/hackage-server.cabal index 0f4d53be4..48a6d8ff1 100644 --- a/hackage-server.cabal +++ b/hackage-server.cabal @@ -27,7 +27,14 @@ copyright: 2008-2015 Duncan Coutts, license: BSD-3-Clause license-file: LICENSE -tested-with: GHC == { 9.6.1, 9.4.4, 9.2.7, 9.0.2, 8.10.7, 8.8.4 } +tested-with: + GHC == 9.8.1 + GHC == 9.6.3 + GHC == 9.4.7 + GHC == 9.2.8 + GHC == 9.0.2 + GHC == 8.10.7 + GHC == 8.8.4 data-dir: datafiles data-files: @@ -46,6 +53,17 @@ data-files: TUF/timestamp.private extra-source-files: + tests/golden/ReverseDependenciesTest/getNotificationEmails-NotifyNewVersion.golden + tests/golden/ReverseDependenciesTest/getNotificationEmails-NotifyNewRevision.golden + tests/golden/ReverseDependenciesTest/getNotificationEmails-NotifyMaintainerUpdate-MaintainerAdded.golden + tests/golden/ReverseDependenciesTest/getNotificationEmails-NotifyMaintainerUpdate-MaintainerRemoved.golden + tests/golden/ReverseDependenciesTest/getNotificationEmails-NotifyDocsBuild-success.golden + tests/golden/ReverseDependenciesTest/getNotificationEmails-NotifyDocsBuild-failure.golden + tests/golden/ReverseDependenciesTest/getNotificationEmails-NotifyUpdateTags.golden + tests/golden/ReverseDependenciesTest/getNotificationEmails-NotifyDependencyUpdate-Always.golden + tests/golden/ReverseDependenciesTest/getNotificationEmails-NotifyDependencyUpdate-NewIncompatibility.golden + tests/golden/ReverseDependenciesTest/getNotificationEmails-NotifyDependencyUpdate-BoundsOutOfRange.golden + tests/golden/ReverseDependenciesTest/getNotificationEmails-batched.golden tests/permissions-tarballs/*.tar.gz tests/unpack-checks/correct-package-0.1.0.0/LICENSE tests/unpack-checks/correct-package-0.1.0.0/Main.hs @@ -111,26 +129,26 @@ common defaults -- see `cabal.project.local-ghc-${VERSION}` files build-depends: , array >= 0.5 && < 0.6 - , base >= 4.13 && < 4.19 + , base >= 4.13 && < 4.20 , binary >= 0.8 && < 0.9 - , bytestring >= 0.10 && < 0.12 - , containers ^>= 0.6.0 - , deepseq >= 1.4 && < 1.5 + , 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 , mtl >= 2.2.1 && < 2.4 , pretty >= 1.1 && < 1.2 , process >= 1.6 && < 1.7 - , text ^>= 1.2.5.0 || ^>= 2.0 + , text ^>= 1.2.5.0 || >= 2.0 && < 2.2 , time >= 1.9 && < 1.13 , transformers >= 0.5 && < 0.7 , unix >= 2.7 && < 2.9 , scientific -- other dependencies shared by most components build-depends: - , aeson ^>= 2.0.3.0 || ^>= 2.1.0.0 - , Cabal ^>= 3.10.1.0 - , Cabal-syntax ^>= 3.10.1.0 + , aeson >= 2.1.0.0 && < 2.3 + , Cabal >= 3.10.1.0 && < 3.12 + , Cabal-syntax >= 3.10.1.0 && < 3.12 -- Cabal-syntax needs to be bound to constrain hackage-security -- see https://github.com/haskell/hackage-server/issues/1130 , fail ^>= 4.9.0 @@ -258,6 +276,7 @@ library lib-server Distribution.Server.Util.CountingMap Distribution.Server.Util.CabalRevisions Distribution.Server.Util.DocMeta + Distribution.Server.Util.Email Distribution.Server.Util.Parse Distribution.Server.Util.ServeTarball Distribution.Server.Util.Validators @@ -354,8 +373,9 @@ library lib-server Distribution.Server.Features.Search.TermBag Distribution.Server.Features.Sitemap.Functions Distribution.Server.Features.Votes - Distribution.Server.Features.Votes.State Distribution.Server.Features.Votes.Render + Distribution.Server.Features.Votes.State + Distribution.Server.Features.Vouch Distribution.Server.Features.RecentPackages Distribution.Server.Features.PreferredVersions Distribution.Server.Features.PreferredVersions.State @@ -431,7 +451,7 @@ library lib-server , stm ^>= 2.5.0 , stringsearch ^>= 0.3.6.6 , tagged ^>= 0.8.5 - , xhtml ^>= 3000.2 + , xhtml ^>= 3000.2.0.0 , xmlgen ^>= 0.6 , xss-sanitize ^>= 0.3.6 @@ -546,6 +566,7 @@ test-suite HighLevelTest build-depends: -- version constraints inherited from lib-server , HTTP + , attoparsec-aeson >= 2.1.0.0 && < 2.3 , base64-bytestring , random -- component-specific dependencies @@ -553,18 +574,31 @@ test-suite HighLevelTest , io-streams ^>= 1.5.0.1 , http-io-streams ^>= 0.1.6.1 +test-suite VouchTest + import: test-defaults + type: exitcode-stdio-1.0 + main-is: VouchTest.hs + build-depends: + , tasty ^>= 1.5 + , tasty-hunit ^>= 0.10 + test-suite ReverseDependenciesTest import: test-defaults type: exitcode-stdio-1.0 main-is: ReverseDependenciesTest.hs build-tool-depends: hackage-server:hackage-server build-depends: - , tasty ^>= 1.4 + , tasty ^>= 1.5 + , tasty-golden ^>= 2.3 + , tasty-hedgehog ^>= 1.4 , tasty-hunit ^>= 0.10 , HUnit ^>= 1.6 - , hedgehog ^>= 1.2 + , hedgehog ^>= 1.4 , exceptions , bimap + , mime-mail + , random + , transformers other-modules: RevDepCommon benchmark RevDeps @@ -624,7 +658,7 @@ test-suite PackageTests build-depends: -- version constraints inherited from lib-server -- component-specific dependencies - , tasty ^>= 1.4 + , tasty ^>= 1.5 , tasty-hunit ^>= 0.10 , HUnit ^>= 1.6 @@ -642,7 +676,7 @@ test-suite HashTests , cryptohash-sha256 , safecopy -- component-specific dependencies - , tasty ^>= 1.4 + , tasty ^>= 1.5 , tasty-hunit ^>= 0.10 test-suite DocTests diff --git a/src/Distribution/Server/Features.hs b/src/Distribution/Server/Features.hs index d4eeb8c17..f58bd4dba 100644 --- a/src/Distribution/Server/Features.hs +++ b/src/Distribution/Server/Features.hs @@ -51,6 +51,7 @@ import Distribution.Server.Features.Votes (initVotesFeature) import Distribution.Server.Features.Sitemap (initSitemapFeature) import Distribution.Server.Features.UserNotify (initUserNotifyFeature) import Distribution.Server.Features.PackageFeed (initPackageFeedFeature) +import Distribution.Server.Features.Vouch (initVouchFeature) #endif import Distribution.Server.Features.ServerIntrospect (serverIntrospectFeature) @@ -159,6 +160,8 @@ initHackageFeatures env@ServerEnv{serverVerbosity = verbosity} = do initUserNotifyFeature env mkPackageFeedFeature <- logStartup "package feed" $ initPackageFeedFeature env + mkVouchFeature <- logStartup "vouch" $ + initVouchFeature env mkBrowseFeature <- logStartup "browse" $ initBrowseFeature env mkPackageJSONFeature <- logStartup "package info JSON" $ @@ -344,6 +347,10 @@ initHackageFeatures env@ServerEnv{serverVerbosity = verbosity} = do tagsFeature tarIndexCacheFeature + vouchFeature <- mkVouchFeature + usersFeature + uploadFeature + userNotifyFeature <- mkUserNotifyFeature usersFeature coreFeature @@ -353,6 +360,7 @@ initHackageFeatures env@ServerEnv{serverVerbosity = verbosity} = do reportsCoreFeature tagsFeature reverseFeature + vouchFeature packageFeedFeature <- mkPackageFeedFeature coreFeature @@ -415,6 +423,7 @@ initHackageFeatures env@ServerEnv{serverVerbosity = verbosity} = do , getFeatureInterface userNotifyFeature , getFeatureInterface packageFeedFeature , getFeatureInterface packageInfoJSONFeature + , getFeatureInterface vouchFeature #endif , staticFilesFeature , serverIntrospectFeature allFeatures diff --git a/src/Distribution/Server/Features/Browse.hs b/src/Distribution/Server/Features/Browse.hs index 0ff354f3b..9b53e01b3 100644 --- a/src/Distribution/Server/Features/Browse.hs +++ b/src/Distribution/Server/Features/Browse.hs @@ -139,7 +139,7 @@ packageIndexInfoToValue :: CoreResource -> TagsResource -> UserResource -> Packa packageIndexInfoToValue coreResource tagsResource userResource PackageItem{itemName, itemDownloads, itemVotes, - itemDesc, itemTags, itemLastUpload, itemLastVersion, itemMaintainer} = + itemDesc, itemTags, itemLastUpload, itemReferenceVersion, itemMaintainer} = object [ Key.fromString "name" .= renderPackage itemName , Key.fromString "downloads" .= itemDownloads @@ -147,7 +147,7 @@ packageIndexInfoToValue , Key.fromString "description" .= itemDesc , Key.fromString "tags" .= map renderTag (S.toAscList itemTags) , Key.fromString "lastUpload" .= iso8601Show itemLastUpload - , Key.fromString "lastVersion" .= itemLastVersion + , Key.fromString "referenceVersion" .= itemReferenceVersion , Key.fromString "maintainers" .= map renderUser itemMaintainer ] where diff --git a/src/Distribution/Server/Features/Browse/ApplyFilter.hs b/src/Distribution/Server/Features/Browse/ApplyFilter.hs index c86082fc8..f129109fb 100644 --- a/src/Distribution/Server/Features/Browse/ApplyFilter.hs +++ b/src/Distribution/Server/Features/Browse/ApplyFilter.hs @@ -63,7 +63,7 @@ sort isSearch sortColumn sortDirection = Description -> comparing itemDesc Tags -> comparing (S.toAscList . itemTags) LastUpload -> comparing itemLastUpload - LastVersion -> comparing itemLastVersion + ReferenceVersion -> comparing itemReferenceVersion Maintainers -> comparing itemMaintainer in sortBy (maybeReverse comparer) where diff --git a/src/Distribution/Server/Features/Browse/Options.hs b/src/Distribution/Server/Features/Browse/Options.hs index dd93401ef..64416b355 100644 --- a/src/Distribution/Server/Features/Browse/Options.hs +++ b/src/Distribution/Server/Features/Browse/Options.hs @@ -9,7 +9,7 @@ import Distribution.Server.Features.Browse.Parsers (Filter, conditions, condsToF data IsSearch = IsSearch | IsNotSearch -data NormalColumn = Name | Downloads | Rating | Description | Tags | LastUpload | LastVersion | Maintainers +data NormalColumn = Name | Downloads | Rating | Description | Tags | LastUpload | ReferenceVersion | Maintainers deriving (Show, Eq) data Column = DefaultColumn | NormalColumn NormalColumn @@ -36,7 +36,7 @@ instance FromJSON Column where "description" -> pure $ NormalColumn Description "tags" -> pure $ NormalColumn Tags "lastUpload" -> pure $ NormalColumn LastUpload - "lastVersion" -> pure $ NormalColumn LastVersion + "referenceVersion" -> pure $ NormalColumn ReferenceVersion "maintainers" -> pure $ NormalColumn Maintainers t -> fail $ "Column invalid: " ++ T.unpack t @@ -49,7 +49,7 @@ columnToTemplateName = \case NormalColumn Description -> "description" NormalColumn Tags -> "tags" NormalColumn LastUpload -> "lastUpload" - NormalColumn LastVersion -> "lastVersion" + NormalColumn ReferenceVersion -> "referenceVersion" NormalColumn Maintainers -> "maintainers" instance FromJSON Direction where diff --git a/src/Distribution/Server/Features/Core.hs b/src/Distribution/Server/Features/Core.hs index 6aec793ab..916b1e4ac 100644 --- a/src/Distribution/Server/Features/Core.hs +++ b/src/Distribution/Server/Features/Core.hs @@ -24,7 +24,7 @@ module Distribution.Server.Features.Core ( -- stdlib import qualified Codec.Compression.GZip as GZip -import Data.Aeson (Value (..)) +import Data.Aeson (Value (..), toJSON) import qualified Data.Aeson.Key as Key import qualified Data.Aeson.KeyMap as KeyMap import Data.ByteString.Lazy (ByteString) @@ -40,6 +40,7 @@ import Distribution.Server.Prelude import Distribution.Server.Features.Core.Backup import Distribution.Server.Features.Core.State import Distribution.Server.Features.Security.Migration +import Distribution.Server.Features.Security.SHA256 (sha256) import Distribution.Server.Features.Users import Distribution.Server.Framework import qualified Distribution.Server.Framework.BlobStorage as BlobStorage @@ -225,6 +226,7 @@ data CoreResource = CoreResource { corePackageTarball :: Resource, -- | A Cabal file metatada revision. coreCabalFileRev :: Resource, + coreCabalFileRevName :: Resource, -- Rendering resources. -- | URI for `corePackagesPage`, given a format (blank for none). @@ -403,6 +405,7 @@ coreFeature ServerEnv{serverBlobStore = store} UserFeature{..} , coreCabalFile , coreCabalFileRevs , coreCabalFileRev + , coreCabalFileRevName , coreUserDeauth , coreAdminDeauth , corePackUserDeauth @@ -456,6 +459,11 @@ coreFeature ServerEnv{serverBlobStore = store} UserFeature{..} resourceDesc = [(GET, "Get package .cabal file revision")] , resourceGet = [("cabal", serveCabalFileRevision)] } + coreCabalFileRevName = (resourceAt "/package/:package/revision/:tarball-:revision.:format") { + resourceDesc = [(GET, "Get package .cabal file revision with name")] + , resourceGet = [("cabal", serveCabalFileRevisionName)] + } + coreUserDeauth = (resourceAt "/packages/deauth") { resourceDesc = [(GET, "Deauth Package user")] @@ -728,12 +736,15 @@ coreFeature ServerEnv{serverBlobStore = store} UserFeature{..} pkginfo <- packageInPath dpath >>= lookupPackageId users <- queryGetUserDb let revisions = pkgMetadataRevisions pkginfo - revisionToObj rev (_, (utime, uid)) = - let uname = userIdToName users uid in + revisionToObj rev (cabalFileText, (utime, uid)) = + let uname = userIdToName users uid + hash = sha256 (cabalFileByteString cabalFileText) + in Object $ KeyMap.fromList [ (Key.fromString "number", Number (fromIntegral rev)) , (Key.fromString "user", String (Text.pack (display uname))) , (Key.fromString "time", String (Text.pack (formatTime defaultTimeLocale "%Y-%m-%dT%H:%M:%SZ" utime))) + , (Key.fromString "sha256", toJSON hash) ] revisionsJson = Array $ Vec.imap revisionToObj revisions return (toResponse revisionsJson) @@ -750,6 +761,21 @@ coreFeature ServerEnv{serverBlobStore = store} UserFeature{..} Nothing -> errNotFound "Package revision not found" [MText "Cannot parse revision, or revision out of range."] + serveCabalFileRevisionName :: DynamicPath -> ServerPartE Response + serveCabalFileRevisionName dpath = do + pkgid1 <- packageTarballInPath dpath + pkgid2 <- packageInPath dpath + guard (pkgVersion pkgid2 == pkgVersion pkgid2) + pkginfo <- packageInPath dpath >>= lookupPackageId + let mrev = lookup "revision" dpath >>= fromReqURI + revisions = pkgMetadataRevisions pkginfo + case mrev >>= \rev -> revisions Vec.!? rev of + Just (fileRev, (utime, _uid)) -> return $ toResponse cabalfile + where + cabalfile = Resource.CabalFile (cabalFileByteString fileRev) utime + Nothing -> errNotFound "Package revision not found" + [MText "Cannot parse revision, or revision out of range."] + deauth :: DynamicPath -> ServerPartE Response deauth _ = do diff --git a/src/Distribution/Server/Features/Html/HtmlUtilities.hs b/src/Distribution/Server/Features/Html/HtmlUtilities.hs index d0fd2f44f..298810ff0 100644 --- a/src/Distribution/Server/Features/Html/HtmlUtilities.hs +++ b/src/Distribution/Server/Features/Html/HtmlUtilities.hs @@ -52,7 +52,7 @@ htmlUtilities CoreFeature{coreResource} , td $ toHtml $ itemDesc item , td $ " (" +++ renderTags (itemTags item) +++ ")" , td $ toHtml $ formatTime defaultTimeLocale "%F" (itemLastUpload item) - , td $ toHtml $ itemLastVersion item + , td $ toHtml $ itemReferenceVersion item , td $ "" +++ intersperse (toHtml ", ") (map renderUser (itemMaintainer item)) ] where diff --git a/src/Distribution/Server/Features/PackageList.hs b/src/Distribution/Server/Features/PackageList.hs index 57b1c1b8a..d2b063c29 100644 --- a/src/Distribution/Server/Features/PackageList.hs +++ b/src/Distribution/Server/Features/PackageList.hs @@ -29,6 +29,7 @@ import Distribution.Package import Distribution.PackageDescription import Distribution.PackageDescription.Configuration import Distribution.Pretty (prettyShow) +import Distribution.Types.Version (Version) import Distribution.Utils.ShortText (fromShortText) import Control.Concurrent @@ -89,8 +90,8 @@ data PackageItem = PackageItem { itemLastUpload :: !UTCTime, -- Hotness = recent downloads + stars + 2 * no rev deps itemHotness :: !Float, - -- Last version - itemLastVersion :: !String + -- Reference version (non-deprecated highest numbered version) + itemReferenceVersion :: !String } instance MemSize PackageItem where @@ -98,8 +99,24 @@ instance MemSize PackageItem where emptyPackageItem :: PackageName -> PackageItem -emptyPackageItem pkg = PackageItem pkg Set.empty Nothing "" [] - 0 0 0 False 0 0 0 (UTCTime (toEnum 0) 0) 0 "" +emptyPackageItem pkg = + PackageItem { + itemName = pkg, + itemTags = Set.empty, + itemDeprecated = Nothing, + itemDesc = "", + itemMaintainer = [], + itemVotes = 0, + itemDownloads = 0, + itemRevDepsCount = 0, + itemHasLibrary = False, + itemNumExecutables = 0, + itemNumTests = 0, + itemNumBenchmarks = 0, + itemLastUpload = UTCTime (toEnum 0) 0, + itemHotness = 0, + itemReferenceVersion = "" + } initListFeature :: ServerEnv @@ -134,10 +151,14 @@ initListFeature _env = do registerHookJust packageChangeHook isPackageAdd $ \pkg -> do let pkgname = packageName . packageId $ pkg - modifyItem pkgname $ \x -> x - {itemLastUpload = fst (pkgOriginalUploadInfo pkg) - ,itemLastVersion = prettyShow $ pkgVersion $ pkgInfoId pkg - } + prefsinfo <- queryGetPreferredInfo pkgname + index <- queryGetPackageIndex + let allVersions = packageVersion <$> PackageIndex.lookupPackageName index pkgname + modifyItem pkgname $ \x -> + updateReferenceVersion prefsinfo allVersions $ + x + { itemLastUpload = fst (pkgOriginalUploadInfo pkg) + } runHook_ itemUpdate (Set.singleton pkgname) registerHook groupChangedHook $ \(gd,_,_,_,_) -> @@ -174,6 +195,11 @@ initListFeature _env = do modifyItem pkgname (updateDeprecation mpkgs) runHook_ itemUpdate (Set.singleton pkgname) + registerHook updatePreferredHook $ \(pkgname, prefsinfo) -> do + index <- queryGetPackageIndex + let allVersions = packageVersion <$> PackageIndex.lookupPackageName index pkgname + modifyItem pkgname $ updateReferenceVersion prefsinfo allVersions + return feature @@ -265,8 +291,9 @@ listFeature CoreFeature{..} votes <- pkgNumScore pkgname deprs <- queryGetDeprecatedFor pkgname maintainers <- queryUserGroup (maintainersGroup pkgname) + prefsinfo <- queryGetPreferredInfo pkgname - return $ (,) pkgname $ (updateDescriptionItem desc $ emptyPackageItem pkgname) { + return $ (,) pkgname . updateReferenceVersion prefsinfo [pkgVersion (pkgInfoId pkg)] $ (updateDescriptionItem desc $ emptyPackageItem pkgname) { itemTags = tags , itemMaintainer = map (userIdToName users) (UserIdSet.toList maintainers) , itemDeprecated = deprs @@ -275,7 +302,6 @@ listFeature CoreFeature{..} , itemLastUpload = fst (pkgOriginalUploadInfo pkg) , itemRevDepsCount = intRevDirectCount , itemHotness = votes + fromIntegral (cmFind pkgname downs) + fromIntegral intRevDirectCount * 2 - , itemLastVersion = prettyShow $ pkgVersion $ pkgInfoId pkg } ------------------------------ @@ -329,6 +355,17 @@ updateDeprecation pkgs item = itemDeprecated = pkgs } +updateReferenceVersion :: PreferredInfo -> [Version] -> PackageItem -> PackageItem +updateReferenceVersion prefsinfo allVersions item = + item { + itemReferenceVersion = + case nonDeprecatedVersion of + [] -> "" + xs -> prettyShow $ maximum xs + } + where + nonDeprecatedVersion = filter (`notElem` deprecatedVersions prefsinfo) allVersions + updateReverseItem :: Int -> PackageItem -> PackageItem updateReverseItem revDirectCount item = item { diff --git a/src/Distribution/Server/Features/PreferredVersions.hs b/src/Distribution/Server/Features/PreferredVersions.hs index 78c5ddeac..6097afa0c 100644 --- a/src/Distribution/Server/Features/PreferredVersions.hs +++ b/src/Distribution/Server/Features/PreferredVersions.hs @@ -55,6 +55,7 @@ data VersionsFeature = VersionsFeature { versionsResource :: VersionsResource, deprecatedHook :: Hook (PackageName, Maybe [PackageName]) (), putDeprecated :: PackageName -> ServerPartE Bool, + updatePreferredHook :: Hook (PackageName, PreferredInfo) (), putPreferred :: PackageName -> ServerPartE (), updateDeprecatedTags :: IO (), @@ -101,12 +102,14 @@ initVersionsFeature :: ServerEnv initVersionsFeature env@ServerEnv{serverStateDir} = do preferredState <- preferredStateComponent False serverStateDir deprecatedHook <- newHook + updatePreferredHook <- newHook return $ \core upload tags user -> do let feature = versionsFeature env core upload tags user preferredState deprecatedHook + updatePreferredHook return feature preferredStateComponent :: Bool -> FilePath -> IO (StateComponent AcidState PreferredVersions) @@ -130,6 +133,7 @@ versionsFeature :: ServerEnv -> UserFeature -> StateComponent AcidState PreferredVersions -> Hook (PackageName, Maybe [PackageName]) () + -> Hook (PackageName, PreferredInfo) () -> VersionsFeature versionsFeature ServerEnv{ serverVerbosity = verbosity } CoreFeature{..} @@ -138,6 +142,7 @@ versionsFeature ServerEnv{ serverVerbosity = verbosity } UserFeature{ guardAuthorised_ } preferredState deprecatedHook + updatePreferredHook = VersionsFeature{..} where versionsFeatureInterface = (emptyHackageFeature "versions") { @@ -315,6 +320,7 @@ versionsFeature ServerEnv{ serverVerbosity = verbosity } (prefs, deprs) <- lookPrefRangeDeprecatedVersions pkgs prefinfo <- updateState preferredState (SetPreferredInfo pkgname prefs deprs) + runHook_ updatePreferredHook (pkgname, prefinfo { deprecatedVersions = deprs }) -- It seems they are not set updateIndexPackagePreferredVersions pkgname prefinfo where lookPrefRangeDeprecatedVersions pkgs = do diff --git a/src/Distribution/Server/Features/UserNotify.hs b/src/Distribution/Server/Features/UserNotify.hs index 34c066371..2d0289a20 100644 --- a/src/Distribution/Server/Features/UserNotify.hs +++ b/src/Distribution/Server/Features/UserNotify.hs @@ -2,20 +2,26 @@ TypeFamilies, TemplateHaskell, RankNTypes, NamedFieldPuns, RecordWildCards, BangPatterns, DefaultSignatures, OverloadedStrings #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-} module Distribution.Server.Features.UserNotify ( NotifyData(..), NotifyPref(..), - NotifyRevisionRange, + NotifyRevisionRange(..), NotifyTriggerBounds(..), UserNotifyFeature(..), defaultNotifyPrefs, - dependencyReleaseEmails, + getUserNotificationsOnRelease, importNotifyPref, initUserNotifyFeature, notifyDataToCSV, + + -- * getNotificationEmails + Notification(..), + NotifyMaintainerUpdateType(..), + getNotificationEmails, ) where import Prelude hiding (lookup) @@ -46,8 +52,13 @@ import Distribution.Server.Features.Tags import Distribution.Server.Features.Upload import Distribution.Server.Features.UserDetails import Distribution.Server.Features.Users +import Distribution.Server.Features.Vouch + +import Distribution.Server.Util.Email +import Data.Map (Map) import qualified Data.Map as Map +import Data.Set (Set) import qualified Data.Set as Set import Control.Concurrent (threadDelay) @@ -58,26 +69,27 @@ import Data.Bifunctor (Bifunctor(second)) import Data.Bimap (lookup, lookupR) import Data.Graph (Vertex) import Data.Hashable (Hashable(..)) -import Data.List (maximumBy, sortBy) -import Data.List (intercalate) +import Data.List (maximumBy, sortOn) import Data.Maybe (fromJust, fromMaybe, listToMaybe, mapMaybe, maybeToList) -import Data.Ord (comparing) +import Data.Ord (Down(..), comparing) import Data.SafeCopy (Migrate(migrate), MigrateFrom, base, deriveSafeCopy, extension) import Data.Time (UTCTime(..), addUTCTime, defaultTimeLocale, diffUTCTime, formatTime, getCurrentTime) import Data.Time.Format.Internal (buildTime) import Data.Typeable (Typeable) import Distribution.Text (display) import Network.Mail.Mime -import Network.URI(uriAuthority, uriRegName, uriToString) +import Network.URI (uriAuthority, uriPath, uriRegName) import Text.CSV (CSV, Record) import Text.PrettyPrint hiding ((<>)) import Text.XHtml hiding (base, text, ()) import qualified Data.Aeson as Aeson import qualified Data.Aeson.Types as Aeson -import qualified Data.ByteString.Char8 as BSS import qualified Data.ByteString.Lazy.Char8 as BS +import Data.Text (Text) import qualified Data.Text as T +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.Encoding as TL import qualified Data.Vector as Vec -- A feature to manage notifications to users when package metadata, etc is updated. @@ -426,6 +438,7 @@ initUserNotifyFeature :: ServerEnv -> ReportsFeature -> TagsFeature -> ReverseFeature + -> VouchFeature -> IO UserNotifyFeature) initUserNotifyFeature env@ServerEnv{ serverStateDir, serverTemplatesDir, serverTemplatesMode } = do @@ -437,32 +450,34 @@ initUserNotifyFeature env@ServerEnv{ serverStateDir, serverTemplatesDir, [serverTemplatesDir, serverTemplatesDir "UserNotify"] [ "user-notify-form.html" ] - return $ \users core uploadfeature adminlog userdetails reports tags revers -> do + return $ \users core uploadfeature adminlog userdetails reports tags revers vouch -> do let feature = userNotifyFeature env users core uploadfeature adminlog userdetails reports tags - revers notifyState templates + revers vouch notifyState templates return feature data InRange = InRange | OutOfRange --- | Get the release notification emails when a new package has been released. --- The new package (PackageIdentifier) must already be in the indexes. --- The keys in the returned map are the new packages. The values are the revDeps. -dependencyReleaseEmails +-- | Get the users to notify when a new package has been released. +-- The new package (PackageId) must already be in the indexes. +-- The keys in the returned map are the user to notify, and the values are +-- the packages the user maintains that depend on the new package (i.e. the +-- reverse dependencies of the new package). +getUserNotificationsOnRelease :: forall m. Monad m => (PackageName -> m UserIdSet) -> PackageIndex.PackageIndex PkgInfo -> ReverseIndex -> (UserId -> m (Maybe NotifyPref)) - -> PackageIdentifier - -> m (Map.Map (UserId, PackageId) [PackageId]) -dependencyReleaseEmails _ index _ _ pkgId + -> PackageId + -> m (Map.Map UserId [PackageId]) +getUserNotificationsOnRelease _ index _ _ pkgId | let versionsForNewRelease = packageVersion <$> PackageIndex.lookupPackageName index (pkgName pkgId) , pkgVersion pkgId /= maximum versionsForNewRelease -- If e.g. a minor bugfix release is made for an old release series, never notify maintainers. -- Only start checking if the new version is the highest. = pure mempty -dependencyReleaseEmails userSetIdForPackage index (ReverseIndex revs nodemap dependencies) queryGetUserNotifyPref pkgId = +getUserNotificationsOnRelease userSetIdForPackage index (ReverseIndex revs nodemap dependencies) queryGetUserNotifyPref pkgId = case lookup (pkgName pkgId) nodemap :: Maybe NodeId of Nothing -> pure mempty Just foundPackage -> do @@ -473,8 +488,8 @@ dependencyReleaseEmails userSetIdForPackage index (ReverseIndex revs nodemap dep revDepNames = mapMaybe (`lookupR` nodemap) (Set.toList vertices) toNotify <- traverse maintainersToNotify revDepNames pure $ - Map.fromList - [ ( (maintainerId, pkgId), [ packageId latestRevDep ] ) + Map.fromListWith (++) + [ (maintainerId, [packageId latestRevDep]) | (ids, latestRevDep) <- toNotify , maintainerId <- ids ] @@ -505,7 +520,7 @@ dependencyReleaseEmails userSetIdForPackage index (ReverseIndex revs nodemap dep case notifyDependencyTriggerBounds of NewIncompatibility -> do let allNewUploadPkgInfos = PackageIndex.lookupPackageName index (pkgName pkgId) - sortedByVersionDesc = sortBy (flip $ comparing packageVersion) allNewUploadPkgInfos + sortedByVersionDesc = sortOn (Down . packageVersion) allNewUploadPkgInfos mSecondHighest = case sortedByVersionDesc of _:b:_ -> Just b @@ -569,18 +584,20 @@ userNotifyFeature :: ServerEnv -> ReportsFeature -> TagsFeature -> ReverseFeature + -> VouchFeature -> StateComponent AcidState NotifyData -> Templates -> UserNotifyFeature -userNotifyFeature ServerEnv{serverBaseURI, serverCron} +userNotifyFeature serverEnv@ServerEnv{serverCron} UserFeature{..} CoreFeature{..} UploadFeature{..} AdminLogFeature{..} - UserDetailsFeature{..} + userDetailsFeature@UserDetailsFeature{..} ReportsFeature{..} TagsFeature{..} ReverseFeature{queryReverseIndex} + VouchFeature{drainQueuedNotifications} notifyState templates = UserNotifyFeature {..} @@ -681,75 +698,37 @@ userNotifyFeature ServerEnv{serverBaseURI, serverCron} users <- queryGetUserDb revisionsAndUploads <- collectRevisionsAndUploads trimLastTime now - revisionUploadNotifications <- foldM (genRevUploadList notifyPrefs) Map.empty revisionsAndUploads - let revisionUploadEmails = map (describeRevision users trimLastTime now) <$> revisionUploadNotifications + revisionUploadNotifications <- concatMapM (genRevUploadList notifyPrefs trimLastTime now) revisionsAndUploads groupActions <- collectAdminActions trimLastTime now - groupActionNotifications <- foldM (genGroupUploadList notifyPrefs) Map.empty groupActions - let groupActionEmails = mapMaybe (describeGroupAction users) <$> groupActionNotifications + groupActionNotifications <- concatMapM (genGroupUploadList notifyPrefs) groupActions docReports <- collectDocReport trimLastTime now - docReportNotifications <- foldM (genDocReportList notifyPrefs) Map.empty docReports - let docReportEmails = map describeDocReport <$> docReportNotifications + docReportNotifications <- concatMapM (genDocReportList notifyPrefs) docReports tagProposals <- collectTagProposals - tagProposalNotifications <- foldM (genTagProposalList notifyPrefs) Map.empty tagProposals - let tagProposalEmails = map describeTagProposal <$> tagProposalNotifications + tagProposalNotifications <- concatMapM (genTagProposalList notifyPrefs) tagProposals idx <- queryGetPackageIndex revIdx <- liftIO queryReverseIndex - let - genEmails :: PackageIdentifier -> IO (Map.Map (UserId, PackageId) [PackageId]) - genEmails = - dependencyReleaseEmails (queryUserGroup . maintainersGroup) idx revIdx queryGetUserNotifyPref - dependencyEmailMaps <- traverse (genEmails . pkgInfoToPkgId) revisionsAndUploads - let - dependencyEmailMap :: Map.Map (UserId, PackageId) [PackageId] - dependencyEmailMap = Map.unionsWith (++) dependencyEmailMaps - emailText :: MonadIO m => (UserId, PackageId) -> [PackageId] -> m [String] - emailText (uId, dep) revDeps = do - mPrefs <- queryGetUserNotifyPref uId - pure $ - case mPrefs of - Nothing -> [] - Just NotifyPref{notifyDependencyTriggerBounds} -> - [ "The dependency " <> display dep <> " has been updated." - ] ++ - case notifyDependencyTriggerBounds of - Always -> - [ "You have requested to be notified for each upload/revision of a dependency. \ - \These are your packages that depend on " <> display dep <> ":" - ] - outOfRangeOption -> - [ "You have requested to be notified when a dependency isn't accepted by any of \ - \your maintained packages." - ] ++ - case outOfRangeOption of - NewIncompatibility -> - [ "The following packages did accept the second highest version of " - <> display (packageName dep) <> "." - ] - _ -> - [] - ++ - [ "These are your packages that require " <> display (packageName dep) <> " but don't accept " <> display (packageVersion dep) <> ":" - ] - ++ map display revDeps - dependencyEmailTextMaps <- Map.mapKeys fst <$> Map.traverseWithKey emailText dependencyEmailMap - - -- Concat the constituent email parts such that only one email is sent per user - mapM_ (sendNotifyEmailAndDelay users) . Map.toList $ foldr1 (Map.unionWith (++)) $ [revisionUploadEmails, groupActionEmails, docReportEmails, tagProposalEmails] - - -- Dependency email notifications consist of multiple paragraphs, so it would be confusing if concatenated. - -- So they're sent independently. - mapM_ (sendNotifyEmailAndDelay users) . Map.toList $ dependencyEmailTextMaps + dependencyUpdateNotifications <- concatMapM (genDependencyUpdateList notifyPrefs idx revIdx . pkgInfoToPkgId) revisionsAndUploads + + vouchNotifications <- fmap (, NotifyVouchingCompleted) <$> drainQueuedNotifications + + emails <- + getNotificationEmails serverEnv userDetailsFeature users $ + concat + [ revisionUploadNotifications + , groupActionNotifications + , docReportNotifications + , tagProposalNotifications + , dependencyUpdateNotifications + , vouchNotifications + ] + mapM_ sendNotifyEmailAndDelay emails updateState notifyState (SetNotifyTime now) - formatTimeUser users t u = - display (Users.userIdToName users u) ++ " [" ++ - (formatTime defaultTimeLocale "%c" t) ++ "]" - collectRevisionsAndUploads earlier now = do pkgIndex <- queryGetPackageIndex let isRecent pkgInfo = @@ -780,122 +759,373 @@ userNotifyFeature ServerEnv{serverBaseURI, serverCron} writeMemState tagProposalLog Map.empty pure $ Map.toList logs - genRevUploadList notifyPrefs mp pkg = do + genRevUploadList notifyPrefs earlier now pkg = do pkgIndex <- queryGetPackageIndex let actor = pkgLatestUploadUser pkg isRevision = pkgNumRevisions pkg > 1 pkgName = packageName . pkgInfoId $ pkg mbLatest = listToMaybe . take 1 . reverse $ PackageIndex.lookupPackageName pkgIndex pkgName isLatestVersion = maybe False (\x -> pkgInfoId pkg == pkgInfoId x) mbLatest - addNotification uid m = - if not (notifyOptOut npref) && - (isRevision && - ( notifyRevisionRange npref == NotifyAllVersions || - ((notifyRevisionRange npref == NotifyNewestVersion) && isLatestVersion)) - || - not isRevision && notifyUpload npref) - then Map.insertWith (++) uid [pkg] m - else m - where npref = fromMaybe defaultNotifyPrefs (Map.lookup uid notifyPrefs) maintainers <- queryUserGroup $ maintainersGroup (packageName . pkgInfoId $ pkg) - return $ foldr addNotification mp (toList (delete actor maintainers)) - - genGroupUploadList notifyPrefs mp ga = - let (actor,gdesc) = case ga of (_,uid,Admin_GroupAddUser _ gd,_) -> (uid, gd) - (_,uid,Admin_GroupDelUser _ gd,_) -> (uid, gd) - addNotification uid m = if not (notifyOptOut npref) && notifyMaintainerGroup npref - then Map.insertWith (++) uid [ga] m - else m - where npref = fromMaybe defaultNotifyPrefs (Map.lookup uid notifyPrefs) - in case gdesc of - (MaintainerGroup pkg) -> do - maintainers <- queryUserGroup $ maintainersGroup (mkPackageName $ BS.unpack pkg) - return $ foldr addNotification mp (toList (delete actor maintainers)) - _ -> return mp - - genDocReportList notifyPrefs mp pkgDoc = do - let addNotification uid m = - if not (notifyOptOut npref) && notifyDocBuilderReport npref - then Map.insertWith (++) uid [pkgDoc] m - else m - where npref = fromMaybe defaultNotifyPrefs (Map.lookup uid notifyPrefs) - maintainers <- queryUserGroup $ maintainersGroup (packageName . pkgInfoId . fst $ pkgDoc) - return $ foldr addNotification mp (toList maintainers) - - genTagProposalList notifyPrefs mp pkgTags = do - let addNotification uid m = - if not (notifyOptOut npref) && notifyPendingTags npref - then Map.insertWith (++) uid [pkgTags] m - else m - where npref = fromMaybe defaultNotifyPrefs (Map.lookup uid notifyPrefs) - maintainers <- queryUserGroup $ maintainersGroup (fst pkgTags) - return $ foldr addNotification mp (toList maintainers) - - describeRevision users earlier now pkg = - if pkgNumRevisions pkg <= 1 - then "Package upload, " ++ display (packageName pkg) ++ ", by " ++ - formatTimeUser users (pkgLatestUploadTime pkg) (pkgLatestUploadUser pkg) - else "Package metadata revision(s), " ++ display (packageName pkg) ++ ":\n" ++ - unlines (map (uncurry (formatTimeUser users) . snd) recentRevs) - where - revs = reverse $ Vec.toList (pkgMetadataRevisions pkg) - recentRevs = filter ((\x -> x > earlier && x <= now) . fst . snd) revs - - describeGroupAction users (time, uid, act, descr) = - case act of - (Admin_GroupAddUser tn (MaintainerGroup pkg)) -> Just $ - "Group modified by " ++ formatTimeUser users time uid ++ ":\n" ++ - display (Users.userIdToName users tn) ++ " added to maintainers for " ++ BS.unpack pkg ++ - "\n" ++ "reason: " ++ BS.unpack descr - (Admin_GroupDelUser tn (MaintainerGroup pkg)) -> Just $ - "Group modified by " ++ formatTimeUser users time uid ++ ":\n" ++ - display (Users.userIdToName users tn) ++ " removed from maintainers for " ++ BS.unpack pkg ++ - "\n" ++ "reason: " ++ BS.unpack descr - _ -> Nothing - - describeDocReport (pkg, doc) = - "Package doc build for " ++ display (packageName pkg) ++ ":\n" ++ - if doc - then "Build successful." - else "Build failed." - - describeTagProposal (pkgName, (addTags, delTags)) = - "Pending tag propasal for " ++ display pkgName ++ ":\n" ++ - "Addition: " ++ showTags addTags ++ "\n" ++ - "Deletion: " ++ showTags delTags + pure . flip mapMaybe (toList maintainers) $ \uid -> + fmap (uid,) $ do + let NotifyPref{..} = fromMaybe defaultNotifyPrefs (Map.lookup uid notifyPrefs) + guard $ uid /= actor + guard $ not notifyOptOut + if isRevision + then do + guard $ + notifyRevisionRange == NotifyAllVersions || + (notifyRevisionRange == NotifyNewestVersion && isLatestVersion) + Just + NotifyNewRevision + { notifyPackageId = pkgInfoId pkg + , notifyRevisions = + filter (\(t, _) -> earlier < t && t <= now) + . map snd + . Vec.toList + $ pkgMetadataRevisions pkg + } + else do + guard notifyUpload + Just + NotifyNewVersion + { notifyPackageInfo = pkg + } + + genGroupUploadList notifyPrefs groupAction = + let notifyAllMaintainers actor pkg notif = do + maintainers <- queryUserGroup $ maintainersGroup (mkPackageName $ BS.unpack pkg) + pure . flip mapMaybe (toList maintainers) $ \uid -> do + let NotifyPref{..} = fromMaybe defaultNotifyPrefs (Map.lookup uid notifyPrefs) + guard $ uid /= actor + guard $ not notifyOptOut + Just (uid, notif) + in case groupAction of + (time, userActor, Admin_GroupAddUser userSubject (MaintainerGroup pkg), reason) -> + notifyAllMaintainers userActor pkg $ + NotifyMaintainerUpdate + { notifyMaintainerUpdateType = MaintainerAdded + , notifyUserActor = userActor + , notifyUserSubject = userSubject + , notifyPackageName = mkPackageName $ BS.unpack pkg + , notifyReason = TL.toStrict $ TL.decodeUtf8 reason + , notifyUpdatedAt = time + } + (time, userActor, Admin_GroupDelUser userSubject (MaintainerGroup pkg), reason) -> + notifyAllMaintainers userActor pkg $ + NotifyMaintainerUpdate + { notifyMaintainerUpdateType = MaintainerRemoved + , notifyUserActor = userActor + , notifyUserSubject = userSubject + , notifyPackageName = mkPackageName $ BS.unpack pkg + , notifyReason = TL.toStrict $ TL.decodeUtf8 reason + , notifyUpdatedAt = time + } + _ -> pure [] + + genDocReportList notifyPrefs (pkg, success) = do + maintainers <- queryUserGroup $ maintainersGroup (packageName $ pkgInfoId pkg) + pure . flip mapMaybe (toList maintainers) $ \uid -> + fmap (uid,) $ do + let NotifyPref{..} = fromMaybe defaultNotifyPrefs (Map.lookup uid notifyPrefs) + guard $ not notifyOptOut + guard notifyDocBuilderReport + Just + NotifyDocsBuild + { notifyPackageId = pkgInfoId pkg + , notifyBuildSuccess = success + } + + genTagProposalList notifyPrefs (pkg, (addedTags, deletedTags)) = do + maintainers <- queryUserGroup $ maintainersGroup pkg + pure . flip mapMaybe (toList maintainers) $ \uid -> + fmap (uid,) $ do + let NotifyPref{..} = fromMaybe defaultNotifyPrefs (Map.lookup uid notifyPrefs) + guard $ not notifyOptOut + guard notifyPendingTags + Just + NotifyUpdateTags + { notifyPackageName = pkg + , notifyAddedTags = addedTags + , notifyDeletedTags = deletedTags + } + + genDependencyUpdateList notifyPrefs idx revIdx pkg = do + let toNotif uid watchedPkgs = + NotifyDependencyUpdate + { notifyPackageId = pkg + , notifyWatchedPackages = watchedPkgs + , notifyTriggerBounds = + notifyDependencyTriggerBounds $ + fromMaybe defaultNotifyPrefs (Map.lookup uid notifyPrefs) + } + Map.toList . Map.mapWithKey toNotif + <$> getUserNotificationsOnRelease (queryUserGroup . maintainersGroup) idx revIdx queryGetUserNotifyPref pkg + + sendNotifyEmailAndDelay :: Mail -> IO () + sendNotifyEmailAndDelay email = do + -- TODO: if we need any configuration of sendmail stuff, has to go here + renderSendMail email + + -- delay sending out emails, to avoid spamming people if we accidentally + -- send out too many emails + threadDelay 250000 + +data Notification + = NotifyNewVersion + { notifyPackageInfo :: PkgInfo + } + | NotifyNewRevision + { notifyPackageId :: PackageId + , notifyRevisions :: [UploadInfo] + } + | NotifyMaintainerUpdate + { notifyMaintainerUpdateType :: NotifyMaintainerUpdateType + , notifyUserActor :: UserId + , notifyUserSubject :: UserId + , notifyPackageName :: PackageName + , notifyReason :: Text + , notifyUpdatedAt :: UTCTime + } + | NotifyDocsBuild + { notifyPackageId :: PackageId + , notifyBuildSuccess :: Bool + } + | NotifyUpdateTags + { notifyPackageName :: PackageName + , notifyAddedTags :: Set Tag + , notifyDeletedTags :: Set Tag + } + | NotifyDependencyUpdate + { notifyPackageId :: PackageId + -- ^ Dependency that was updated + , notifyWatchedPackages :: [PackageId] + -- ^ Packages maintained by user that depend on updated dep + , notifyTriggerBounds :: NotifyTriggerBounds + } + | NotifyVouchingCompleted + deriving (Show) + +data NotifyMaintainerUpdateType = MaintainerAdded | MaintainerRemoved + deriving (Show) + +-- | Notifications in the same group are batched in the same email. +-- +-- TODO: How often do multiple notifications come in at once? Maybe it's +-- fine to just send one email per notification. +data NotificationGroup + = GeneralNotification + | DependencyNotification PackageId + deriving (Eq, Ord) + +-- | Get all the emails to send for the given notifications. +getNotificationEmails + :: ServerEnv + -> UserDetailsFeature + -> Users.Users + -> [(UserId, Notification)] + -> IO [Mail] +getNotificationEmails + ServerEnv{serverBaseURI} + UserDetailsFeature{queryUserDetails} + allUsers + notifications = do + let userIds = Set.fromList $ map fst notifications + userIdToDetails <- Map.mapMaybe id <$> fromSetM queryUserDetails userIds + + pure $ + let emails = groupNotifications $ map (fmap renderNotification) notifications + in flip mapMaybe (Map.toList emails) $ \((uid, group), emailContent) -> + case uid `Map.lookup` userIdToDetails of + Nothing -> Nothing + Just AccountDetails{..} -> Just $ + Mail + { mailFrom = + Address + { addressName = Just "Hackage website" + , addressEmail = "noreply@" <> hostname + } + , mailTo = + [ Address + { addressName = Just accountName + , addressEmail = accountContactEmail + } + ] + , mailCc = [] + , mailBcc = [] + , mailHeaders = + [ ("Subject", "[Hackage] " <> getEmailSubject group) + ] + , mailParts = + [ fromEmailContent $ emailContent <> updatePreferencesText uid + ] + } + where + groupNotifications :: [(UserId, (EmailContent, NotificationGroup))] -> Map (UserId, NotificationGroup) EmailContent + groupNotifications = + Map.fromListWith (<>) + . map (\(uid, (emailContent, group)) -> ((uid, group), emailContent)) + + getEmailSubject = \case + GeneralNotification -> "Maintainer Notifications" + DependencyNotification pkg -> "Dependency Update: " <> T.pack (display pkg) + + hostname = + case uriAuthority serverBaseURI of + Just auth -> T.pack $ uriRegName auth + Nothing -> error $ "Could not get hostname from serverBaseURI: " <> show serverBaseURI + + updatePreferencesText uid = + EmailContentParagraph $ + "You can adjust your notification preferences at" <> EmailContentSoftBreak + <> emailContentUrl + serverBaseURI + { uriPath = + concatMap ("/" <>) + [ "user" + , display $ Users.userIdToName allUsers uid + , "notify" + ] + } + + {----- Render notifications -----} + + renderNotification :: Notification -> (EmailContent, NotificationGroup) + renderNotification = \case + NotifyNewVersion{..} -> + generalNotification $ + renderNotifyNewVersion + notifyPackageInfo + NotifyNewRevision{..} -> + generalNotification $ + renderNotifyNewRevision + notifyPackageId + notifyRevisions + NotifyMaintainerUpdate{..} -> + generalNotification $ + renderNotifyMaintainerUpdate + notifyMaintainerUpdateType + notifyUserActor + notifyUserSubject + notifyPackageName + notifyReason + notifyUpdatedAt + NotifyDocsBuild{..} -> + generalNotification $ + renderNotifyDocsBuild + notifyPackageId + notifyBuildSuccess + NotifyUpdateTags{..} -> + generalNotification $ + renderNotifyUpdateTags + notifyPackageName + notifyAddedTags + notifyDeletedTags + NotifyDependencyUpdate{..} -> + ( renderNotifyDependencyUpdate + notifyTriggerBounds + notifyPackageId + notifyWatchedPackages + , DependencyNotification notifyPackageId + ) + NotifyVouchingCompleted -> + generalNotification + renderNotifyVouchingCompleted + where - showTags = intercalate ", " . map display . Set.toList - - sendNotifyEmailAndDelay :: Users.Users -> (UserId, [String]) -> IO () - sendNotifyEmailAndDelay users (uid, ebody) = do - mudetails <- queryUserDetails uid - case mudetails of - Nothing -> return () - Just (AccountDetails{accountContactEmail=eml, accountName=aname})-> do - let mailFrom = Address (Just (T.pack "Hackage website")) - (T.pack ("noreply@" ++ uriRegName ourHost)) - mail = (emptyMail mailFrom) { - mailTo = [Address (Just aname) eml], - mailHeaders = [(BSS.pack "Subject", - T.pack "[Hackage] Maintainer Notifications")], - mailParts = [[Part (T.pack "text/plain; charset=utf-8") - None DefaultDisposition [] - (PartContent $ BS.pack $ - intercalate "\n\n" ebody - <> "\n\n" - <> adjustmentLinkParagraph - ) - ]] - } - Just ourHost = uriAuthority serverBaseURI + generalNotification = (, GeneralNotification) + + renderNotifyNewVersion pkg = + EmailContentParagraph $ + "Package upload, " <> renderPkgLink (pkgInfoId pkg) <> ", by " <> + renderUserTime (pkgLatestUploadUser pkg) (pkgLatestUploadTime pkg) + + renderNotifyNewRevision pkg revs = + EmailContentParagraph ("Package metadata revision(s), " <> renderPkgLink pkg <> ":") + <> EmailContentList (map (uncurry $ flip renderUserTime) $ sortOn (Down . fst) revs) + + renderNotifyMaintainerUpdate updateType userActor userSubject pkg reason time = + EmailContentParagraph ("Group modified by " <> renderUserTime userActor time <> ":") + <> EmailContentList + [ case updateType of + MaintainerAdded -> + renderUser userSubject <> " added to maintainers for " <> renderPackageName pkg + MaintainerRemoved -> + renderUser userSubject <> " removed from maintainers for " <> renderPackageName pkg + , "Reason: " <> EmailContentText reason + ] - renderSendMail mail --TODO: if we need any configuration of - -- sendmail stuff, has to go here - threadDelay 250000 + renderNotifyDocsBuild pkg success = + EmailContentParagraph $ + "Package doc build for " <> renderPkgLink pkg <> ":" <> EmailContentSoftBreak + <> if success + then "Build successful." + else "Build failed." + + renderNotifyUpdateTags pkg addedTags deletedTags = + EmailContentParagraph ("Pending tag proposal for " <> emailContentDisplay pkg <> ":") + <> EmailContentList + [ "Additions: " <> showTags addedTags + , "Deletions: " <> showTags deletedTags + ] where - adjustmentLinkParagraph = - "You can adjust your notification preferences at\n" - <> uriToString id serverBaseURI "" - <> "/user/" - <> display (Users.userIdToName users uid) - <> "/notify" + showTags = emailContentIntercalate ", " . map emailContentDisplay . Set.toList + + renderNotifyDependencyUpdate triggerBounds dep revDeps = + let depName = emailContentDisplay (packageName dep) + depVersion = emailContentDisplay (packageVersion dep) + in + foldMap EmailContentParagraph + [ "The dependency " <> renderPkgLink dep <> " has been uploaded or revised." + , case triggerBounds of + Always -> + "You have requested to be notified for each upload or revision \ + \of a dependency." + _ -> + "You have requested to be notified when a dependency isn't \ + \accepted by any of your maintained packages." + , case triggerBounds of + Always -> + "These are your packages that depend on " <> depName <> ":" + BoundsOutOfRange -> + "These are your packages that require " <> depName + <> " but don't accept " <> depVersion <> ":" + NewIncompatibility -> + "The following packages require " <> depName + <> " but don't accept " <> depVersion + <> " (they do accept the second-highest version):" + ] + <> EmailContentList (map renderPkgLink revDeps) + + renderNotifyVouchingCompleted = + EmailContentParagraph + "You have received all necessary endorsements. \ + \You have been added the the 'uploaders' group. \ + \You can now upload packages to Hackage. \ + \Note that packages cannot be deleted, so be careful." + + {----- Rendering helpers -----} + + renderPackageName = emailContentStr . unPackageName + + renderPkgLink pkg = + EmailContentLink + (T.pack $ display pkg) + serverBaseURI + { uriPath = "/package/" <> display (packageName pkg) <> "-" <> display (packageVersion pkg) + } + + renderUser = emailContentDisplay . Users.userIdToName allUsers + + renderTime = emailContentStr . formatTime defaultTimeLocale "%c" + + renderUserTime u t = renderUser u <> " [" <> renderTime t <> "]" + +{----- Utilities -----} + +fromSetM :: Monad m => (k -> m v) -> Set k -> m (Map k v) +fromSetM f = traverse id . Map.fromSet f + +concatMapM :: Monad m => (a -> m [b]) -> [a] -> m [b] +concatMapM f = fmap concat . mapM f diff --git a/src/Distribution/Server/Features/UserSignup.hs b/src/Distribution/Server/Features/UserSignup.hs index 90bb3292b..0e49d5c3e 100644 --- a/src/Distribution/Server/Features/UserSignup.hs +++ b/src/Distribution/Server/Features/UserSignup.hs @@ -491,6 +491,7 @@ userSignupFeature ServerEnv{serverBaseURI, serverCron} uriPath = "/users/register-request/" ++ renderNonce nonce } + , "endorselink" $- serverBaseURI {uriPath = "/user/" ++ username ++ "/endorse" , "serverhost" $= serverBaseURI ] Just ourHost = uriAuthority serverBaseURI diff --git a/src/Distribution/Server/Features/Vouch.hs b/src/Distribution/Server/Features/Vouch.hs new file mode 100644 index 000000000..ba08ecc4a --- /dev/null +++ b/src/Distribution/Server/Features/Vouch.hs @@ -0,0 +1,255 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE RankNTypes #-} +module Distribution.Server.Features.Vouch (VouchFeature(..), VouchData(..), VouchError(..), VouchSuccess(..), initVouchFeature, judgeVouch) where + +import Control.Monad (when, join) +import Control.Monad.Except (runExceptT, throwError) +import Control.Monad.Reader (ask) +import Control.Monad.State (get, put) +import Control.Monad.IO.Class (MonadIO) +import qualified Data.ByteString.Lazy.Char8 as LBS +import qualified Data.Map.Strict as Map +import qualified Data.Set as Set +import Data.Maybe (fromMaybe) +import Data.Time (UTCTime(..), addUTCTime, getCurrentTime, nominalDay, secondsToDiffTime) +import Data.Time.Format.ISO8601 (formatShow, iso8601Format) +import Text.XHtml.Strict (prettyHtmlFragment, stringToHtml, li) + +import Data.SafeCopy (base, deriveSafeCopy) +import Distribution.Server.Framework ((), AcidState, DynamicPath, HackageFeature, IsHackageFeature, IsHackageFeature(..), MemSize(..), memSize2) +import Distribution.Server.Framework (MessageSpan(MText), Method(..), Query, Response, ServerEnv(..), ServerPartE, StateComponent(..), Update) +import Distribution.Server.Framework (abstractAcidStateComponent, emptyHackageFeature, errBadRequest) +import Distribution.Server.Framework (featureDesc, featureReloadFiles, featureResources, featureState) +import Distribution.Server.Framework (liftIO, makeAcidic, openLocalStateFrom, query, queryState, resourceAt, resourceDesc, resourceGet) +import Distribution.Server.Framework (resourcePost, toResponse, update, updateState) +import Distribution.Server.Framework.BackupRestore (RestoreBackup(..)) +import Distribution.Server.Framework.Templating (($=), TemplateAttr, getTemplate, loadTemplates, reloadTemplates, templateUnescaped) +import qualified Distribution.Server.Users.Group as Group +import Distribution.Server.Users.Types (UserId(..), UserInfo, UserName(..), userName) +import Distribution.Server.Features.Upload(UploadFeature(..)) +import Distribution.Server.Features.Users (UserFeature(..)) +import Distribution.Simple.Utils (toUTF8LBS) + +data VouchData = + VouchData + { vouches :: Map.Map UserId [(UserId, UTCTime)] + , notNotified :: Set.Set UserId + } + deriving (Show, Eq) + +instance MemSize VouchData where + memSize (VouchData vouches notified) = memSize2 vouches notified + +putVouch :: UserId -> (UserId, UTCTime) -> Update VouchData () +putVouch vouchee (voucher, now) = do + VouchData tbl notNotified <- get + let oldMap = fromMaybe [] (Map.lookup vouchee tbl) + newMap = (voucher, now) : oldMap + put $ VouchData (Map.insert vouchee newMap tbl) notNotified + +getVouchesFor :: UserId -> Query VouchData [(UserId, UTCTime)] +getVouchesFor needle = do + VouchData tbl _notNotified <- ask + pure . fromMaybe [] $ Map.lookup needle tbl + +getVouchesData :: Query VouchData VouchData +getVouchesData = ask + +replaceVouchesData :: VouchData -> Update VouchData () +replaceVouchesData = put + +$(deriveSafeCopy 0 'base ''VouchData) + +makeAcidic ''VouchData + [ 'putVouch + , 'getVouchesFor + -- Stock + , 'getVouchesData + , 'replaceVouchesData + ] + +vouchStateComponent :: FilePath -> IO (StateComponent AcidState VouchData) +vouchStateComponent stateDir = do + st <- openLocalStateFrom (stateDir "db" "Vouch") (VouchData mempty mempty) + let initialVouchData = VouchData mempty mempty + restore = + RestoreBackup + { restoreEntry = error "Unexpected backup entry" + , restoreFinalize = return initialVouchData + } + pure StateComponent + { stateDesc = "Keeps track of vouches" + , stateHandle = st + , getState = query st GetVouchesData + , putState = update st . ReplaceVouchesData + , backupState = \_ _ -> [] + , restoreState = restore + , resetState = vouchStateComponent + } + +data VouchFeature = + VouchFeature + { vouchFeatureInterface :: HackageFeature + , drainQueuedNotifications :: forall m. MonadIO m => m [UserId] + } + +instance IsHackageFeature VouchFeature where + getFeatureInterface = vouchFeatureInterface + +requiredCountOfVouches :: Int +requiredCountOfVouches = 2 + +isWithinLastMonth :: UTCTime -> (UserId, UTCTime) -> Bool +isWithinLastMonth now (_, vouchTime) = + addUTCTime (30 * nominalDay) vouchTime >= now + +data VouchError + = NotAnUploader + | You'reTooNew + | VoucheeAlreadyUploader + | AlreadySufficientlyVouched + | YouAlreadyVouched + deriving stock (Show, Eq) + +data VouchSuccess = AddVouchComplete | AddVouchIncomplete Int + deriving stock (Show, Eq) + +judgeVouch + :: Group.UserIdSet + -> UTCTime + -> UserId + -> [(UserId, UTCTime)] + -> [(UserId, UTCTime)] + -> UserId + -> Either VouchError VouchSuccess +judgeVouch ugroup now vouchee vouchersForVoucher existingVouchers voucher = join . runExceptT $ do + when (not (voucher `Group.member` ugroup)) $ + throwError NotAnUploader + -- You can only vouch for non-uploaders, so if this list has items, the user is uploader because of these vouches. + -- Make sure none of them are too recent. + when (length vouchersForVoucher >= requiredCountOfVouches && any (isWithinLastMonth now) vouchersForVoucher) $ + throwError You'reTooNew + when (vouchee `Group.member` ugroup) $ + throwError VoucheeAlreadyUploader + when (length existingVouchers >= requiredCountOfVouches) $ + throwError AlreadySufficientlyVouched + when (voucher `elem` map fst existingVouchers) $ + throwError YouAlreadyVouched + pure $ + if length existingVouchers == requiredCountOfVouches - 1 + then AddVouchComplete + else + let stillRequired = requiredCountOfVouches - length existingVouchers - 1 + in AddVouchIncomplete stillRequired + +renderToLBS :: (UserId -> ServerPartE UserInfo) -> [(UserId, UTCTime)] -> ServerPartE TemplateAttr +renderToLBS lookupUserInfo vouches = do + rendered <- traverse (renderVouchers lookupUserInfo) vouches + pure $ + templateUnescaped "vouches" $ + if null rendered + then LBS.pack "Nobody has endorsed yet." + else LBS.intercalate mempty rendered + +renderVouchers :: (UserId -> ServerPartE UserInfo) -> (UserId, UTCTime) -> ServerPartE LBS.ByteString +renderVouchers lookupUserInfo (uid, timestamp) = do + info <- lookupUserInfo uid + let UserName name = userName info + -- We don't need to show millisecond precision + -- So we truncate it off here + truncated = truncate $ utctDayTime timestamp + newUTCTime = timestamp {utctDayTime = secondsToDiffTime truncated} + pure . toUTF8LBS . prettyHtmlFragment . li . stringToHtml $ name <> " vouched on " <> formatShow iso8601Format newUTCTime + +initVouchFeature :: ServerEnv -> IO (UserFeature -> UploadFeature -> IO VouchFeature) +initVouchFeature ServerEnv{serverStateDir, serverTemplatesDir, serverTemplatesMode} = do + vouchState <- vouchStateComponent serverStateDir + templates <- loadTemplates serverTemplatesMode [ serverTemplatesDir, serverTemplatesDir "Html"] + ["vouch.html"] + vouchTemplate <- getTemplate templates "vouch.html" + return $ \UserFeature{userNameInPath, lookupUserName, lookupUserInfo, guardAuthenticated} + UploadFeature{uploadersGroup} -> do + let + handleGetVouches :: DynamicPath -> ServerPartE Response + handleGetVouches dpath = do + uid <- lookupUserName =<< userNameInPath dpath + vouches <- queryState vouchState $ GetVouchesFor uid + param <- renderToLBS lookupUserInfo vouches + pure . toResponse $ vouchTemplate + [ "msg" $= "" + , "requiredNumber" $= show requiredCountOfVouches + , param + ] + handlePostVouch :: DynamicPath -> ServerPartE Response + handlePostVouch dpath = do + voucher <- guardAuthenticated + ugroup <- liftIO $ Group.queryUserGroup uploadersGroup + now <- liftIO getCurrentTime + vouchee <- lookupUserName =<< userNameInPath dpath + vouchersForVoucher <- queryState vouchState $ GetVouchesFor voucher + existingVouchers <- queryState vouchState $ GetVouchesFor vouchee + case judgeVouch ugroup now vouchee vouchersForVoucher existingVouchers voucher of + Left NotAnUploader -> + errBadRequest "Not an uploader" [MText "You must be an uploader yourself to endorse other users."] + Left You'reTooNew -> + errBadRequest "You're too new" [MText "The latest of the endorsements for your user must be at least 30 days old."] + Left VoucheeAlreadyUploader -> + errBadRequest "Endorsee already uploader" [MText "You can't endorse this user, since they are already an uploader."] + Left AlreadySufficientlyVouched -> + errBadRequest "Already sufficiently endorsed" [MText "There are already a sufficient number of endorsements for this user."] + Left YouAlreadyVouched -> + errBadRequest "Already endorsed" [MText "You have already endorsed this user."] + Right result -> do + updateState vouchState $ PutVouch vouchee (voucher, now) + param <- renderToLBS lookupUserInfo $ existingVouchers ++ [(voucher, now)] + case result of + AddVouchComplete -> do + -- enqueue vouching completed notification + -- which will be read using drainQueuedNotifications + VouchData vouches notNotified <- + queryState vouchState GetVouchesData + let newState = VouchData vouches (Set.insert vouchee notNotified) + updateState vouchState $ ReplaceVouchesData newState + + liftIO $ Group.addUserToGroup uploadersGroup vouchee + pure . toResponse $ vouchTemplate + [ "msg" $= "Added endorsement. User is now an uploader!" + , "requiredNumber" $= show requiredCountOfVouches + , param + ] + AddVouchIncomplete stillRequired -> + pure . toResponse $ vouchTemplate + [ "msg" $= + "Added endorsement. User still needs " + <> show stillRequired + <> if stillRequired == 1 then " endorsement" else " endorsements" + <> " to become uploader." + , param + ] + return $ VouchFeature { + vouchFeatureInterface = + (emptyHackageFeature "endorse") + { featureDesc = "Endorsing users such that they get upload permission." + , featureResources = + [(resourceAt "/user/:username/endorse") + { resourceDesc = [(GET, "list people endorsing") + ,(POST, "endorse for user") + ] + , resourceGet = [("html", handleGetVouches)] + , resourcePost = [("html", handlePostVouch)] + } + ] + , featureState = [ abstractAcidStateComponent vouchState ] + , featureReloadFiles = reloadTemplates templates + }, + drainQueuedNotifications = do + VouchData vouches notNotified <- + queryState vouchState GetVouchesData + let newState = VouchData vouches mempty + updateState vouchState $ ReplaceVouchesData newState + pure $ Set.toList notNotified + } diff --git a/src/Distribution/Server/Framework/Instances.hs b/src/Distribution/Server/Framework/Instances.hs index d2a68cf57..273278664 100644 --- a/src/Distribution/Server/Framework/Instances.hs +++ b/src/Distribution/Server/Framework/Instances.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts, BangPatterns, TypeFamilies #-} {-# OPTIONS_GHC -fno-warn-orphans #-} @@ -119,6 +120,9 @@ instance SafeCopy VersionRange where instance SafeCopy OS where errorTypeName _ = "OS" +#if !MIN_VERSION_Cabal_syntax(3,11,0) + putCopy (OtherOS "haiku") = contain $ putWord8 18 +#endif putCopy (OtherOS s) = contain $ putWord8 0 >> safePut s putCopy Linux = contain $ putWord8 1 putCopy Windows = contain $ putWord8 2 @@ -137,6 +141,9 @@ instance SafeCopy OS where putCopy Hurd = contain $ putWord8 15 putCopy Android = contain $ putWord8 16 putCopy Wasi = contain $ putWord8 17 +#if MIN_VERSION_Cabal_syntax(3,11,0) + putCopy Haiku = contain $ putWord8 18 +#endif getCopy = contain $ do tag <- getWord8 @@ -159,6 +166,11 @@ instance SafeCopy OS where 15 -> return Hurd 16 -> return Android 17 -> return Wasi +#if MIN_VERSION_Cabal_syntax(3,11,0) + 18 -> return Haiku +#else + 18 -> return $ OtherOS "haiku" +#endif _ -> fail "SafeCopy OS getCopy: unexpected tag" instance SafeCopy Arch where @@ -382,7 +394,13 @@ 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 ] + , pure HPUX, pure IRIX, pure HaLVM, pure IOS +#if MIN_VERSION_Cabal_syntax(3,11,0) + , pure Haiku +#else + , pure $ OtherOS "haiku" +#endif + ] instance Arbitrary FlagName where arbitrary = mkFlagName <$> vectorOf 4 (choose ('a', 'z')) diff --git a/src/Distribution/Server/Packages/Unpack.hs b/src/Distribution/Server/Packages/Unpack.hs index b9a8bdba5..abc6895dc 100644 --- a/src/Distribution/Server/Packages/Unpack.hs +++ b/src/Distribution/Server/Packages/Unpack.hs @@ -215,9 +215,9 @@ specVersionChecks specVerOk specVer = do when (specVer < CabalSpecV1_10) $ throwError "'cabal-version' must be at least 1.10" - -- Safeguard; should already be caught by parser - unless (specVer <= CabalSpecV3_0) $ - throwError "'cabal-version' must be at most 3.0" + -- To keep people from uploading packages most users cannot use. + 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 diff --git a/src/Distribution/Server/Pages/Recent.hs b/src/Distribution/Server/Pages/Recent.hs index 65b81eac7..ab8cd9ce4 100644 --- a/src/Distribution/Server/Pages/Recent.hs +++ b/src/Distribution/Server/Pages/Recent.hs @@ -241,7 +241,7 @@ releaseItem users hostURI pkgInfo = title = display (packageName pkgId) ++ " " ++ display (packageVersion pkgId) body = fromShortText $ synopsis (packageDescription (pkgDesc pkgInfo)) desc = "Added by " ++ display user ++ ", " ++ showTime time ++ "." - ++ if null body then "" else "

" ++ body + ++ if null body then "" else "

" ++ body ++ "

" user = Users.userIdToName users userId (time, userId) = pkgOriginalUploadInfo pkgInfo @@ -261,7 +261,7 @@ revisionItem users hostURI pkgInfo = title = display (packageName pkgId) ++ " " ++ display (packageVersion pkgId) body = "Revision #" ++ show revision desc = "Revised by " ++ display user ++ ", " ++ showTime time ++ "." - ++ if null body then "" else "

" ++ body + ++ if null body then "" else "

" ++ body ++ "

" user = Users.userIdToName users userId revision = pkgNumRevisions pkgInfo - 1 diff --git a/src/Distribution/Server/Util/Email.hs b/src/Distribution/Server/Util/Email.hs new file mode 100644 index 000000000..daabdfd62 --- /dev/null +++ b/src/Distribution/Server/Util/Email.hs @@ -0,0 +1,137 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + +module Distribution.Server.Util.Email + ( EmailContent(..) + , emailContentStr + , emailContentLBS + , emailContentDisplay + , emailContentIntercalate + , emailContentUrl + + -- * Rendering email content + , fromEmailContent + , toPlainContent + , toHtmlContent + ) where + +import qualified Data.ByteString.Lazy as Lazy (ByteString) +import Data.List (intersperse) +import Data.String (IsString(..)) +import Data.Text (Text) +import qualified Data.Text as Text +import qualified Data.Text.Lazy as TextL +import qualified Data.Text.Lazy.Encoding as TextL +import Distribution.Pretty (Pretty) +import Distribution.Text (display) +import Network.Mail.Mime +import Network.URI (URI, uriToString) + +{- $setup +>>> :set -XOverloadedStrings +>>> import qualified Data.Text.IO as Text +>>> import Network.URI (parseURI) +-} + +data EmailContent + = EmailContentText Text + | EmailContentLink Text URI + | EmailContentSoftBreak + | EmailContentParagraph EmailContent + | EmailContentList [EmailContent] + | EmailContentConcat EmailContent EmailContent + deriving (Show) + +instance IsString EmailContent where + fromString = EmailContentText . Text.pack + +instance Semigroup EmailContent where + (<>) = EmailContentConcat + +instance Monoid EmailContent where + mempty = EmailContentText "" + +emailContentStr :: String -> EmailContent +emailContentStr = EmailContentText . Text.pack + +emailContentLBS :: Lazy.ByteString -> EmailContent +emailContentLBS = EmailContentText . TextL.toStrict . TextL.decodeUtf8 + +emailContentDisplay :: Pretty a => a -> EmailContent +emailContentDisplay = EmailContentText . Text.pack . display + +emailContentIntercalate :: EmailContent -> [EmailContent] -> EmailContent +emailContentIntercalate x = mconcat . intersperse x + +emailContentUrl :: URI -> EmailContent +emailContentUrl uri = EmailContentLink (uriToText uri) uri + +fromEmailContent :: EmailContent -> Alternatives +fromEmailContent emailContent = + [ plainPart $ TextL.fromStrict $ toPlainContent emailContent + , htmlPart $ TextL.fromStrict $ toHtmlContent emailContent + ] + +-- | Convert an 'EmailContent' to plain text. +-- +-- >>> let Just haskellURI = parseURI "https://haskell.org" +-- >>> let Just hackageURI = parseURI "https://hackage.haskell.org" +-- >>> :{ +-- Text.putStr . toPlainContent . mconcat $ +-- [ EmailContentParagraph "Haskell is fun!" +-- , EmailContentList +-- [ "Website: " <> EmailContentLink "haskell.org" haskellURI +-- , EmailContentLink "Hackage" hackageURI +-- ] +-- ] +-- :} +-- Haskell is fun! +-- +-- * Website: haskell.org (https://haskell.org) +-- * Hackage (https://hackage.haskell.org) +-- +toPlainContent :: EmailContent -> Text +toPlainContent = \case + EmailContentText s -> s + EmailContentLink s uri -> s <> " (" <> uriToText uri <> ")" + EmailContentSoftBreak -> "\n" + EmailContentParagraph content -> toPlainContent content <> "\n\n" + EmailContentList items -> + let renderListItem item = "* " <> toPlainContent item + in Text.intercalate "\n" (map renderListItem items) <> "\n\n" + EmailContentConcat a b -> toPlainContent a <> toPlainContent b + +-- | Convert an 'EmailContent' to HTML. +-- +-- >>> let Just haskellURI = parseURI "https://haskell.org" +-- >>> let Just hackageURI = parseURI "https://hackage.haskell.org" +-- >>> :{ +-- Text.putStr . toHtmlContent . mconcat $ +-- [ EmailContentParagraph "Haskell is fun!" +-- , EmailContentList +-- [ "Website: " <> EmailContentLink "haskell.org" haskellURI +-- , EmailContentLink "Hackage" hackageURI +-- ] +-- ] +-- :} +-- +--

+-- Haskell is fun! +--

+-- +toHtmlContent :: EmailContent -> Text +toHtmlContent = \case + EmailContentText s -> s + EmailContentLink s uri -> " uriToText uri <> "\">" <> s <> "" + EmailContentSoftBreak -> "\n
" + EmailContentParagraph content -> "\n

\n" <> toHtmlContent content <> "\n

" + EmailContentList items -> + let renderListItem item = "
  • " <> toHtmlContent item <> "
    • " + in "\n
      \n" <> Text.unlines (map renderListItem items) <> "
    " + EmailContentConcat a b -> toHtmlContent a <> toHtmlContent b + +uriToText :: URI -> Text +uriToText uri = Text.pack $ uriToString id uri "" diff --git a/tests/HttpUtils.hs b/tests/HttpUtils.hs index a688efa7d..5a6e714db 100644 --- a/tests/HttpUtils.hs +++ b/tests/HttpUtils.hs @@ -27,7 +27,8 @@ import Control.Monad import Data.Maybe import Network.HTTP hiding (user) import Network.HTTP.Auth -import Data.Aeson (Result(..), Value(..), FromJSON(..), (.:), fromJSON, json') +import Data.Aeson (Result(..), Value(..), FromJSON(..), (.:), fromJSON) +import Data.Aeson.Parser (json') import System.Exit (die) import qualified Network.Http.Client as HC diff --git a/tests/ReverseDependenciesTest.hs b/tests/ReverseDependenciesTest.hs index 030eb8d08..fa78807d9 100644 --- a/tests/ReverseDependenciesTest.hs +++ b/tests/ReverseDependenciesTest.hs @@ -1,35 +1,82 @@ {-# LANGUAGE OverloadedStrings, NamedFieldPuns, TypeApplications, ScopedTypeVariables #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TupleSections #-} module Main where +import Control.Monad (guard) import Control.Monad.IO.Class (liftIO) +import qualified Control.Monad.Trans.State as State import qualified Data.Array as Arr import qualified Data.Bimap as Bimap +import qualified Data.ByteString.Lazy as Lazy (ByteString) +import qualified Data.ByteString.Lazy as ByteStringL import Data.Foldable (for_) import Data.Functor.Identity (Identity(..)) import Data.List (partition, foldl') import qualified Data.Map as Map +import Data.Maybe (fromJust) import qualified Data.Set as Set +import qualified Data.Time as Time +import Data.Vector (Vector) +import qualified Data.Vector as Vector +import qualified Network.Mail.Mime as Mail +import Network.URI (parseURI) +import System.Random (mkStdGen) import Distribution.Package (PackageIdentifier(..), mkPackageName, packageId, packageName) import Distribution.Server.Features.PreferredVersions.State (PreferredVersions(..), VersionStatus(NormalVersion), PreferredInfo(..)) import Distribution.Server.Features.ReverseDependencies (ReverseFeature(..), ReverseCount(..), reverseFeature) import Distribution.Server.Features.ReverseDependencies.State (ReverseIndex(..), addPackage, constructReverseIndex, emptyReverseIndex, getDependenciesFlat, getDependencies, getDependenciesFlatRaw, getDependenciesRaw) -import Distribution.Server.Features.UserNotify (NotifyData(..), NotifyPref(..), NotifyRevisionRange, NotifyTriggerBounds(..), defaultNotifyPrefs, dependencyReleaseEmails, importNotifyPref, notifyDataToCSV) +import Distribution.Server.Features.Tags (Tag(..)) +import Distribution.Server.Features.UserDetails (AccountDetails(..), UserDetailsFeature(..)) +import Distribution.Server.Features.UserNotify + ( Notification(..) + , NotifyMaintainerUpdateType(..) + , NotifyData(..) + , NotifyPref(..) + , NotifyRevisionRange(..) + , NotifyTriggerBounds(..) + , defaultNotifyPrefs + , getNotificationEmails + , getUserNotificationsOnRelease + , importNotifyPref + , notifyDataToCSV + ) import Distribution.Server.Framework.BackupRestore (runRestore) import Distribution.Server.Framework.Hook (newHook) import Distribution.Server.Framework.MemState (newMemStateWHNF) +import Distribution.Server.Framework.ServerEnv (ServerEnv(..)) import Distribution.Server.Packages.PackageIndex as PackageIndex -import Distribution.Server.Packages.Types (PkgInfo(..)) -import Distribution.Server.Users.Types (UserId(..)) +import Distribution.Server.Packages.Types (CabalFileText(..), PkgInfo(..)) +import Distribution.Server.Users.Types + ( PasswdHash(..) + , UserAuth(..) + , UserId(..) + , UserName(..) + ) import Distribution.Server.Users.UserIdSet as UserIdSet +import qualified Distribution.Server.Users.Users as Users import Distribution.Version (mkVersion, version0) -import Test.Tasty (TestTree, defaultMain, testGroup) +import Test.Tasty (TestName, TestTree, defaultMain, testGroup) +import Test.Tasty.Golden (goldenVsString) +import Test.Tasty.Hedgehog (testProperty) import Test.Tasty.HUnit import qualified Hedgehog.Range as Range import qualified Hedgehog.Gen as Gen -import Hedgehog ((===), Group(Group), MonadGen, Property, PropertyT, checkSequential, forAll, property) +import Hedgehog + ( (===) + , Group(Group) + , MonadGen + , Property + , PropertyT + , Range + , checkSequential + , forAll + , property + , withTests + ) import RevDepCommon (Package(..), TestPackage(..), mkPackage, mkPackageWithCabalFileSuffix, packToPkgInfo) @@ -56,6 +103,14 @@ newBaseReleased = , mkPackage "mtl" [2,3] ["base < 4.15"] ] +newBaseReleasedMultiple :: [PkgInfo] +newBaseReleasedMultiple = + [ mkPackage "base" [4,14] [] + , mkPackage "base" [4,15] [] + , mkPackage "mtl" [2,3] ["base < 4.15"] + , mkPackage "mtl2" [2,3] ["base < 4.15"] + ] + newVersionOfOldBase :: [PkgInfo] newVersionOfOldBase = [ mkPackage "base" [4,14] [] @@ -104,6 +159,17 @@ allTests = testGroup "ReverseDependenciesTest" res <- revPackageName "mtl" let ref = Map.fromList [("beeline", (version0, Just NormalVersion))] assertEqual "reverse dependencies must be [beeline]" ref res + , testCase "with set [beeline->mtl, beeline2->mtl] and querying for mtl, we get [beeline, beeline2]" $ do + let pkgs = + [ mkPackage "base" [4,15] [] + , mkPackage "mtl" [2,3] ["base"] + , mkPackage "beeline" [0] ["mtl"] + , mkPackage "beeline2" [0] ["mtl"] + ] + ReverseFeature{revPackageName} <- mkRevFeat pkgs + res <- revPackageName "mtl" + let ref = Map.fromList [("beeline", (version0, Just NormalVersion)), ("beeline2", (version0, Just NormalVersion))] + assertEqual "reverse dependencies must be [beeline, beeline2]" ref res , testCase "revPackageName selects only the version with an actual dependency, even if it is not the newest" $ do let pkgs = [ mkPackage "base" [4,15] [] @@ -167,7 +233,7 @@ allTests = testGroup "ReverseDependenciesTest" ReverseFeature{revDisplayInfo} <- mkRevFeat mtlBeelineLens res <- revDisplayInfo assertEqual "beeline preferred is old" (PreferredInfo [] [] Nothing, [mkVersion [0]]) (res "beeline") - , testCase "dependencyReleaseEmails sends notification" $ do + , testCase "getUserNotificationsOnRelease sends notification" $ do let userSetIdForPackage arg | arg == mkPackageName "mtl" = Identity (UserIdSet.fromList [UserId 0]) | otherwise = error "should only get user ids for mtl" notifyPref triggerBounds = @@ -178,9 +244,9 @@ allTests = testGroup "ReverseDependenciesTest" } pref triggerBounds (UserId 0) = Identity (Just $ notifyPref triggerBounds) pref _ _ = error "should only get preferences for UserId 0" - refNotification base = Map.fromList + userNotification = Map.fromList [ - ( (UserId 0, base) + ( UserId 0 , [PackageIdentifier (mkPackageName "mtl") (mkVersion [2,3])] ) ] @@ -189,33 +255,51 @@ allTests = testGroup "ReverseDependenciesTest" base4_15 = PackageIdentifier "base" (mkVersion [4,15]) base4_16 = PackageIdentifier "base" (mkVersion [4,16]) runWithPref preferences index pkg = runIdentity $ - dependencyReleaseEmails userSetIdForPackage index (constructReverseIndex index) preferences pkg + getUserNotificationsOnRelease userSetIdForPackage index (constructReverseIndex index) preferences pkg + runWithPrefAlsoMtl2 preferences index pkg = runIdentity $ + getUserNotificationsOnRelease userSet index (constructReverseIndex index) preferences pkg + where + userSet arg | arg == mkPackageName "mtl" = Identity (UserIdSet.fromList [UserId 0]) + | arg == mkPackageName "mtl2" = Identity (UserIdSet.fromList [UserId 0]) + | otherwise = error "should only get user ids for mtl and mtl2" assertEqual - "dependencyReleaseEmails(trigger=NewIncompatibility) shouldn't generate a notification when there are packages, but none are behind" + "getUserNotificationsOnRelease(trigger=NewIncompatibility) shouldn't generate a notification when there are packages, but none are behind" mempty (runWithPref (pref NewIncompatibility) (PackageIndex.fromList twoPackagesWithNoDepsOutOfRange) base4_14) assertEqual - "dependencyReleaseEmails(trigger=NewIncompatibility) should generate a notification when package is a single base version behind" - (refNotification base4_15) + "getUserNotificationsOnRelease(trigger=NewIncompatibility) should generate a notification when package is a single base version behind" + userNotification (runWithPref (pref NewIncompatibility) (PackageIndex.fromList newBaseReleased) base4_15) assertEqual - "dependencyReleaseEmails(trigger=BoundsOutOfRange) should generate a notification when package is a single base version behind" - (refNotification base4_15) + "getUserNotificationsOnRelease(trigger=NewIncompatibility) should generate a notification for two packages that are a single base version behind" + (Just $ + Set.fromList + [ PackageIdentifier (mkPackageName "mtl") (mkVersion [2,3]) + , PackageIdentifier (mkPackageName "mtl2") (mkVersion [2,3]) + ] + ) + ( fmap Set.fromList + . Map.lookup (UserId 0) + $ runWithPrefAlsoMtl2 (pref NewIncompatibility) (PackageIndex.fromList newBaseReleasedMultiple) base4_15 + ) + assertEqual + "getUserNotificationsOnRelease(trigger=BoundsOutOfRange) should generate a notification when package is a single base version behind" + userNotification (runWithPref (pref BoundsOutOfRange) (PackageIndex.fromList newBaseReleased) base4_15) assertEqual - "dependencyReleaseEmails(trigger=NewIncompatibility) shouldn't generate a notification when package is two base versions behind" + "getUserNotificationsOnRelease(trigger=NewIncompatibility) shouldn't generate a notification when package is two base versions behind" mempty (runWithPref (pref NewIncompatibility) (PackageIndex.fromList twoNewBasesReleased) base4_16) assertEqual - "dependencyReleaseEmails(trigger=BoundsOutOfRange) should generate a notification when package is two base versions behind" - (refNotification base4_16) + "getUserNotificationsOnRelease(trigger=BoundsOutOfRange) should generate a notification when package is two base versions behind" + userNotification (runWithPref (pref BoundsOutOfRange) (PackageIndex.fromList twoNewBasesReleased) base4_16) assertEqual - "dependencyReleaseEmails(trigger=BoundsOutOfRange) shouldn't generate a notification when the new package is for an old release series" + "getUserNotificationsOnRelease(trigger=BoundsOutOfRange) shouldn't generate a notification when the new package is for an old release series" mempty (runWithPref (pref BoundsOutOfRange) (PackageIndex.fromList newVersionOfOldBase) base4_14_1) assertEqual - "dependencyReleaseEmails(trigger=BoundsOutOfRange) should only generate a notification when the new version is forbidden across all branches" + "getUserNotificationsOnRelease(trigger=BoundsOutOfRange) should only generate a notification when the new version is forbidden across all branches" mempty -- The two branches below should get OR'd and therefore the dependency is not out of bounds (runWithPref (pref BoundsOutOfRange) @@ -230,11 +314,251 @@ allTests = testGroup "ReverseDependenciesTest" \ build-depends: base >= 4.15 && < 4.16" ]) base4_15) + , getNotificationEmailsTests , testCase "hedgehogTests" $ do res <- hedgehogTests assertEqual "hedgehog test pass" True res ] +getNotificationEmailsTests :: TestTree +getNotificationEmailsTests = + testGroup "getNotificationEmails" + [ testProperty "All general notifications batched in one email" . withTests 30 . property $ do + notifs <- forAll $ Gen.list (Range.linear 1 10) $ Gen.filterT isGeneral genNotification + emails <- liftIO $ getNotificationEmailsMocked $ map (userWatcher,) notifs + length emails === 1 + , testGolden "Render NotifyNewVersion" "getNotificationEmails-NotifyNewVersion.golden" $ + fmap renderMail . getNotificationEmailMocked userWatcher $ + NotifyNewVersion + { notifyPackageInfo = + PkgInfo + { pkgInfoId = PackageIdentifier "base" (mkVersion [4, 18, 0, 0]) + , pkgMetadataRevisions = Vector.singleton (CabalFileText "", (timestamp, userActor)) + , pkgTarballRevisions = mempty + } + } + , testGolden "Render NotifyNewRevision" "getNotificationEmails-NotifyNewRevision.golden" $ do + let mkRev rev = (CabalFileText "", (rev, userActor)) + rev0 = (0 * Time.nominalDay) `Time.addUTCTime` timestamp + rev1 = (1 * Time.nominalDay) `Time.addUTCTime` timestamp + rev2 = (2 * Time.nominalDay) `Time.addUTCTime` timestamp + fmap renderMail . getNotificationEmailMocked userWatcher $ + NotifyNewRevision + { notifyPackageId = PackageIdentifier "base" (mkVersion [4, 18, 0, 0]) + , notifyRevisions = map (, userActor) [rev1, rev2] + } + , testGolden "Render NotifyMaintainerUpdate-MaintainerAdded" "getNotificationEmails-NotifyMaintainerUpdate-MaintainerAdded.golden" $ + fmap renderMail . getNotificationEmailMocked userWatcher $ + NotifyMaintainerUpdate + { notifyMaintainerUpdateType = MaintainerAdded + , notifyUserActor = userActor + , notifyUserSubject = userSubject + , notifyPackageName = "base" + , notifyReason = "User is cool" + , notifyUpdatedAt = timestamp + } + , testGolden "Render NotifyMaintainerUpdate-MaintainerRemoved" "getNotificationEmails-NotifyMaintainerUpdate-MaintainerRemoved.golden" $ + fmap renderMail . getNotificationEmailMocked userWatcher $ + NotifyMaintainerUpdate + { notifyMaintainerUpdateType = MaintainerRemoved + , notifyUserActor = userActor + , notifyUserSubject = userSubject + , notifyPackageName = "base" + , notifyReason = "User is no longer cool" + , notifyUpdatedAt = timestamp + } + , testGolden "Render NotifyDocsBuild-success" "getNotificationEmails-NotifyDocsBuild-success.golden" $ + fmap renderMail . getNotificationEmailMocked userWatcher $ + NotifyDocsBuild + { notifyPackageId = PackageIdentifier "base" (mkVersion [4, 18, 0, 0]) + , notifyBuildSuccess = True + } + , testGolden "Render NotifyDocsBuild-failure" "getNotificationEmails-NotifyDocsBuild-failure.golden" $ + fmap renderMail . getNotificationEmailMocked userWatcher $ + NotifyDocsBuild + { notifyPackageId = PackageIdentifier "base" (mkVersion [4, 18, 0, 0]) + , notifyBuildSuccess = False + } + , testGolden "Render NotifyUpdateTags" "getNotificationEmails-NotifyUpdateTags.golden" $ + fmap renderMail . getNotificationEmailMocked userWatcher $ + NotifyUpdateTags + { notifyPackageName = "base" + , notifyAddedTags = Set.fromList . map Tag $ ["bsd3", "library", "prelude"] + , notifyDeletedTags = Set.fromList . map Tag $ ["example", "bad", "foo"] + } + , testGolden "Render NotifyDependencyUpdate-Always" "getNotificationEmails-NotifyDependencyUpdate-Always.golden" $ + fmap renderMail + . getNotificationEmail + testServerEnv + testUserDetailsFeature + allUsers + userWatcher + $ NotifyDependencyUpdate + { notifyPackageId = PackageIdentifier "base" (mkVersion [4, 18, 0, 0]) + , notifyWatchedPackages = [PackageIdentifier "mtl" (mkVersion [2, 3])] + , notifyTriggerBounds = Always + } + , testGolden "Render NotifyDependencyUpdate-NewIncompatibility" "getNotificationEmails-NotifyDependencyUpdate-NewIncompatibility.golden" $ + fmap renderMail + . getNotificationEmail + testServerEnv + testUserDetailsFeature + allUsers + userWatcher + $ NotifyDependencyUpdate + { notifyPackageId = PackageIdentifier "base" (mkVersion [4, 18, 0, 0]) + , notifyWatchedPackages = [PackageIdentifier "mtl" (mkVersion [2, 3])] + , notifyTriggerBounds = NewIncompatibility + } + , testGolden "Render NotifyDependencyUpdate-BoundsOutOfRange" "getNotificationEmails-NotifyDependencyUpdate-BoundsOutOfRange.golden" $ + fmap renderMail + . getNotificationEmail + testServerEnv + testUserDetailsFeature + allUsers + userWatcher + $ NotifyDependencyUpdate + { notifyPackageId = PackageIdentifier "base" (mkVersion [4, 18, 0, 0]) + , notifyWatchedPackages = [PackageIdentifier "mtl" (mkVersion [2, 3])] + , notifyTriggerBounds = BoundsOutOfRange + } + , testGolden "Render NotifyVouchingCompleted" "getNotificationEmails-NotifyVouchingCompleted.golden" $ + fmap renderMail $ getNotificationEmailMocked userWatcher NotifyVouchingCompleted + , testGolden "Render general notifications in single batched email" "getNotificationEmails-batched.golden" $ do + emails <- + getNotificationEmailsMocked . map (userWatcher,) $ + [ NotifyNewRevision + { notifyPackageId = PackageIdentifier "base" (mkVersion [4, 18, 0, 0]) + , notifyRevisions = [(timestamp, userActor)] + } + , NotifyDocsBuild + { notifyPackageId = PackageIdentifier "base" (mkVersion [4, 18, 0, 0]) + , notifyBuildSuccess = True + } + , NotifyUpdateTags + { notifyPackageName = "base" + , notifyAddedTags = Set.fromList [Tag "newtag"] + , notifyDeletedTags = Set.fromList [Tag "oldtag"] + } + ] + case emails of + [email] -> pure $ renderMail email + _ -> error $ "Emails were not batched: " ++ show emails + ] + where + -- If adding a new constructor here, make sure to do the following: + -- * update genNotification + -- * add a golden test above + -- * add the golden file to hackage-server.cabal + _allNotificationTypes = \case + NotifyNewVersion{} -> () + NotifyNewRevision{} -> () + NotifyMaintainerUpdate{} -> () + NotifyDocsBuild{} -> () + NotifyUpdateTags{} -> () + NotifyDependencyUpdate{} -> () + NotifyVouchingCompleted{} -> () + + isGeneral = \case + NotifyNewVersion{} -> True + NotifyNewRevision{} -> True + NotifyMaintainerUpdate{} -> True + NotifyDocsBuild{} -> True + NotifyUpdateTags{} -> True + NotifyDependencyUpdate{} -> False + NotifyVouchingCompleted{} -> True + + -- userWatcher = user getting the notification + -- userActor = user that did the action + -- userSubject = user the action is about + ((userWatcher, userActor, userSubject), allUsers) = + (`State.runState` Users.emptyUsers) $ do + let addUser name = State.StateT $ \users0 -> + case Users.addUserEnabled (UserName name) (UserAuth $ PasswdHash "") users0 of + Right (users1, uid) -> pure (uid, users1) + Left _ -> error $ "Got duplicate username: " <> name + (,,) + <$> addUser "user-watcher" + <*> addUser "user-actor" + <*> addUser "user-subject" + + getNotificationEmail env details users uid notif = + getNotificationEmails env details users [(uid, notif)] >>= \case + [email] -> pure email + _ -> error "Did not get exactly one email" + + testServerEnv = + ServerEnv + { serverBaseURI = fromJust $ parseURI "https://hackage.haskell.org" + } + testUserDetailsFeature = + UserDetailsFeature + { queryUserDetails = \uid -> + pure $ do + guard $ uid == userWatcher + Just + AccountDetails + { accountName = "user-watcher" + , accountContactEmail = "user-watcher@example.com" + , accountKind = Nothing + , accountAdminNotes = "" + } + } + getNotificationEmailsMocked = + getNotificationEmails + testServerEnv + testUserDetailsFeature + allUsers + getNotificationEmailMocked = + getNotificationEmail + testServerEnv + testUserDetailsFeature + allUsers + + renderMail = fst . Mail.renderMail (mkStdGen 0) + timestamp = Time.UTCTime (Time.fromGregorian 2020 1 1) 0 + + genNotification = + Gen.choice + [ NotifyNewVersion + <$> genPkgInfo + , NotifyNewRevision + <$> genPackageId + <*> Gen.list (Range.linear 1 5) genUploadInfo + , NotifyMaintainerUpdate + <$> Gen.element [MaintainerAdded, MaintainerRemoved] + <*> genNonExistentUserId + <*> genNonExistentUserId + <*> genPackageName + <*> Gen.text (Range.linear 1 20) Gen.unicode + <*> genUTCTime + , NotifyDocsBuild + <$> genPackageId + <*> Gen.bool + , NotifyUpdateTags + <$> genPackageName + <*> Gen.set (Range.linear 1 5) genTag + <*> Gen.set (Range.linear 1 5) genTag + , NotifyDependencyUpdate + <$> genPackageId + <*> Gen.list (Range.linear 1 10) genPackageId + <*> Gen.element [Always, NewIncompatibility, BoundsOutOfRange] + , pure NotifyVouchingCompleted + ] + + genPackageName = mkPackageName <$> Gen.string (Range.linear 1 30) Gen.unicode + genVersion = mkVersion <$> Gen.list (Range.linear 1 4) (Gen.int $ Range.linear 0 50) + genPackageId = PackageIdentifier <$> genPackageName <*> genVersion + genCabalFileText = CabalFileText . ByteStringL.fromStrict <$> Gen.utf8 (Range.linear 0 50000) Gen.unicode + genNonExistentUserId = UserId <$> Gen.int (Range.linear (-1000) (-1)) + genUploadInfo = (,) <$> genUTCTime <*> genNonExistentUserId + genTag = Tag <$> Gen.string (Range.linear 1 10) Gen.unicode + genPkgInfo = + PkgInfo + <$> genPackageId + <*> genVec (Range.linear 1 5) ((,) <$> genCabalFileText <*> genUploadInfo) + <*> pure Vector.empty -- ignoring pkgTarballRevisions for now + genPacks :: PropertyT IO [Package TestPackage] genPacks = do numPacks <- forAll $ Gen.int (Range.linear 1 10) @@ -339,5 +663,26 @@ hedgehogTests = , ("prop_csvBackupRoundtrips", prop_csvBackupRoundtrips) ] +testGolden :: TestName -> FilePath -> IO Lazy.ByteString -> TestTree +testGolden name fp = goldenVsString name ("tests/golden/ReverseDependenciesTest/" <> fp) + main :: IO () main = defaultMain allTests + +{----- Utilities -----} + +genUTCTime :: MonadGen m => m Time.UTCTime +genUTCTime = + Time.UTCTime + <$> genDay + <*> genDiffTime + where + genDay = + Time.fromGregorian + <$> Gen.integral (Range.linear 0 3000) + <*> Gen.int (Range.linear 1 12) + <*> Gen.int (Range.linear 1 31) + genDiffTime = realToFrac <$> Gen.double (Range.linearFrac 0 86400) + +genVec :: MonadGen m => Range Int -> m a -> m (Vector a) +genVec r = fmap Vector.fromList . Gen.list r diff --git a/tests/VouchTest.hs b/tests/VouchTest.hs new file mode 100644 index 000000000..ece72d578 --- /dev/null +++ b/tests/VouchTest.hs @@ -0,0 +1,96 @@ +module Main where + +import Data.Time (UTCTime(UTCTime), fromGregorian) + +import Distribution.Server.Features.Vouch (VouchError(..), VouchSuccess(..), judgeVouch) +import Distribution.Server.Users.UserIdSet (fromList) +import Distribution.Server.Users.Types (UserId(UserId)) + +import Test.Tasty (TestTree, defaultMain, testGroup) +import Test.Tasty.HUnit (assertEqual, testCase) + +allTests :: TestTree +allTests = testGroup "VouchTest" + [ testCase "happy path, vouch added, but more vouches needed" $ do + let ref = Right (AddVouchIncomplete 1) + voucher = UserId 1 + vouchee = UserId 2 + assertEqual "must match" ref $ + judgeVouch + (fromList [voucher]) -- uploaders. Can't vouch if user is not a voucher + (UTCTime (fromGregorian 2020 1 1) 0) + vouchee + [] -- vouchers for voucher. If this short enough, voucher is assumed to be old enough to vouch themselves. + [] -- no existing vouchers + voucher + , testCase "happy path, vouch added, no more vouches needed" $ do + let ref = Right AddVouchComplete + voucher = UserId 1 + vouchee = UserId 2 + otherVoucherForVouchee = UserId 4 + assertEqual "must match" ref $ + judgeVouch + (fromList [voucher]) + (UTCTime (fromGregorian 2020 1 1) 0) + vouchee + [] + [(otherVoucherForVouchee, UTCTime (fromGregorian 2020 1 1) 0)] + voucher + , testCase "non-uploader tried to vouch" $ do + let ref = Left NotAnUploader + voucher = UserId 1 + vouchee = UserId 2 + assertEqual "must match" ref $ + judgeVouch + (fromList []) -- empty. Should contain voucher for operation to proceed. + (UTCTime (fromGregorian 2020 1 1) 0) + vouchee + [] + [] + voucher + , testCase "voucher too new" $ do + let ref = Left You'reTooNew + voucher = UserId 1 + vouchee = UserId 2 + fstVoucherForVoucher = UserId 3 + sndVoucherForVoucher = UserId 4 + now = UTCTime (fromGregorian 2020 1 1) 0 + assertEqual "must match" ref $ + judgeVouch + (fromList [voucher]) + now + vouchee + [ (fstVoucherForVoucher, now) -- These two timestamps are too new + , (sndVoucherForVoucher, now) + ] + [] + voucher + , testCase "vouchee already uploader" $ do + let ref = Left VoucheeAlreadyUploader + voucher = UserId 1 + vouchee = UserId 2 + now = UTCTime (fromGregorian 2020 1 1) 0 + assertEqual "must match" ref $ + judgeVouch + (fromList [voucher, vouchee]) -- vouchee is here. So they're already an uploader. + now + vouchee + [] + [] + voucher + , testCase "already vouched" $ do + let ref = Left YouAlreadyVouched + voucher = UserId 1 + vouchee = UserId 2 + assertEqual "must match" ref $ + judgeVouch + (fromList [voucher]) + (UTCTime (fromGregorian 2020 1 1) 0) + vouchee + [] + [(voucher, UTCTime (fromGregorian 2020 1 1) 0)] -- voucher is here. So they already vouched + voucher + ] + +main :: IO () +main = defaultMain allTests diff --git a/tests/golden/ReverseDependenciesTest/getNotificationEmails-NotifyDependencyUpdate-Always.golden b/tests/golden/ReverseDependenciesTest/getNotificationEmails-NotifyDependencyUpdate-Always.golden new file mode 100644 index 000000000..03900ecaf --- /dev/null +++ b/tests/golden/ReverseDependenciesTest/getNotificationEmails-NotifyDependencyUpdate-Always.golden @@ -0,0 +1,51 @@ +From: =?utf-8?Q?Hackage_website?= +To: =?utf-8?Q?user-watcher?= +Subject: [Hackage] Dependency Update: base-4.18.0.0 +MIME-Version: 1.0 +Content-Type: multipart/alternative; boundary="YIYrWcf3to" + +--YIYrWcf3to +Content-Type: text/plain; charset=utf-8 +Content-Transfer-Encoding: quoted-printable + +The dependency base-4=2E18=2E0=2E0 (https://hackage=2Ehaskell=2Eorg/package= +/base-4=2E18=2E0=2E0) has been uploaded or revised=2E + +You have requested to be notified for each upload or revision of a dependen= +cy=2E + +These are your packages that depend on base: + +* mtl-2=2E3 (https://hackage=2Ehaskell=2Eorg/package/mtl-2=2E3) + +You can adjust your notification preferences at +https://hackage=2Ehaskell=2Eorg/user/user-watcher/notify (https://hackage= +=2Ehaskell=2Eorg/user/user-watcher/notify) + + +--YIYrWcf3to +Content-Type: text/html; charset=utf-8 +Content-Transfer-Encoding: quoted-printable + + +

    +The dependency base-4=2E18=2E0=2E0 has been uploaded or revised=2E +

    +

    +You have requested to be notified for each upload or revision of a dependen= +cy=2E +

    +

    +These are your packages that depend on base: +

    + +

    +You can adjust your notification preferences at +
    = +https://hackage=2Ehaskell=2Eorg/user/user-watcher/notify +

    +--YIYrWcf3to-- \ No newline at end of file diff --git a/tests/golden/ReverseDependenciesTest/getNotificationEmails-NotifyDependencyUpdate-BoundsOutOfRange.golden b/tests/golden/ReverseDependenciesTest/getNotificationEmails-NotifyDependencyUpdate-BoundsOutOfRange.golden new file mode 100644 index 000000000..f02b34387 --- /dev/null +++ b/tests/golden/ReverseDependenciesTest/getNotificationEmails-NotifyDependencyUpdate-BoundsOutOfRange.golden @@ -0,0 +1,51 @@ +From: =?utf-8?Q?Hackage_website?= +To: =?utf-8?Q?user-watcher?= +Subject: [Hackage] Dependency Update: base-4.18.0.0 +MIME-Version: 1.0 +Content-Type: multipart/alternative; boundary="YIYrWcf3to" + +--YIYrWcf3to +Content-Type: text/plain; charset=utf-8 +Content-Transfer-Encoding: quoted-printable + +The dependency base-4=2E18=2E0=2E0 (https://hackage=2Ehaskell=2Eorg/package= +/base-4=2E18=2E0=2E0) has been uploaded or revised=2E + +You have requested to be notified when a dependency isn't accepted by any o= +f your maintained packages=2E + +These are your packages that require base but don't accept 4=2E18=2E0=2E0: + +* mtl-2=2E3 (https://hackage=2Ehaskell=2Eorg/package/mtl-2=2E3) + +You can adjust your notification preferences at +https://hackage=2Ehaskell=2Eorg/user/user-watcher/notify (https://hackage= +=2Ehaskell=2Eorg/user/user-watcher/notify) + + +--YIYrWcf3to +Content-Type: text/html; charset=utf-8 +Content-Transfer-Encoding: quoted-printable + + +

    +The dependency base-4=2E18=2E0=2E0 has been uploaded or revised=2E +

    +

    +You have requested to be notified when a dependency isn't accepted by any o= +f your maintained packages=2E +

    +

    +These are your packages that require base but don't accept 4=2E18=2E0=2E0: +

    + +

    +You can adjust your notification preferences at +
    = +https://hackage=2Ehaskell=2Eorg/user/user-watcher/notify +

    +--YIYrWcf3to-- \ No newline at end of file diff --git a/tests/golden/ReverseDependenciesTest/getNotificationEmails-NotifyDependencyUpdate-NewIncompatibility.golden b/tests/golden/ReverseDependenciesTest/getNotificationEmails-NotifyDependencyUpdate-NewIncompatibility.golden new file mode 100644 index 000000000..8c05de87a --- /dev/null +++ b/tests/golden/ReverseDependenciesTest/getNotificationEmails-NotifyDependencyUpdate-NewIncompatibility.golden @@ -0,0 +1,53 @@ +From: =?utf-8?Q?Hackage_website?= +To: =?utf-8?Q?user-watcher?= +Subject: [Hackage] Dependency Update: base-4.18.0.0 +MIME-Version: 1.0 +Content-Type: multipart/alternative; boundary="YIYrWcf3to" + +--YIYrWcf3to +Content-Type: text/plain; charset=utf-8 +Content-Transfer-Encoding: quoted-printable + +The dependency base-4=2E18=2E0=2E0 (https://hackage=2Ehaskell=2Eorg/package= +/base-4=2E18=2E0=2E0) has been uploaded or revised=2E + +You have requested to be notified when a dependency isn't accepted by any o= +f your maintained packages=2E + +The following packages require base but don't accept 4=2E18=2E0=2E0 (they d= +o accept the second-highest version): + +* mtl-2=2E3 (https://hackage=2Ehaskell=2Eorg/package/mtl-2=2E3) + +You can adjust your notification preferences at +https://hackage=2Ehaskell=2Eorg/user/user-watcher/notify (https://hackage= +=2Ehaskell=2Eorg/user/user-watcher/notify) + + +--YIYrWcf3to +Content-Type: text/html; charset=utf-8 +Content-Transfer-Encoding: quoted-printable + + +

    +The dependency base-4=2E18=2E0=2E0 has been uploaded or revised=2E +

    +

    +You have requested to be notified when a dependency isn't accepted by any o= +f your maintained packages=2E +

    +

    +The following packages require base but don't accept 4=2E18=2E0=2E0 (they d= +o accept the second-highest version): +

    + +

    +You can adjust your notification preferences at +
    = +https://hackage=2Ehaskell=2Eorg/user/user-watcher/notify +

    +--YIYrWcf3to-- \ No newline at end of file diff --git a/tests/golden/ReverseDependenciesTest/getNotificationEmails-NotifyDocsBuild-failure.golden b/tests/golden/ReverseDependenciesTest/getNotificationEmails-NotifyDocsBuild-failure.golden new file mode 100644 index 000000000..a328aca46 --- /dev/null +++ b/tests/golden/ReverseDependenciesTest/getNotificationEmails-NotifyDocsBuild-failure.golden @@ -0,0 +1,35 @@ +From: =?utf-8?Q?Hackage_website?= +To: =?utf-8?Q?user-watcher?= +Subject: [Hackage] Maintainer Notifications +MIME-Version: 1.0 +Content-Type: multipart/alternative; boundary="YIYrWcf3to" + +--YIYrWcf3to +Content-Type: text/plain; charset=utf-8 +Content-Transfer-Encoding: quoted-printable + +Package doc build for base-4=2E18=2E0=2E0 (https://hackage=2Ehaskell=2Eorg/= +package/base-4=2E18=2E0=2E0): +Build failed=2E + +You can adjust your notification preferences at +https://hackage=2Ehaskell=2Eorg/user/user-watcher/notify (https://hackage= +=2Ehaskell=2Eorg/user/user-watcher/notify) + + +--YIYrWcf3to +Content-Type: text/html; charset=utf-8 +Content-Transfer-Encoding: quoted-printable + + +

    +Package doc build for base-4=2E18=2E0=2E0: +
    Build failed=2E +

    +

    +You can adjust your notification preferences at +
    = +https://hackage=2Ehaskell=2Eorg/user/user-watcher/notify +

    +--YIYrWcf3to-- \ No newline at end of file diff --git a/tests/golden/ReverseDependenciesTest/getNotificationEmails-NotifyDocsBuild-success.golden b/tests/golden/ReverseDependenciesTest/getNotificationEmails-NotifyDocsBuild-success.golden new file mode 100644 index 000000000..aa6392fff --- /dev/null +++ b/tests/golden/ReverseDependenciesTest/getNotificationEmails-NotifyDocsBuild-success.golden @@ -0,0 +1,35 @@ +From: =?utf-8?Q?Hackage_website?= +To: =?utf-8?Q?user-watcher?= +Subject: [Hackage] Maintainer Notifications +MIME-Version: 1.0 +Content-Type: multipart/alternative; boundary="YIYrWcf3to" + +--YIYrWcf3to +Content-Type: text/plain; charset=utf-8 +Content-Transfer-Encoding: quoted-printable + +Package doc build for base-4=2E18=2E0=2E0 (https://hackage=2Ehaskell=2Eorg/= +package/base-4=2E18=2E0=2E0): +Build successful=2E + +You can adjust your notification preferences at +https://hackage=2Ehaskell=2Eorg/user/user-watcher/notify (https://hackage= +=2Ehaskell=2Eorg/user/user-watcher/notify) + + +--YIYrWcf3to +Content-Type: text/html; charset=utf-8 +Content-Transfer-Encoding: quoted-printable + + +

    +Package doc build for base-4=2E18=2E0=2E0: +
    Build successful=2E +

    +

    +You can adjust your notification preferences at +
    = +https://hackage=2Ehaskell=2Eorg/user/user-watcher/notify +

    +--YIYrWcf3to-- \ No newline at end of file diff --git a/tests/golden/ReverseDependenciesTest/getNotificationEmails-NotifyMaintainerUpdate-MaintainerAdded.golden b/tests/golden/ReverseDependenciesTest/getNotificationEmails-NotifyMaintainerUpdate-MaintainerAdded.golden new file mode 100644 index 000000000..e3777cc93 --- /dev/null +++ b/tests/golden/ReverseDependenciesTest/getNotificationEmails-NotifyMaintainerUpdate-MaintainerAdded.golden @@ -0,0 +1,38 @@ +From: =?utf-8?Q?Hackage_website?= +To: =?utf-8?Q?user-watcher?= +Subject: [Hackage] Maintainer Notifications +MIME-Version: 1.0 +Content-Type: multipart/alternative; boundary="YIYrWcf3to" + +--YIYrWcf3to +Content-Type: text/plain; charset=utf-8 +Content-Transfer-Encoding: quoted-printable + +Group modified by user-actor [Wed Jan 1 00:00:00 UTC 2020]: + +* user-subject added to maintainers for base +* Reason: User is cool + +You can adjust your notification preferences at +https://hackage=2Ehaskell=2Eorg/user/user-watcher/notify (https://hackage= +=2Ehaskell=2Eorg/user/user-watcher/notify) + + +--YIYrWcf3to +Content-Type: text/html; charset=utf-8 +Content-Transfer-Encoding: quoted-printable + + +

    +Group modified by user-actor [Wed Jan 1 00:00:00 UTC 2020]: +

    +
      +
    • user-subject added to maintainers for base
      • +
    • Reason: User is cool
      • +
    +

    +You can adjust your notification preferences at +
    = +https://hackage=2Ehaskell=2Eorg/user/user-watcher/notify +

    +--YIYrWcf3to-- \ No newline at end of file diff --git a/tests/golden/ReverseDependenciesTest/getNotificationEmails-NotifyMaintainerUpdate-MaintainerRemoved.golden b/tests/golden/ReverseDependenciesTest/getNotificationEmails-NotifyMaintainerUpdate-MaintainerRemoved.golden new file mode 100644 index 000000000..a5a4c91f7 --- /dev/null +++ b/tests/golden/ReverseDependenciesTest/getNotificationEmails-NotifyMaintainerUpdate-MaintainerRemoved.golden @@ -0,0 +1,38 @@ +From: =?utf-8?Q?Hackage_website?= +To: =?utf-8?Q?user-watcher?= +Subject: [Hackage] Maintainer Notifications +MIME-Version: 1.0 +Content-Type: multipart/alternative; boundary="YIYrWcf3to" + +--YIYrWcf3to +Content-Type: text/plain; charset=utf-8 +Content-Transfer-Encoding: quoted-printable + +Group modified by user-actor [Wed Jan 1 00:00:00 UTC 2020]: + +* user-subject removed from maintainers for base +* Reason: User is no longer cool + +You can adjust your notification preferences at +https://hackage=2Ehaskell=2Eorg/user/user-watcher/notify (https://hackage= +=2Ehaskell=2Eorg/user/user-watcher/notify) + + +--YIYrWcf3to +Content-Type: text/html; charset=utf-8 +Content-Transfer-Encoding: quoted-printable + + +

    +Group modified by user-actor [Wed Jan 1 00:00:00 UTC 2020]: +

    +
      +
    • user-subject removed from maintainers for base
      • +
    • Reason: User is no longer cool
      • +
    +

    +You can adjust your notification preferences at +
    = +https://hackage=2Ehaskell=2Eorg/user/user-watcher/notify +

    +--YIYrWcf3to-- \ No newline at end of file diff --git a/tests/golden/ReverseDependenciesTest/getNotificationEmails-NotifyNewRevision.golden b/tests/golden/ReverseDependenciesTest/getNotificationEmails-NotifyNewRevision.golden new file mode 100644 index 000000000..02e1aca6f --- /dev/null +++ b/tests/golden/ReverseDependenciesTest/getNotificationEmails-NotifyNewRevision.golden @@ -0,0 +1,40 @@ +From: =?utf-8?Q?Hackage_website?= +To: =?utf-8?Q?user-watcher?= +Subject: [Hackage] Maintainer Notifications +MIME-Version: 1.0 +Content-Type: multipart/alternative; boundary="YIYrWcf3to" + +--YIYrWcf3to +Content-Type: text/plain; charset=utf-8 +Content-Transfer-Encoding: quoted-printable + +Package metadata revision(s), base-4=2E18=2E0=2E0 (https://hackage=2Ehaskel= +l=2Eorg/package/base-4=2E18=2E0=2E0): + +* user-actor [Fri Jan 3 00:00:00 UTC 2020] +* user-actor [Thu Jan 2 00:00:00 UTC 2020] + +You can adjust your notification preferences at +https://hackage=2Ehaskell=2Eorg/user/user-watcher/notify (https://hackage= +=2Ehaskell=2Eorg/user/user-watcher/notify) + + +--YIYrWcf3to +Content-Type: text/html; charset=utf-8 +Content-Transfer-Encoding: quoted-printable + + +

    +Package metadata revision(s), base-4=2E18=2E0=2E0: +

    +
      +
    • user-actor [Fri Jan 3 00:00:00 UTC 2020]
      • +
    • user-actor [Thu Jan 2 00:00:00 UTC 2020]
      • +
    +

    +You can adjust your notification preferences at +
    = +https://hackage=2Ehaskell=2Eorg/user/user-watcher/notify +

    +--YIYrWcf3to-- \ No newline at end of file diff --git a/tests/golden/ReverseDependenciesTest/getNotificationEmails-NotifyNewVersion.golden b/tests/golden/ReverseDependenciesTest/getNotificationEmails-NotifyNewVersion.golden new file mode 100644 index 000000000..9a9cf7cfa --- /dev/null +++ b/tests/golden/ReverseDependenciesTest/getNotificationEmails-NotifyNewVersion.golden @@ -0,0 +1,34 @@ +From: =?utf-8?Q?Hackage_website?= +To: =?utf-8?Q?user-watcher?= +Subject: [Hackage] Maintainer Notifications +MIME-Version: 1.0 +Content-Type: multipart/alternative; boundary="YIYrWcf3to" + +--YIYrWcf3to +Content-Type: text/plain; charset=utf-8 +Content-Transfer-Encoding: quoted-printable + +Package upload, base-4=2E18=2E0=2E0 (https://hackage=2Ehaskell=2Eorg/packag= +e/base-4=2E18=2E0=2E0), by user-actor [Wed Jan 1 00:00:00 UTC 2020] + +You can adjust your notification preferences at +https://hackage=2Ehaskell=2Eorg/user/user-watcher/notify (https://hackage= +=2Ehaskell=2Eorg/user/user-watcher/notify) + + +--YIYrWcf3to +Content-Type: text/html; charset=utf-8 +Content-Transfer-Encoding: quoted-printable + + +

    +Package upload, base-4=2E18=2E0=2E0, by user-actor [Wed Jan 1 00:00:00 = +UTC 2020] +

    +

    +You can adjust your notification preferences at +
    = +https://hackage=2Ehaskell=2Eorg/user/user-watcher/notify +

    +--YIYrWcf3to-- \ No newline at end of file diff --git a/tests/golden/ReverseDependenciesTest/getNotificationEmails-NotifyUpdateTags.golden b/tests/golden/ReverseDependenciesTest/getNotificationEmails-NotifyUpdateTags.golden new file mode 100644 index 000000000..b9e473041 --- /dev/null +++ b/tests/golden/ReverseDependenciesTest/getNotificationEmails-NotifyUpdateTags.golden @@ -0,0 +1,38 @@ +From: =?utf-8?Q?Hackage_website?= +To: =?utf-8?Q?user-watcher?= +Subject: [Hackage] Maintainer Notifications +MIME-Version: 1.0 +Content-Type: multipart/alternative; boundary="YIYrWcf3to" + +--YIYrWcf3to +Content-Type: text/plain; charset=utf-8 +Content-Transfer-Encoding: quoted-printable + +Pending tag proposal for base: + +* Additions: bsd3, library, prelude +* Deletions: bad, example, foo + +You can adjust your notification preferences at +https://hackage=2Ehaskell=2Eorg/user/user-watcher/notify (https://hackage= +=2Ehaskell=2Eorg/user/user-watcher/notify) + + +--YIYrWcf3to +Content-Type: text/html; charset=utf-8 +Content-Transfer-Encoding: quoted-printable + + +

    +Pending tag proposal for base: +

    +
      +
    • Additions: bsd3, library, prelude
      • +
    • Deletions: bad, example, foo
      • +
    +

    +You can adjust your notification preferences at +
    = +https://hackage=2Ehaskell=2Eorg/user/user-watcher/notify +

    +--YIYrWcf3to-- \ No newline at end of file diff --git a/tests/golden/ReverseDependenciesTest/getNotificationEmails-NotifyVouchingCompleted.golden b/tests/golden/ReverseDependenciesTest/getNotificationEmails-NotifyVouchingCompleted.golden new file mode 100644 index 000000000..b45e64f28 --- /dev/null +++ b/tests/golden/ReverseDependenciesTest/getNotificationEmails-NotifyVouchingCompleted.golden @@ -0,0 +1,35 @@ +From: =?utf-8?Q?Hackage_website?= +To: =?utf-8?Q?user-watcher?= +Subject: [Hackage] Maintainer Notifications +MIME-Version: 1.0 +Content-Type: multipart/alternative; boundary="YIYrWcf3to" + +--YIYrWcf3to +Content-Type: text/plain; charset=utf-8 +Content-Transfer-Encoding: quoted-printable + +You have received all necessary endorsements=2E You have been added the the= + 'uploaders' group=2E You can now upload packages to Hackage=2E Note that p= +ackages cannot be deleted, so be careful=2E + +You can adjust your notification preferences at +https://hackage=2Ehaskell=2Eorg/user/user-watcher/notify (https://hackage= +=2Ehaskell=2Eorg/user/user-watcher/notify) + + +--YIYrWcf3to +Content-Type: text/html; charset=utf-8 +Content-Transfer-Encoding: quoted-printable + + +

    +You have received all necessary endorsements=2E You have been added the the= + 'uploaders' group=2E You can now upload packages to Hackage=2E Note that p= +ackages cannot be deleted, so be careful=2E +

    +

    +You can adjust your notification preferences at +
    = +https://hackage=2Ehaskell=2Eorg/user/user-watcher/notify +

    +--YIYrWcf3to-- \ No newline at end of file diff --git a/tests/golden/ReverseDependenciesTest/getNotificationEmails-batched.golden b/tests/golden/ReverseDependenciesTest/getNotificationEmails-batched.golden new file mode 100644 index 000000000..d3d6811de --- /dev/null +++ b/tests/golden/ReverseDependenciesTest/getNotificationEmails-batched.golden @@ -0,0 +1,59 @@ +From: =?utf-8?Q?Hackage_website?= +To: =?utf-8?Q?user-watcher?= +Subject: [Hackage] Maintainer Notifications +MIME-Version: 1.0 +Content-Type: multipart/alternative; boundary="YIYrWcf3to" + +--YIYrWcf3to +Content-Type: text/plain; charset=utf-8 +Content-Transfer-Encoding: quoted-printable + +Pending tag proposal for base: + +* Additions: newtag +* Deletions: oldtag + +Package doc build for base-4=2E18=2E0=2E0 (https://hackage=2Ehaskell=2Eorg/= +package/base-4=2E18=2E0=2E0): +Build successful=2E + +Package metadata revision(s), base-4=2E18=2E0=2E0 (https://hackage=2Ehaskel= +l=2Eorg/package/base-4=2E18=2E0=2E0): + +* user-actor [Wed Jan 1 00:00:00 UTC 2020] + +You can adjust your notification preferences at +https://hackage=2Ehaskell=2Eorg/user/user-watcher/notify (https://hackage= +=2Ehaskell=2Eorg/user/user-watcher/notify) + + +--YIYrWcf3to +Content-Type: text/html; charset=utf-8 +Content-Transfer-Encoding: quoted-printable + + +

    +Pending tag proposal for base: +

    +
      +
    • Additions: newtag
      • +
    • Deletions: oldtag
      • +
    +

    +Package doc build for base-4=2E18=2E0=2E0: +
    Build successful=2E +

    +

    +Package metadata revision(s), base-4=2E18=2E0=2E0: +

    +
      +
    • user-actor [Wed Jan 1 00:00:00 UTC 2020]
      • +
    +

    +You can adjust your notification preferences at +
    = +https://hackage=2Ehaskell=2Eorg/user/user-watcher/notify +

    +--YIYrWcf3to-- \ No newline at end of file