From abe21276a66c86930ed8e4119c64e0a7905ecd80 Mon Sep 17 00:00:00 2001 From: Janus Troelsen Date: Sun, 21 May 2023 11:40:36 -0500 Subject: [PATCH 01/71] Email notification: Disjunction across bounds for same package --- .../Server/Features/UserNotify.hs | 26 ++++++++++++++++++- tests/RevDepCommon.hs | 9 ++++++- tests/ReverseDependenciesTest.hs | 18 ++++++++++++- 3 files changed, 50 insertions(+), 3 deletions(-) diff --git a/src/Distribution/Server/Features/UserNotify.hs b/src/Distribution/Server/Features/UserNotify.hs index 88941ec94..34c066371 100644 --- a/src/Distribution/Server/Features/UserNotify.hs +++ b/src/Distribution/Server/Features/UserNotify.hs @@ -494,7 +494,14 @@ dependencyReleaseEmails userSetIdForPackage index (ReverseIndex revs nodemap dep (userId, Just NotifyPref{..}) <- zip ids mPrefs guard $ not notifyOptOut guard notifyDependencyForMaintained - Just depList <- [mDepList] + + Just depListWithCollisions <- [mDepList] + -- Remove collisions on the same PackageName, amassed e.g. across + -- multiple conditional branches. The branches could be from either + -- side of an 'if' block conditioned on a flag. If either of them + -- permits the newly released version, avoid sending the notification. + let depList = unionSamePackageName depListWithCollisions + case notifyDependencyTriggerBounds of NewIncompatibility -> do let allNewUploadPkgInfos = PackageIndex.lookupPackageName index (pkgName pkgId) @@ -532,6 +539,23 @@ dependencyReleaseEmails userSetIdForPackage index (ReverseIndex revs nodemap dep | otherwise = True newestVersion = pkgVersion pkgId +-- | Boolean OR on ranges across dependencies on the same PackageName +unionSamePackageName :: [Dependency] -> [Dependency] +unionSamePackageName collisions = + let + maps = [Map.singleton depName dep | dep@(Dependency depName _ _) <- collisions] + disjunct :: Dependency -> Dependency -> Dependency + disjunct + (Dependency fName fRange fLibraries) + (Dependency _ gRange gLibraries) = + mkDependency + fName + (unionVersionRanges fRange gRange) + (fLibraries <> gLibraries) + disjunctions = Map.unionsWith disjunct maps + in + Map.elems disjunctions + pkgInfoToPkgId :: PkgInfo -> PackageIdentifier pkgInfoToPkgId pkgInfo = PackageIdentifier (packageName pkgInfo) (packageVersion pkgInfo) diff --git a/tests/RevDepCommon.hs b/tests/RevDepCommon.hs index a7f79ff9c..9a9ac3330 100644 --- a/tests/RevDepCommon.hs +++ b/tests/RevDepCommon.hs @@ -31,6 +31,13 @@ packToPkgInfo Package {pName, pVersion, pDeps} = mkPackage :: PackageName -> [Int] -> [BSL.ByteString] -> PkgInfo mkPackage name intVersion depends = + mkPackageWithCabalFileSuffix name intVersion $ + if depends /= [] + then "library\n build-depends: " <> BSL.intercalate "," depends + else "" + +mkPackageWithCabalFileSuffix :: PackageName -> [Int] -> BSL.ByteString -> PkgInfo +mkPackageWithCabalFileSuffix name intVersion cabalFileSuffix = let version = mkVersion intVersion -- e.g. "2.3" for [2,3] @@ -41,7 +48,7 @@ mkPackage name intVersion depends = \name: " <> BSL.fromStrict (Char8.pack $ unPackageName name) <> "\n\ \version: " <> dotVersion <> "\n" cabalFile :: CabalFileText - cabalFile = CabalFileText $ cabalFilePrefix <> if depends /= [] then "library\n build-depends: " <> BSL.intercalate "," depends else "" + cabalFile = CabalFileText $ cabalFilePrefix <> cabalFileSuffix in PkgInfo (PackageIdentifier name version) diff --git a/tests/ReverseDependenciesTest.hs b/tests/ReverseDependenciesTest.hs index 0e74a8d8e..030eb8d08 100644 --- a/tests/ReverseDependenciesTest.hs +++ b/tests/ReverseDependenciesTest.hs @@ -31,7 +31,7 @@ import qualified Hedgehog.Range as Range import qualified Hedgehog.Gen as Gen import Hedgehog ((===), Group(Group), MonadGen, Property, PropertyT, checkSequential, forAll, property) -import RevDepCommon (Package(..), TestPackage(..), mkPackage, packToPkgInfo) +import RevDepCommon (Package(..), TestPackage(..), mkPackage, mkPackageWithCabalFileSuffix, packToPkgInfo) mtlBeelineLens :: [PkgInfo] mtlBeelineLens = @@ -214,6 +214,22 @@ allTests = testGroup "ReverseDependenciesTest" "dependencyReleaseEmails(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" + mempty -- The two branches below should get OR'd and therefore the dependency is not out of bounds + (runWithPref + (pref BoundsOutOfRange) + (PackageIndex.fromList + [ mkPackage "base" [4,14] [] + , mkPackage "base" [4,15] [] + , mkPackageWithCabalFileSuffix "mtl" [2,3] + "library\n\ + \ if arch(arm)\n\ + \ build-depends: base >= 4.14 && < 4.15\n\ + \ else\n\ + \ build-depends: base >= 4.15 && < 4.16" + ]) + base4_15) , testCase "hedgehogTests" $ do res <- hedgehogTests assertEqual "hedgehog test pass" True res From 6569675d6e8509b9287431e6e55faa49d5087c18 Mon Sep 17 00:00:00 2001 From: Peter Becich Date: Sun, 21 May 2023 14:48:41 -0700 Subject: [PATCH 02/71] Hackage CSS theme takes precedence over `datatables.min.css` --- datafiles/templates/Html/candidate-index.html.st | 2 +- datafiles/templates/Html/table-interface.html.st | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/datafiles/templates/Html/candidate-index.html.st b/datafiles/templates/Html/candidate-index.html.st index 60c56a70c..96c85f2cf 100644 --- a/datafiles/templates/Html/candidate-index.html.st +++ b/datafiles/templates/Html/candidate-index.html.st @@ -2,9 +2,9 @@ - $hackageCssTheme()$ + $hackageCssTheme()$ Package candidates | Hackage diff --git a/datafiles/templates/Html/table-interface.html.st b/datafiles/templates/Html/table-interface.html.st index f08fb67eb..72accfad2 100644 --- a/datafiles/templates/Html/table-interface.html.st +++ b/datafiles/templates/Html/table-interface.html.st @@ -2,13 +2,13 @@ - $hackageCssTheme()$ $if(!noDatatable)$ $endif$ + $hackageCssTheme()$ All packages by name | Hackage From cc6ecceba685b009b162cd876cd6196805c719e1 Mon Sep 17 00:00:00 2001 From: Peter Becich Date: Sun, 28 May 2023 12:45:53 -0700 Subject: [PATCH 03/71] colors for paginate buttons and dataTables length, filter text --- datafiles/static/hackage.css | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/datafiles/static/hackage.css b/datafiles/static/hackage.css index 1e0523b82..a640d3d31 100644 --- a/datafiles/static/hackage.css +++ b/datafiles/static/hackage.css @@ -1079,6 +1079,12 @@ table.fancy th { table.dataTable.compact.fancy tbody td { background: #333; } + div#table_length.dataTables_length { + color: #fff + } + div#table_filter.dataTables_filter { + color: #fff + } } table.fancy td, table.properties td, @@ -1163,6 +1169,9 @@ a.deprecated[href]:visited { .paginator a { color: #474747; } + .paginate_button { + background-color: #979797; + } } @media (prefers-color-scheme: light) { From eef83438545904205eac9f2db4d7dc380a9f817c Mon Sep 17 00:00:00 2001 From: Tristan de Cacqueray Date: Thu, 1 Jun 2023 22:16:00 +0000 Subject: [PATCH 04/71] Remove trailing whitespace on package links (#1204) This change fixes the link as described in this issue: https://stackoverflow.com/a/73074209 --- datafiles/templates/Html/package-page.html.st | 10 +++------- 1 file changed, 3 insertions(+), 7 deletions(-) diff --git a/datafiles/templates/Html/package-page.html.st b/datafiles/templates/Html/package-page.html.st index 72faee82d..cfa131b8d 100644 --- a/datafiles/templates/Html/package-page.html.st +++ b/datafiles/templates/Html/package-page.html.st @@ -31,7 +31,7 @@

$package.name$$if(package.optional.hasSynopsis)$: $package.optional.synopsis$$endif$

[ $tags$ ] - [ Propose Tags ] + [ Propose Tags ]
$if(isDeprecated)$ @@ -187,9 +187,7 @@ Home page - - $package.optional.homepage$ - + $package.optional.homepage$ $endif$ @@ -198,9 +196,7 @@ Bug tracker - - $package.optional.bugTracker$ - + $package.optional.bugTracker$ $endif$ From b9aca8922b97cb5c3a6f9dd69cb5bed1d1ef0103 Mon Sep 17 00:00:00 2001 From: gbaz Date: Thu, 1 Jun 2023 19:42:03 -0400 Subject: [PATCH 05/71] relax upper bounds revision check (#1214) MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * relax upper bounds revision check * Update src/Distribution/Server/Util/CabalRevisions.hs Co-authored-by: ˌbodʲɪˈɡrʲim --------- Co-authored-by: ˌbodʲɪˈɡrʲim --- src/Distribution/Server/Util/CabalRevisions.hs | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/src/Distribution/Server/Util/CabalRevisions.hs b/src/Distribution/Server/Util/CabalRevisions.hs index 7a38d1d75..9036cf9c8 100644 --- a/src/Distribution/Server/Util/CabalRevisions.hs +++ b/src/Distribution/Server/Util/CabalRevisions.hs @@ -179,7 +179,12 @@ checkCabalFileRevision checkXRevision old new = do checkPackageChecks :: Check GenericPackageDescription checkPackageChecks pkg pkg' = let checks = checkPackage pkg Nothing - checks' = checkPackage pkg' Nothing + checks' = filter notUpperBounds $ checkPackage pkg' Nothing + -- if multiple upper bounds are missing, then the simple set subtraction might detect a change to + -- just one, and fail. Ideally we'd perform a set subtraction directly on just the missing bounds + -- warning contents. A simple second best is to discard this check for now. + notUpperBounds (PackageDistSuspiciousWarn (MissingUpperBounds _)) = False + notUpperBounds _ = True in case checks' \\ checks of [] -> return () newchecks -> fail $ unlines (map ppPackageCheck newchecks) From 1d09c1807f2f6cf33c7e15dfdf9471481b6fac80 Mon Sep 17 00:00:00 2001 From: "dependabot[bot]" <49699333+dependabot[bot]@users.noreply.github.com> Date: Tue, 6 Jun 2023 14:46:54 -0400 Subject: [PATCH 06/71] Bump cachix/install-nix-action from 20 to 21 (#1212) Bumps [cachix/install-nix-action](https://github.com/cachix/install-nix-action) from 20 to 21. - [Release notes](https://github.com/cachix/install-nix-action/releases) - [Commits](https://github.com/cachix/install-nix-action/compare/v20...v21) --- updated-dependencies: - dependency-name: cachix/install-nix-action dependency-type: direct:production update-type: version-update:semver-major ... Signed-off-by: dependabot[bot] Co-authored-by: dependabot[bot] <49699333+dependabot[bot]@users.noreply.github.com> --- .github/workflows/nix-flake.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/workflows/nix-flake.yml b/.github/workflows/nix-flake.yml index 83dff3376..ebb68cb58 100644 --- a/.github/workflows/nix-flake.yml +++ b/.github/workflows/nix-flake.yml @@ -18,7 +18,7 @@ jobs: runs-on: ${{ matrix.os }} steps: - uses: actions/checkout@v3.1.0 - - uses: cachix/install-nix-action@v20 + - uses: cachix/install-nix-action@v21 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= From 7eaca159ef77a4b0bb4637f1f2009584b09bae36 Mon Sep 17 00:00:00 2001 From: Peter Becich Date: Sun, 18 Jun 2023 21:16:16 -0700 Subject: [PATCH 07/71] enable `nix flake check` and Mac build in GitHub Action https://github.com/haskell/hackage-server/issues/1193 --- .github/workflows/nix-flake.yml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/.github/workflows/nix-flake.yml b/.github/workflows/nix-flake.yml index ebb68cb58..19c94a373 100644 --- a/.github/workflows/nix-flake.yml +++ b/.github/workflows/nix-flake.yml @@ -13,7 +13,7 @@ jobs: matrix: os: - ubuntu-latest - # - macos-latest + - macos-latest name: Nix on ${{ matrix.os }} runs-on: ${{ matrix.os }} steps: @@ -29,4 +29,4 @@ jobs: name: hackage-server authToken: '${{ secrets.CACHIX_AUTH_TOKEN }}' - run: nix build - # - run: nix flake check + - run: nix flake check From 8a6154732a5f55e6e33babe3d41125ba2d71a896 Mon Sep 17 00:00:00 2001 From: Peter Becich Date: Sun, 18 Jun 2023 21:26:49 -0700 Subject: [PATCH 08/71] update GitHub Actions versions --- .github/workflows/nix-flake.yml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/.github/workflows/nix-flake.yml b/.github/workflows/nix-flake.yml index 19c94a373..00bad8b82 100644 --- a/.github/workflows/nix-flake.yml +++ b/.github/workflows/nix-flake.yml @@ -17,8 +17,8 @@ jobs: 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@v3.5.3 + - uses: cachix/install-nix-action@v22 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= From 5222ef74408b600922b7697f9fd2b8e413899bbc Mon Sep 17 00:00:00 2001 From: Peter Becich Date: Sun, 18 Jun 2023 23:33:53 -0700 Subject: [PATCH 09/71] leave `nix flake check` disabled until https://github.com/haskell/hackage-server/pull/1219#issuecomment-1596576063 solved --- .github/workflows/nix-flake.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/workflows/nix-flake.yml b/.github/workflows/nix-flake.yml index 00bad8b82..7324c67b6 100644 --- a/.github/workflows/nix-flake.yml +++ b/.github/workflows/nix-flake.yml @@ -29,4 +29,4 @@ jobs: name: hackage-server authToken: '${{ secrets.CACHIX_AUTH_TOKEN }}' - run: nix build - - run: nix flake check + # - run: nix flake check From 7c2b32b91028c84d2843ed7da5309094e89ea088 Mon Sep 17 00:00:00 2001 From: ffaf1 Date: Tue, 27 Jun 2023 01:18:30 +0200 Subject: [PATCH 10/71] Update max cabal-version check (#1224) Also add a more informative comment. --- src/Distribution/Server/Packages/Unpack.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Distribution/Server/Packages/Unpack.hs b/src/Distribution/Server/Packages/Unpack.hs index 79a69570b..f3881bb2c 100644 --- a/src/Distribution/Server/Packages/Unpack.hs +++ b/src/Distribution/Server/Packages/Unpack.hs @@ -216,9 +216,9 @@ specVersionChecks specVerOk specVer = do when (specVer < CabalSpecV1_2) $ throwError "'cabal-version' must be at least 1.2" - -- 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 From b48fa5f2aeb33d704cec9d5551c4d72725374b49 Mon Sep 17 00:00:00 2001 From: Raoul Hidalgo Charman Date: Wed, 28 Jun 2023 07:37:08 -0400 Subject: [PATCH 11/71] Filter out metadata revisions before mirroring These are still there from the index being mirrored, but we avoid mirroring tarballs for each metadata revision. This seems to also improve ram usage. --- exes/MirrorClient.hs | 14 ++++++++++---- 1 file changed, 10 insertions(+), 4 deletions(-) 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 From 9279b9a243fedaf044121ac92887c884030f1ad1 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?=CB=8Cbod=CA=B2=C9=AA=CB=88=C9=A1r=CA=B2im?= Date: Thu, 6 Jul 2023 04:47:52 +0100 Subject: [PATCH 12/71] Enable MathJAX on candidate pages (#1232) --- datafiles/templates/Html/candidate-page.html.st | 2 ++ 1 file changed, 2 insertions(+) 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 @@ + + From 2a7d751630e8341554a520aa0c545fdcc1f423df Mon Sep 17 00:00:00 2001 From: Janus Troelsen Date: Sat, 8 Jul 2023 17:25:44 +0200 Subject: [PATCH 13/71] Fix package list when user has multiple packages --- .../Server/Features/UserNotify.hs | 2 +- tests/ReverseDependenciesTest.hs | 37 +++++++++++++++++++ 2 files changed, 38 insertions(+), 1 deletion(-) diff --git a/src/Distribution/Server/Features/UserNotify.hs b/src/Distribution/Server/Features/UserNotify.hs index 34c066371..eabc2b49c 100644 --- a/src/Distribution/Server/Features/UserNotify.hs +++ b/src/Distribution/Server/Features/UserNotify.hs @@ -473,7 +473,7 @@ dependencyReleaseEmails userSetIdForPackage index (ReverseIndex revs nodemap dep revDepNames = mapMaybe (`lookupR` nodemap) (Set.toList vertices) toNotify <- traverse maintainersToNotify revDepNames pure $ - Map.fromList + Map.fromListWith (++) [ ( (maintainerId, pkgId), [ packageId latestRevDep ] ) | (ids, latestRevDep) <- toNotify , maintainerId <- ids diff --git a/tests/ReverseDependenciesTest.hs b/tests/ReverseDependenciesTest.hs index 030eb8d08..d72ebcf1a 100644 --- a/tests/ReverseDependenciesTest.hs +++ b/tests/ReverseDependenciesTest.hs @@ -56,6 +56,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 +112,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] [] @@ -190,6 +209,12 @@ allTests = testGroup "ReverseDependenciesTest" base4_16 = PackageIdentifier "base" (mkVersion [4,16]) runWithPref preferences index pkg = runIdentity $ dependencyReleaseEmails userSetIdForPackage index (constructReverseIndex index) preferences pkg + runWithPrefAlsoMtl2 preferences index pkg = runIdentity $ + dependencyReleaseEmails 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" mempty @@ -198,6 +223,18 @@ allTests = testGroup "ReverseDependenciesTest" "dependencyReleaseEmails(trigger=NewIncompatibility) should generate a notification when package is a single base version behind" (refNotification base4_15) (runWithPref (pref NewIncompatibility) (PackageIndex.fromList newBaseReleased) base4_15) + assertEqual + "dependencyReleaseEmails(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, base4_15) + $ runWithPrefAlsoMtl2 (pref NewIncompatibility) (PackageIndex.fromList newBaseReleasedMultiple) base4_15 + ) assertEqual "dependencyReleaseEmails(trigger=BoundsOutOfRange) should generate a notification when package is a single base version behind" (refNotification base4_15) From eabf54a2e1ed56fa8cee13bea6d71680a4535267 Mon Sep 17 00:00:00 2001 From: Jessica Hamilton Date: Wed, 7 Jun 2023 11:19:44 +1200 Subject: [PATCH 14/71] haiku: add as known platform This combines via CPP two PRs by @jessicah: - https://github.com/haskell/hackage-server/pull/1217 (for Cabal >= 3.11) - https://github.com/haskell/hackage-server/pull/1221 (for Cabal <= 3.10) --- hackage-server.cabal | 4 ++-- .../Server/Framework/Instances.hs | 20 ++++++++++++++++++- 2 files changed, 21 insertions(+), 3 deletions(-) diff --git a/hackage-server.cabal b/hackage-server.cabal index 237636d7c..6873dca29 100644 --- a/hackage-server.cabal +++ b/hackage-server.cabal @@ -130,8 +130,8 @@ common defaults -- 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 + , 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 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')) From 7d9af0dffdb7504a95dcd0c5d842e334a8ffb863 Mon Sep 17 00:00:00 2001 From: Andreas Abel Date: Thu, 3 Aug 2023 16:39:50 +0200 Subject: [PATCH 15/71] Bump aeson to ^>= 2.2.0.0, use attoparsec-aeson --- hackage-server.cabal | 3 ++- tests/HttpUtils.hs | 3 ++- 2 files changed, 4 insertions(+), 2 deletions(-) diff --git a/hackage-server.cabal b/hackage-server.cabal index 6873dca29..a0b8310c8 100644 --- a/hackage-server.cabal +++ b/hackage-server.cabal @@ -129,7 +129,7 @@ common defaults , scientific -- other dependencies shared by most components build-depends: - , aeson ^>= 2.0.3.0 || ^>= 2.1.0.0 + , aeson ^>= 2.2.0.0 , 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 @@ -547,6 +547,7 @@ test-suite HighLevelTest build-depends: -- version constraints inherited from lib-server , HTTP + , attoparsec-aeson ^>= 2.2.0.0 , base64-bytestring , random -- component-specific dependencies 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 From 73465709ac5e34d9d58b9046ec15dd664e0ff60e Mon Sep 17 00:00:00 2001 From: Andreas Abel Date: Thu, 3 Aug 2023 16:41:14 +0200 Subject: [PATCH 16/71] Bumps, to allow building with GHC 9.8.1-alpha1 Tested locally. --- hackage-server.cabal | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/hackage-server.cabal b/hackage-server.cabal index a0b8310c8..f99a971c9 100644 --- a/hackage-server.cabal +++ b/hackage-server.cabal @@ -111,11 +111,11 @@ 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 + , deepseq >= 1.4 && < 1.6 , directory >= 1.3 && < 1.4 , filepath >= 1.4 && < 1.5 , mtl >= 2.2.1 && < 2.4 @@ -564,7 +564,7 @@ test-suite ReverseDependenciesTest , tasty ^>= 1.4 , tasty-hunit ^>= 0.10 , HUnit ^>= 1.6 - , hedgehog ^>= 1.2 + , hedgehog ^>= 1.3 , exceptions , bimap other-modules: RevDepCommon From 310942f23e3962cac81770a687f3c2dc4f3aa9e0 Mon Sep 17 00:00:00 2001 From: Andreas Abel Date: Thu, 3 Aug 2023 16:47:51 +0200 Subject: [PATCH 17/71] CI: bump haskell-ci.yml to GHCs 9.6.2 9.4.5 9.2.8 --- .github/workflows/haskell-ci.yml | 22 +++++++++++----------- hackage-server.cabal | 8 +++++++- 2 files changed, 18 insertions(+), 12 deletions(-) diff --git a/.github/workflows/haskell-ci.yml b/.github/workflows/haskell-ci.yml index 726be0826..155cec0ac 100644 --- a/.github/workflows/haskell-ci.yml +++ b/.github/workflows/haskell-ci.yml @@ -8,9 +8,9 @@ # # For more information, see https://github.com/haskell-CI/haskell-ci # -# version: 0.15.20230321 +# version: 0.16.6.20230729 # -# REGENDATA ("0.15.20230321",["github","hackage-server.cabal"]) +# REGENDATA ("0.16.6.20230729",["github","hackage-server.cabal"]) # name: Haskell-CI on: @@ -34,19 +34,19 @@ jobs: strategy: matrix: include: - - compiler: ghc-9.6.1 + - compiler: ghc-9.6.2 compilerKind: ghc - compilerVersion: 9.6.1 + compilerVersion: 9.6.2 setup-method: ghcup allow-failure: false - - compiler: ghc-9.4.4 + - compiler: ghc-9.4.5 compilerKind: ghc - compilerVersion: 9.4.4 + compilerVersion: 9.4.5 setup-method: ghcup allow-failure: false - - compiler: ghc-9.2.7 + - compiler: ghc-9.2.8 compilerKind: ghc - compilerVersion: 9.2.7 + compilerVersion: 9.2.8 setup-method: ghcup allow-failure: false - compiler: ghc-9.0.2 @@ -71,7 +71,7 @@ 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" install ghc "$HCVER" || (cat "$HOME"/.ghcup/logs/*.* && false) "$HOME/.ghcup/bin/ghcup" install cabal 3.10.1.0 || (cat "$HOME"/.ghcup/logs/*.* && false) @@ -142,8 +142,8 @@ 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 diff --git a/hackage-server.cabal b/hackage-server.cabal index f99a971c9..e0479f091 100644 --- a/hackage-server.cabal +++ b/hackage-server.cabal @@ -27,7 +27,13 @@ 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.6.2 + GHC == 9.4.5 + GHC == 9.2.8 + GHC == 9.0.2 + GHC == 8.10.7 + GHC == 8.8.4 data-dir: datafiles data-files: From e5dd400eeab60c1d0b64d2b967f1eb05b4a3901f Mon Sep 17 00:00:00 2001 From: Andreas Abel Date: Thu, 3 Aug 2023 16:48:34 +0200 Subject: [PATCH 18/71] CI: bump cabal.yml to GHC 9.6.2 and cabal 3.10.1.0 --- .github/workflows/cabal.yml | 57 +++++++++++++++++++------------------ 1 file changed, 30 insertions(+), 27 deletions(-) diff --git a/.github/workflows/cabal.yml b/.github/workflows/cabal.yml index 2f49c5b5b..e4c404a13 100644 --- a/.github/workflows/cabal.yml +++ b/.github/workflows/cabal.yml @@ -14,14 +14,14 @@ jobs: strategy: fail-fast: false matrix: - ghc: ['9.4.4', '9.2.7', '9.0.2'] - cabal: ['3.8.1.0'] + ghc: ['9.6.2', '9.4.5', '9.2.8', '9.0.2'] + cabal: ['3.10.1.0'] os: [ubuntu-latest] name: Cabal with GHC ${{ matrix.ghc }} steps: - uses: actions/checkout@v3 - name: Setup Haskell - uses: haskell/actions/setup@v2 + uses: haskell-actions/setup@v2 with: ghc-version: ${{ matrix.ghc }} cabal-version: ${{ matrix.cabal }} @@ -33,27 +33,30 @@ jobs: 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' + + ## 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@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' From e7f3a553afd18d70bb96d291e477934f661a6434 Mon Sep 17 00:00:00 2001 From: Peter Becich Date: Sat, 12 Aug 2023 18:25:48 -0700 Subject: [PATCH 19/71] fix `flake.nix` https://github.com/haskell/hackage-server/issues/1237 --- flake.lock | 135 ++----------------------------------------- flake.nix | 70 +--------------------- hackage-server.cabal | 4 +- 3 files changed, 8 insertions(+), 201 deletions(-) diff --git a/flake.lock b/flake.lock index 113d672e4..06592f6eb 100644 --- a/flake.lock +++ b/flake.lock @@ -48,94 +48,6 @@ "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, @@ -153,16 +65,16 @@ }, "nixpkgs": { "locked": { - "lastModified": 1682109806, - "narHash": "sha256-d9g7RKNShMLboTWwukM+RObDWWpHKaqTYXB48clBWXI=", + "lastModified": 1691885509, + "narHash": "sha256-MCKEstJdWdlUnh3V34SpOZTQj4bOeada+xhDh9U/0y8=", "owner": "nixos", "repo": "nixpkgs", - "rev": "2362848adf8def2866fabbffc50462e929d7fffb", + "rev": "163a5a5675d7e95d3856cf6ae2a26227f25a96f8", "type": "github" }, "original": { "owner": "nixos", - "ref": "nixpkgs-unstable", + "ref": "haskell-updates", "repo": "nixpkgs", "type": "github" } @@ -216,56 +128,17 @@ "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" diff --git a/flake.nix b/flake.nix index cbac13ae7..8e81f1b39 100644 --- a/flake.nix +++ b/flake.nix @@ -1,43 +1,12 @@ { 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"; }; @@ -59,45 +28,10 @@ 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" {}); }; diff --git a/hackage-server.cabal b/hackage-server.cabal index e0479f091..08a90264b 100644 --- a/hackage-server.cabal +++ b/hackage-server.cabal @@ -135,7 +135,7 @@ common defaults , scientific -- other dependencies shared by most components build-depends: - , aeson ^>= 2.2.0.0 + , aeson >= 2.1.0.0 , 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 @@ -553,7 +553,7 @@ test-suite HighLevelTest build-depends: -- version constraints inherited from lib-server , HTTP - , attoparsec-aeson ^>= 2.2.0.0 + , attoparsec-aeson >= 2.1.0.0 , base64-bytestring , random -- component-specific dependencies From 1d82ded8b583592b8dd1e75a93f5314fbb712548 Mon Sep 17 00:00:00 2001 From: Peter Becich Date: Sat, 12 Aug 2023 18:34:28 -0700 Subject: [PATCH 20/71] disable `fail-fast` for Flake GitHub Action --- .github/workflows/nix-flake.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/workflows/nix-flake.yml b/.github/workflows/nix-flake.yml index 7324c67b6..040cdf5f2 100644 --- a/.github/workflows/nix-flake.yml +++ b/.github/workflows/nix-flake.yml @@ -9,7 +9,7 @@ on: jobs: nix: strategy: - fail-fast: true + fail-fast: false matrix: os: - ubuntu-latest From 6bc9d71c0f7a39bda6254128c603f05a28753ebe Mon Sep 17 00:00:00 2001 From: Peter Becich Date: Sat, 12 Aug 2023 18:52:06 -0700 Subject: [PATCH 21/71] attempt to fix `nix build` on Mac --- flake.nix | 3 +++ 1 file changed, 3 insertions(+) diff --git a/flake.nix b/flake.nix index 8e81f1b39..77f64c5e3 100644 --- a/flake.nix +++ b/flake.nix @@ -34,6 +34,9 @@ Cabal-syntax = super.Cabal-syntax_3_10_1_0; ghcide = pkgs.haskell.lib.dontCheck (self.callHackage "ghcide" "1.9.0.0" {}); + + streamly = self.callHackage "streamly" "0.9.0" {}; + streamly_0_9_0 = self.callHackage "streamly" "0.9.0" {}; }; devShell = { hlsCheck.enable = false; From 99ad0125720873bdb452ea63f83d6cd7a0323980 Mon Sep 17 00:00:00 2001 From: Peter Becich Date: Thu, 17 Aug 2023 18:19:56 -0700 Subject: [PATCH 22/71] upper bound on `aeson` --- hackage-server.cabal | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/hackage-server.cabal b/hackage-server.cabal index 08a90264b..8c3f2e6a2 100644 --- a/hackage-server.cabal +++ b/hackage-server.cabal @@ -135,7 +135,7 @@ common defaults , scientific -- other dependencies shared by most components build-depends: - , aeson >= 2.1.0.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 @@ -553,7 +553,7 @@ test-suite HighLevelTest build-depends: -- version constraints inherited from lib-server , HTTP - , attoparsec-aeson >= 2.1.0.0 + , attoparsec-aeson >= 2.1.0.0 && < 2.3 , base64-bytestring , random -- component-specific dependencies From f01e00e872f95d88d891efcb3663d373e34bceba Mon Sep 17 00:00:00 2001 From: Brandon Chinn Date: Wed, 16 Aug 2023 12:04:12 -0700 Subject: [PATCH 23/71] Update README for Mac --- README.md | 27 +++++++++++++++++++++++++++ 1 file changed, 27 insertions(+) diff --git a/README.md b/README.md index 6e7995d78..ba9979ac3 100644 --- a/README.md +++ b/README.md @@ -89,6 +89,33 @@ You'll need to do the following to get `hackage-server`'s dependency `hs-captcha nix-shell --packages zlib +#### Mac OS X + +In addition to the above commands, you'll need to run + +```bash +brew install pkg-config +``` + +After running the above `brew install` commands, you also need to update `cabal.project.local` with the following: + +```bash +cat >> cabal.project.local < Date: Wed, 16 Aug 2023 14:00:09 -0700 Subject: [PATCH 24/71] Minor spelling improvements --- src/Distribution/Server/Features/UserNotify.hs | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/src/Distribution/Server/Features/UserNotify.hs b/src/Distribution/Server/Features/UserNotify.hs index eabc2b49c..6e4383050 100644 --- a/src/Distribution/Server/Features/UserNotify.hs +++ b/src/Distribution/Server/Features/UserNotify.hs @@ -846,11 +846,11 @@ userNotifyFeature ServerEnv{serverBaseURI, serverCron} (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 + "\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 + "\n" ++ "Reason: " ++ BS.unpack descr _ -> Nothing describeDocReport (pkg, doc) = @@ -860,9 +860,9 @@ userNotifyFeature ServerEnv{serverBaseURI, serverCron} else "Build failed." describeTagProposal (pkgName, (addTags, delTags)) = - "Pending tag propasal for " ++ display pkgName ++ ":\n" ++ - "Addition: " ++ showTags addTags ++ "\n" ++ - "Deletion: " ++ showTags delTags + "Pending tag proposal for " ++ display pkgName ++ ":\n" ++ + "Additions: " ++ showTags addTags ++ "\n" ++ + "Deletions: " ++ showTags delTags where showTags = intercalate ", " . map display . Set.toList From 53ef87d492fee494a4b243b56de529ce8f5ce068 Mon Sep 17 00:00:00 2001 From: Brandon Chinn Date: Thu, 17 Aug 2023 09:51:13 -0700 Subject: [PATCH 25/71] Use sortOn instead of sortBy --- src/Distribution/Server/Features/UserNotify.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Distribution/Server/Features/UserNotify.hs b/src/Distribution/Server/Features/UserNotify.hs index 6e4383050..011550da5 100644 --- a/src/Distribution/Server/Features/UserNotify.hs +++ b/src/Distribution/Server/Features/UserNotify.hs @@ -58,10 +58,10 @@ 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 (maximumBy, sortOn) import Data.List (intercalate) 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) @@ -505,7 +505,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 From 58a197329b58a6002e63f30e37ec25de7b7f65a2 Mon Sep 17 00:00:00 2001 From: Brandon Chinn Date: Wed, 16 Aug 2023 14:06:02 -0700 Subject: [PATCH 26/71] Consolidate dependencyEmailMap => dependencyEmailMaps --- src/Distribution/Server/Features/UserNotify.hs | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/src/Distribution/Server/Features/UserNotify.hs b/src/Distribution/Server/Features/UserNotify.hs index 011550da5..85bc197bc 100644 --- a/src/Distribution/Server/Features/UserNotify.hs +++ b/src/Distribution/Server/Features/UserNotify.hs @@ -702,10 +702,8 @@ userNotifyFeature ServerEnv{serverBaseURI, serverCron} genEmails :: PackageIdentifier -> IO (Map.Map (UserId, PackageId) [PackageId]) genEmails = dependencyReleaseEmails (queryUserGroup . maintainersGroup) idx revIdx queryGetUserNotifyPref - dependencyEmailMaps <- traverse (genEmails . pkgInfoToPkgId) revisionsAndUploads + dependencyEmailMap <- Map.unionsWith (++) <$> 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 From 0f21fe94f73ef9b605061e107a3773d46ed012d2 Mon Sep 17 00:00:00 2001 From: Brandon Chinn Date: Wed, 16 Aug 2023 14:07:28 -0700 Subject: [PATCH 27/71] Move + rename emailText => describeDependencyUpdate --- .../Server/Features/UserNotify.hs | 63 +++++++++---------- 1 file changed, 31 insertions(+), 32 deletions(-) diff --git a/src/Distribution/Server/Features/UserNotify.hs b/src/Distribution/Server/Features/UserNotify.hs index 85bc197bc..2bd8dba1e 100644 --- a/src/Distribution/Server/Features/UserNotify.hs +++ b/src/Distribution/Server/Features/UserNotify.hs @@ -703,44 +703,14 @@ userNotifyFeature ServerEnv{serverBaseURI, serverCron} genEmails = dependencyReleaseEmails (queryUserGroup . maintainersGroup) idx revIdx queryGetUserNotifyPref dependencyEmailMap <- Map.unionsWith (++) <$> traverse (genEmails . pkgInfoToPkgId) revisionsAndUploads - let - 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 + dependencyEmails <- Map.mapKeys fst <$> Map.traverseWithKey describeDependencyUpdate 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 + mapM_ (sendNotifyEmailAndDelay users) . Map.toList $ dependencyEmails updateState notifyState (SetNotifyTime now) @@ -864,6 +834,35 @@ userNotifyFeature ServerEnv{serverBaseURI, serverCron} where showTags = intercalate ", " . map display . Set.toList + describeDependencyUpdate (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 + sendNotifyEmailAndDelay :: Users.Users -> (UserId, [String]) -> IO () sendNotifyEmailAndDelay users (uid, ebody) = do mudetails <- queryUserDetails uid From 7a92fc1c9baafdc29c413c0340361c62f70f757d Mon Sep 17 00:00:00 2001 From: Brandon Chinn Date: Thu, 17 Aug 2023 10:04:11 -0700 Subject: [PATCH 28/71] Move + rename genEmails => genDependencyUpdateList --- src/Distribution/Server/Features/UserNotify.hs | 11 +++++------ 1 file changed, 5 insertions(+), 6 deletions(-) diff --git a/src/Distribution/Server/Features/UserNotify.hs b/src/Distribution/Server/Features/UserNotify.hs index 2bd8dba1e..9daa94d32 100644 --- a/src/Distribution/Server/Features/UserNotify.hs +++ b/src/Distribution/Server/Features/UserNotify.hs @@ -698,12 +698,8 @@ userNotifyFeature ServerEnv{serverBaseURI, serverCron} idx <- queryGetPackageIndex revIdx <- liftIO queryReverseIndex - let - genEmails :: PackageIdentifier -> IO (Map.Map (UserId, PackageId) [PackageId]) - genEmails = - dependencyReleaseEmails (queryUserGroup . maintainersGroup) idx revIdx queryGetUserNotifyPref - dependencyEmailMap <- Map.unionsWith (++) <$> traverse (genEmails . pkgInfoToPkgId) revisionsAndUploads - dependencyEmails <- Map.mapKeys fst <$> Map.traverseWithKey describeDependencyUpdate dependencyEmailMap + dependencyUpdateNotifications <- Map.unionsWith (++) <$> traverse (genDependencyUpdateList idx revIdx . pkgInfoToPkgId) revisionsAndUploads + dependencyEmails <- Map.mapKeys fst <$> Map.traverseWithKey describeDependencyUpdate dependencyUpdateNotifications -- 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] @@ -799,6 +795,9 @@ userNotifyFeature ServerEnv{serverBaseURI, serverCron} maintainers <- queryUserGroup $ maintainersGroup (fst pkgTags) return $ foldr addNotification mp (toList maintainers) + genDependencyUpdateList idx revIdx = + dependencyReleaseEmails (queryUserGroup . maintainersGroup) idx revIdx queryGetUserNotifyPref + describeRevision users earlier now pkg = if pkgNumRevisions pkg <= 1 then "Package upload, " ++ display (packageName pkg) ++ ", by " ++ From e652a607f3b74f440f6475172d8eae08d4fc3335 Mon Sep 17 00:00:00 2001 From: Brandon Chinn Date: Wed, 16 Aug 2023 14:17:17 -0700 Subject: [PATCH 29/71] Improve email subject for dep update emails --- .../Server/Features/UserNotify.hs | 21 ++++++++++++------- 1 file changed, 14 insertions(+), 7 deletions(-) diff --git a/src/Distribution/Server/Features/UserNotify.hs b/src/Distribution/Server/Features/UserNotify.hs index 9daa94d32..56565bb6f 100644 --- a/src/Distribution/Server/Features/UserNotify.hs +++ b/src/Distribution/Server/Features/UserNotify.hs @@ -699,14 +699,22 @@ userNotifyFeature ServerEnv{serverBaseURI, serverCron} idx <- queryGetPackageIndex revIdx <- liftIO queryReverseIndex dependencyUpdateNotifications <- Map.unionsWith (++) <$> traverse (genDependencyUpdateList idx revIdx . pkgInfoToPkgId) revisionsAndUploads - dependencyEmails <- Map.mapKeys fst <$> Map.traverseWithKey describeDependencyUpdate dependencyUpdateNotifications + dependencyEmails <- Map.traverseWithKey describeDependencyUpdate dependencyUpdateNotifications -- 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] + mapM_ (sendNotifyEmailAndDelay users) . Map.toList $ + fmap ("Maintainer Notifications",) . 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 $ dependencyEmails + mapM_ (sendNotifyEmailAndDelay users) . Map.toList $ + Map.mapKeys fst . Map.mapWithKey (\(_, dep) ebody -> ("Dependency Update: " <> T.pack (display dep), ebody)) $ + dependencyEmails updateState notifyState (SetNotifyTime now) @@ -862,8 +870,8 @@ userNotifyFeature ServerEnv{serverBaseURI, serverCron} ] ++ map display revDeps - sendNotifyEmailAndDelay :: Users.Users -> (UserId, [String]) -> IO () - sendNotifyEmailAndDelay users (uid, ebody) = do + sendNotifyEmailAndDelay :: Users.Users -> (UserId, (T.Text, [String])) -> IO () + sendNotifyEmailAndDelay users (uid, (subject, ebody)) = do mudetails <- queryUserDetails uid case mudetails of Nothing -> return () @@ -872,8 +880,7 @@ userNotifyFeature ServerEnv{serverBaseURI, serverCron} (T.pack ("noreply@" ++ uriRegName ourHost)) mail = (emptyMail mailFrom) { mailTo = [Address (Just aname) eml], - mailHeaders = [(BSS.pack "Subject", - T.pack "[Hackage] Maintainer Notifications")], + mailHeaders = [(BSS.pack "Subject", "[Hackage] " <> subject)], mailParts = [[Part (T.pack "text/plain; charset=utf-8") None DefaultDisposition [] (PartContent $ BS.pack $ From fb09c8b8f3787027dc3cf1d3c5c7d79f619fb881 Mon Sep 17 00:00:00 2001 From: Brandon Chinn Date: Thu, 17 Aug 2023 15:58:34 -0700 Subject: [PATCH 30/71] Simplify describeDependencyUpdate --- .../Server/Features/UserNotify.hs | 43 ++++++++++--------- 1 file changed, 22 insertions(+), 21 deletions(-) diff --git a/src/Distribution/Server/Features/UserNotify.hs b/src/Distribution/Server/Features/UserNotify.hs index 56565bb6f..5d8de66a0 100644 --- a/src/Distribution/Server/Features/UserNotify.hs +++ b/src/Distribution/Server/Features/UserNotify.hs @@ -847,27 +847,28 @@ userNotifyFeature ServerEnv{serverBaseURI, serverCron} 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) <> ":" - ] + let depName = display (packageName dep) + depVersion = display (packageVersion dep) + in + [ "The dependency " <> display dep <> " has been uploaded or revised." + , case notifyDependencyTriggerBounds 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 notifyDependencyTriggerBounds 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):" + ] ++ map display revDeps sendNotifyEmailAndDelay :: Users.Users -> (UserId, (T.Text, [String])) -> IO () From 5e48f72ff224b8f7fddaa195e2d090b8ac100afe Mon Sep 17 00:00:00 2001 From: Brandon Chinn Date: Thu, 17 Aug 2023 16:02:11 -0700 Subject: [PATCH 31/71] Refactor message generation --- .../Server/Features/UserNotify.hs | 49 +++++++++++-------- 1 file changed, 28 insertions(+), 21 deletions(-) diff --git a/src/Distribution/Server/Features/UserNotify.hs b/src/Distribution/Server/Features/UserNotify.hs index 5d8de66a0..4a913ed90 100644 --- a/src/Distribution/Server/Features/UserNotify.hs +++ b/src/Distribution/Server/Features/UserNotify.hs @@ -806,31 +806,40 @@ userNotifyFeature ServerEnv{serverBaseURI, serverCron} genDependencyUpdateList idx revIdx = dependencyReleaseEmails (queryUserGroup . maintainersGroup) idx revIdx queryGetUserNotifyPref - 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) + describeRevision users earlier now pkg + | pkgNumRevisions pkg <= 1 = + "Package upload, " ++ display (packageName pkg) ++ ", by " ++ + formatTimeUser users (pkgLatestUploadTime pkg) (pkgLatestUploadUser pkg) + | otherwise = + "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 + describeGroupAction users (time, uid, act, reason) = + fmap + ( \message -> + "Group modified by " ++ formatTimeUser users time uid ++ ":\n" + ++ message ++ "\n" + ++ "Reason: " ++ BS.unpack reason + ) + $ case act of + (Admin_GroupAddUser tn (MaintainerGroup pkg)) -> + Just $ + display (Users.userIdToName users tn) + <> " added to maintainers for " + <> BS.unpack pkg + (Admin_GroupDelUser tn (MaintainerGroup pkg)) -> + Just $ + display (Users.userIdToName users tn) + <> " removed from maintainers for " + <> BS.unpack pkg _ -> Nothing - describeDocReport (pkg, doc) = + describeDocReport (pkg, success) = "Package doc build for " ++ display (packageName pkg) ++ ":\n" ++ - if doc + if success then "Build successful." else "Build failed." @@ -885,9 +894,7 @@ userNotifyFeature ServerEnv{serverBaseURI, serverCron} mailParts = [[Part (T.pack "text/plain; charset=utf-8") None DefaultDisposition [] (PartContent $ BS.pack $ - intercalate "\n\n" ebody - <> "\n\n" - <> adjustmentLinkParagraph + intercalate "\n\n" (ebody <> [adjustmentLinkParagraph]) ) ]] } From 8d62bbe9c7e1845958dacd031a6359c746e2737d Mon Sep 17 00:00:00 2001 From: Brandon Chinn Date: Thu, 17 Aug 2023 15:36:51 -0700 Subject: [PATCH 32/71] Add email markup implementation --- hackage-server.cabal | 1 + src/Distribution/Server/Util/Email.hs | 148 ++++++++++++++++++++++++++ 2 files changed, 149 insertions(+) create mode 100644 src/Distribution/Server/Util/Email.hs diff --git a/hackage-server.cabal b/hackage-server.cabal index 8c3f2e6a2..98e4731b6 100644 --- a/hackage-server.cabal +++ b/hackage-server.cabal @@ -265,6 +265,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 diff --git a/src/Distribution/Server/Util/Email.hs b/src/Distribution/Server/Util/Email.hs new file mode 100644 index 000000000..30fd8bb9c --- /dev/null +++ b/src/Distribution/Server/Util/Email.hs @@ -0,0 +1,148 @@ +{-# 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 = + [ Part + { partType = contentType <> "; charset=utf-8" + , partEncoding = None + , partDisposition = DefaultDisposition + , partHeaders = [] + , partContent = PartContent $ TextL.encodeUtf8 $ TextL.fromStrict content + } + | (contentType, content) <- contents + ] + where + contents = + [ ("text/plain", toPlainContent emailContent) + , ("text/html", 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 "" From f39dd8a195cf342f6382b33566f4c0ae5f6ceea6 Mon Sep 17 00:00:00 2001 From: Brandon Chinn Date: Thu, 17 Aug 2023 16:08:49 -0700 Subject: [PATCH 33/71] Direct translation from plain text to EmailContent --- .../Server/Features/UserNotify.hs | 75 ++++++++++--------- 1 file changed, 39 insertions(+), 36 deletions(-) diff --git a/src/Distribution/Server/Features/UserNotify.hs b/src/Distribution/Server/Features/UserNotify.hs index 4a913ed90..af2738416 100644 --- a/src/Distribution/Server/Features/UserNotify.hs +++ b/src/Distribution/Server/Features/UserNotify.hs @@ -47,6 +47,8 @@ import Distribution.Server.Features.Upload import Distribution.Server.Features.UserDetails import Distribution.Server.Features.Users +import Distribution.Server.Util.Email + import qualified Data.Map as Map import qualified Data.Set as Set @@ -59,7 +61,6 @@ import Data.Bimap (lookup, lookupR) import Data.Graph (Vertex) import Data.Hashable (Hashable(..)) import Data.List (maximumBy, sortOn) -import Data.List (intercalate) import Data.Maybe (fromJust, fromMaybe, listToMaybe, mapMaybe, maybeToList) import Data.Ord (Down(..), comparing) import Data.SafeCopy (Migrate(migrate), MigrateFrom, base, deriveSafeCopy, extension) @@ -713,12 +714,13 @@ userNotifyFeature ServerEnv{serverBaseURI, serverCron} -- Dependency email notifications consist of multiple paragraphs, so it would be confusing if concatenated. -- So they're sent independently. mapM_ (sendNotifyEmailAndDelay users) . Map.toList $ - Map.mapKeys fst . Map.mapWithKey (\(_, dep) ebody -> ("Dependency Update: " <> T.pack (display dep), ebody)) $ + Map.mapKeys fst . Map.mapWithKey (\(_, dep) emailContent -> ("Dependency Update: " <> T.pack (display dep), emailContent)) $ dependencyEmails updateState notifyState (SetNotifyTime now) formatTimeUser users t u = + EmailContentText . T.pack $ display (Users.userIdToName users u) ++ " [" ++ (formatTime defaultTimeLocale "%c" t) ++ "]" @@ -808,11 +810,11 @@ userNotifyFeature ServerEnv{serverBaseURI, serverCron} describeRevision users earlier now pkg | pkgNumRevisions pkg <= 1 = - "Package upload, " ++ display (packageName pkg) ++ ", by " ++ - formatTimeUser users (pkgLatestUploadTime pkg) (pkgLatestUploadUser pkg) + "Package upload, " <> emailContentDisplay (packageName pkg) <> ", by " <> + formatTimeUser users (pkgLatestUploadTime pkg) (pkgLatestUploadUser pkg) | otherwise = - "Package metadata revision(s), " ++ display (packageName pkg) ++ ":\n" ++ - unlines (map (uncurry (formatTimeUser users) . snd) recentRevs) + "Package metadata revision(s), " <> emailContentDisplay (packageName pkg) <> ":" <> EmailContentSoftBreak + <> foldMap (<> EmailContentSoftBreak) (map (uncurry (formatTimeUser users) . snd) recentRevs) where revs = reverse $ Vec.toList (pkgMetadataRevisions pkg) recentRevs = filter ((\x -> x > earlier && x <= now) . fst . snd) revs @@ -820,35 +822,35 @@ userNotifyFeature ServerEnv{serverBaseURI, serverCron} describeGroupAction users (time, uid, act, reason) = fmap ( \message -> - "Group modified by " ++ formatTimeUser users time uid ++ ":\n" - ++ message ++ "\n" - ++ "Reason: " ++ BS.unpack reason + "Group modified by " <> formatTimeUser users time uid <> ":" <> EmailContentSoftBreak + <> message <> EmailContentSoftBreak + <> "Reason: " <> emailContentLBS reason ) $ case act of (Admin_GroupAddUser tn (MaintainerGroup pkg)) -> Just $ - display (Users.userIdToName users tn) + emailContentDisplay (Users.userIdToName users tn) <> " added to maintainers for " - <> BS.unpack pkg + <> emailContentLBS pkg (Admin_GroupDelUser tn (MaintainerGroup pkg)) -> Just $ - display (Users.userIdToName users tn) + emailContentDisplay (Users.userIdToName users tn) <> " removed from maintainers for " - <> BS.unpack pkg + <> emailContentLBS pkg _ -> Nothing describeDocReport (pkg, success) = - "Package doc build for " ++ display (packageName pkg) ++ ":\n" ++ + "Package doc build for " <> emailContentDisplay (packageName pkg) <> ":" <> EmailContentSoftBreak <> if success then "Build successful." else "Build failed." describeTagProposal (pkgName, (addTags, delTags)) = - "Pending tag proposal for " ++ display pkgName ++ ":\n" ++ - "Additions: " ++ showTags addTags ++ "\n" ++ - "Deletions: " ++ showTags delTags + "Pending tag proposal for " <> emailContentDisplay pkgName <> ":" <> EmailContentSoftBreak + <> "Additions: " <> showTags addTags <> EmailContentSoftBreak + <> "Deletions: " <> showTags delTags where - showTags = intercalate ", " . map display . Set.toList + showTags = emailContentIntercalate ", " . map emailContentDisplay . Set.toList describeDependencyUpdate (uId, dep) revDeps = do mPrefs <- queryGetUserNotifyPref uId @@ -856,10 +858,10 @@ userNotifyFeature ServerEnv{serverBaseURI, serverCron} case mPrefs of Nothing -> [] Just NotifyPref{notifyDependencyTriggerBounds} -> - let depName = display (packageName dep) - depVersion = display (packageVersion dep) + let depName = emailContentDisplay (packageName dep) + depVersion = emailContentDisplay (packageVersion dep) in - [ "The dependency " <> display dep <> " has been uploaded or revised." + [ "The dependency " <> emailContentDisplay dep <> " has been uploaded or revised." , case notifyDependencyTriggerBounds of Always -> "You have requested to be notified for each upload or revision \ @@ -878,10 +880,10 @@ userNotifyFeature ServerEnv{serverBaseURI, serverCron} <> " but don't accept " <> depVersion <> " (they do accept the second-highest version):" ] - ++ map display revDeps + ++ map emailContentDisplay revDeps - sendNotifyEmailAndDelay :: Users.Users -> (UserId, (T.Text, [String])) -> IO () - sendNotifyEmailAndDelay users (uid, (subject, ebody)) = do + sendNotifyEmailAndDelay :: Users.Users -> (UserId, (T.Text, [EmailContent])) -> IO () + sendNotifyEmailAndDelay users (uid, (subject, emailContent)) = do mudetails <- queryUserDetails uid case mudetails of Nothing -> return () @@ -891,12 +893,11 @@ userNotifyFeature ServerEnv{serverBaseURI, serverCron} mail = (emptyMail mailFrom) { mailTo = [Address (Just aname) eml], mailHeaders = [(BSS.pack "Subject", "[Hackage] " <> subject)], - mailParts = [[Part (T.pack "text/plain; charset=utf-8") - None DefaultDisposition [] - (PartContent $ BS.pack $ - intercalate "\n\n" (ebody <> [adjustmentLinkParagraph]) - ) - ]] + mailParts = + [ fromEmailContent $ + foldMap EmailContentParagraph $ + emailContent <> [updatePreferencesText] + ] } Just ourHost = uriAuthority serverBaseURI @@ -904,9 +905,11 @@ userNotifyFeature ServerEnv{serverBaseURI, serverCron} -- sendmail stuff, has to go here threadDelay 250000 where - adjustmentLinkParagraph = - "You can adjust your notification preferences at\n" - <> uriToString id serverBaseURI "" - <> "/user/" - <> display (Users.userIdToName users uid) - <> "/notify" + updatePreferencesText = + "You can adjust your notification preferences at" <> EmailContentSoftBreak + <> (EmailContentText . T.pack) + ( uriToString id serverBaseURI "" + <> "/user/" + <> display (Users.userIdToName users uid) + <> "/notify" + ) From cbca2d69d5911058f1388968487f2df043347ae0 Mon Sep 17 00:00:00 2001 From: Brandon Chinn Date: Thu, 17 Aug 2023 16:33:17 -0700 Subject: [PATCH 34/71] Add markup to emails --- .../Server/Features/UserNotify.hs | 80 +++++++++++-------- 1 file changed, 48 insertions(+), 32 deletions(-) diff --git a/src/Distribution/Server/Features/UserNotify.hs b/src/Distribution/Server/Features/UserNotify.hs index af2738416..33169dd3f 100644 --- a/src/Distribution/Server/Features/UserNotify.hs +++ b/src/Distribution/Server/Features/UserNotify.hs @@ -69,7 +69,7 @@ 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, ()) @@ -683,19 +683,19 @@ userNotifyFeature ServerEnv{serverBaseURI, serverCron} revisionsAndUploads <- collectRevisionsAndUploads trimLastTime now revisionUploadNotifications <- foldM (genRevUploadList notifyPrefs) Map.empty revisionsAndUploads - let revisionUploadEmails = map (describeRevision users trimLastTime now) <$> revisionUploadNotifications + let revisionUploadEmails = foldMap (describeRevision users trimLastTime now) <$> revisionUploadNotifications groupActions <- collectAdminActions trimLastTime now groupActionNotifications <- foldM (genGroupUploadList notifyPrefs) Map.empty groupActions - let groupActionEmails = mapMaybe (describeGroupAction users) <$> groupActionNotifications + let groupActionEmails = mconcat . mapMaybe (describeGroupAction users) <$> groupActionNotifications docReports <- collectDocReport trimLastTime now docReportNotifications <- foldM (genDocReportList notifyPrefs) Map.empty docReports - let docReportEmails = map describeDocReport <$> docReportNotifications + let docReportEmails = foldMap describeDocReport <$> docReportNotifications tagProposals <- collectTagProposals tagProposalNotifications <- foldM (genTagProposalList notifyPrefs) Map.empty tagProposals - let tagProposalEmails = map describeTagProposal <$> tagProposalNotifications + let tagProposalEmails = foldMap describeTagProposal <$> tagProposalNotifications idx <- queryGetPackageIndex revIdx <- liftIO queryReverseIndex @@ -704,7 +704,7 @@ userNotifyFeature ServerEnv{serverBaseURI, serverCron} -- Concat the constituent email parts such that only one email is sent per user mapM_ (sendNotifyEmailAndDelay users) . Map.toList $ - fmap ("Maintainer Notifications",) . foldr1 (Map.unionWith (++)) $ + fmap ("Maintainer Notifications",) . foldr1 (Map.unionWith (<>)) $ [ revisionUploadEmails , groupActionEmails , docReportEmails @@ -719,6 +719,13 @@ userNotifyFeature ServerEnv{serverBaseURI, serverCron} updateState notifyState (SetNotifyTime now) + renderPkgLink pkg = + EmailContentLink + (T.pack $ display pkg) + serverBaseURI + { uriPath = "/package/" <> display (packageName pkg) <> "-" <> display (packageVersion pkg) + } + formatTimeUser users t u = EmailContentText . T.pack $ display (Users.userIdToName users u) ++ " [" ++ @@ -810,11 +817,12 @@ userNotifyFeature ServerEnv{serverBaseURI, serverCron} describeRevision users earlier now pkg | pkgNumRevisions pkg <= 1 = - "Package upload, " <> emailContentDisplay (packageName pkg) <> ", by " <> + EmailContentParagraph $ + "Package upload, " <> renderPkgLink (pkgInfoId pkg) <> ", by " <> formatTimeUser users (pkgLatestUploadTime pkg) (pkgLatestUploadUser pkg) | otherwise = - "Package metadata revision(s), " <> emailContentDisplay (packageName pkg) <> ":" <> EmailContentSoftBreak - <> foldMap (<> EmailContentSoftBreak) (map (uncurry (formatTimeUser users) . snd) recentRevs) + EmailContentParagraph ("Package metadata revision(s), " <> renderPkgLink (pkgInfoId pkg) <> ":") + <> EmailContentList (map (uncurry (formatTimeUser users) . snd) recentRevs) where revs = reverse $ Vec.toList (pkgMetadataRevisions pkg) recentRevs = filter ((\x -> x > earlier && x <= now) . fst . snd) revs @@ -822,9 +830,11 @@ userNotifyFeature ServerEnv{serverBaseURI, serverCron} describeGroupAction users (time, uid, act, reason) = fmap ( \message -> - "Group modified by " <> formatTimeUser users time uid <> ":" <> EmailContentSoftBreak - <> message <> EmailContentSoftBreak - <> "Reason: " <> emailContentLBS reason + EmailContentParagraph ("Group modified by " <> formatTimeUser users time uid <> ":") + <> EmailContentList + [ message + , "Reason: " <> emailContentLBS reason + ] ) $ case act of (Admin_GroupAddUser tn (MaintainerGroup pkg)) -> @@ -840,15 +850,18 @@ userNotifyFeature ServerEnv{serverBaseURI, serverCron} _ -> Nothing describeDocReport (pkg, success) = - "Package doc build for " <> emailContentDisplay (packageName pkg) <> ":" <> EmailContentSoftBreak <> - if success - then "Build successful." - else "Build failed." + EmailContentParagraph $ + "Package doc build for " <> emailContentDisplay (packageName pkg) <> ":" <> EmailContentSoftBreak <> + if success + then "Build successful." + else "Build failed." describeTagProposal (pkgName, (addTags, delTags)) = - "Pending tag proposal for " <> emailContentDisplay pkgName <> ":" <> EmailContentSoftBreak - <> "Additions: " <> showTags addTags <> EmailContentSoftBreak - <> "Deletions: " <> showTags delTags + EmailContentParagraph ("Pending tag proposal for " <> emailContentDisplay pkgName <> ":") + <> EmailContentList + [ "Additions: " <> showTags addTags + , "Deletions: " <> showTags delTags + ] where showTags = emailContentIntercalate ", " . map emailContentDisplay . Set.toList @@ -856,12 +869,13 @@ userNotifyFeature ServerEnv{serverBaseURI, serverCron} mPrefs <- queryGetUserNotifyPref uId pure $ case mPrefs of - Nothing -> [] + Nothing -> mempty Just NotifyPref{notifyDependencyTriggerBounds} -> let depName = emailContentDisplay (packageName dep) depVersion = emailContentDisplay (packageVersion dep) in - [ "The dependency " <> emailContentDisplay dep <> " has been uploaded or revised." + foldMap EmailContentParagraph + [ "The dependency " <> renderPkgLink dep <> " has been uploaded or revised." , case notifyDependencyTriggerBounds of Always -> "You have requested to be notified for each upload or revision \ @@ -880,9 +894,9 @@ userNotifyFeature ServerEnv{serverBaseURI, serverCron} <> " but don't accept " <> depVersion <> " (they do accept the second-highest version):" ] - ++ map emailContentDisplay revDeps + <> EmailContentList (map renderPkgLink revDeps) - sendNotifyEmailAndDelay :: Users.Users -> (UserId, (T.Text, [EmailContent])) -> IO () + sendNotifyEmailAndDelay :: Users.Users -> (UserId, (T.Text, EmailContent)) -> IO () sendNotifyEmailAndDelay users (uid, (subject, emailContent)) = do mudetails <- queryUserDetails uid case mudetails of @@ -894,9 +908,7 @@ userNotifyFeature ServerEnv{serverBaseURI, serverCron} mailTo = [Address (Just aname) eml], mailHeaders = [(BSS.pack "Subject", "[Hackage] " <> subject)], mailParts = - [ fromEmailContent $ - foldMap EmailContentParagraph $ - emailContent <> [updatePreferencesText] + [ fromEmailContent $ emailContent <> updatePreferencesText ] } Just ourHost = uriAuthority serverBaseURI @@ -906,10 +918,14 @@ userNotifyFeature ServerEnv{serverBaseURI, serverCron} threadDelay 250000 where updatePreferencesText = + EmailContentParagraph $ "You can adjust your notification preferences at" <> EmailContentSoftBreak - <> (EmailContentText . T.pack) - ( uriToString id serverBaseURI "" - <> "/user/" - <> display (Users.userIdToName users uid) - <> "/notify" - ) + <> emailContentUrl + serverBaseURI + { uriPath = + concatMap ("/" <>) + [ "user" + , display $ Users.userIdToName users uid + , "notify" + ] + } From 0ded9fc5744e48b0a118293a93e856c01931faf8 Mon Sep 17 00:00:00 2001 From: Brandon Chinn Date: Thu, 17 Aug 2023 16:33:20 -0700 Subject: [PATCH 35/71] Reformat --- .../Server/Features/UserNotify.hs | 62 +++++++++---------- 1 file changed, 31 insertions(+), 31 deletions(-) diff --git a/src/Distribution/Server/Features/UserNotify.hs b/src/Distribution/Server/Features/UserNotify.hs index 33169dd3f..cfb4aaf4c 100644 --- a/src/Distribution/Server/Features/UserNotify.hs +++ b/src/Distribution/Server/Features/UserNotify.hs @@ -818,8 +818,8 @@ userNotifyFeature ServerEnv{serverBaseURI, serverCron} describeRevision users earlier now pkg | pkgNumRevisions pkg <= 1 = EmailContentParagraph $ - "Package upload, " <> renderPkgLink (pkgInfoId pkg) <> ", by " <> - formatTimeUser users (pkgLatestUploadTime pkg) (pkgLatestUploadUser pkg) + "Package upload, " <> renderPkgLink (pkgInfoId pkg) <> ", by " <> + formatTimeUser users (pkgLatestUploadTime pkg) (pkgLatestUploadUser pkg) | otherwise = EmailContentParagraph ("Package metadata revision(s), " <> renderPkgLink (pkgInfoId pkg) <> ":") <> EmailContentList (map (uncurry (formatTimeUser users) . snd) recentRevs) @@ -875,25 +875,25 @@ userNotifyFeature ServerEnv{serverBaseURI, serverCron} depVersion = emailContentDisplay (packageVersion dep) in foldMap EmailContentParagraph - [ "The dependency " <> renderPkgLink dep <> " has been uploaded or revised." - , case notifyDependencyTriggerBounds 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 notifyDependencyTriggerBounds 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):" - ] + [ "The dependency " <> renderPkgLink dep <> " has been uploaded or revised." + , case notifyDependencyTriggerBounds 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 notifyDependencyTriggerBounds 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) sendNotifyEmailAndDelay :: Users.Users -> (UserId, (T.Text, EmailContent)) -> IO () @@ -919,13 +919,13 @@ userNotifyFeature ServerEnv{serverBaseURI, serverCron} where updatePreferencesText = EmailContentParagraph $ - "You can adjust your notification preferences at" <> EmailContentSoftBreak - <> emailContentUrl - serverBaseURI - { uriPath = - concatMap ("/" <>) - [ "user" - , display $ Users.userIdToName users uid - , "notify" - ] - } + "You can adjust your notification preferences at" <> EmailContentSoftBreak + <> emailContentUrl + serverBaseURI + { uriPath = + concatMap ("/" <>) + [ "user" + , display $ Users.userIdToName users uid + , "notify" + ] + } From 23eae0c9f301c16e77b1b4b2f1991ffdffa405ea Mon Sep 17 00:00:00 2001 From: Brandon Chinn Date: Wed, 16 Aug 2023 16:47:56 -0700 Subject: [PATCH 36/71] Give dependencyReleaseEmails more accurate name + type --- .../Server/Features/UserNotify.hs | 27 ++++++----- tests/ReverseDependenciesTest.hs | 45 +++++++++++-------- 2 files changed, 42 insertions(+), 30 deletions(-) diff --git a/src/Distribution/Server/Features/UserNotify.hs b/src/Distribution/Server/Features/UserNotify.hs index cfb4aaf4c..ba864a1e5 100644 --- a/src/Distribution/Server/Features/UserNotify.hs +++ b/src/Distribution/Server/Features/UserNotify.hs @@ -12,7 +12,7 @@ module Distribution.Server.Features.UserNotify ( NotifyTriggerBounds(..), UserNotifyFeature(..), defaultNotifyPrefs, - dependencyReleaseEmails, + getUserNotificationsOnRelease, importNotifyPref, initUserNotifyFeature, notifyDataToCSV, @@ -446,24 +446,26 @@ initUserNotifyFeature env@ServerEnv{ serverStateDir, serverTemplatesDir, 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 @@ -475,7 +477,7 @@ dependencyReleaseEmails userSetIdForPackage index (ReverseIndex revs nodemap dep toNotify <- traverse maintainersToNotify revDepNames pure $ Map.fromListWith (++) - [ ( (maintainerId, pkgId), [ packageId latestRevDep ] ) + [ (maintainerId, [packageId latestRevDep]) | (ids, latestRevDep) <- toNotify , maintainerId <- ids ] @@ -812,8 +814,9 @@ userNotifyFeature ServerEnv{serverBaseURI, serverCron} maintainers <- queryUserGroup $ maintainersGroup (fst pkgTags) return $ foldr addNotification mp (toList maintainers) - genDependencyUpdateList idx revIdx = - dependencyReleaseEmails (queryUserGroup . maintainersGroup) idx revIdx queryGetUserNotifyPref + genDependencyUpdateList idx revIdx pid = + Map.mapKeys (, pid) <$> + getUserNotificationsOnRelease (queryUserGroup . maintainersGroup) idx revIdx queryGetUserNotifyPref pid describeRevision users earlier now pkg | pkgNumRevisions pkg <= 1 = diff --git a/tests/ReverseDependenciesTest.hs b/tests/ReverseDependenciesTest.hs index d72ebcf1a..2626f7a34 100644 --- a/tests/ReverseDependenciesTest.hs +++ b/tests/ReverseDependenciesTest.hs @@ -14,7 +14,16 @@ import Distribution.Package (PackageIdentifier(..), mkPackageName, packageId, pa 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.UserNotify + ( NotifyData(..) + , NotifyPref(..) + , NotifyRevisionRange + , NotifyTriggerBounds(..) + , defaultNotifyPrefs + , getUserNotificationsOnRelease + , importNotifyPref + , notifyDataToCSV + ) import Distribution.Server.Framework.BackupRestore (runRestore) import Distribution.Server.Framework.Hook (newHook) import Distribution.Server.Framework.MemState (newMemStateWHNF) @@ -186,7 +195,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 = @@ -197,9 +206,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])] ) ] @@ -208,23 +217,23 @@ 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 $ - dependencyReleaseEmails userSet index (constructReverseIndex index) preferences pkg + 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=NewIncompatibility) should generate a notification for two packages that are a single base version behind" + "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]) @@ -232,27 +241,27 @@ allTests = testGroup "ReverseDependenciesTest" ] ) ( fmap Set.fromList - . Map.lookup (UserId 0, base4_15) + . Map.lookup (UserId 0) $ runWithPrefAlsoMtl2 (pref NewIncompatibility) (PackageIndex.fromList newBaseReleasedMultiple) base4_15 ) assertEqual - "dependencyReleaseEmails(trigger=BoundsOutOfRange) should generate a notification when package is a single base version behind" - (refNotification base4_15) + "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) From 9da933c27e7f6cde33a75ef2a2cfc40ef5ae92fb Mon Sep 17 00:00:00 2001 From: Brandon Chinn Date: Thu, 17 Aug 2023 11:11:33 -0700 Subject: [PATCH 37/71] Break out getNotificationEmails from sendNotifyEmailAndDelay --- .../Server/Features/UserNotify.hs | 164 ++++++++++++------ 1 file changed, 115 insertions(+), 49 deletions(-) diff --git a/src/Distribution/Server/Features/UserNotify.hs b/src/Distribution/Server/Features/UserNotify.hs index ba864a1e5..bdabe79a0 100644 --- a/src/Distribution/Server/Features/UserNotify.hs +++ b/src/Distribution/Server/Features/UserNotify.hs @@ -2,6 +2,7 @@ TypeFamilies, TemplateHaskell, RankNTypes, NamedFieldPuns, RecordWildCards, BangPatterns, DefaultSignatures, OverloadedStrings #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-} @@ -49,7 +50,9 @@ import Distribution.Server.Features.Users 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) @@ -76,7 +79,6 @@ 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 qualified Data.Text as T import qualified Data.Vector as Vec @@ -575,12 +577,12 @@ userNotifyFeature :: ServerEnv -> StateComponent AcidState NotifyData -> Templates -> UserNotifyFeature -userNotifyFeature ServerEnv{serverBaseURI, serverCron} +userNotifyFeature serverEnv@ServerEnv{serverBaseURI, serverCron} UserFeature{..} CoreFeature{..} UploadFeature{..} AdminLogFeature{..} - UserDetailsFeature{..} + userDetailsFeature@UserDetailsFeature{..} ReportsFeature{..} TagsFeature{..} ReverseFeature{queryReverseIndex} @@ -704,20 +706,17 @@ userNotifyFeature ServerEnv{serverBaseURI, serverCron} dependencyUpdateNotifications <- Map.unionsWith (++) <$> traverse (genDependencyUpdateList idx revIdx . pkgInfoToPkgId) revisionsAndUploads dependencyEmails <- Map.traverseWithKey describeDependencyUpdate dependencyUpdateNotifications - -- Concat the constituent email parts such that only one email is sent per user - mapM_ (sendNotifyEmailAndDelay users) . Map.toList $ - fmap ("Maintainer Notifications",) . 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 $ - Map.mapKeys fst . Map.mapWithKey (\(_, dep) emailContent -> ("Dependency Update: " <> T.pack (display dep), emailContent)) $ - dependencyEmails + emails <- + getNotificationEmails serverEnv userDetailsFeature users + ( foldr1 (Map.unionWith (<>)) + [ revisionUploadEmails + , groupActionEmails + , docReportEmails + , tagProposalEmails + ] + , dependencyEmails + ) + mapM_ sendNotifyEmailAndDelay emails updateState notifyState (SetNotifyTime now) @@ -899,36 +898,103 @@ userNotifyFeature ServerEnv{serverBaseURI, serverCron} ] <> EmailContentList (map renderPkgLink revDeps) - sendNotifyEmailAndDelay :: Users.Users -> (UserId, (T.Text, EmailContent)) -> IO () - sendNotifyEmailAndDelay users (uid, (subject, emailContent)) = 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", "[Hackage] " <> subject)], - mailParts = - [ fromEmailContent $ emailContent <> updatePreferencesText - ] - } - Just ourHost = uriAuthority serverBaseURI + sendNotifyEmailAndDelay :: Mail -> IO () + sendNotifyEmailAndDelay email = do + -- TODO: if we need any configuration of sendmail stuff, has to go here + renderSendMail email - renderSendMail mail --TODO: if we need any configuration of - -- sendmail stuff, has to go here - threadDelay 250000 - where - updatePreferencesText = - EmailContentParagraph $ - "You can adjust your notification preferences at" <> EmailContentSoftBreak - <> emailContentUrl - serverBaseURI - { uriPath = - concatMap ("/" <>) - [ "user" - , display $ Users.userIdToName users uid - , "notify" - ] - } + -- delay sending out emails, because ??? + threadDelay 250000 + +-- | 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 + -> (Map UserId EmailContent, Map (UserId, PackageId) EmailContent) + -> IO [Mail] +getNotificationEmails + ServerEnv{serverBaseURI} + UserDetailsFeature{queryUserDetails} + allUsers + (generalEmails, dependencyUpdateEmails) = do + let userIds = Set.fromList . Map.keys $ generalEmails <> Map.mapKeys fst dependencyUpdateEmails + userIdToDetails <- Map.mapMaybe id <$> fromSetM queryUserDetails userIds + + pure $ + let emails = + groupNotifications . concat $ + [ Map.toList + . fmap (, GeneralNotification) + $ generalEmails + , Map.toList + . Map.mapKeys fst + . Map.mapWithKey (\(_, pkg) emailContent -> (emailContent, DependencyNotification pkg)) + $ dependencyUpdateEmails + ] + 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" + ] + } + +{----- Utilities -----} + +fromSetM :: Monad m => (k -> m v) -> Set k -> m (Map k v) +fromSetM f = traverse id . Map.fromSet f From b896c75b551c4e3a8bb41a5292eed21306be66de Mon Sep 17 00:00:00 2001 From: Brandon Chinn Date: Thu, 17 Aug 2023 17:26:08 -0700 Subject: [PATCH 38/71] Move describeRevision into getNotificationEmails --- .../Server/Features/UserNotify.hs | 124 +++++++++++++----- 1 file changed, 92 insertions(+), 32 deletions(-) diff --git a/src/Distribution/Server/Features/UserNotify.hs b/src/Distribution/Server/Features/UserNotify.hs index bdabe79a0..afe638a1d 100644 --- a/src/Distribution/Server/Features/UserNotify.hs +++ b/src/Distribution/Server/Features/UserNotify.hs @@ -686,8 +686,7 @@ userNotifyFeature serverEnv@ServerEnv{serverBaseURI, serverCron} users <- queryGetUserDb revisionsAndUploads <- collectRevisionsAndUploads trimLastTime now - revisionUploadNotifications <- foldM (genRevUploadList notifyPrefs) Map.empty revisionsAndUploads - let revisionUploadEmails = foldMap (describeRevision users trimLastTime now) <$> revisionUploadNotifications + revisionUploadNotifications <- concatMapM (genRevUploadList notifyPrefs trimLastTime now) revisionsAndUploads groupActions <- collectAdminActions trimLastTime now groupActionNotifications <- foldM (genGroupUploadList notifyPrefs) Map.empty groupActions @@ -709,13 +708,15 @@ userNotifyFeature serverEnv@ServerEnv{serverBaseURI, serverCron} emails <- getNotificationEmails serverEnv userDetailsFeature users ( foldr1 (Map.unionWith (<>)) - [ revisionUploadEmails - , groupActionEmails + [ groupActionEmails , docReportEmails , tagProposalEmails ] , dependencyEmails - ) + ) $ + concat + [ revisionUploadNotifications + ] mapM_ sendNotifyEmailAndDelay emails updateState notifyState (SetNotifyTime now) @@ -762,25 +763,39 @@ userNotifyFeature serverEnv@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)) + 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 mp ga = let (actor,gdesc) = case ga of (_,uid,Admin_GroupAddUser _ gd,_) -> (uid, gd) @@ -817,18 +832,6 @@ userNotifyFeature serverEnv@ServerEnv{serverBaseURI, serverCron} Map.mapKeys (, pid) <$> getUserNotificationsOnRelease (queryUserGroup . maintainersGroup) idx revIdx queryGetUserNotifyPref pid - describeRevision users earlier now pkg - | pkgNumRevisions pkg <= 1 = - EmailContentParagraph $ - "Package upload, " <> renderPkgLink (pkgInfoId pkg) <> ", by " <> - formatTimeUser users (pkgLatestUploadTime pkg) (pkgLatestUploadUser pkg) - | otherwise = - EmailContentParagraph ("Package metadata revision(s), " <> renderPkgLink (pkgInfoId pkg) <> ":") - <> EmailContentList (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, reason) = fmap ( \message -> @@ -906,6 +909,15 @@ userNotifyFeature serverEnv@ServerEnv{serverBaseURI, serverCron} -- delay sending out emails, because ??? threadDelay 250000 +data Notification + = NotifyNewVersion + { notifyPackageInfo :: PkgInfo + } + | NotifyNewRevision + { notifyPackageId :: PackageId + , notifyRevisions :: [UploadInfo] + } + -- | Notifications in the same group are batched in the same email. -- -- TODO: How often do multiple notifications come in at once? Maybe it's @@ -921,14 +933,17 @@ getNotificationEmails -> UserDetailsFeature -> Users.Users -> (Map UserId EmailContent, Map (UserId, PackageId) EmailContent) + -> [(UserId, Notification)] -> IO [Mail] getNotificationEmails ServerEnv{serverBaseURI} UserDetailsFeature{queryUserDetails} allUsers - (generalEmails, dependencyUpdateEmails) = do - let userIds = Set.fromList . Map.keys $ generalEmails <> Map.mapKeys fst dependencyUpdateEmails - userIdToDetails <- Map.mapMaybe id <$> fromSetM queryUserDetails userIds + (generalEmails, dependencyUpdateEmails) + notifications = do + let userIds = Set.fromList $ map fst notifications + let userIds' = Set.fromList . Map.keys $ generalEmails <> Map.mapKeys fst dependencyUpdateEmails + userIdToDetails <- Map.mapMaybe id <$> fromSetM queryUserDetails (userIds <> userIds') pure $ let emails = @@ -940,6 +955,8 @@ getNotificationEmails . Map.mapKeys fst . Map.mapWithKey (\(_, pkg) emailContent -> (emailContent, DependencyNotification pkg)) $ dependencyUpdateEmails + , flip mapMaybe notifications $ \(uid, notif) -> + fmap (uid,) $ renderNotification notif ] in flip mapMaybe (Map.toList emails) $ \((uid, group), emailContent) -> case uid `Map.lookup` userIdToDetails of @@ -994,7 +1011,50 @@ getNotificationEmails ] } + {----- Render notifications -----} + + renderNotification :: Notification -> Maybe (EmailContent, NotificationGroup) + renderNotification = \case + NotifyNewVersion{..} -> + generalNotification $ + renderNotifyNewVersion + notifyPackageInfo + NotifyNewRevision{..} -> + generalNotification $ + renderNotifyNewRevision + notifyPackageId + notifyRevisions + where + generalNotification emailContent = Just (emailContent, 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) + + {----- Rendering helpers -----} + + 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 From d6d0d94eb0a618f9cd73f2aae8064ebc2f260fca Mon Sep 17 00:00:00 2001 From: Brandon Chinn Date: Thu, 17 Aug 2023 17:31:56 -0700 Subject: [PATCH 39/71] Move describeGroupAction into getNotificationEmails --- .../Server/Features/UserNotify.hs | 112 +++++++++++------- 1 file changed, 69 insertions(+), 43 deletions(-) diff --git a/src/Distribution/Server/Features/UserNotify.hs b/src/Distribution/Server/Features/UserNotify.hs index afe638a1d..37ce441eb 100644 --- a/src/Distribution/Server/Features/UserNotify.hs +++ b/src/Distribution/Server/Features/UserNotify.hs @@ -80,7 +80,10 @@ import Text.XHtml hiding (base, text, ()) import qualified Data.Aeson as Aeson import qualified Data.Aeson.Types as Aeson 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. @@ -689,8 +692,7 @@ userNotifyFeature serverEnv@ServerEnv{serverBaseURI, serverCron} revisionUploadNotifications <- concatMapM (genRevUploadList notifyPrefs trimLastTime now) revisionsAndUploads groupActions <- collectAdminActions trimLastTime now - groupActionNotifications <- foldM (genGroupUploadList notifyPrefs) Map.empty groupActions - let groupActionEmails = mconcat . mapMaybe (describeGroupAction users) <$> groupActionNotifications + groupActionNotifications <- concatMapM (genGroupUploadList notifyPrefs) groupActions docReports <- collectDocReport trimLastTime now docReportNotifications <- foldM (genDocReportList notifyPrefs) Map.empty docReports @@ -708,14 +710,14 @@ userNotifyFeature serverEnv@ServerEnv{serverBaseURI, serverCron} emails <- getNotificationEmails serverEnv userDetailsFeature users ( foldr1 (Map.unionWith (<>)) - [ groupActionEmails - , docReportEmails + [ docReportEmails , tagProposalEmails ] , dependencyEmails ) $ concat [ revisionUploadNotifications + , groupActionNotifications ] mapM_ sendNotifyEmailAndDelay emails @@ -728,11 +730,6 @@ userNotifyFeature serverEnv@ServerEnv{serverBaseURI, serverCron} { uriPath = "/package/" <> display (packageName pkg) <> "-" <> display (packageVersion pkg) } - formatTimeUser users t u = - EmailContentText . T.pack $ - display (Users.userIdToName users u) ++ " [" ++ - (formatTime defaultTimeLocale "%c" t) ++ "]" - collectRevisionsAndUploads earlier now = do pkgIndex <- queryGetPackageIndex let isRecent pkgInfo = @@ -797,18 +794,36 @@ userNotifyFeature serverEnv@ServerEnv{serverBaseURI, serverCron} { notifyPackageInfo = pkg } - 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 + 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 mp pkgDoc = do let addNotification uid m = @@ -832,28 +847,6 @@ userNotifyFeature serverEnv@ServerEnv{serverBaseURI, serverCron} Map.mapKeys (, pid) <$> getUserNotificationsOnRelease (queryUserGroup . maintainersGroup) idx revIdx queryGetUserNotifyPref pid - describeGroupAction users (time, uid, act, reason) = - fmap - ( \message -> - EmailContentParagraph ("Group modified by " <> formatTimeUser users time uid <> ":") - <> EmailContentList - [ message - , "Reason: " <> emailContentLBS reason - ] - ) - $ case act of - (Admin_GroupAddUser tn (MaintainerGroup pkg)) -> - Just $ - emailContentDisplay (Users.userIdToName users tn) - <> " added to maintainers for " - <> emailContentLBS pkg - (Admin_GroupDelUser tn (MaintainerGroup pkg)) -> - Just $ - emailContentDisplay (Users.userIdToName users tn) - <> " removed from maintainers for " - <> emailContentLBS pkg - _ -> Nothing - describeDocReport (pkg, success) = EmailContentParagraph $ "Package doc build for " <> emailContentDisplay (packageName pkg) <> ":" <> EmailContentSoftBreak <> @@ -917,6 +910,16 @@ data Notification { notifyPackageId :: PackageId , notifyRevisions :: [UploadInfo] } + | NotifyMaintainerUpdate + { notifyMaintainerUpdateType :: NotifyMaintainerUpdateType + , notifyUserActor :: UserId + , notifyUserSubject :: UserId + , notifyPackageName :: PackageName + , notifyReason :: Text + , notifyUpdatedAt :: UTCTime + } + +data NotifyMaintainerUpdateType = MaintainerAdded | MaintainerRemoved -- | Notifications in the same group are batched in the same email. -- @@ -1024,6 +1027,15 @@ getNotificationEmails renderNotifyNewRevision notifyPackageId notifyRevisions + NotifyMaintainerUpdate{..} -> + generalNotification $ + renderNotifyMaintainerUpdate + notifyMaintainerUpdateType + notifyUserActor + notifyUserSubject + notifyPackageName + notifyReason + notifyUpdatedAt where generalNotification emailContent = Just (emailContent, GeneralNotification) @@ -1036,8 +1048,22 @@ getNotificationEmails 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 + ] + + {----- Rendering helpers -----} + renderPackageName = emailContentStr . unPackageName + renderPkgLink pkg = EmailContentLink (T.pack $ display pkg) From 8f7c98ea93496af91acc41cf728696ae0c7e7db0 Mon Sep 17 00:00:00 2001 From: Brandon Chinn Date: Thu, 17 Aug 2023 17:35:02 -0700 Subject: [PATCH 40/71] Move describeTagProposal into getNotificationEmails --- .../Server/Features/UserNotify.hs | 54 ++++++++++++------- 1 file changed, 34 insertions(+), 20 deletions(-) diff --git a/src/Distribution/Server/Features/UserNotify.hs b/src/Distribution/Server/Features/UserNotify.hs index 37ce441eb..a99217cc2 100644 --- a/src/Distribution/Server/Features/UserNotify.hs +++ b/src/Distribution/Server/Features/UserNotify.hs @@ -699,8 +699,7 @@ userNotifyFeature serverEnv@ServerEnv{serverBaseURI, serverCron} let docReportEmails = foldMap describeDocReport <$> docReportNotifications tagProposals <- collectTagProposals - tagProposalNotifications <- foldM (genTagProposalList notifyPrefs) Map.empty tagProposals - let tagProposalEmails = foldMap describeTagProposal <$> tagProposalNotifications + tagProposalNotifications <- concatMapM (genTagProposalList notifyPrefs) tagProposals idx <- queryGetPackageIndex revIdx <- liftIO queryReverseIndex @@ -711,13 +710,13 @@ userNotifyFeature serverEnv@ServerEnv{serverBaseURI, serverCron} getNotificationEmails serverEnv userDetailsFeature users ( foldr1 (Map.unionWith (<>)) [ docReportEmails - , tagProposalEmails ] , dependencyEmails ) $ concat [ revisionUploadNotifications , groupActionNotifications + , tagProposalNotifications ] mapM_ sendNotifyEmailAndDelay emails @@ -834,14 +833,19 @@ userNotifyFeature serverEnv@ServerEnv{serverBaseURI, serverCron} 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) + 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 idx revIdx pid = Map.mapKeys (, pid) <$> @@ -854,15 +858,6 @@ userNotifyFeature serverEnv@ServerEnv{serverBaseURI, serverCron} then "Build successful." else "Build failed." - describeTagProposal (pkgName, (addTags, delTags)) = - EmailContentParagraph ("Pending tag proposal for " <> emailContentDisplay pkgName <> ":") - <> EmailContentList - [ "Additions: " <> showTags addTags - , "Deletions: " <> showTags delTags - ] - where - showTags = emailContentIntercalate ", " . map emailContentDisplay . Set.toList - describeDependencyUpdate (uId, dep) revDeps = do mPrefs <- queryGetUserNotifyPref uId pure $ @@ -918,6 +913,11 @@ data Notification , notifyReason :: Text , notifyUpdatedAt :: UTCTime } + | NotifyUpdateTags + { notifyPackageName :: PackageName + , notifyAddedTags :: Set Tag + , notifyDeletedTags :: Set Tag + } data NotifyMaintainerUpdateType = MaintainerAdded | MaintainerRemoved @@ -1036,6 +1036,12 @@ getNotificationEmails notifyPackageName notifyReason notifyUpdatedAt + NotifyUpdateTags{..} -> + generalNotification $ + renderNotifyUpdateTags + notifyPackageName + notifyAddedTags + notifyDeletedTags where generalNotification emailContent = Just (emailContent, GeneralNotification) @@ -1059,6 +1065,14 @@ getNotificationEmails , "Reason: " <> EmailContentText reason ] + renderNotifyUpdateTags pkg addedTags deletedTags = + EmailContentParagraph ("Pending tag proposal for " <> emailContentDisplay pkg <> ":") + <> EmailContentList + [ "Additions: " <> showTags addedTags + , "Deletions: " <> showTags deletedTags + ] + where + showTags = emailContentIntercalate ", " . map emailContentDisplay . Set.toList {----- Rendering helpers -----} From b60a9c2df9ae9611d89b20b45b320285ad3f4f4f Mon Sep 17 00:00:00 2001 From: Brandon Chinn Date: Thu, 17 Aug 2023 17:38:50 -0700 Subject: [PATCH 41/71] Move describeDependencyUpdate into getNotificationEmails --- .../Server/Features/UserNotify.hs | 111 ++++++++++-------- 1 file changed, 62 insertions(+), 49 deletions(-) diff --git a/src/Distribution/Server/Features/UserNotify.hs b/src/Distribution/Server/Features/UserNotify.hs index a99217cc2..31dfc10c1 100644 --- a/src/Distribution/Server/Features/UserNotify.hs +++ b/src/Distribution/Server/Features/UserNotify.hs @@ -580,7 +580,7 @@ userNotifyFeature :: ServerEnv -> StateComponent AcidState NotifyData -> Templates -> UserNotifyFeature -userNotifyFeature serverEnv@ServerEnv{serverBaseURI, serverCron} +userNotifyFeature serverEnv@ServerEnv{serverCron} UserFeature{..} CoreFeature{..} UploadFeature{..} @@ -703,32 +703,25 @@ userNotifyFeature serverEnv@ServerEnv{serverBaseURI, serverCron} idx <- queryGetPackageIndex revIdx <- liftIO queryReverseIndex - dependencyUpdateNotifications <- Map.unionsWith (++) <$> traverse (genDependencyUpdateList idx revIdx . pkgInfoToPkgId) revisionsAndUploads - dependencyEmails <- Map.traverseWithKey describeDependencyUpdate dependencyUpdateNotifications + dependencyUpdateNotifications <- concatMapM (genDependencyUpdateList idx revIdx . pkgInfoToPkgId) revisionsAndUploads emails <- - getNotificationEmails serverEnv userDetailsFeature users + getNotificationEmails serverEnv userDetailsFeature queryGetUserNotifyPref users ( foldr1 (Map.unionWith (<>)) [ docReportEmails ] - , dependencyEmails + , mempty ) $ concat [ revisionUploadNotifications , groupActionNotifications , tagProposalNotifications + , dependencyUpdateNotifications ] mapM_ sendNotifyEmailAndDelay emails updateState notifyState (SetNotifyTime now) - renderPkgLink pkg = - EmailContentLink - (T.pack $ display pkg) - serverBaseURI - { uriPath = "/package/" <> display (packageName pkg) <> "-" <> display (packageVersion pkg) - } - collectRevisionsAndUploads earlier now = do pkgIndex <- queryGetPackageIndex let isRecent pkgInfo = @@ -847,9 +840,14 @@ userNotifyFeature serverEnv@ServerEnv{serverBaseURI, serverCron} , notifyDeletedTags = deletedTags } - genDependencyUpdateList idx revIdx pid = - Map.mapKeys (, pid) <$> - getUserNotificationsOnRelease (queryUserGroup . maintainersGroup) idx revIdx queryGetUserNotifyPref pid + genDependencyUpdateList idx revIdx pkg = do + let toNotif watchedPkgs = + NotifyDependencyUpdate + { notifyPackageId = pkg + , notifyWatchedPackages = watchedPkgs + } + Map.toList . fmap toNotif + <$> getUserNotificationsOnRelease (queryUserGroup . maintainersGroup) idx revIdx queryGetUserNotifyPref pkg describeDocReport (pkg, success) = EmailContentParagraph $ @@ -858,37 +856,6 @@ userNotifyFeature serverEnv@ServerEnv{serverBaseURI, serverCron} then "Build successful." else "Build failed." - describeDependencyUpdate (uId, dep) revDeps = do - mPrefs <- queryGetUserNotifyPref uId - pure $ - case mPrefs of - Nothing -> mempty - Just NotifyPref{notifyDependencyTriggerBounds} -> - let depName = emailContentDisplay (packageName dep) - depVersion = emailContentDisplay (packageVersion dep) - in - foldMap EmailContentParagraph - [ "The dependency " <> renderPkgLink dep <> " has been uploaded or revised." - , case notifyDependencyTriggerBounds 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 notifyDependencyTriggerBounds 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) - sendNotifyEmailAndDelay :: Mail -> IO () sendNotifyEmailAndDelay email = do -- TODO: if we need any configuration of sendmail stuff, has to go here @@ -918,6 +885,12 @@ data Notification , notifyAddedTags :: Set Tag , notifyDeletedTags :: Set Tag } + | NotifyDependencyUpdate + { notifyPackageId :: PackageId + -- ^ Dependency that was updated + , notifyWatchedPackages :: [PackageId] + -- ^ Packages maintained by user that depend on updated dep + } data NotifyMaintainerUpdateType = MaintainerAdded | MaintainerRemoved @@ -934,6 +907,7 @@ data NotificationGroup getNotificationEmails :: ServerEnv -> UserDetailsFeature + -> (UserId -> IO (Maybe NotifyPref)) -> Users.Users -> (Map UserId EmailContent, Map (UserId, PackageId) EmailContent) -> [(UserId, Notification)] @@ -941,12 +915,14 @@ getNotificationEmails getNotificationEmails ServerEnv{serverBaseURI} UserDetailsFeature{queryUserDetails} + queryGetUserNotifyPref allUsers (generalEmails, dependencyUpdateEmails) notifications = do let userIds = Set.fromList $ map fst notifications let userIds' = Set.fromList . Map.keys $ generalEmails <> Map.mapKeys fst dependencyUpdateEmails userIdToDetails <- Map.mapMaybe id <$> fromSetM queryUserDetails (userIds <> userIds') + userIdToNotifyPref <- Map.mapMaybe id <$> fromSetM queryGetUserNotifyPref userIds pure $ let emails = @@ -959,7 +935,7 @@ getNotificationEmails . Map.mapWithKey (\(_, pkg) emailContent -> (emailContent, DependencyNotification pkg)) $ dependencyUpdateEmails , flip mapMaybe notifications $ \(uid, notif) -> - fmap (uid,) $ renderNotification notif + fmap (uid,) $ renderNotification userIdToNotifyPref uid notif ] in flip mapMaybe (Map.toList emails) $ \((uid, group), emailContent) -> case uid `Map.lookup` userIdToDetails of @@ -1016,8 +992,8 @@ getNotificationEmails {----- Render notifications -----} - renderNotification :: Notification -> Maybe (EmailContent, NotificationGroup) - renderNotification = \case + renderNotification :: Map UserId NotifyPref -> UserId -> Notification -> Maybe (EmailContent, NotificationGroup) + renderNotification userIdToNotifyPref uid = \case NotifyNewVersion{..} -> generalNotification $ renderNotifyNewVersion @@ -1042,6 +1018,17 @@ getNotificationEmails notifyPackageName notifyAddedTags notifyDeletedTags + NotifyDependencyUpdate{..} -> + case uid `Map.lookup` userIdToNotifyPref of + Nothing -> Nothing + Just notifyPref -> + Just + ( renderNotifyDependencyUpdate + notifyPref + notifyPackageId + notifyWatchedPackages + , DependencyNotification notifyPackageId + ) where generalNotification emailContent = Just (emailContent, GeneralNotification) @@ -1074,6 +1061,32 @@ getNotificationEmails where showTags = emailContentIntercalate ", " . map emailContentDisplay . Set.toList + renderNotifyDependencyUpdate NotifyPref{..} dep revDeps = + let depName = emailContentDisplay (packageName dep) + depVersion = emailContentDisplay (packageVersion dep) + in + foldMap EmailContentParagraph + [ "The dependency " <> renderPkgLink dep <> " has been uploaded or revised." + , case notifyDependencyTriggerBounds 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 notifyDependencyTriggerBounds 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) + {----- Rendering helpers -----} renderPackageName = emailContentStr . unPackageName From cab758ef502b6abd285470e2f4137c977e578f60 Mon Sep 17 00:00:00 2001 From: Brandon Chinn Date: Thu, 17 Aug 2023 17:41:25 -0700 Subject: [PATCH 42/71] Move describeDocReport into getNotificationEmails --- .../Server/Features/UserNotify.hs | 49 ++++++++++++------- 1 file changed, 31 insertions(+), 18 deletions(-) diff --git a/src/Distribution/Server/Features/UserNotify.hs b/src/Distribution/Server/Features/UserNotify.hs index 31dfc10c1..496f92ca2 100644 --- a/src/Distribution/Server/Features/UserNotify.hs +++ b/src/Distribution/Server/Features/UserNotify.hs @@ -695,8 +695,7 @@ userNotifyFeature serverEnv@ServerEnv{serverCron} groupActionNotifications <- concatMapM (genGroupUploadList notifyPrefs) groupActions docReports <- collectDocReport trimLastTime now - docReportNotifications <- foldM (genDocReportList notifyPrefs) Map.empty docReports - let docReportEmails = foldMap describeDocReport <$> docReportNotifications + docReportNotifications <- concatMapM (genDocReportList notifyPrefs) docReports tagProposals <- collectTagProposals tagProposalNotifications <- concatMapM (genTagProposalList notifyPrefs) tagProposals @@ -708,13 +707,14 @@ userNotifyFeature serverEnv@ServerEnv{serverCron} emails <- getNotificationEmails serverEnv userDetailsFeature queryGetUserNotifyPref users ( foldr1 (Map.unionWith (<>)) - [ docReportEmails + [ ] , mempty ) $ concat [ revisionUploadNotifications , groupActionNotifications + , docReportNotifications , tagProposalNotifications , dependencyUpdateNotifications ] @@ -817,14 +817,18 @@ userNotifyFeature serverEnv@ServerEnv{serverCron} } _ -> pure [] - 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) + 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 @@ -849,13 +853,6 @@ userNotifyFeature serverEnv@ServerEnv{serverCron} Map.toList . fmap toNotif <$> getUserNotificationsOnRelease (queryUserGroup . maintainersGroup) idx revIdx queryGetUserNotifyPref pkg - describeDocReport (pkg, success) = - EmailContentParagraph $ - "Package doc build for " <> emailContentDisplay (packageName pkg) <> ":" <> EmailContentSoftBreak <> - if success - then "Build successful." - else "Build failed." - sendNotifyEmailAndDelay :: Mail -> IO () sendNotifyEmailAndDelay email = do -- TODO: if we need any configuration of sendmail stuff, has to go here @@ -880,6 +877,10 @@ data Notification , notifyReason :: Text , notifyUpdatedAt :: UTCTime } + | NotifyDocsBuild + { notifyPackageId :: PackageId + , notifyBuildSuccess :: Bool + } | NotifyUpdateTags { notifyPackageName :: PackageName , notifyAddedTags :: Set Tag @@ -1012,6 +1013,11 @@ getNotificationEmails notifyPackageName notifyReason notifyUpdatedAt + NotifyDocsBuild{..} -> + generalNotification $ + renderNotifyDocsBuild + notifyPackageId + notifyBuildSuccess NotifyUpdateTags{..} -> generalNotification $ renderNotifyUpdateTags @@ -1052,6 +1058,13 @@ getNotificationEmails , "Reason: " <> EmailContentText reason ] + 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 From 3a0fad28eaec9ad6f9412fd6c2cd8c5833a6909c Mon Sep 17 00:00:00 2001 From: Brandon Chinn Date: Thu, 17 Aug 2023 17:42:03 -0700 Subject: [PATCH 43/71] Remove migration workarounds --- .../Server/Features/UserNotify.hs | 25 +++---------------- 1 file changed, 4 insertions(+), 21 deletions(-) diff --git a/src/Distribution/Server/Features/UserNotify.hs b/src/Distribution/Server/Features/UserNotify.hs index 496f92ca2..7b21ceaa9 100644 --- a/src/Distribution/Server/Features/UserNotify.hs +++ b/src/Distribution/Server/Features/UserNotify.hs @@ -705,12 +705,7 @@ userNotifyFeature serverEnv@ServerEnv{serverCron} dependencyUpdateNotifications <- concatMapM (genDependencyUpdateList idx revIdx . pkgInfoToPkgId) revisionsAndUploads emails <- - getNotificationEmails serverEnv userDetailsFeature queryGetUserNotifyPref users - ( foldr1 (Map.unionWith (<>)) - [ - ] - , mempty - ) $ + getNotificationEmails serverEnv userDetailsFeature queryGetUserNotifyPref users $ concat [ revisionUploadNotifications , groupActionNotifications @@ -910,7 +905,6 @@ getNotificationEmails -> UserDetailsFeature -> (UserId -> IO (Maybe NotifyPref)) -> Users.Users - -> (Map UserId EmailContent, Map (UserId, PackageId) EmailContent) -> [(UserId, Notification)] -> IO [Mail] getNotificationEmails @@ -918,26 +912,15 @@ getNotificationEmails UserDetailsFeature{queryUserDetails} queryGetUserNotifyPref allUsers - (generalEmails, dependencyUpdateEmails) notifications = do let userIds = Set.fromList $ map fst notifications - let userIds' = Set.fromList . Map.keys $ generalEmails <> Map.mapKeys fst dependencyUpdateEmails - userIdToDetails <- Map.mapMaybe id <$> fromSetM queryUserDetails (userIds <> userIds') + userIdToDetails <- Map.mapMaybe id <$> fromSetM queryUserDetails userIds userIdToNotifyPref <- Map.mapMaybe id <$> fromSetM queryGetUserNotifyPref userIds pure $ let emails = - groupNotifications . concat $ - [ Map.toList - . fmap (, GeneralNotification) - $ generalEmails - , Map.toList - . Map.mapKeys fst - . Map.mapWithKey (\(_, pkg) emailContent -> (emailContent, DependencyNotification pkg)) - $ dependencyUpdateEmails - , flip mapMaybe notifications $ \(uid, notif) -> - fmap (uid,) $ renderNotification userIdToNotifyPref uid notif - ] + groupNotifications . flip mapMaybe notifications $ \(uid, notif) -> + fmap (uid,) $ renderNotification userIdToNotifyPref uid notif in flip mapMaybe (Map.toList emails) $ \((uid, group), emailContent) -> case uid `Map.lookup` userIdToDetails of Nothing -> Nothing From 3d3f48a72b6f0cb2918eb137ef74da8a90052755 Mon Sep 17 00:00:00 2001 From: Brandon Chinn Date: Thu, 17 Aug 2023 13:34:50 -0700 Subject: [PATCH 44/71] Add tests for getNotificationEmails --- hackage-server.cabal | 16 + .../Server/Features/UserNotify.hs | 9 +- tests/ReverseDependenciesTest.hs | 321 +++++++++++++++++- ...mails-NotifyDependencyUpdate-Always.golden | 42 +++ ...fyDependencyUpdate-BoundsOutOfRange.golden | 42 +++ ...DependencyUpdate-NewIncompatibility.golden | 42 +++ ...ationEmails-NotifyDocsBuild-failure.golden | 29 ++ ...ationEmails-NotifyDocsBuild-success.golden | 29 ++ ...ifyMaintainerUpdate-MaintainerAdded.golden | 34 ++ ...yMaintainerUpdate-MaintainerRemoved.golden | 34 ++ ...otificationEmails-NotifyNewRevision.golden | 34 ++ ...NotificationEmails-NotifyNewVersion.golden | 27 ++ ...NotificationEmails-NotifyUpdateTags.golden | 34 ++ .../getNotificationEmails-batched.golden | 51 +++ 14 files changed, 737 insertions(+), 7 deletions(-) create mode 100644 tests/golden/ReverseDependenciesTest/getNotificationEmails-NotifyDependencyUpdate-Always.golden create mode 100644 tests/golden/ReverseDependenciesTest/getNotificationEmails-NotifyDependencyUpdate-BoundsOutOfRange.golden create mode 100644 tests/golden/ReverseDependenciesTest/getNotificationEmails-NotifyDependencyUpdate-NewIncompatibility.golden create mode 100644 tests/golden/ReverseDependenciesTest/getNotificationEmails-NotifyDocsBuild-failure.golden create mode 100644 tests/golden/ReverseDependenciesTest/getNotificationEmails-NotifyDocsBuild-success.golden create mode 100644 tests/golden/ReverseDependenciesTest/getNotificationEmails-NotifyMaintainerUpdate-MaintainerAdded.golden create mode 100644 tests/golden/ReverseDependenciesTest/getNotificationEmails-NotifyMaintainerUpdate-MaintainerRemoved.golden create mode 100644 tests/golden/ReverseDependenciesTest/getNotificationEmails-NotifyNewRevision.golden create mode 100644 tests/golden/ReverseDependenciesTest/getNotificationEmails-NotifyNewVersion.golden create mode 100644 tests/golden/ReverseDependenciesTest/getNotificationEmails-NotifyUpdateTags.golden create mode 100644 tests/golden/ReverseDependenciesTest/getNotificationEmails-batched.golden diff --git a/hackage-server.cabal b/hackage-server.cabal index 98e4731b6..fc0f51c88 100644 --- a/hackage-server.cabal +++ b/hackage-server.cabal @@ -52,6 +52,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 @@ -569,11 +580,16 @@ test-suite ReverseDependenciesTest build-tool-depends: hackage-server:hackage-server build-depends: , tasty ^>= 1.4 + , tasty-golden ^>= 2.3 + , tasty-hedgehog ^>= 1.4 , tasty-hunit ^>= 0.10 , HUnit ^>= 1.6 , hedgehog ^>= 1.3 , exceptions , bimap + , mime-mail + , random + , transformers other-modules: RevDepCommon benchmark RevDeps diff --git a/src/Distribution/Server/Features/UserNotify.hs b/src/Distribution/Server/Features/UserNotify.hs index 7b21ceaa9..47fa29b3d 100644 --- a/src/Distribution/Server/Features/UserNotify.hs +++ b/src/Distribution/Server/Features/UserNotify.hs @@ -9,7 +9,7 @@ module Distribution.Server.Features.UserNotify ( NotifyData(..), NotifyPref(..), - NotifyRevisionRange, + NotifyRevisionRange(..), NotifyTriggerBounds(..), UserNotifyFeature(..), defaultNotifyPrefs, @@ -17,6 +17,11 @@ module Distribution.Server.Features.UserNotify ( importNotifyPref, initUserNotifyFeature, notifyDataToCSV, + + -- * getNotificationEmails + Notification(..), + NotifyMaintainerUpdateType(..), + getNotificationEmails, ) where import Prelude hiding (lookup) @@ -887,8 +892,10 @@ data Notification , notifyWatchedPackages :: [PackageId] -- ^ Packages maintained by user that depend on updated dep } + deriving (Show) data NotifyMaintainerUpdateType = MaintainerAdded | MaintainerRemoved + deriving (Show) -- | Notifications in the same group are batched in the same email. -- diff --git a/tests/ReverseDependenciesTest.hs b/tests/ReverseDependenciesTest.hs index 2626f7a34..6910066c3 100644 --- a/tests/ReverseDependenciesTest.hs +++ b/tests/ReverseDependenciesTest.hs @@ -1,25 +1,43 @@ {-# 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.Tags (Tag(..)) +import Distribution.Server.Features.UserDetails (AccountDetails(..), UserDetailsFeature(..)) import Distribution.Server.Features.UserNotify - ( NotifyData(..) + ( Notification(..) + , NotifyMaintainerUpdateType(..) + , NotifyData(..) , NotifyPref(..) - , NotifyRevisionRange + , NotifyRevisionRange(..) , NotifyTriggerBounds(..) , defaultNotifyPrefs + , getNotificationEmails , getUserNotificationsOnRelease , importNotifyPref , notifyDataToCSV @@ -27,18 +45,38 @@ import Distribution.Server.Features.UserNotify 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) @@ -276,11 +314,261 @@ 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 + (\_ -> pure $ Just notifyEverything{notifyDependencyTriggerBounds = Always}) + allUsers + userWatcher + $ NotifyDependencyUpdate + { notifyPackageId = PackageIdentifier "base" (mkVersion [4, 18, 0, 0]) + , notifyWatchedPackages = [PackageIdentifier "mtl" (mkVersion [2, 3])] + } + , testGolden "Render NotifyDependencyUpdate-NewIncompatibility" "getNotificationEmails-NotifyDependencyUpdate-NewIncompatibility.golden" $ + fmap renderMail + . getNotificationEmail + testServerEnv + testUserDetailsFeature + (\_ -> pure $ Just notifyEverything{notifyDependencyTriggerBounds = NewIncompatibility}) + allUsers + userWatcher + $ NotifyDependencyUpdate + { notifyPackageId = PackageIdentifier "base" (mkVersion [4, 18, 0, 0]) + , notifyWatchedPackages = [PackageIdentifier "mtl" (mkVersion [2, 3])] + } + , testGolden "Render NotifyDependencyUpdate-BoundsOutOfRange" "getNotificationEmails-NotifyDependencyUpdate-BoundsOutOfRange.golden" $ + fmap renderMail + . getNotificationEmail + testServerEnv + testUserDetailsFeature + (\_ -> pure $ Just notifyEverything{notifyDependencyTriggerBounds = BoundsOutOfRange}) + allUsers + userWatcher + $ NotifyDependencyUpdate + { notifyPackageId = PackageIdentifier "base" (mkVersion [4, 18, 0, 0]) + , notifyWatchedPackages = [PackageIdentifier "mtl" (mkVersion [2, 3])] + } + , 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{} -> () + + isGeneral = \case + NotifyNewVersion{} -> True + NotifyNewRevision{} -> True + NotifyMaintainerUpdate{} -> True + NotifyDocsBuild{} -> True + NotifyUpdateTags{} -> True + NotifyDependencyUpdate{} -> False + + -- 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 pref users uid notif = + getNotificationEmails env details pref 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 = "" + } + } + notifyEverything = + NotifyPref + { notifyOptOut = False + , notifyRevisionRange = NotifyAllVersions + , notifyUpload = True + , notifyMaintainerGroup = True + , notifyDocBuilderReport = True + , notifyPendingTags = True + , notifyDependencyForMaintained = True + , notifyDependencyTriggerBounds = Always + } + testGetUserNotifyPref uid = pure $ do + guard $ uid == userWatcher + Just notifyEverything + getNotificationEmailsMocked = + getNotificationEmails + testServerEnv + testUserDetailsFeature + testGetUserNotifyPref + allUsers + getNotificationEmailMocked = + getNotificationEmail + testServerEnv + testUserDetailsFeature + testGetUserNotifyPref + 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 + ] + + 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) @@ -385,5 +673,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/golden/ReverseDependenciesTest/getNotificationEmails-NotifyDependencyUpdate-Always.golden b/tests/golden/ReverseDependenciesTest/getNotificationEmails-NotifyDependencyUpdate-Always.golden new file mode 100644 index 000000000..1be08910f --- /dev/null +++ b/tests/golden/ReverseDependenciesTest/getNotificationEmails-NotifyDependencyUpdate-Always.golden @@ -0,0 +1,42 @@ +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 + +The dependency base-4.18.0.0 (https://hackage.haskell.org/package/base-4.18.0.0) has been uploaded or revised. + +You have requested to be notified for each upload or revision of a dependency. + +These are your packages that depend on base: + +* mtl-2.3 (https://hackage.haskell.org/package/mtl-2.3) + +You can adjust your notification preferences at +https://hackage.haskell.org/user/user-watcher/notify (https://hackage.haskell.org/user/user-watcher/notify) + + +--YIYrWcf3to +Content-Type: text/html; charset=utf-8 + + +

    +The dependency base-4.18.0.0 has been uploaded or revised. +

    +

    +You have requested to be notified for each upload or revision of a dependency. +

    +

    +These are your packages that depend on base: +

    + +

    +You can adjust your notification preferences at +
    https://hackage.haskell.org/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..f0af6524b --- /dev/null +++ b/tests/golden/ReverseDependenciesTest/getNotificationEmails-NotifyDependencyUpdate-BoundsOutOfRange.golden @@ -0,0 +1,42 @@ +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 + +The dependency base-4.18.0.0 (https://hackage.haskell.org/package/base-4.18.0.0) has been uploaded or revised. + +You have requested to be notified when a dependency isn't accepted by any of your maintained packages. + +These are your packages that require base but don't accept 4.18.0.0: + +* mtl-2.3 (https://hackage.haskell.org/package/mtl-2.3) + +You can adjust your notification preferences at +https://hackage.haskell.org/user/user-watcher/notify (https://hackage.haskell.org/user/user-watcher/notify) + + +--YIYrWcf3to +Content-Type: text/html; charset=utf-8 + + +

    +The dependency base-4.18.0.0 has been uploaded or revised. +

    +

    +You have requested to be notified when a dependency isn't accepted by any of your maintained packages. +

    +

    +These are your packages that require base but don't accept 4.18.0.0: +

    + +

    +You can adjust your notification preferences at +
    https://hackage.haskell.org/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..e14720d55 --- /dev/null +++ b/tests/golden/ReverseDependenciesTest/getNotificationEmails-NotifyDependencyUpdate-NewIncompatibility.golden @@ -0,0 +1,42 @@ +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 + +The dependency base-4.18.0.0 (https://hackage.haskell.org/package/base-4.18.0.0) has been uploaded or revised. + +You have requested to be notified when a dependency isn't accepted by any of your maintained packages. + +The following packages require base but don't accept 4.18.0.0 (they do accept the second-highest version): + +* mtl-2.3 (https://hackage.haskell.org/package/mtl-2.3) + +You can adjust your notification preferences at +https://hackage.haskell.org/user/user-watcher/notify (https://hackage.haskell.org/user/user-watcher/notify) + + +--YIYrWcf3to +Content-Type: text/html; charset=utf-8 + + +

    +The dependency base-4.18.0.0 has been uploaded or revised. +

    +

    +You have requested to be notified when a dependency isn't accepted by any of your maintained packages. +

    +

    +The following packages require base but don't accept 4.18.0.0 (they do accept the second-highest version): +

    + +

    +You can adjust your notification preferences at +
    https://hackage.haskell.org/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..5932132ed --- /dev/null +++ b/tests/golden/ReverseDependenciesTest/getNotificationEmails-NotifyDocsBuild-failure.golden @@ -0,0 +1,29 @@ +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 + +Package doc build for base-4.18.0.0 (https://hackage.haskell.org/package/base-4.18.0.0): +Build failed. + +You can adjust your notification preferences at +https://hackage.haskell.org/user/user-watcher/notify (https://hackage.haskell.org/user/user-watcher/notify) + + +--YIYrWcf3to +Content-Type: text/html; charset=utf-8 + + +

    +Package doc build for base-4.18.0.0: +
    Build failed. +

    +

    +You can adjust your notification preferences at +
    https://hackage.haskell.org/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..f60d93d7f --- /dev/null +++ b/tests/golden/ReverseDependenciesTest/getNotificationEmails-NotifyDocsBuild-success.golden @@ -0,0 +1,29 @@ +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 + +Package doc build for base-4.18.0.0 (https://hackage.haskell.org/package/base-4.18.0.0): +Build successful. + +You can adjust your notification preferences at +https://hackage.haskell.org/user/user-watcher/notify (https://hackage.haskell.org/user/user-watcher/notify) + + +--YIYrWcf3to +Content-Type: text/html; charset=utf-8 + + +

    +Package doc build for base-4.18.0.0: +
    Build successful. +

    +

    +You can adjust your notification preferences at +
    https://hackage.haskell.org/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..07d465d03 --- /dev/null +++ b/tests/golden/ReverseDependenciesTest/getNotificationEmails-NotifyMaintainerUpdate-MaintainerAdded.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 + +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.haskell.org/user/user-watcher/notify (https://hackage.haskell.org/user/user-watcher/notify) + + +--YIYrWcf3to +Content-Type: text/html; charset=utf-8 + + +

    +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.haskell.org/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..73dccf5c7 --- /dev/null +++ b/tests/golden/ReverseDependenciesTest/getNotificationEmails-NotifyMaintainerUpdate-MaintainerRemoved.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 + +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.haskell.org/user/user-watcher/notify (https://hackage.haskell.org/user/user-watcher/notify) + + +--YIYrWcf3to +Content-Type: text/html; charset=utf-8 + + +

    +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.haskell.org/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..afd5fd08a --- /dev/null +++ b/tests/golden/ReverseDependenciesTest/getNotificationEmails-NotifyNewRevision.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 + +Package metadata revision(s), base-4.18.0.0 (https://hackage.haskell.org/package/base-4.18.0.0): + +* 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.haskell.org/user/user-watcher/notify (https://hackage.haskell.org/user/user-watcher/notify) + + +--YIYrWcf3to +Content-Type: text/html; charset=utf-8 + + +

    +Package metadata revision(s), base-4.18.0.0: +

    +
      +
    • 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.haskell.org/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..303ffed7f --- /dev/null +++ b/tests/golden/ReverseDependenciesTest/getNotificationEmails-NotifyNewVersion.golden @@ -0,0 +1,27 @@ +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 + +Package upload, base-4.18.0.0 (https://hackage.haskell.org/package/base-4.18.0.0), by user-actor [Wed Jan 1 00:00:00 UTC 2020] + +You can adjust your notification preferences at +https://hackage.haskell.org/user/user-watcher/notify (https://hackage.haskell.org/user/user-watcher/notify) + + +--YIYrWcf3to +Content-Type: text/html; charset=utf-8 + + +

    +Package upload, base-4.18.0.0, by user-actor [Wed Jan 1 00:00:00 UTC 2020] +

    +

    +You can adjust your notification preferences at +
    https://hackage.haskell.org/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..718f2c2c3 --- /dev/null +++ b/tests/golden/ReverseDependenciesTest/getNotificationEmails-NotifyUpdateTags.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 + +Pending tag proposal for base: + +* Additions: bsd3, library, prelude +* Deletions: bad, example, foo + +You can adjust your notification preferences at +https://hackage.haskell.org/user/user-watcher/notify (https://hackage.haskell.org/user/user-watcher/notify) + + +--YIYrWcf3to +Content-Type: text/html; charset=utf-8 + + +

    +Pending tag proposal for base: +

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

    +You can adjust your notification preferences at +
    https://hackage.haskell.org/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..abf6f7167 --- /dev/null +++ b/tests/golden/ReverseDependenciesTest/getNotificationEmails-batched.golden @@ -0,0 +1,51 @@ +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 + +Pending tag proposal for base: + +* Additions: newtag +* Deletions: oldtag + +Package doc build for base-4.18.0.0 (https://hackage.haskell.org/package/base-4.18.0.0): +Build successful. + +Package metadata revision(s), base-4.18.0.0 (https://hackage.haskell.org/package/base-4.18.0.0): + +* user-actor [Wed Jan 1 00:00:00 UTC 2020] + +You can adjust your notification preferences at +https://hackage.haskell.org/user/user-watcher/notify (https://hackage.haskell.org/user/user-watcher/notify) + + +--YIYrWcf3to +Content-Type: text/html; charset=utf-8 + + +

    +Pending tag proposal for base: +

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

    +Package doc build for base-4.18.0.0: +
    Build successful. +

    +

    +Package metadata revision(s), base-4.18.0.0: +

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

    +You can adjust your notification preferences at +
    https://hackage.haskell.org/user/user-watcher/notify +

    +--YIYrWcf3to-- \ No newline at end of file From 364ffe90cb76848ca07ba9553fb30b6c769a3246 Mon Sep 17 00:00:00 2001 From: Brandon Chinn Date: Fri, 18 Aug 2023 09:53:09 -0700 Subject: [PATCH 45/71] Update threadDelay comment, use htmlPart/plainPart --- .../Server/Features/UserNotify.hs | 3 +- src/Distribution/Server/Util/Email.hs | 15 +--- ...mails-NotifyDependencyUpdate-Always.golden | 67 ++++++++------- ...fyDependencyUpdate-BoundsOutOfRange.golden | 67 ++++++++------- ...DependencyUpdate-NewIncompatibility.golden | 69 ++++++++------- ...ationEmails-NotifyDocsBuild-failure.golden | 34 ++++---- ...ationEmails-NotifyDocsBuild-success.golden | 34 ++++---- ...ifyMaintainerUpdate-MaintainerAdded.golden | 46 +++++----- ...yMaintainerUpdate-MaintainerRemoved.golden | 46 +++++----- ...otificationEmails-NotifyNewRevision.golden | 48 ++++++----- ...NotificationEmails-NotifyNewVersion.golden | 31 ++++--- ...NotificationEmails-NotifyUpdateTags.golden | 46 +++++----- .../getNotificationEmails-batched.golden | 84 ++++++++++--------- 13 files changed, 327 insertions(+), 263 deletions(-) diff --git a/src/Distribution/Server/Features/UserNotify.hs b/src/Distribution/Server/Features/UserNotify.hs index 47fa29b3d..cb6b96c39 100644 --- a/src/Distribution/Server/Features/UserNotify.hs +++ b/src/Distribution/Server/Features/UserNotify.hs @@ -858,7 +858,8 @@ userNotifyFeature serverEnv@ServerEnv{serverCron} -- TODO: if we need any configuration of sendmail stuff, has to go here renderSendMail email - -- delay sending out emails, because ??? + -- delay sending out emails, to avoid spamming people if we accidentally + -- send out too many emails threadDelay 250000 data Notification diff --git a/src/Distribution/Server/Util/Email.hs b/src/Distribution/Server/Util/Email.hs index 30fd8bb9c..daabdfd62 100644 --- a/src/Distribution/Server/Util/Email.hs +++ b/src/Distribution/Server/Util/Email.hs @@ -68,20 +68,9 @@ emailContentUrl uri = EmailContentLink (uriToText uri) uri fromEmailContent :: EmailContent -> Alternatives fromEmailContent emailContent = - [ Part - { partType = contentType <> "; charset=utf-8" - , partEncoding = None - , partDisposition = DefaultDisposition - , partHeaders = [] - , partContent = PartContent $ TextL.encodeUtf8 $ TextL.fromStrict content - } - | (contentType, content) <- contents + [ plainPart $ TextL.fromStrict $ toPlainContent emailContent + , htmlPart $ TextL.fromStrict $ toHtmlContent emailContent ] - where - contents = - [ ("text/plain", toPlainContent emailContent) - , ("text/html", toHtmlContent emailContent) - ] -- | Convert an 'EmailContent' to plain text. -- diff --git a/tests/golden/ReverseDependenciesTest/getNotificationEmails-NotifyDependencyUpdate-Always.golden b/tests/golden/ReverseDependenciesTest/getNotificationEmails-NotifyDependencyUpdate-Always.golden index 1be08910f..03900ecaf 100644 --- a/tests/golden/ReverseDependenciesTest/getNotificationEmails-NotifyDependencyUpdate-Always.golden +++ b/tests/golden/ReverseDependenciesTest/getNotificationEmails-NotifyDependencyUpdate-Always.golden @@ -6,37 +6,46 @@ Content-Type: multipart/alternative; boundary="YIYrWcf3to" --YIYrWcf3to Content-Type: text/plain; charset=utf-8 - -The dependency base-4.18.0.0 (https://hackage.haskell.org/package/base-4.18.0.0) has been uploaded or revised. - -You have requested to be notified for each upload or revision of a dependency. - -These are your packages that depend on base: - -* mtl-2.3 (https://hackage.haskell.org/package/mtl-2.3) - -You can adjust your notification preferences at -https://hackage.haskell.org/user/user-watcher/notify (https://hackage.haskell.org/user/user-watcher/notify) - +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 - - -

    -The dependency base-4.18.0.0 has been uploaded or revised. -

    -

    -You have requested to be notified for each upload or revision of a dependency. -

    -

    -These are your packages that depend on base: -

    - -

    -You can adjust your notification preferences at -
    https://hackage.haskell.org/user/user-watcher/notify +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 index f0af6524b..f02b34387 100644 --- a/tests/golden/ReverseDependenciesTest/getNotificationEmails-NotifyDependencyUpdate-BoundsOutOfRange.golden +++ b/tests/golden/ReverseDependenciesTest/getNotificationEmails-NotifyDependencyUpdate-BoundsOutOfRange.golden @@ -6,37 +6,46 @@ Content-Type: multipart/alternative; boundary="YIYrWcf3to" --YIYrWcf3to Content-Type: text/plain; charset=utf-8 - -The dependency base-4.18.0.0 (https://hackage.haskell.org/package/base-4.18.0.0) has been uploaded or revised. - -You have requested to be notified when a dependency isn't accepted by any of your maintained packages. - -These are your packages that require base but don't accept 4.18.0.0: - -* mtl-2.3 (https://hackage.haskell.org/package/mtl-2.3) - -You can adjust your notification preferences at -https://hackage.haskell.org/user/user-watcher/notify (https://hackage.haskell.org/user/user-watcher/notify) - +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 - - -

    -The dependency base-4.18.0.0 has been uploaded or revised. -

    -

    -You have requested to be notified when a dependency isn't accepted by any of your maintained packages. -

    -

    -These are your packages that require base but don't accept 4.18.0.0: -

    - -

    -You can adjust your notification preferences at -
    https://hackage.haskell.org/user/user-watcher/notify +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 index e14720d55..8c05de87a 100644 --- a/tests/golden/ReverseDependenciesTest/getNotificationEmails-NotifyDependencyUpdate-NewIncompatibility.golden +++ b/tests/golden/ReverseDependenciesTest/getNotificationEmails-NotifyDependencyUpdate-NewIncompatibility.golden @@ -6,37 +6,48 @@ Content-Type: multipart/alternative; boundary="YIYrWcf3to" --YIYrWcf3to Content-Type: text/plain; charset=utf-8 - -The dependency base-4.18.0.0 (https://hackage.haskell.org/package/base-4.18.0.0) has been uploaded or revised. - -You have requested to be notified when a dependency isn't accepted by any of your maintained packages. - -The following packages require base but don't accept 4.18.0.0 (they do accept the second-highest version): - -* mtl-2.3 (https://hackage.haskell.org/package/mtl-2.3) - -You can adjust your notification preferences at -https://hackage.haskell.org/user/user-watcher/notify (https://hackage.haskell.org/user/user-watcher/notify) - +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 - - -

    -The dependency base-4.18.0.0 has been uploaded or revised. -

    -

    -You have requested to be notified when a dependency isn't accepted by any of your maintained packages. -

    -

    -The following packages require base but don't accept 4.18.0.0 (they do accept the second-highest version): -

    - -

    -You can adjust your notification preferences at -
    https://hackage.haskell.org/user/user-watcher/notify +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 index 5932132ed..a328aca46 100644 --- a/tests/golden/ReverseDependenciesTest/getNotificationEmails-NotifyDocsBuild-failure.golden +++ b/tests/golden/ReverseDependenciesTest/getNotificationEmails-NotifyDocsBuild-failure.golden @@ -6,24 +6,30 @@ 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.18.0.0 (https://hackage.haskell.org/package/base-4.18.0.0): -Build failed. - -You can adjust your notification preferences at -https://hackage.haskell.org/user/user-watcher/notify (https://hackage.haskell.org/user/user-watcher/notify) - +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.18.0.0: -
    Build failed. -

    -

    -You can adjust your notification preferences at -
    https://hackage.haskell.org/user/user-watcher/notify + +

    +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 index f60d93d7f..aa6392fff 100644 --- a/tests/golden/ReverseDependenciesTest/getNotificationEmails-NotifyDocsBuild-success.golden +++ b/tests/golden/ReverseDependenciesTest/getNotificationEmails-NotifyDocsBuild-success.golden @@ -6,24 +6,30 @@ 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.18.0.0 (https://hackage.haskell.org/package/base-4.18.0.0): -Build successful. - -You can adjust your notification preferences at -https://hackage.haskell.org/user/user-watcher/notify (https://hackage.haskell.org/user/user-watcher/notify) - +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.18.0.0: -
    Build successful. -

    -

    -You can adjust your notification preferences at -
    https://hackage.haskell.org/user/user-watcher/notify + +

    +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 index 07d465d03..e3777cc93 100644 --- a/tests/golden/ReverseDependenciesTest/getNotificationEmails-NotifyMaintainerUpdate-MaintainerAdded.golden +++ b/tests/golden/ReverseDependenciesTest/getNotificationEmails-NotifyMaintainerUpdate-MaintainerAdded.golden @@ -6,29 +6,33 @@ Content-Type: multipart/alternative; boundary="YIYrWcf3to" --YIYrWcf3to Content-Type: text/plain; charset=utf-8 - -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.haskell.org/user/user-watcher/notify (https://hackage.haskell.org/user/user-watcher/notify) - +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 - - -

    -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.haskell.org/user/user-watcher/notify +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 index 73dccf5c7..a5a4c91f7 100644 --- a/tests/golden/ReverseDependenciesTest/getNotificationEmails-NotifyMaintainerUpdate-MaintainerRemoved.golden +++ b/tests/golden/ReverseDependenciesTest/getNotificationEmails-NotifyMaintainerUpdate-MaintainerRemoved.golden @@ -6,29 +6,33 @@ Content-Type: multipart/alternative; boundary="YIYrWcf3to" --YIYrWcf3to Content-Type: text/plain; charset=utf-8 - -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.haskell.org/user/user-watcher/notify (https://hackage.haskell.org/user/user-watcher/notify) - +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 - - -

    -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.haskell.org/user/user-watcher/notify +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 index afd5fd08a..02e1aca6f 100644 --- a/tests/golden/ReverseDependenciesTest/getNotificationEmails-NotifyNewRevision.golden +++ b/tests/golden/ReverseDependenciesTest/getNotificationEmails-NotifyNewRevision.golden @@ -6,29 +6,35 @@ Content-Type: multipart/alternative; boundary="YIYrWcf3to" --YIYrWcf3to Content-Type: text/plain; charset=utf-8 - -Package metadata revision(s), base-4.18.0.0 (https://hackage.haskell.org/package/base-4.18.0.0): - -* 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.haskell.org/user/user-watcher/notify (https://hackage.haskell.org/user/user-watcher/notify) - +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 - - -

    -Package metadata revision(s), base-4.18.0.0: -

    -
      -
    • 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.haskell.org/user/user-watcher/notify +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 index 303ffed7f..9a9cf7cfa 100644 --- a/tests/golden/ReverseDependenciesTest/getNotificationEmails-NotifyNewVersion.golden +++ b/tests/golden/ReverseDependenciesTest/getNotificationEmails-NotifyNewVersion.golden @@ -6,22 +6,29 @@ Content-Type: multipart/alternative; boundary="YIYrWcf3to" --YIYrWcf3to Content-Type: text/plain; charset=utf-8 +Content-Transfer-Encoding: quoted-printable -Package upload, base-4.18.0.0 (https://hackage.haskell.org/package/base-4.18.0.0), by user-actor [Wed Jan 1 00:00:00 UTC 2020] - -You can adjust your notification preferences at -https://hackage.haskell.org/user/user-watcher/notify (https://hackage.haskell.org/user/user-watcher/notify) - +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.18.0.0, by user-actor [Wed Jan 1 00:00:00 UTC 2020] -

    -

    -You can adjust your notification preferences at -
    https://hackage.haskell.org/user/user-watcher/notify + +

    +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 index 718f2c2c3..b9e473041 100644 --- a/tests/golden/ReverseDependenciesTest/getNotificationEmails-NotifyUpdateTags.golden +++ b/tests/golden/ReverseDependenciesTest/getNotificationEmails-NotifyUpdateTags.golden @@ -6,29 +6,33 @@ Content-Type: multipart/alternative; boundary="YIYrWcf3to" --YIYrWcf3to Content-Type: text/plain; charset=utf-8 - -Pending tag proposal for base: - -* Additions: bsd3, library, prelude -* Deletions: bad, example, foo - -You can adjust your notification preferences at -https://hackage.haskell.org/user/user-watcher/notify (https://hackage.haskell.org/user/user-watcher/notify) - +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 - - -

    -Pending tag proposal for base: -

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

    -You can adjust your notification preferences at -
    https://hackage.haskell.org/user/user-watcher/notify +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-batched.golden b/tests/golden/ReverseDependenciesTest/getNotificationEmails-batched.golden index abf6f7167..d3d6811de 100644 --- a/tests/golden/ReverseDependenciesTest/getNotificationEmails-batched.golden +++ b/tests/golden/ReverseDependenciesTest/getNotificationEmails-batched.golden @@ -6,46 +6,54 @@ Content-Type: multipart/alternative; boundary="YIYrWcf3to" --YIYrWcf3to Content-Type: text/plain; charset=utf-8 - -Pending tag proposal for base: - -* Additions: newtag -* Deletions: oldtag - -Package doc build for base-4.18.0.0 (https://hackage.haskell.org/package/base-4.18.0.0): -Build successful. - -Package metadata revision(s), base-4.18.0.0 (https://hackage.haskell.org/package/base-4.18.0.0): - -* user-actor [Wed Jan 1 00:00:00 UTC 2020] - -You can adjust your notification preferences at -https://hackage.haskell.org/user/user-watcher/notify (https://hackage.haskell.org/user/user-watcher/notify) - +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 - - -

    -Pending tag proposal for base: -

    -
      -
    • Additions: newtag
      • -
    • Deletions: oldtag
      • -
    -

    -Package doc build for base-4.18.0.0: -
    Build successful. -

    -

    -Package metadata revision(s), base-4.18.0.0: -

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

    -You can adjust your notification preferences at -
    https://hackage.haskell.org/user/user-watcher/notify +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 From 6d820545f2fdbdd96285e715f3d43b971faa7740 Mon Sep 17 00:00:00 2001 From: Brandon Chinn Date: Fri, 18 Aug 2023 11:15:13 -0700 Subject: [PATCH 46/71] Move NotifyTriggerBounds into NotifyDependencyUpdate --- .../Server/Features/UserNotify.hs | 49 +++++++++---------- tests/ReverseDependenciesTest.hs | 27 +++------- 2 files changed, 28 insertions(+), 48 deletions(-) diff --git a/src/Distribution/Server/Features/UserNotify.hs b/src/Distribution/Server/Features/UserNotify.hs index cb6b96c39..fb11fa5ef 100644 --- a/src/Distribution/Server/Features/UserNotify.hs +++ b/src/Distribution/Server/Features/UserNotify.hs @@ -707,10 +707,10 @@ userNotifyFeature serverEnv@ServerEnv{serverCron} idx <- queryGetPackageIndex revIdx <- liftIO queryReverseIndex - dependencyUpdateNotifications <- concatMapM (genDependencyUpdateList idx revIdx . pkgInfoToPkgId) revisionsAndUploads + dependencyUpdateNotifications <- concatMapM (genDependencyUpdateList notifyPrefs idx revIdx . pkgInfoToPkgId) revisionsAndUploads emails <- - getNotificationEmails serverEnv userDetailsFeature queryGetUserNotifyPref users $ + getNotificationEmails serverEnv userDetailsFeature users $ concat [ revisionUploadNotifications , groupActionNotifications @@ -844,13 +844,16 @@ userNotifyFeature serverEnv@ServerEnv{serverCron} , notifyDeletedTags = deletedTags } - genDependencyUpdateList idx revIdx pkg = do - let toNotif watchedPkgs = + 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 . fmap toNotif + Map.toList . Map.mapWithKey toNotif <$> getUserNotificationsOnRelease (queryUserGroup . maintainersGroup) idx revIdx queryGetUserNotifyPref pkg sendNotifyEmailAndDelay :: Mail -> IO () @@ -892,6 +895,7 @@ data Notification -- ^ Dependency that was updated , notifyWatchedPackages :: [PackageId] -- ^ Packages maintained by user that depend on updated dep + , notifyTriggerBounds :: NotifyTriggerBounds } deriving (Show) @@ -911,24 +915,19 @@ data NotificationGroup getNotificationEmails :: ServerEnv -> UserDetailsFeature - -> (UserId -> IO (Maybe NotifyPref)) -> Users.Users -> [(UserId, Notification)] -> IO [Mail] getNotificationEmails ServerEnv{serverBaseURI} UserDetailsFeature{queryUserDetails} - queryGetUserNotifyPref allUsers notifications = do let userIds = Set.fromList $ map fst notifications userIdToDetails <- Map.mapMaybe id <$> fromSetM queryUserDetails userIds - userIdToNotifyPref <- Map.mapMaybe id <$> fromSetM queryGetUserNotifyPref userIds pure $ - let emails = - groupNotifications . flip mapMaybe notifications $ \(uid, notif) -> - fmap (uid,) $ renderNotification userIdToNotifyPref uid notif + let emails = groupNotifications $ map (fmap renderNotification) notifications in flip mapMaybe (Map.toList emails) $ \((uid, group), emailContent) -> case uid `Map.lookup` userIdToDetails of Nothing -> Nothing @@ -984,8 +983,8 @@ getNotificationEmails {----- Render notifications -----} - renderNotification :: Map UserId NotifyPref -> UserId -> Notification -> Maybe (EmailContent, NotificationGroup) - renderNotification userIdToNotifyPref uid = \case + renderNotification :: Notification -> (EmailContent, NotificationGroup) + renderNotification = \case NotifyNewVersion{..} -> generalNotification $ renderNotifyNewVersion @@ -1016,18 +1015,14 @@ getNotificationEmails notifyAddedTags notifyDeletedTags NotifyDependencyUpdate{..} -> - case uid `Map.lookup` userIdToNotifyPref of - Nothing -> Nothing - Just notifyPref -> - Just - ( renderNotifyDependencyUpdate - notifyPref - notifyPackageId - notifyWatchedPackages - , DependencyNotification notifyPackageId - ) + ( renderNotifyDependencyUpdate + notifyTriggerBounds + notifyPackageId + notifyWatchedPackages + , DependencyNotification notifyPackageId + ) where - generalNotification emailContent = Just (emailContent, GeneralNotification) + generalNotification = (, GeneralNotification) renderNotifyNewVersion pkg = EmailContentParagraph $ @@ -1065,20 +1060,20 @@ getNotificationEmails where showTags = emailContentIntercalate ", " . map emailContentDisplay . Set.toList - renderNotifyDependencyUpdate NotifyPref{..} dep revDeps = + 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 notifyDependencyTriggerBounds of + , 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 notifyDependencyTriggerBounds of + , case triggerBounds of Always -> "These are your packages that depend on " <> depName <> ":" BoundsOutOfRange -> diff --git a/tests/ReverseDependenciesTest.hs b/tests/ReverseDependenciesTest.hs index 6910066c3..5b0333a04 100644 --- a/tests/ReverseDependenciesTest.hs +++ b/tests/ReverseDependenciesTest.hs @@ -391,36 +391,36 @@ getNotificationEmailsTests = . getNotificationEmail testServerEnv testUserDetailsFeature - (\_ -> pure $ Just notifyEverything{notifyDependencyTriggerBounds = Always}) 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 - (\_ -> pure $ Just notifyEverything{notifyDependencyTriggerBounds = NewIncompatibility}) 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 - (\_ -> pure $ Just notifyEverything{notifyDependencyTriggerBounds = BoundsOutOfRange}) allUsers userWatcher $ NotifyDependencyUpdate { notifyPackageId = PackageIdentifier "base" (mkVersion [4, 18, 0, 0]) , notifyWatchedPackages = [PackageIdentifier "mtl" (mkVersion [2, 3])] + , notifyTriggerBounds = BoundsOutOfRange } , testGolden "Render general notifications in single batched email" "getNotificationEmails-batched.golden" $ do emails <- @@ -478,8 +478,8 @@ getNotificationEmailsTests = <*> addUser "user-actor" <*> addUser "user-subject" - getNotificationEmail env details pref users uid notif = - getNotificationEmails env details pref users [(uid, notif)] >>= \case + getNotificationEmail env details users uid notif = + getNotificationEmails env details users [(uid, notif)] >>= \case [email] -> pure email _ -> error "Did not get exactly one email" @@ -500,31 +500,15 @@ getNotificationEmailsTests = , accountAdminNotes = "" } } - notifyEverything = - NotifyPref - { notifyOptOut = False - , notifyRevisionRange = NotifyAllVersions - , notifyUpload = True - , notifyMaintainerGroup = True - , notifyDocBuilderReport = True - , notifyPendingTags = True - , notifyDependencyForMaintained = True - , notifyDependencyTriggerBounds = Always - } - testGetUserNotifyPref uid = pure $ do - guard $ uid == userWatcher - Just notifyEverything getNotificationEmailsMocked = getNotificationEmails testServerEnv testUserDetailsFeature - testGetUserNotifyPref allUsers getNotificationEmailMocked = getNotificationEmail testServerEnv testUserDetailsFeature - testGetUserNotifyPref allUsers renderMail = fst . Mail.renderMail (mkStdGen 0) @@ -554,6 +538,7 @@ getNotificationEmailsTests = , NotifyDependencyUpdate <$> genPackageId <*> Gen.list (Range.linear 1 10) genPackageId + <*> Gen.element [Always, NewIncompatibility, BoundsOutOfRange] ] genPackageName = mkPackageName <$> Gen.string (Range.linear 1 30) Gen.unicode From 06f831ef7a701967f22128087b3817cdff185cbc Mon Sep 17 00:00:00 2001 From: Peter Becich Date: Sun, 9 Jul 2023 12:18:26 -0700 Subject: [PATCH 47/71] update `flake.nix` for recent `haskell-flake` and `nix flake update` --- README.md | 70 ++++++++++++++++++++++++++++---- cabal.project | 9 ++++- flake.lock | 109 ++++++-------------------------------------------- flake.nix | 88 +++++++++++++++++----------------------- 4 files changed, 120 insertions(+), 156 deletions(-) diff --git a/README.md b/README.md index 6e7995d78..5753f2c07 100644 --- a/README.md +++ b/README.md @@ -7,25 +7,81 @@ This is the `hackage-server` code. This is what powers Date: Mon, 21 Aug 2023 18:04:04 -0700 Subject: [PATCH 48/71] Flake `cabal.project` parser succeeds with `.` here --- cabal.project | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/cabal.project b/cabal.project index 8b8fc0c18..292cfa64c 100644 --- a/cabal.project +++ b/cabal.project @@ -1,5 +1,5 @@ packages: - . + . -- This comment moved below "packages" to fix parsing of this file -- by flake.nix From 1b2d9c6f5b80dfa49492aa372fd29b6f3fd8b894 Mon Sep 17 00:00:00 2001 From: Peter Becich Date: Mon, 21 Aug 2023 18:28:00 -0700 Subject: [PATCH 49/71] attempt to fix Flake on Mac --- flake.nix | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/flake.nix b/flake.nix index 8cc759e1e..747ac2c97 100644 --- a/flake.nix +++ b/flake.nix @@ -34,14 +34,14 @@ # Setting to null should remove this tool from defaults. ghcid = null; haskell-language-server = null; - inherit (pkgs) cabal-install ghc - glibc - icu67 - zlib + # https://github.com/haskell/hackage-server/pull/1219#issuecomment-1597140858 + # glibc + # icu67 + # zlib openssl cryptodev pkg-config From 4dbfbf73cfae9c9ad653ea2a6e941ddcef970eef Mon Sep 17 00:00:00 2001 From: Peter Becich Date: Mon, 21 Aug 2023 20:15:10 -0700 Subject: [PATCH 50/71] fix `ghcid` in `nix develop` --- flake.lock | 6 +++--- flake.nix | 1 - 2 files changed, 3 insertions(+), 4 deletions(-) diff --git a/flake.lock b/flake.lock index 9a2ad973d..6b4c0e051 100644 --- a/flake.lock +++ b/flake.lock @@ -52,11 +52,11 @@ }, "nixpkgs": { "locked": { - "lastModified": 1692490321, - "narHash": "sha256-5GAMLkvPQroGsLv6gmCct+GLFCOOL0hKQFv7UWpUMsc=", + "lastModified": 1692663074, + "narHash": "sha256-RfwM4yauPOS5zOKtjIKULrbe64LEpXTtZkz2S9J70WE=", "owner": "nixos", "repo": "nixpkgs", - "rev": "b8a3b5d228949ae9cc782ef0e9cf2b4518403dad", + "rev": "fe2033d9c47e1aaa4e0458d5e86c91d474032f47", "type": "github" }, "original": { diff --git a/flake.nix b/flake.nix index 747ac2c97..d73c0b212 100644 --- a/flake.nix +++ b/flake.nix @@ -32,7 +32,6 @@ devShell = { tools = hp: { # Setting to null should remove this tool from defaults. - ghcid = null; haskell-language-server = null; inherit (pkgs) cabal-install From a32611dc171765561301d780f3b6516aebf64ef8 Mon Sep 17 00:00:00 2001 From: Peter Becich Date: Mon, 21 Aug 2023 20:26:36 -0700 Subject: [PATCH 51/71] fix `nix build` --- flake.nix | 1 + 1 file changed, 1 insertion(+) diff --git a/flake.nix b/flake.nix index d73c0b212..728138d77 100644 --- a/flake.nix +++ b/flake.nix @@ -22,6 +22,7 @@ settings = { hackage-server.check = false; heist.check = false; + threads.check = false; }; packages = { Cabal.source = "3.10.1.0"; From cb3e0b64d5a3c42aa68a1477012d80acdf37edde Mon Sep 17 00:00:00 2001 From: Peter Becich Date: Mon, 19 Jun 2023 10:37:06 -0700 Subject: [PATCH 52/71] enable `nix flake check` in GitHub Action --- .github/workflows/nix-flake.yml | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/.github/workflows/nix-flake.yml b/.github/workflows/nix-flake.yml index 040cdf5f2..257dbf61d 100644 --- a/.github/workflows/nix-flake.yml +++ b/.github/workflows/nix-flake.yml @@ -29,4 +29,7 @@ jobs: name: hackage-server authToken: '${{ secrets.CACHIX_AUTH_TOKEN }}' - run: nix build - # - run: nix flake check + + # allow error until Flake check is improved + - continue-on-error: true + run: nix flake check From f74bedfcd475e5f1b7c4e2b59253f5b3c1515d69 Mon Sep 17 00:00:00 2001 From: Peter Becich Date: Fri, 25 Aug 2023 23:27:25 -0700 Subject: [PATCH 53/71] remove Mac-incompatible Nix Flake dependency Squashed commit of the following: commit ab42f6c05bbe85caf1aac7d49772aa105d4bb5bb Author: Peter Becich Date: Fri Aug 25 23:25:03 2023 -0700 `nix flake check` should succeed commit 112b5d931decc1c1c75bc936f334814efdc26883 Author: Peter Becich Date: Fri Aug 25 23:12:08 2023 -0700 remove other dev shell dependencies commit c24534ce6bd89120f4bc27851a822ffabc563e72 Author: Peter Becich Date: Fri Aug 25 23:00:51 2023 -0700 remove pkg-config commit bf4c4000bcc8da1cb28fd5a70c57ca69de2efcee Author: Peter Becich Date: Fri Aug 25 22:50:44 2023 -0700 try to fix `nix develop` on Mac https://github.com/haskell/hackage-server/issues/1247 --- .github/workflows/nix-flake.yml | 3 +-- flake.nix | 6 +++--- 2 files changed, 4 insertions(+), 5 deletions(-) diff --git a/.github/workflows/nix-flake.yml b/.github/workflows/nix-flake.yml index 257dbf61d..39fe13b5e 100644 --- a/.github/workflows/nix-flake.yml +++ b/.github/workflows/nix-flake.yml @@ -30,6 +30,5 @@ jobs: authToken: '${{ secrets.CACHIX_AUTH_TOKEN }}' - run: nix build - # allow error until Flake check is improved - - continue-on-error: true + - continue-on-error: false run: nix flake check diff --git a/flake.nix b/flake.nix index 728138d77..27d24584c 100644 --- a/flake.nix +++ b/flake.nix @@ -40,10 +40,10 @@ # https://github.com/haskell/hackage-server/pull/1219#issuecomment-1597140858 # glibc - # icu67 - # zlib + icu67 + zlib openssl - cryptodev + # cryptodev pkg-config brotli From 20587a803d4ef203e5853eb602cc3de6210c5adf Mon Sep 17 00:00:00 2001 From: "dependabot[bot]" <49699333+dependabot[bot]@users.noreply.github.com> Date: Mon, 4 Sep 2023 16:12:59 +0000 Subject: [PATCH 54/71] Bump actions/checkout from 3 to 4 Bumps [actions/checkout](https://github.com/actions/checkout) from 3 to 4. - [Release notes](https://github.com/actions/checkout/releases) - [Changelog](https://github.com/actions/checkout/blob/main/CHANGELOG.md) - [Commits](https://github.com/actions/checkout/compare/v3...v4) --- updated-dependencies: - dependency-name: actions/checkout dependency-type: direct:production update-type: version-update:semver-major ... Signed-off-by: dependabot[bot] --- .github/workflows/cabal.yml | 4 ++-- .github/workflows/haskell-ci.yml | 2 +- .github/workflows/nix-flake.yml | 2 +- 3 files changed, 4 insertions(+), 4 deletions(-) diff --git a/.github/workflows/cabal.yml b/.github/workflows/cabal.yml index e4c404a13..f92a9585b 100644 --- a/.github/workflows/cabal.yml +++ b/.github/workflows/cabal.yml @@ -19,7 +19,7 @@ jobs: os: [ubuntu-latest] name: Cabal with GHC ${{ matrix.ghc }} steps: - - uses: actions/checkout@v3 + - uses: actions/checkout@v4 - name: Setup Haskell uses: haskell-actions/setup@v2 with: @@ -46,7 +46,7 @@ jobs: # os: [ubuntu-latest] # name: Cabal with GHC ${{ matrix.ghc }} and mtl >= 2.3.1 # steps: - # - uses: actions/checkout@v3 + # - uses: actions/checkout@v4 # - name: Setup Haskell # uses: haskell/actions/setup@v2 # with: diff --git a/.github/workflows/haskell-ci.yml b/.github/workflows/haskell-ci.yml index 155cec0ac..9e17c7011 100644 --- a/.github/workflows/haskell-ci.yml +++ b/.github/workflows/haskell-ci.yml @@ -149,7 +149,7 @@ jobs: 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 39fe13b5e..1d8813854 100644 --- a/.github/workflows/nix-flake.yml +++ b/.github/workflows/nix-flake.yml @@ -17,7 +17,7 @@ jobs: name: Nix on ${{ matrix.os }} runs-on: ${{ matrix.os }} steps: - - uses: actions/checkout@v3.5.3 + - uses: actions/checkout@v4 - uses: cachix/install-nix-action@v22 with: extra_nix_config: | From 9c91563cf6b352fff7a61a6c74f337432c4d8f42 Mon Sep 17 00:00:00 2001 From: Peter Becich Date: Fri, 15 Sep 2023 19:01:46 -0700 Subject: [PATCH 55/71] `nix flake update` HLS provided in `nix develop` shell --- flake.lock | 24 ++++++++++++------------ flake.nix | 17 ++++++++++++++--- 2 files changed, 26 insertions(+), 15 deletions(-) diff --git a/flake.lock b/flake.lock index 6b4c0e051..7903bf046 100644 --- a/flake.lock +++ b/flake.lock @@ -7,11 +7,11 @@ ] }, "locked": { - "lastModified": 1690933134, - "narHash": "sha256-ab989mN63fQZBFrkk4Q8bYxQCktuHmBIBqUG1jl6/FQ=", + "lastModified": 1693611461, + "narHash": "sha256-aPODl8vAgGQ0ZYFIRisxYG5MOGSkIczvu2Cd8Gb9+1Y=", "owner": "hercules-ci", "repo": "flake-parts", - "rev": "59cf3f1447cfc75087e7273b04b31e689a8599fb", + "rev": "7f53fdb7bdc5bb237da7fefef12d099e4fd611ca", "type": "github" }, "original": { @@ -22,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": { @@ -37,11 +37,11 @@ }, "haskell-flake": { "locked": { - "lastModified": 1691763544, - "narHash": "sha256-QQsSI5VXm0bBijeGSXXNf4fyw76/XmN67NGbmTCx71s=", + "lastModified": 1694478711, + "narHash": "sha256-zW/saV4diypxwP56b8l93Nw8fR7tXLbOFku2I+xYCxU=", "owner": "srid", "repo": "haskell-flake", - "rev": "f16e7ac05b1f22b66ef05b7fcc8a96281bb2b749", + "rev": "ddc704f3f62d3d3569ced794b534e8fd065c379c", "type": "github" }, "original": { @@ -52,11 +52,11 @@ }, "nixpkgs": { "locked": { - "lastModified": 1692663074, - "narHash": "sha256-RfwM4yauPOS5zOKtjIKULrbe64LEpXTtZkz2S9J70WE=", + "lastModified": 1694736714, + "narHash": "sha256-5xqXf2CfPiIHg2W7f+6odQ9c09L+jTVqGmxLB6qxPLc=", "owner": "nixos", "repo": "nixpkgs", - "rev": "fe2033d9c47e1aaa4e0458d5e86c91d474032f47", + "rev": "8b1c1ca2feb87ae8b7d9455d8dfe5361f249e4cf", "type": "github" }, "original": { diff --git a/flake.nix b/flake.nix index 27d24584c..f266814d7 100644 --- a/flake.nix +++ b/flake.nix @@ -22,18 +22,29 @@ settings = { hackage-server.check = false; heist.check = false; + fourmolu.check = false; threads.check = false; + hls-cabal-plugin.check = false; + hls-fourmolu-plugin.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.3"; + 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: { - # Setting to null should remove this tool from defaults. - haskell-language-server = null; inherit (pkgs) cabal-install ghc From d170f8f938f02689994493c38e36f9fe6ff8aa13 Mon Sep 17 00:00:00 2001 From: Peter Becich Date: Fri, 15 Sep 2023 23:04:04 -0700 Subject: [PATCH 56/71] remove unnecessary flake settings --- flake.nix | 3 --- 1 file changed, 3 deletions(-) diff --git a/flake.nix b/flake.nix index f266814d7..3d79ffd0d 100644 --- a/flake.nix +++ b/flake.nix @@ -23,9 +23,6 @@ hackage-server.check = false; heist.check = false; fourmolu.check = false; - threads.check = false; - hls-cabal-plugin.check = false; - hls-fourmolu-plugin.check = false; hw-prim.jailbreak = true; hw-hspec-hedgehog.jailbreak = true; hw-fingertree.jailbreak = true; From c3f997e935d7d8cd7b5e54381620f8012b0b9201 Mon Sep 17 00:00:00 2001 From: "dependabot[bot]" <49699333+dependabot[bot]@users.noreply.github.com> Date: Sat, 16 Sep 2023 06:08:53 +0000 Subject: [PATCH 57/71] Bump cachix/install-nix-action from 22 to 23 Bumps [cachix/install-nix-action](https://github.com/cachix/install-nix-action) from 22 to 23. - [Release notes](https://github.com/cachix/install-nix-action/releases) - [Commits](https://github.com/cachix/install-nix-action/compare/v22...v23) --- updated-dependencies: - dependency-name: cachix/install-nix-action dependency-type: direct:production update-type: version-update:semver-major ... Signed-off-by: dependabot[bot] --- .github/workflows/nix-flake.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/workflows/nix-flake.yml b/.github/workflows/nix-flake.yml index 1d8813854..e036875cc 100644 --- a/.github/workflows/nix-flake.yml +++ b/.github/workflows/nix-flake.yml @@ -18,7 +18,7 @@ jobs: runs-on: ${{ matrix.os }} steps: - uses: actions/checkout@v4 - - uses: cachix/install-nix-action@v22 + - 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= From b69b5d6a3a649b03ae186cbb1f8192c3b9a40d8b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?H=C3=A9cate=20Moonlight?= Date: Sat, 23 Sep 2023 14:16:47 +0200 Subject: [PATCH 58/71] Close

    tags in the revisions RSS feed --- src/Distribution/Server/Pages/Recent.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Distribution/Server/Pages/Recent.hs b/src/Distribution/Server/Pages/Recent.hs index 19e7e75b0..ac60f89af 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 From bf8ee3abbd454a3b629a4cd80971b5a0832dd7f0 Mon Sep 17 00:00:00 2001 From: Janus Troelsen Date: Sat, 3 Sep 2022 09:43:51 -0500 Subject: [PATCH 59/71] Add vouching Vouching allows new users to get added to the uploaders group by way of other people "vouching" for then. This should alleviate privileged Hackage users, since they were previously the only people that could add people to the uploaders group. --- datafiles/templates/Html/vouch.html.st | 29 +++ hackage-server.cabal | 3 +- src/Distribution/Server/Features.hs | 8 + src/Distribution/Server/Features/Vouch.hs | 218 ++++++++++++++++++++++ 4 files changed, 257 insertions(+), 1 deletion(-) create mode 100644 datafiles/templates/Html/vouch.html.st create mode 100644 src/Distribution/Server/Features/Vouch.hs diff --git a/datafiles/templates/Html/vouch.html.st b/datafiles/templates/Html/vouch.html.st new file mode 100644 index 000000000..89ae9c238 --- /dev/null +++ b/datafiles/templates/Html/vouch.html.st @@ -0,0 +1,29 @@ + + + +$hackageCssTheme()$ +Vouch for user | Hackage + + + +$hackagePageHeader()$ + +
    +

    Vouch for user

    + +

    $msg$

    + +
    + +
    + +

    Vouching cannot be undone! When the user has three vouches, the user +can upload packages. Note that users are, to a certain degree, held accountable +for the actions of the users they vouch for. Only vouch for people you know.

    + +
      + $vouches$ +
    + +
    + diff --git a/hackage-server.cabal b/hackage-server.cabal index fc0f51c88..e5749d161 100644 --- a/hackage-server.cabal +++ b/hackage-server.cabal @@ -373,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 diff --git a/src/Distribution/Server/Features.hs b/src/Distribution/Server/Features.hs index be89e4175..0a9b52011 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" $ @@ -359,6 +362,10 @@ initHackageFeatures env@ServerEnv{serverVerbosity = verbosity} = do usersFeature tarIndexCacheFeature + vouchFeature <- mkVouchFeature + usersFeature + uploadFeature + browseFeature <- mkBrowseFeature coreFeature usersFeature @@ -415,6 +422,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/Vouch.hs b/src/Distribution/Server/Features/Vouch.hs new file mode 100644 index 000000000..df846d0b8 --- /dev/null +++ b/src/Distribution/Server/Features/Vouch.hs @@ -0,0 +1,218 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DerivingStrategies #-} +module Distribution.Server.Features.Vouch where + +import Control.Monad (when, join) +import Control.Monad.Except (runExceptT, throwError) +import Control.Monad.Reader (ask) +import Control.Monad.State (get, put) +import qualified Data.ByteString.Lazy.Char8 as LBS +import qualified Data.Map.Strict as Map +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) +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) + +newtype VouchData = VouchData (Map.Map UserId [(UserId, UTCTime)]) + deriving (Show, Eq) + deriving newtype MemSize + +putVouch :: UserId -> (UserId, UTCTime) -> Update VouchData () +putVouch vouchee (voucher, now) = do + VouchData tbl <- get + let oldMap = fromMaybe [] (Map.lookup vouchee tbl) + newMap = (voucher, now) : oldMap + put $ VouchData (Map.insert vouchee newMap tbl) + +getVouchesFor :: UserId -> Query VouchData [(UserId, UTCTime)] +getVouchesFor needle = do + VouchData tbl <- 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) + let initialVouchData = VouchData 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 + } + +instance IsHackageFeature VouchFeature where + getFeatureInterface = vouchFeatureInterface + +requiredCountOfVouches :: Int +requiredCountOfVouches = 3 + +isWithinLastMonth :: UTCTime -> (UserId, UTCTime) -> Bool +isWithinLastMonth now (_, vouchTime) = + addUTCTime (30 * nominalDay) vouchTime < now + +data Err + = NotAnUploader + | You'reTooNew + | VoucheeAlreadyUploader + | AlreadySufficientlyVouched + | YouAlreadyVouched + +data Success = AddVouchComplete | AddVouchIncomplete + +judge :: Group.UserIdSet -> UTCTime -> UserId -> [(UserId, UTCTime)] -> [(UserId, UTCTime)] -> UserId -> Either Err (Either Err Success) +judge ugroup now vouchee vouchersForVoucher existingVouchers voucher = 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 >= 3) $ + throwError AlreadySufficientlyVouched + when (voucher `elem` map fst existingVouchers) $ + throwError YouAlreadyVouched + pure $ + if length existingVouchers == requiredCountOfVouches - 1 + then AddVouchComplete + else AddVouchIncomplete + +renderToLBS :: (UserId -> ServerPartE UserInfo) -> [(UserId, UTCTime)] -> ServerPartE TemplateAttr +renderToLBS lookupUserInfo vouches = do + rendered <- traverse renderVouchers vouches + pure $ + templateUnescaped "vouches" $ + if null rendered + then LBS.pack "Nobody has vouched yet." + else LBS.intercalate mempty rendered + where + renderVouchers :: (UserId, UTCTime) -> ServerPartE LBS.ByteString + renderVouchers (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 + userIds <- queryState vouchState $ GetVouchesFor uid + param <- renderToLBS lookupUserInfo userIds + pure . toResponse $ vouchTemplate + [ "msg" $= "" + , 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 join $ judge ugroup now vouchee vouchersForVoucher existingVouchers voucher of + Left NotAnUploader -> + errBadRequest "Not an uploader" [MText "You must be an uploader yourself to vouch for other users."] + Left You'reTooNew -> + errBadRequest "You're too new" [MText "The latest of the vouches for your user must be at least 30 days old."] + Left VoucheeAlreadyUploader -> + errBadRequest "Vouchee already uploader" [MText "You can't vouch for this user, since they are already an uploader."] + Left AlreadySufficientlyVouched -> + errBadRequest "Already sufficiently vouched" [MText "There are already a sufficient number of vouches for this user."] + Left YouAlreadyVouched -> + errBadRequest "Already vouched" [MText "You have already vouched for this user."] + Right result -> do + updateState vouchState $ PutVouch vouchee (voucher, now) + param <- renderToLBS lookupUserInfo $ existingVouchers ++ [(voucher, now)] + case result of + AddVouchComplete -> do + liftIO $ Group.addUserToGroup uploadersGroup vouchee + pure . toResponse $ vouchTemplate + [ "msg" $= "Added vouch. User is now an uploader!" + , param + ] + AddVouchIncomplete -> do + let stillRequired = requiredCountOfVouches - length existingVouchers - 1 + pure . toResponse $ vouchTemplate + [ "msg" $= + "Added vouch. User still needs " + <> show stillRequired + <> if stillRequired == 1 then " vouch" else " vouches" + <> " to become uploader." + , param + ] + return $ VouchFeature $ + (emptyHackageFeature "vouch") + { featureDesc = "Vouching for users getting upload permission." + , featureResources = + [(resourceAt "/user/:username/vouch") + { resourceDesc = [(GET, "list people vouching") + ,(POST, "vouch for user") + ] + , resourceGet = [("html", handleGetVouches)] + , resourcePost = [("html", handlePostVouch)] + } + ] + , featureState = [ abstractAcidStateComponent vouchState ] + , featureReloadFiles = reloadTemplates templates + } From 3c82d01dec38a974d8d998233804a42ad5dccd1a Mon Sep 17 00:00:00 2001 From: Janus Troelsen Date: Mon, 16 Oct 2023 16:53:21 -0600 Subject: [PATCH 60/71] Vouching: Address review comments, add tests --- hackage-server.cabal | 8 ++ src/Distribution/Server/Features/Vouch.hs | 60 ++++++++------ tests/VouchTest.hs | 96 +++++++++++++++++++++++ 3 files changed, 139 insertions(+), 25 deletions(-) create mode 100644 tests/VouchTest.hs diff --git a/hackage-server.cabal b/hackage-server.cabal index e5749d161..a4bde6531 100644 --- a/hackage-server.cabal +++ b/hackage-server.cabal @@ -574,6 +574,14 @@ 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.4 + , tasty-hunit ^>= 0.10 + test-suite ReverseDependenciesTest import: test-defaults type: exitcode-stdio-1.0 diff --git a/src/Distribution/Server/Features/Vouch.hs b/src/Distribution/Server/Features/Vouch.hs index df846d0b8..88a0f3494 100644 --- a/src/Distribution/Server/Features/Vouch.hs +++ b/src/Distribution/Server/Features/Vouch.hs @@ -3,7 +3,7 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE DerivingStrategies #-} -module Distribution.Server.Features.Vouch where +module Distribution.Server.Features.Vouch (VouchError(..), VouchSuccess(..), initVouchFeature, judgeVouch) where import Control.Monad (when, join) import Control.Monad.Except (runExceptT, throwError) @@ -91,23 +91,32 @@ instance IsHackageFeature VouchFeature where getFeatureInterface = vouchFeatureInterface requiredCountOfVouches :: Int -requiredCountOfVouches = 3 +requiredCountOfVouches = 2 isWithinLastMonth :: UTCTime -> (UserId, UTCTime) -> Bool isWithinLastMonth now (_, vouchTime) = - addUTCTime (30 * nominalDay) vouchTime < now + addUTCTime (30 * nominalDay) vouchTime >= now -data Err +data VouchError = NotAnUploader | You'reTooNew | VoucheeAlreadyUploader | AlreadySufficientlyVouched | YouAlreadyVouched - -data Success = AddVouchComplete | AddVouchIncomplete - -judge :: Group.UserIdSet -> UTCTime -> UserId -> [(UserId, UTCTime)] -> [(UserId, UTCTime)] -> UserId -> Either Err (Either Err Success) -judge ugroup now vouchee vouchersForVoucher existingVouchers voucher = runExceptT $ do + 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. @@ -116,33 +125,35 @@ judge ugroup now vouchee vouchersForVoucher existingVouchers voucher = runExcept throwError You'reTooNew when (vouchee `Group.member` ugroup) $ throwError VoucheeAlreadyUploader - when (length existingVouchers >= 3) $ + when (length existingVouchers >= requiredCountOfVouches) $ throwError AlreadySufficientlyVouched when (voucher `elem` map fst existingVouchers) $ throwError YouAlreadyVouched pure $ if length existingVouchers == requiredCountOfVouches - 1 then AddVouchComplete - else AddVouchIncomplete + 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 vouches + rendered <- traverse (renderVouchers lookupUserInfo) vouches pure $ templateUnescaped "vouches" $ if null rendered then LBS.pack "Nobody has vouched yet." else LBS.intercalate mempty rendered - where - renderVouchers :: (UserId, UTCTime) -> ServerPartE LBS.ByteString - renderVouchers (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 + +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 @@ -170,7 +181,7 @@ initVouchFeature ServerEnv{serverStateDir, serverTemplatesDir, serverTemplatesMo vouchee <- lookupUserName =<< userNameInPath dpath vouchersForVoucher <- queryState vouchState $ GetVouchesFor voucher existingVouchers <- queryState vouchState $ GetVouchesFor vouchee - case join $ judge ugroup now vouchee vouchersForVoucher existingVouchers voucher of + case judgeVouch ugroup now vouchee vouchersForVoucher existingVouchers voucher of Left NotAnUploader -> errBadRequest "Not an uploader" [MText "You must be an uploader yourself to vouch for other users."] Left You'reTooNew -> @@ -191,8 +202,7 @@ initVouchFeature ServerEnv{serverStateDir, serverTemplatesDir, serverTemplatesMo [ "msg" $= "Added vouch. User is now an uploader!" , param ] - AddVouchIncomplete -> do - let stillRequired = requiredCountOfVouches - length existingVouchers - 1 + AddVouchIncomplete stillRequired -> pure . toResponse $ vouchTemplate [ "msg" $= "Added vouch. User still needs " 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 From 113d4dfb432c63bc829e27d417058c9f86ddcf64 Mon Sep 17 00:00:00 2001 From: Vladimir Nikishkin <> Date: Thu, 26 Oct 2023 13:11:23 +0800 Subject: [PATCH 61/71] Allow serving cabal files with package name in the file name. Allow serving url like this: https://hackage.haskell.org/package/pkg-2.6/revision/pkg-2.6-1.cabal --- datafiles/templates/Html/revisions.html.st | 2 +- src/Distribution/Server/Features/Core.hs | 22 ++++++++++++++++++++++ 2 files changed, 23 insertions(+), 1 deletion(-) diff --git a/datafiles/templates/Html/revisions.html.st b/datafiles/templates/Html/revisions.html.st index 69cf2b75a..98c875c29 100644 --- a/datafiles/templates/Html/revisions.html.st +++ b/datafiles/templates/Html/revisions.html.st @@ -25,7 +25,7 @@ stored separately. $revisions:{revision| - -r$revision.number$ + -r$revision.number$ ($pkgid$-r$revision.number$) $revision.htmltime$ $revision.user$ $revision.sha256$ diff --git a/src/Distribution/Server/Features/Core.hs b/src/Distribution/Server/Features/Core.hs index 6aec793ab..e32e247e2 100644 --- a/src/Distribution/Server/Features/Core.hs +++ b/src/Distribution/Server/Features/Core.hs @@ -225,6 +225,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 +404,7 @@ coreFeature ServerEnv{serverBlobStore = store} UserFeature{..} , coreCabalFile , coreCabalFileRevs , coreCabalFileRev + , coreCabalFileRevName , coreUserDeauth , coreAdminDeauth , corePackUserDeauth @@ -456,6 +458,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")] @@ -750,6 +757,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 From 4ce6377701fb1d0cf6c52f7c3c71c4823cc61c61 Mon Sep 17 00:00:00 2001 From: Andreas Abel Date: Fri, 13 Oct 2023 21:11:18 +0200 Subject: [PATCH 62/71] Bump dependencies and CI for GHC 9.8.1 Building with GHC 9.8.1 blocked on: - [ ] happstack-server: https://github.com/Happstack/happstack-server/pull/80 --- .github/workflows/cabal.yml | 6 ++---- .github/workflows/haskell-ci.yml | 30 ++++++++++++++++++------------ cabal.haskell-ci | 2 +- hackage-server.cabal | 21 +++++++++++---------- 4 files changed, 32 insertions(+), 27 deletions(-) diff --git a/.github/workflows/cabal.yml b/.github/workflows/cabal.yml index f92a9585b..491a24ad7 100644 --- a/.github/workflows/cabal.yml +++ b/.github/workflows/cabal.yml @@ -2,11 +2,9 @@ on: push: branches: - master - - ci* pull_request: branches: - master - - ci* name: Cabal jobs: build: @@ -14,8 +12,8 @@ jobs: strategy: fail-fast: false matrix: - ghc: ['9.6.2', '9.4.5', '9.2.8', '9.0.2'] - cabal: ['3.10.1.0'] + ghc: ['9.8', '9.6', '9.4', '9.2'] + cabal: ['latest'] os: [ubuntu-latest] name: Cabal with GHC ${{ matrix.ghc }} steps: diff --git a/.github/workflows/haskell-ci.yml b/.github/workflows/haskell-ci.yml index 9e17c7011..79a87d2c1 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.16.6.20230729 +# version: 0.17.20231012 # -# REGENDATA ("0.16.6.20230729",["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,14 +32,19 @@ jobs: strategy: matrix: include: - - compiler: ghc-9.6.2 + - compiler: ghc-9.8.1 compilerKind: ghc - compilerVersion: 9.6.2 + compilerVersion: 9.8.1 setup-method: ghcup allow-failure: false - - compiler: ghc-9.4.5 + - compiler: ghc-9.6.3 compilerKind: ghc - compilerVersion: 9.4.5 + compilerVersion: 9.6.3 + setup-method: ghcup + allow-failure: false + - compiler: ghc-9.4.7 + compilerKind: ghc + compilerVersion: 9.4.7 setup-method: ghcup allow-failure: false - compiler: ghc-9.2.8 @@ -73,6 +76,7 @@ jobs: mkdir -p "$HOME/.ghcup/bin" curl -sL https://downloads.haskell.org/ghcup/0.1.19.5/x86_64-linux-ghcup-0.1.19.5 > "$HOME/.ghcup/bin/ghcup" 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" 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/hackage-server.cabal b/hackage-server.cabal index fc0f51c88..a09731d01 100644 --- a/hackage-server.cabal +++ b/hackage-server.cabal @@ -28,8 +28,9 @@ license: BSD-3-Clause license-file: LICENSE tested-with: - GHC == 9.6.2 - GHC == 9.4.5 + GHC == 9.8.1 + GHC == 9.6.3 + GHC == 9.4.7 GHC == 9.2.8 GHC == 9.0.2 GHC == 8.10.7 @@ -130,8 +131,8 @@ common defaults , array >= 0.5 && < 0.6 , base >= 4.13 && < 4.20 , binary >= 0.8 && < 0.9 - , bytestring >= 0.10 && < 0.12 - , containers ^>= 0.6.0 + , 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 @@ -139,7 +140,7 @@ common defaults -- we use Control.Monad.Except, introduced in mtl-2.2.1 , 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 @@ -450,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 @@ -579,12 +580,12 @@ test-suite ReverseDependenciesTest 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.3 + , hedgehog ^>= 1.4 , exceptions , bimap , mime-mail @@ -649,7 +650,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 @@ -667,7 +668,7 @@ test-suite HashTests , cryptohash-sha256 , safecopy -- component-specific dependencies - , tasty ^>= 1.4 + , tasty ^>= 1.5 , tasty-hunit ^>= 0.10 test-suite DocTests From 1cba0440ea7f83b5d676c2b7b4058ff3da4bd067 Mon Sep 17 00:00:00 2001 From: Andreas Abel Date: Tue, 24 Oct 2023 20:21:26 +0200 Subject: [PATCH 63/71] CI: disable redundant workflow `cabal.yml` - does not add anything over `haskell-ci.yml` - not quite up to the state of the art: * does not do any caching * `cabal haddock` should be invoked with `--disable-documentation`; currently, it rebuilds everything --- .github/workflows/{cabal.yml => cabal.off} | 0 1 file changed, 0 insertions(+), 0 deletions(-) rename .github/workflows/{cabal.yml => cabal.off} (100%) diff --git a/.github/workflows/cabal.yml b/.github/workflows/cabal.off similarity index 100% rename from .github/workflows/cabal.yml rename to .github/workflows/cabal.off From ada92d091073ed0aa97b3e65854f619f21cfdac7 Mon Sep 17 00:00:00 2001 From: Janus Troelsen Date: Fri, 1 Dec 2023 23:13:57 -0600 Subject: [PATCH 64/71] Add e-mail notification when all vouches received --- src/Distribution/Server/Features.hs | 9 ++- .../Server/Features/UserNotify.hs | 23 +++++- src/Distribution/Server/Features/Vouch.hs | 77 ++++++++++++------- tests/ReverseDependenciesTest.hs | 5 ++ ...ationEmails-NotifyVouchingCompleted.golden | 35 +++++++++ 5 files changed, 117 insertions(+), 32 deletions(-) create mode 100644 tests/golden/ReverseDependenciesTest/getNotificationEmails-NotifyVouchingCompleted.golden diff --git a/src/Distribution/Server/Features.hs b/src/Distribution/Server/Features.hs index 0a9b52011..b4e2d96d5 100644 --- a/src/Distribution/Server/Features.hs +++ b/src/Distribution/Server/Features.hs @@ -347,6 +347,10 @@ initHackageFeatures env@ServerEnv{serverVerbosity = verbosity} = do tagsFeature tarIndexCacheFeature + vouchFeature <- mkVouchFeature + usersFeature + uploadFeature + userNotifyFeature <- mkUserNotifyFeature usersFeature coreFeature @@ -356,16 +360,13 @@ initHackageFeatures env@ServerEnv{serverVerbosity = verbosity} = do reportsCoreFeature tagsFeature reverseFeature + vouchFeature packageFeedFeature <- mkPackageFeedFeature coreFeature usersFeature tarIndexCacheFeature - vouchFeature <- mkVouchFeature - usersFeature - uploadFeature - browseFeature <- mkBrowseFeature coreFeature usersFeature diff --git a/src/Distribution/Server/Features/UserNotify.hs b/src/Distribution/Server/Features/UserNotify.hs index fb11fa5ef..ce6a9f9ea 100644 --- a/src/Distribution/Server/Features/UserNotify.hs +++ b/src/Distribution/Server/Features/UserNotify.hs @@ -52,6 +52,7 @@ 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 @@ -437,6 +438,7 @@ initUserNotifyFeature :: ServerEnv -> ReportsFeature -> TagsFeature -> ReverseFeature + -> VouchFeature -> IO UserNotifyFeature) initUserNotifyFeature env@ServerEnv{ serverStateDir, serverTemplatesDir, serverTemplatesMode } = do @@ -448,10 +450,10 @@ 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 @@ -582,6 +584,7 @@ userNotifyFeature :: ServerEnv -> ReportsFeature -> TagsFeature -> ReverseFeature + -> VouchFeature -> StateComponent AcidState NotifyData -> Templates -> UserNotifyFeature @@ -594,6 +597,7 @@ userNotifyFeature serverEnv@ServerEnv{serverCron} ReportsFeature{..} TagsFeature{..} ReverseFeature{queryReverseIndex} + VouchFeature{drainQueuedNotifications} notifyState templates = UserNotifyFeature {..} @@ -709,6 +713,8 @@ userNotifyFeature serverEnv@ServerEnv{serverCron} revIdx <- liftIO queryReverseIndex dependencyUpdateNotifications <- concatMapM (genDependencyUpdateList notifyPrefs idx revIdx . pkgInfoToPkgId) revisionsAndUploads + vouchNotifications <- fmap (, NotifyVouchingCompleted) <$> drainQueuedNotifications + emails <- getNotificationEmails serverEnv userDetailsFeature users $ concat @@ -717,6 +723,7 @@ userNotifyFeature serverEnv@ServerEnv{serverCron} , docReportNotifications , tagProposalNotifications , dependencyUpdateNotifications + , vouchNotifications ] mapM_ sendNotifyEmailAndDelay emails @@ -897,6 +904,7 @@ data Notification -- ^ Packages maintained by user that depend on updated dep , notifyTriggerBounds :: NotifyTriggerBounds } + | NotifyVouchingCompleted deriving (Show) data NotifyMaintainerUpdateType = MaintainerAdded | MaintainerRemoved @@ -1021,6 +1029,10 @@ getNotificationEmails notifyWatchedPackages , DependencyNotification notifyPackageId ) + NotifyVouchingCompleted -> + generalNotification + renderNotifyVouchingCompleted + where generalNotification = (, GeneralNotification) @@ -1086,6 +1098,13 @@ getNotificationEmails ] <> EmailContentList (map renderPkgLink revDeps) + renderNotifyVouchingCompleted = + EmailContentParagraph + "You have received all necessary vouches. \ + \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 diff --git a/src/Distribution/Server/Features/Vouch.hs b/src/Distribution/Server/Features/Vouch.hs index 88a0f3494..d6444e966 100644 --- a/src/Distribution/Server/Features/Vouch.hs +++ b/src/Distribution/Server/Features/Vouch.hs @@ -3,21 +3,24 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE DerivingStrategies #-} -module Distribution.Server.Features.Vouch (VouchError(..), VouchSuccess(..), initVouchFeature, judgeVouch) where +{-# 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) +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) @@ -31,20 +34,26 @@ import Distribution.Server.Features.Upload(UploadFeature(..)) import Distribution.Server.Features.Users (UserFeature(..)) import Distribution.Simple.Utils (toUTF8LBS) -newtype VouchData = VouchData (Map.Map UserId [(UserId, UTCTime)]) +data VouchData = + VouchData + { vouches :: Map.Map UserId [(UserId, UTCTime)] + , notNotified :: Set.Set UserId + } deriving (Show, Eq) - deriving newtype MemSize + +instance MemSize VouchData where + memSize (VouchData vouches notified) = memSize2 vouches notified putVouch :: UserId -> (UserId, UTCTime) -> Update VouchData () putVouch vouchee (voucher, now) = do - VouchData tbl <- get + VouchData tbl notNotified <- get let oldMap = fromMaybe [] (Map.lookup vouchee tbl) newMap = (voucher, now) : oldMap - put $ VouchData (Map.insert vouchee newMap tbl) + put $ VouchData (Map.insert vouchee newMap tbl) notNotified getVouchesFor :: UserId -> Query VouchData [(UserId, UTCTime)] getVouchesFor needle = do - VouchData tbl <- ask + VouchData tbl _notNotified <- ask pure . fromMaybe [] $ Map.lookup needle tbl getVouchesData :: Query VouchData VouchData @@ -65,8 +74,8 @@ makeAcidic ''VouchData vouchStateComponent :: FilePath -> IO (StateComponent AcidState VouchData) vouchStateComponent stateDir = do - st <- openLocalStateFrom (stateDir "db" "Vouch") (VouchData mempty) - let initialVouchData = VouchData mempty + st <- openLocalStateFrom (stateDir "db" "Vouch") (VouchData mempty mempty) + let initialVouchData = VouchData mempty mempty restore = RestoreBackup { restoreEntry = error "Unexpected backup entry" @@ -85,6 +94,7 @@ vouchStateComponent stateDir = do data VouchFeature = VouchFeature { vouchFeatureInterface :: HackageFeature + , drainQueuedNotifications :: forall m. MonadIO m => m [UserId] } instance IsHackageFeature VouchFeature where @@ -167,8 +177,8 @@ initVouchFeature ServerEnv{serverStateDir, serverTemplatesDir, serverTemplatesMo handleGetVouches :: DynamicPath -> ServerPartE Response handleGetVouches dpath = do uid <- lookupUserName =<< userNameInPath dpath - userIds <- queryState vouchState $ GetVouchesFor uid - param <- renderToLBS lookupUserInfo userIds + vouches <- queryState vouchState $ GetVouchesFor uid + param <- renderToLBS lookupUserInfo vouches pure . toResponse $ vouchTemplate [ "msg" $= "" , param @@ -197,6 +207,13 @@ initVouchFeature ServerEnv{serverStateDir, serverTemplatesDir, serverTemplatesMo 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 vouch. User is now an uploader!" @@ -211,18 +228,26 @@ initVouchFeature ServerEnv{serverStateDir, serverTemplatesDir, serverTemplatesMo <> " to become uploader." , param ] - return $ VouchFeature $ - (emptyHackageFeature "vouch") - { featureDesc = "Vouching for users getting upload permission." - , featureResources = - [(resourceAt "/user/:username/vouch") - { resourceDesc = [(GET, "list people vouching") - ,(POST, "vouch for user") - ] - , resourceGet = [("html", handleGetVouches)] - , resourcePost = [("html", handlePostVouch)] - } - ] - , featureState = [ abstractAcidStateComponent vouchState ] - , featureReloadFiles = reloadTemplates templates - } + return $ VouchFeature { + vouchFeatureInterface = + (emptyHackageFeature "vouch") + { featureDesc = "Vouching for users getting upload permission." + , featureResources = + [(resourceAt "/user/:username/vouch") + { resourceDesc = [(GET, "list people vouching") + ,(POST, "vouch 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/tests/ReverseDependenciesTest.hs b/tests/ReverseDependenciesTest.hs index 5b0333a04..fa78807d9 100644 --- a/tests/ReverseDependenciesTest.hs +++ b/tests/ReverseDependenciesTest.hs @@ -422,6 +422,8 @@ getNotificationEmailsTests = , 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,) $ @@ -455,6 +457,7 @@ getNotificationEmailsTests = NotifyDocsBuild{} -> () NotifyUpdateTags{} -> () NotifyDependencyUpdate{} -> () + NotifyVouchingCompleted{} -> () isGeneral = \case NotifyNewVersion{} -> True @@ -463,6 +466,7 @@ getNotificationEmailsTests = NotifyDocsBuild{} -> True NotifyUpdateTags{} -> True NotifyDependencyUpdate{} -> False + NotifyVouchingCompleted{} -> True -- userWatcher = user getting the notification -- userActor = user that did the action @@ -539,6 +543,7 @@ getNotificationEmailsTests = <$> 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 diff --git a/tests/golden/ReverseDependenciesTest/getNotificationEmails-NotifyVouchingCompleted.golden b/tests/golden/ReverseDependenciesTest/getNotificationEmails-NotifyVouchingCompleted.golden new file mode 100644 index 000000000..d0d1d301f --- /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 vouches=2E You have been added the the 'upl= +oaders' group=2E You can now upload packages to Hackage=2E Note that packag= +es 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 vouches=2E You have been added the the 'upl= +oaders' group=2E You can now upload packages to Hackage=2E Note that packag= +es 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 From d9fd27a6b0e25d60f830c05db51704c9594f20d7 Mon Sep 17 00:00:00 2001 From: Janus Troelsen Date: Fri, 1 Dec 2023 23:24:43 -0600 Subject: [PATCH 65/71] Rename user-facing strings to 'endorsements', add threshold template param --- datafiles/templates/Html/vouch.html.st | 10 +++---- .../Server/Features/UserNotify.hs | 2 +- src/Distribution/Server/Features/Vouch.hs | 29 ++++++++++--------- ...ationEmails-NotifyVouchingCompleted.golden | 12 ++++---- 4 files changed, 27 insertions(+), 26 deletions(-) diff --git a/datafiles/templates/Html/vouch.html.st b/datafiles/templates/Html/vouch.html.st index 89ae9c238..36d0e7945 100644 --- a/datafiles/templates/Html/vouch.html.st +++ b/datafiles/templates/Html/vouch.html.st @@ -2,24 +2,24 @@ $hackageCssTheme()$ -Vouch for user | Hackage +Endorse user | Hackage $hackagePageHeader()$
    -

    Vouch for user

    +

    Endorse user

    $msg$

    - +
    -

    Vouching cannot be undone! When the user has three vouches, the user +

    Endorsing cannot be undone! When the user has $requiredNumber$ endorsements, the user can upload packages. Note that users are, to a certain degree, held accountable -for the actions of the users they vouch for. Only vouch for people you know.

    +for the actions of the users they endorse. Only endorse people you know.

      $vouches$ diff --git a/src/Distribution/Server/Features/UserNotify.hs b/src/Distribution/Server/Features/UserNotify.hs index ce6a9f9ea..2d0289a20 100644 --- a/src/Distribution/Server/Features/UserNotify.hs +++ b/src/Distribution/Server/Features/UserNotify.hs @@ -1100,7 +1100,7 @@ getNotificationEmails renderNotifyVouchingCompleted = EmailContentParagraph - "You have received all necessary vouches. \ + "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." diff --git a/src/Distribution/Server/Features/Vouch.hs b/src/Distribution/Server/Features/Vouch.hs index d6444e966..39795f0b5 100644 --- a/src/Distribution/Server/Features/Vouch.hs +++ b/src/Distribution/Server/Features/Vouch.hs @@ -152,7 +152,7 @@ renderToLBS lookupUserInfo vouches = do pure $ templateUnescaped "vouches" $ if null rendered - then LBS.pack "Nobody has vouched yet." + then LBS.pack "Nobody has endorsed yet." else LBS.intercalate mempty rendered renderVouchers :: (UserId -> ServerPartE UserInfo) -> (UserId, UTCTime) -> ServerPartE LBS.ByteString @@ -181,6 +181,7 @@ initVouchFeature ServerEnv{serverStateDir, serverTemplatesDir, serverTemplatesMo param <- renderToLBS lookupUserInfo vouches pure . toResponse $ vouchTemplate [ "msg" $= "" + , "requiredNumber" $= show requiredCountOfVouches , param ] handlePostVouch :: DynamicPath -> ServerPartE Response @@ -193,15 +194,15 @@ initVouchFeature ServerEnv{serverStateDir, serverTemplatesDir, serverTemplatesMo 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 vouch for other users."] + 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 vouches for your user must be at least 30 days old."] + errBadRequest "You're too new" [MText "The latest of the endorsements for your user must be at least 30 days old."] Left VoucheeAlreadyUploader -> - errBadRequest "Vouchee already uploader" [MText "You can't vouch for this user, since they are already an uploader."] + errBadRequest "Endorsee already uploader" [MText "You can't endorse this user, since they are already an uploader."] Left AlreadySufficientlyVouched -> - errBadRequest "Already sufficiently vouched" [MText "There are already a sufficient number of vouches for this user."] + errBadRequest "Already sufficiently endorsed" [MText "There are already a sufficient number of endorsements for this user."] Left YouAlreadyVouched -> - errBadRequest "Already vouched" [MText "You have already vouched for this user."] + 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)] @@ -216,26 +217,26 @@ initVouchFeature ServerEnv{serverStateDir, serverTemplatesDir, serverTemplatesMo liftIO $ Group.addUserToGroup uploadersGroup vouchee pure . toResponse $ vouchTemplate - [ "msg" $= "Added vouch. User is now an uploader!" + [ "msg" $= "Added endorsement. User is now an uploader!" , param ] AddVouchIncomplete stillRequired -> pure . toResponse $ vouchTemplate [ "msg" $= - "Added vouch. User still needs " + "Added endorsement. User still needs " <> show stillRequired - <> if stillRequired == 1 then " vouch" else " vouches" + <> if stillRequired == 1 then " endorsement" else " endorsements" <> " to become uploader." , param ] return $ VouchFeature { vouchFeatureInterface = - (emptyHackageFeature "vouch") - { featureDesc = "Vouching for users getting upload permission." + (emptyHackageFeature "endorse") + { featureDesc = "Endorsing users such that they get upload permission." , featureResources = - [(resourceAt "/user/:username/vouch") - { resourceDesc = [(GET, "list people vouching") - ,(POST, "vouch for user") + [(resourceAt "/user/:username/endorse") + { resourceDesc = [(GET, "list people endorsing") + ,(POST, "endorse for user") ] , resourceGet = [("html", handleGetVouches)] , resourcePost = [("html", handlePostVouch)] diff --git a/tests/golden/ReverseDependenciesTest/getNotificationEmails-NotifyVouchingCompleted.golden b/tests/golden/ReverseDependenciesTest/getNotificationEmails-NotifyVouchingCompleted.golden index d0d1d301f..b45e64f28 100644 --- a/tests/golden/ReverseDependenciesTest/getNotificationEmails-NotifyVouchingCompleted.golden +++ b/tests/golden/ReverseDependenciesTest/getNotificationEmails-NotifyVouchingCompleted.golden @@ -8,9 +8,9 @@ Content-Type: multipart/alternative; boundary="YIYrWcf3to" Content-Type: text/plain; charset=utf-8 Content-Transfer-Encoding: quoted-printable -You have received all necessary vouches=2E You have been added the the 'upl= -oaders' group=2E You can now upload packages to Hackage=2E Note that packag= -es cannot be deleted, so be careful=2E +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= @@ -23,9 +23,9 @@ Content-Transfer-Encoding: quoted-printable

      -You have received all necessary vouches=2E You have been added the the 'upl= -oaders' group=2E You can now upload packages to Hackage=2E Note that packag= -es cannot be deleted, so be careful=2E +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 From 7bad6f8308f09c84f65e1e1b4850457555bd7244 Mon Sep 17 00:00:00 2001 From: Gautier DI FOLCO Date: Thu, 30 Nov 2023 23:22:12 +0100 Subject: [PATCH 66/71] fix: replace list lastVersion by referenceVersion (#1264) --- datafiles/static/browse.js | 2 +- datafiles/templates/Html/browse.html.st | 2 +- src/Distribution/Server/Features/Browse.hs | 4 +- .../Server/Features/Browse/ApplyFilter.hs | 2 +- .../Server/Features/Browse/Options.hs | 6 +- .../Server/Features/Html/HtmlUtilities.hs | 2 +- .../Server/Features/PackageList.hs | 57 +++++++++++++++---- .../Server/Features/PreferredVersions.hs | 6 ++ 8 files changed, 62 insertions(+), 19 deletions(-) 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/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/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 From eb00f2fc0780deaedd80a1b7b1f635e3049fa323 Mon Sep 17 00:00:00 2001 From: Andrea Bedini Date: Wed, 29 Nov 2023 22:19:41 +0800 Subject: [PATCH 67/71] Add hashes to the list of revisions in JSON format The list of metadata revisions for a package is available at the url /package/:package/revisions/ When rendered in HTML this list includes the revision number, timestamp, uploader, and sha256; but when rendered in JSON the sha256 is missing. This change adds revisions sha256 to the JSON rendering. --- src/Distribution/Server/Features/Core.hs | 10 +++++++--- 1 file changed, 7 insertions(+), 3 deletions(-) diff --git a/src/Distribution/Server/Features/Core.hs b/src/Distribution/Server/Features/Core.hs index 6aec793ab..91fc83f62 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 @@ -728,12 +729,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) From f763229b614e479fba0b3678ca1b8a95f9334a1d Mon Sep 17 00:00:00 2001 From: gbaz Date: Mon, 4 Dec 2023 18:10:43 -0500 Subject: [PATCH 68/71] Update Vouch.hs --- src/Distribution/Server/Features/Vouch.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Distribution/Server/Features/Vouch.hs b/src/Distribution/Server/Features/Vouch.hs index 39795f0b5..ba08ecc4a 100644 --- a/src/Distribution/Server/Features/Vouch.hs +++ b/src/Distribution/Server/Features/Vouch.hs @@ -218,6 +218,7 @@ initVouchFeature ServerEnv{serverStateDir, serverTemplatesDir, serverTemplatesMo liftIO $ Group.addUserToGroup uploadersGroup vouchee pure . toResponse $ vouchTemplate [ "msg" $= "Added endorsement. User is now an uploader!" + , "requiredNumber" $= show requiredCountOfVouches , param ] AddVouchIncomplete stillRequired -> From 36ab220e84bb86ff97f5d12e93a67713f5ddc5fd Mon Sep 17 00:00:00 2001 From: gbaz Date: Mon, 4 Dec 2023 18:12:17 -0500 Subject: [PATCH 69/71] Update vouch.html.st --- datafiles/templates/Html/vouch.html.st | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/datafiles/templates/Html/vouch.html.st b/datafiles/templates/Html/vouch.html.st index 36d0e7945..cb34cd855 100644 --- a/datafiles/templates/Html/vouch.html.st +++ b/datafiles/templates/Html/vouch.html.st @@ -18,9 +18,7 @@ $hackagePageHeader()$

      Endorsing cannot be undone! When the user has $requiredNumber$ endorsements, the user -can upload packages. Note that users are, to a certain degree, held accountable -for the actions of the users they endorse. Only endorse people you know.

      - +will be added to the uploaders group, and allowed to upload packages. Only endorse people who you trust to upload packages responsibly.

        $vouches$
      From fcc5c5117b6b4f7faa508dbf826a872442e55b53 Mon Sep 17 00:00:00 2001 From: Gershom Bazerman Date: Mon, 4 Dec 2023 18:30:49 -0500 Subject: [PATCH 70/71] fix tasty dep --- hackage-server.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/hackage-server.cabal b/hackage-server.cabal index a4f4f92c5..6bea36a21 100644 --- a/hackage-server.cabal +++ b/hackage-server.cabal @@ -580,7 +580,7 @@ test-suite VouchTest type: exitcode-stdio-1.0 main-is: VouchTest.hs build-depends: - , tasty ^>= 1.4 + , tasty ^>= 1.5 , tasty-hunit ^>= 0.10 test-suite ReverseDependenciesTest From 44a3b1c0a2e56dce5fbbdd0e318cc9af6fced6d9 Mon Sep 17 00:00:00 2001 From: Gershom Bazerman Date: Mon, 4 Dec 2023 19:40:31 -0500 Subject: [PATCH 71/71] update central-server text for upload ensorsement --- .../UserSignupReset/SignupConfirm.html.st | 5 +++-- .../SignupConfirmation.email.st | 18 ++++++++++++----- .../UserSignupReset/SignupEmailSent.html.st | 5 ++++- .../UserSignupReset/SignupRequest.html.st | 20 ++++++++++++------- .../Server/Features/UserSignup.hs | 1 + 5 files changed, 34 insertions(+), 15 deletions(-) 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/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