Skip to content

Commit ada92d0

Browse files
ysangkokysangkok
committed
Add e-mail notification when all vouches received
1 parent 3c82d01 commit ada92d0

File tree

5 files changed

+117
-32
lines changed

5 files changed

+117
-32
lines changed

‎src/Distribution/Server/Features.hs‎

Lines changed: 5 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -347,6 +347,10 @@ initHackageFeatures env@ServerEnv{serverVerbosity = verbosity} = do
347347
tagsFeature
348348
tarIndexCacheFeature
349349

350+
vouchFeature <- mkVouchFeature
351+
usersFeature
352+
uploadFeature
353+
350354
userNotifyFeature <- mkUserNotifyFeature
351355
usersFeature
352356
coreFeature
@@ -356,16 +360,13 @@ initHackageFeatures env@ServerEnv{serverVerbosity = verbosity} = do
356360
reportsCoreFeature
357361
tagsFeature
358362
reverseFeature
363+
vouchFeature
359364

360365
packageFeedFeature <- mkPackageFeedFeature
361366
coreFeature
362367
usersFeature
363368
tarIndexCacheFeature
364369

365-
vouchFeature <- mkVouchFeature
366-
usersFeature
367-
uploadFeature
368-
369370
browseFeature <- mkBrowseFeature
370371
coreFeature
371372
usersFeature

‎src/Distribution/Server/Features/UserNotify.hs‎

Lines changed: 21 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -52,6 +52,7 @@ import Distribution.Server.Features.Tags
5252
import Distribution.Server.Features.Upload
5353
import Distribution.Server.Features.UserDetails
5454
import Distribution.Server.Features.Users
55+
import Distribution.Server.Features.Vouch
5556

5657
import Distribution.Server.Util.Email
5758

@@ -437,6 +438,7 @@ initUserNotifyFeature :: ServerEnv
437438
-> ReportsFeature
438439
-> TagsFeature
439440
-> ReverseFeature
441+
-> VouchFeature
440442
-> IO UserNotifyFeature)
441443
initUserNotifyFeature env@ServerEnv{ serverStateDir, serverTemplatesDir,
442444
serverTemplatesMode } = do
@@ -448,10 +450,10 @@ initUserNotifyFeature env@ServerEnv{ serverStateDir, serverTemplatesDir,
448450
[serverTemplatesDir, serverTemplatesDir </> "UserNotify"]
449451
[ "user-notify-form.html" ]
450452

451-
return $ \users core uploadfeature adminlog userdetails reports tags revers -> do
453+
return $ \users core uploadfeature adminlog userdetails reports tags revers vouch -> do
452454
let feature = userNotifyFeature env
453455
users core uploadfeature adminlog userdetails reports tags
454-
revers notifyState templates
456+
revers vouch notifyState templates
455457
return feature
456458

457459
data InRange = InRange | OutOfRange
@@ -582,6 +584,7 @@ userNotifyFeature :: ServerEnv
582584
-> ReportsFeature
583585
-> TagsFeature
584586
-> ReverseFeature
587+
-> VouchFeature
585588
-> StateComponent AcidState NotifyData
586589
-> Templates
587590
-> UserNotifyFeature
@@ -594,6 +597,7 @@ userNotifyFeature serverEnv@ServerEnv{serverCron}
594597
ReportsFeature{..}
595598
TagsFeature{..}
596599
ReverseFeature{queryReverseIndex}
600+
VouchFeature{drainQueuedNotifications}
597601
notifyState templates
598602
= UserNotifyFeature {..}
599603

@@ -709,6 +713,8 @@ userNotifyFeature serverEnv@ServerEnv{serverCron}
709713
revIdx <- liftIO queryReverseIndex
710714
dependencyUpdateNotifications <- concatMapM (genDependencyUpdateList notifyPrefs idx revIdx . pkgInfoToPkgId) revisionsAndUploads
711715

716+
vouchNotifications <- fmap (, NotifyVouchingCompleted) <$> drainQueuedNotifications
717+
712718
emails <-
713719
getNotificationEmails serverEnv userDetailsFeature users $
714720
concat
@@ -717,6 +723,7 @@ userNotifyFeature serverEnv@ServerEnv{serverCron}
717723
, docReportNotifications
718724
, tagProposalNotifications
719725
, dependencyUpdateNotifications
726+
, vouchNotifications
720727
]
721728
mapM_ sendNotifyEmailAndDelay emails
722729

