Merge pull request #1257 from haskell/janus/vouch

Add vouching
haskell · Dec 4, 2023 · 294110b · 294110b
2 parents 22b5612 + 36ab220
commit 294110b
Show file tree

Hide file tree

Showing 8 changed files with 458 additions and 3 deletions.
diff --git a/datafiles/templates/Html/vouch.html.st b/datafiles/templates/Html/vouch.html.st
@@ -0,0 +1,27 @@
+<!DOCTYPE html>
+<html>
+<head>
+$hackageCssTheme()$
+<title>Endorse user | Hackage</title>
+</head>
+
+<body>
+$hackagePageHeader()$
+
+<div id="content">
+<h2>Endorse user</h2>
+
+<p>$msg$</p>
+
+<form action="" method=POST>
+<input type=submit value="Endorse this user">
+</form>
+
+<p>Endorsing cannot be undone! When the user has $requiredNumber$ endorsements, the user
+will be added to the uploaders group, and allowed to upload packages. Only endorse people who you trust to upload packages responsibly.</p>
+<ul>
+  $vouches$
+</ul>
+
+</div>
+</body></html>
diff --git a/hackage-server.cabal b/hackage-server.cabal
@@ -374,8 +374,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
@@ -574,6 +575,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.hs b/src/Distribution/Server/Features.hs
@@ -51,6 +51,7 @@ import Distribution.Server.Features.Votes               (initVotesFeature)
 import Distribution.Server.Features.Sitemap             (initSitemapFeature)
 import Distribution.Server.Features.UserNotify          (initUserNotifyFeature)
 import Distribution.Server.Features.PackageFeed         (initPackageFeedFeature)
+import Distribution.Server.Features.Vouch               (initVouchFeature)
 #endif
 import Distribution.Server.Features.ServerIntrospect (serverIntrospectFeature)
 
@@ -159,6 +160,8 @@ initHackageFeatures env@ServerEnv{serverVerbosity = verbosity} = do
                                initUserNotifyFeature env
     mkPackageFeedFeature    <- logStartup "package feed" $
                                initPackageFeedFeature env
+    mkVouchFeature          <- logStartup "vouch" $
+                               initVouchFeature env
     mkBrowseFeature         <- logStartup "browse" $
                                initBrowseFeature env
     mkPackageJSONFeature    <- logStartup "package info JSON" $
@@ -344,6 +347,10 @@ initHackageFeatures env@ServerEnv{serverVerbosity = verbosity} = do
                         tagsFeature
                         tarIndexCacheFeature
 
+    vouchFeature <- mkVouchFeature
+                      usersFeature
+                      uploadFeature
+
     userNotifyFeature <- mkUserNotifyFeature
                            usersFeature
                            coreFeature
@@ -353,6 +360,7 @@ initHackageFeatures env@ServerEnv{serverVerbosity = verbosity} = do
                            reportsCoreFeature
                            tagsFeature
                            reverseFeature
+                           vouchFeature
 
     packageFeedFeature <- mkPackageFeedFeature
                             coreFeature
@@ -415,6 +423,7 @@ initHackageFeatures env@ServerEnv{serverVerbosity = verbosity} = do
          , getFeatureInterface userNotifyFeature
          , getFeatureInterface packageFeedFeature
          , getFeatureInterface packageInfoJSONFeature
+         , getFeatureInterface vouchFeature
 #endif
          , staticFilesFeature
          , serverIntrospectFeature allFeatures

diff --git a/src/Distribution/Server/Features/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 endorsements. \
+        \You have been added the the 'uploaders' group. \
+        \You can now upload packages to Hackage. \
+        \Note that packages cannot be deleted, so be careful."
+
     {----- Rendering helpers -----}
 
     renderPackageName = emailContentStr . unPackageName