@@ -897,6 +904,7 @@ data Notification
897904
-- ^ Packages maintained by user that depend on updated dep
898905
, notifyTriggerBounds :: NotifyTriggerBounds
899906
}
907+
| NotifyVouchingCompleted
900908
deriving (Show)
901909

902910
data NotifyMaintainerUpdateType = MaintainerAdded | MaintainerRemoved
@@ -1021,6 +1029,10 @@ getNotificationEmails
10211029
notifyWatchedPackages
10221030
, DependencyNotification notifyPackageId
10231031
)
1032+
NotifyVouchingCompleted ->
1033+
generalNotification
1034+
renderNotifyVouchingCompleted
1035+
10241036
where
10251037
generalNotification = (, GeneralNotification)
10261038

@@ -1086,6 +1098,13 @@ getNotificationEmails
10861098
]
10871099
<> EmailContentList (map renderPkgLink revDeps)
10881100

1101+
renderNotifyVouchingCompleted =
1102+
EmailContentParagraph
1103+
"You have received all necessary vouches. \
1104+
\You have been added the the 'uploaders' group. \
1105+
\You can now upload packages to Hackage. \
1106+
\Note that packages cannot be deleted, so be careful."
1107+
10891108
{----- Rendering helpers -----}
10901109

10911110
renderPackageName = emailContentStr . unPackageName

‎src/Distribution/Server/Features/Vouch.hs‎

Lines changed: 51 additions & 26 deletions
Original file line numberDiff line numberDiff line change
@@ -3,21 +3,24 @@
33
{-# LANGUAGE TemplateHaskell #-}
44
{-# LANGUAGE TypeFamilies #-}
55
{-# LANGUAGE DerivingStrategies #-}
6-
module Distribution.Server.Features.Vouch (VouchError(..), VouchSuccess(..), initVouchFeature, judgeVouch) where
6+
{-# LANGUAGE RankNTypes #-}
7+
module Distribution.Server.Features.Vouch (VouchFeature(..), VouchData(..), VouchError(..), VouchSuccess(..), initVouchFeature, judgeVouch) where
78

89
import Control.Monad (when, join)
910
import Control.Monad.Except (runExceptT, throwError)
1011
import Control.Monad.Reader (ask)
1112
import Control.Monad.State (get, put)
13+
import Control.Monad.IO.Class (MonadIO)
1214
import qualified Data.ByteString.Lazy.Char8 as LBS
1315
import qualified Data.Map.Strict as Map
16+
import qualified Data.Set as Set
1417
import Data.Maybe (fromMaybe)
1518
import Data.Time (UTCTime(..), addUTCTime, getCurrentTime, nominalDay, secondsToDiffTime)
1619
import Data.Time.Format.ISO8601 (formatShow, iso8601Format)
1720
import Text.XHtml.Strict (prettyHtmlFragment, stringToHtml, li)
1821

1922
import Data.SafeCopy (base, deriveSafeCopy)
20-
import Distribution.Server.Framework ((</>), AcidState, DynamicPath, HackageFeature, IsHackageFeature, IsHackageFeature(..), MemSize)
23+
import Distribution.Server.Framework ((</>), AcidState, DynamicPath, HackageFeature, IsHackageFeature, IsHackageFeature(..), MemSize(..), memSize2)
2124
import Distribution.Server.Framework (MessageSpan(MText), Method(..), Query, Response, ServerEnv(..), ServerPartE, StateComponent(..), Update)
2225
import Distribution.Server.Framework (abstractAcidStateComponent, emptyHackageFeature, errBadRequest)
2326
import Distribution.Server.Framework (featureDesc, featureReloadFiles, featureResources, featureState)
@@ -31,20 +34,26 @@ import Distribution.Server.Features.Upload(UploadFeature(..))
3134
import Distribution.Server.Features.Users (UserFeature(..))
3235
import Distribution.Simple.Utils (toUTF8LBS)
3336

34-
newtype VouchData = VouchData (Map.Map UserId [(UserId, UTCTime)])
37+
data VouchData =
38+
VouchData
39+
{ vouches :: Map.Map UserId [(UserId, UTCTime)]
40+
, notNotified :: Set.Set UserId
41+
}
3542
deriving (Show, Eq)
36-
deriving newtype MemSize
43+
44+
instance MemSize VouchData where
45+
memSize (VouchData vouches notified) = memSize2 vouches notified
3746

3847
putVouch :: UserId -> (UserId, UTCTime) -> Update VouchData ()
3948
putVouch vouchee (voucher, now) = do
40-
VouchData tbl <- get
49+
VouchData tbl notNotified <- get
4150
let oldMap = fromMaybe [] (Map.lookup vouchee tbl)
4251
newMap = (voucher, now) : oldMap
43-
put $ VouchData (Map.insert vouchee newMap tbl)
52+
put $ VouchData (Map.insert vouchee newMap tbl) notNotified
4453

4554
getVouchesFor :: UserId -> Query VouchData [(UserId, UTCTime)]
4655
getVouchesFor needle = do
47-
VouchData tbl <- ask
56+
VouchData tbl _notNotified <- ask
4857
pure . fromMaybe [] $ Map.lookup needle tbl
4958

5059
getVouchesData :: Query VouchData VouchData
@@ -65,8 +74,8 @@ makeAcidic ''VouchData
6574

6675
vouchStateComponent :: FilePath -> IO (StateComponent AcidState VouchData)
6776
vouchStateComponent stateDir = do
68-
st <- openLocalStateFrom (stateDir </> "db" </> "Vouch") (VouchData mempty)
69-
let initialVouchData = VouchData mempty
77+
st <- openLocalStateFrom (stateDir </> "db" </> "Vouch") (VouchData mempty mempty)
78+
let initialVouchData = VouchData mempty mempty
7079
restore =
7180
RestoreBackup
7281
{ restoreEntry = error "Unexpected backup entry"
@@ -85,6 +94,7 @@ vouchStateComponent stateDir = do
8594
data VouchFeature =
8695
VouchFeature
8796
{ vouchFeatureInterface :: HackageFeature
97+
, drainQueuedNotifications :: forall m. MonadIO m => m [UserId]
8898
}
8999

90100
instance IsHackageFeature VouchFeature where
@@ -167,8 +177,8 @@ initVouchFeature ServerEnv{serverStateDir, serverTemplatesDir, serverTemplatesMo
167177
handleGetVouches :: DynamicPath -> ServerPartE Response
168178
handleGetVouches dpath = do
169179
uid <- lookupUserName =<< userNameInPath dpath
170-
userIds <- queryState vouchState $ GetVouchesFor uid
171-
param <- renderToLBS lookupUserInfo userIds
180+
vouches <- queryState vouchState $ GetVouchesFor uid
181+
param <- renderToLBS lookupUserInfo vouches
172182
pure . toResponse $ vouchTemplate
173183
[ "msg" $= ""
174184
, param
@@ -197,6 +207,13 @@ initVouchFeature ServerEnv{serverStateDir, serverTemplatesDir, serverTemplatesMo
197207
param <- renderToLBS lookupUserInfo $ existingVouchers ++ [(voucher, now)]
198208
case result of
199209
AddVouchComplete -> do
210+
-- enqueue vouching completed notification
211+
-- which will be read using drainQueuedNotifications
212+
VouchData vouches notNotified <-
213+
queryState vouchState GetVouchesData
214+
let newState = VouchData vouches (Set.insert vouchee notNotified)
215+
updateState vouchState $ ReplaceVouchesData newState
216+
200217
liftIO $ Group.addUserToGroup uploadersGroup vouchee
201218
pure . toResponse $ vouchTemplate
202219
[ "msg" $= "Added vouch. User is now an uploader!"
@@ -211,18 +228,26 @@ initVouchFeature ServerEnv{serverStateDir, serverTemplatesDir, serverTemplatesMo
211228
<> " to become uploader."
212229
, param
213230
]
214-
return $ VouchFeature $
215-
(emptyHackageFeature "vouch")
216-
{ featureDesc = "Vouching for users getting upload permission."
217-
, featureResources =
218-
[(resourceAt "/user/:username/vouch")
219-
{ resourceDesc = [(GET, "list people vouching")
220-
,(POST, "vouch for user")
221-
]
222-
, resourceGet = [("html", handleGetVouches)]
223-
, resourcePost = [("html", handlePostVouch)]
224-
}
225-
]
226-
, featureState = [ abstractAcidStateComponent vouchState ]
227-
, featureReloadFiles = reloadTemplates templates
228-
}
231+
return $ VouchFeature {
232+
vouchFeatureInterface =
233+
(emptyHackageFeature "vouch")
234+
{ featureDesc = "Vouching for users getting upload permission."
235+
, featureResources =
236+
[(resourceAt "/user/:username/vouch")
237+
{ resourceDesc = [(GET, "list people vouching")
238+
,(POST, "vouch for user")
239+
]
240+
, resourceGet = [("html", handleGetVouches)]
241+
, resourcePost = [("html", handlePostVouch)]
242+
}
243+
]
244+
, featureState = [ abstractAcidStateComponent vouchState ]
245+
, featureReloadFiles = reloadTemplates templates
246+
},
247+
drainQueuedNotifications = do
248+
VouchData vouches notNotified <-
249+
queryState vouchState GetVouchesData
250+
let newState = VouchData vouches mempty
251+
updateState vouchState $ ReplaceVouchesData newState
252+
pure $ Set.toList notNotified
253+
}

‎tests/ReverseDependenciesTest.hs‎

Lines changed: 5 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -422,6 +422,8 @@ getNotificationEmailsTests =
422422
, notifyWatchedPackages = [PackageIdentifier "mtl" (mkVersion [2, 3])]
423423
, notifyTriggerBounds = BoundsOutOfRange
424424
}
425+
, testGolden "Render NotifyVouchingCompleted" "getNotificationEmails-NotifyVouchingCompleted.golden" $
426+
fmap renderMail $ getNotificationEmailMocked userWatcher NotifyVouchingCompleted
425427
, testGolden "Render general notifications in single batched email" "getNotificationEmails-batched.golden" $ do
426428
emails <-
427429
getNotificationEmailsMocked . map (userWatcher,) $
@@ -455,6 +457,7 @@ getNotificationEmailsTests =
455457
NotifyDocsBuild{} -> ()
456458
NotifyUpdateTags{} -> ()
457459
NotifyDependencyUpdate{} -> ()
460+
NotifyVouchingCompleted{} -> ()
458461

459462
isGeneral = \case
460463
NotifyNewVersion{} -> True
@@ -463,6 +466,7 @@ getNotificationEmailsTests =
463466
NotifyDocsBuild{} -> True
464467
NotifyUpdateTags{} -> True
465468
NotifyDependencyUpdate{} -> False
469+
NotifyVouchingCompleted{} -> True
466470

467471
-- userWatcher = user getting the notification
468472
-- userActor = user that did the action
@@ -539,6 +543,7 @@ getNotificationEmailsTests =
539543
<$> genPackageId
540544
<*> Gen.list (Range.linear 1 10) genPackageId
541545
<*> Gen.element [Always, NewIncompatibility, BoundsOutOfRange]
546+
, pure NotifyVouchingCompleted
542547
]
543548

544549
genPackageName = mkPackageName <$> Gen.string (Range.linear 1 30) Gen.unicode

‎tests/golden/ReverseDependenciesTest/getNotificationEmails-NotifyVouchingCompleted.golden‎

Lines changed: 35 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,35 @@
1+
From: =?utf-8?Q?Hackage_website?= <noreply@hackage.haskell.org>
2+
To: =?utf-8?Q?user-watcher?= <user-watcher@example.com>
3+
Subject: [Hackage] Maintainer Notifications
4+
MIME-Version: 1.0
5+
Content-Type: multipart/alternative; boundary="YIYrWcf3to"
6+
7+
--YIYrWcf3to
8+
Content-Type: text/plain; charset=utf-8
9+
Content-Transfer-Encoding: quoted-printable
10+
11+
You have received all necessary vouches=2E You have been added the the 'upl=
12+
oaders' group=2E You can now upload packages to Hackage=2E Note that packag=
13+
es cannot be deleted, so be careful=2E
14+
15+
You can adjust your notification preferences at
16+
https://hackage=2Ehaskell=2Eorg/user/user-watcher/notify (https://hackage=
17+
=2Ehaskell=2Eorg/user/user-watcher/notify)
18+
19+
20+
--YIYrWcf3to
21+
Content-Type: text/html; charset=utf-8
22+
Content-Transfer-Encoding: quoted-printable
23+
24+
25+
<p>
26+
You have received all necessary vouches=2E You have been added the the 'upl=
27+
oaders' group=2E You can now upload packages to Hackage=2E Note that packag=
28+
es cannot be deleted, so be careful=2E
29+
</p>
30+
<p>
31+
You can adjust your notification preferences at
32+
<br /><a href=3D"https://hackage=2Ehaskell=2Eorg/user/user-watcher/notify">=
33+
https://hackage=2Ehaskell=2Eorg/user/user-watcher/notify</a>
34+
</p>
35+
--YIYrWcf3to--

0 commit comments

Comments
 (0)