diff --git a/datafiles/templates/Html/vouch.html.st b/datafiles/templates/Html/vouch.html.st
new file mode 100644
index 00000000..cb34cd85
--- /dev/null
+++ b/datafiles/templates/Html/vouch.html.st
@@ -0,0 +1,27 @@
+
+
+
+$hackageCssTheme()$
+
+
Endorse user
+
+
$msg$
+
+
+
+
Endorsing cannot be undone! When the user has $requiredNumber$ endorsements, the user
+will be added to the uploaders group, and allowed to upload packages. Only endorse people who you trust to upload packages responsibly.
+
+
+
+
diff --git a/hackage-server.cabal b/hackage-server.cabal
index a09731d0..a4f4f92c 100644
--- 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
index be89e417..b4e2d96d 100644
--- a/src/Distribution/Server/Features.hs
+++ b/src/Distribution/Server/Features.hs
@@ -51,6 +51,7 @@ import Distribution.Server.Features.Votes (initVotesFeature)
import Distribution.Server.Features.Sitemap (initSitemapFeature)
import Distribution.Server.Features.UserNotify (initUserNotifyFeature)
import Distribution.Server.Features.PackageFeed (initPackageFeedFeature)
+import Distribution.Server.Features.Vouch (initVouchFeature)
#endif
import Distribution.Server.Features.ServerIntrospect (serverIntrospectFeature)
@@ -159,6 +160,8 @@ initHackageFeatures env@ServerEnv{serverVerbosity = verbosity} = do
initUserNotifyFeature env
mkPackageFeedFeature <- logStartup "package feed" $
initPackageFeedFeature env
+ mkVouchFeature <- logStartup "vouch" $
+ initVouchFeature env
mkBrowseFeature <- logStartup "browse" $
initBrowseFeature env
mkPackageJSONFeature <- logStartup "package info JSON" $
@@ -344,6 +347,10 @@ initHackageFeatures env@ServerEnv{serverVerbosity = verbosity} = do
tagsFeature
tarIndexCacheFeature
+ vouchFeature <- mkVouchFeature
+ usersFeature
+ uploadFeature
+
userNotifyFeature <- mkUserNotifyFeature
usersFeature
coreFeature
@@ -353,6 +360,7 @@ initHackageFeatures env@ServerEnv{serverVerbosity = verbosity} = do
reportsCoreFeature
tagsFeature
reverseFeature
+ vouchFeature
packageFeedFeature <- mkPackageFeedFeature
coreFeature
@@ -415,6 +423,7 @@ initHackageFeatures env@ServerEnv{serverVerbosity = verbosity} = do
, getFeatureInterface userNotifyFeature
, getFeatureInterface packageFeedFeature
, getFeatureInterface packageInfoJSONFeature
+ , getFeatureInterface vouchFeature
#endif
, staticFilesFeature
, serverIntrospectFeature allFeatures
diff --git a/src/Distribution/Server/Features/UserNotify.hs b/src/Distribution/Server/Features/UserNotify.hs
index fb11fa5e..2d0289a2 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 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
diff --git a/src/Distribution/Server/Features/Vouch.hs b/src/Distribution/Server/Features/Vouch.hs
new file mode 100644
index 00000000..ba08ecc4
--- /dev/null
+++ b/src/Distribution/Server/Features/Vouch.hs
@@ -0,0 +1,255 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE RankNTypes #-}
+module Distribution.Server.Features.Vouch (VouchFeature(..), VouchData(..), VouchError(..), VouchSuccess(..), initVouchFeature, judgeVouch) where
+
+import Control.Monad (when, join)
+import Control.Monad.Except (runExceptT, throwError)
+import Control.Monad.Reader (ask)
+import Control.Monad.State (get, put)
+import Control.Monad.IO.Class (MonadIO)
+import qualified Data.ByteString.Lazy.Char8 as LBS
+import qualified Data.Map.Strict as Map
+import qualified Data.Set as Set
+import Data.Maybe (fromMaybe)
+import Data.Time (UTCTime(..), addUTCTime, getCurrentTime, nominalDay, secondsToDiffTime)
+import Data.Time.Format.ISO8601 (formatShow, iso8601Format)
+import Text.XHtml.Strict (prettyHtmlFragment, stringToHtml, li)
+
+import Data.SafeCopy (base, deriveSafeCopy)
+import Distribution.Server.Framework ((>), AcidState, DynamicPath, HackageFeature, IsHackageFeature, IsHackageFeature(..), MemSize(..), memSize2)
+import Distribution.Server.Framework (MessageSpan(MText), Method(..), Query, Response, ServerEnv(..), ServerPartE, StateComponent(..), Update)
+import Distribution.Server.Framework (abstractAcidStateComponent, emptyHackageFeature, errBadRequest)
+import Distribution.Server.Framework (featureDesc, featureReloadFiles, featureResources, featureState)
+import Distribution.Server.Framework (liftIO, makeAcidic, openLocalStateFrom, query, queryState, resourceAt, resourceDesc, resourceGet)
+import Distribution.Server.Framework (resourcePost, toResponse, update, updateState)
+import Distribution.Server.Framework.BackupRestore (RestoreBackup(..))
+import Distribution.Server.Framework.Templating (($=), TemplateAttr, getTemplate, loadTemplates, reloadTemplates, templateUnescaped)
+import qualified Distribution.Server.Users.Group as Group
+import Distribution.Server.Users.Types (UserId(..), UserInfo, UserName(..), userName)
+import Distribution.Server.Features.Upload(UploadFeature(..))
+import Distribution.Server.Features.Users (UserFeature(..))
+import Distribution.Simple.Utils (toUTF8LBS)
+
+data VouchData =
+ VouchData
+ { vouches :: Map.Map UserId [(UserId, UTCTime)]
+ , notNotified :: Set.Set UserId
+ }
+ deriving (Show, Eq)
+
+instance MemSize VouchData where
+ memSize (VouchData vouches notified) = memSize2 vouches notified
+
+putVouch :: UserId -> (UserId, UTCTime) -> Update VouchData ()
+putVouch vouchee (voucher, now) = do
+ VouchData tbl notNotified <- get
+ let oldMap = fromMaybe [] (Map.lookup vouchee tbl)
+ newMap = (voucher, now) : oldMap
+ put $ VouchData (Map.insert vouchee newMap tbl) notNotified
+
+getVouchesFor :: UserId -> Query VouchData [(UserId, UTCTime)]
+getVouchesFor needle = do
+ VouchData tbl _notNotified <- ask
+ pure . fromMaybe [] $ Map.lookup needle tbl
+
+getVouchesData :: Query VouchData VouchData
+getVouchesData = ask
+
+replaceVouchesData :: VouchData -> Update VouchData ()
+replaceVouchesData = put
+
+$(deriveSafeCopy 0 'base ''VouchData)
+
+makeAcidic ''VouchData
+ [ 'putVouch
+ , 'getVouchesFor
+ -- Stock
+ , 'getVouchesData
+ , 'replaceVouchesData
+ ]
+
+vouchStateComponent :: FilePath -> IO (StateComponent AcidState VouchData)
+vouchStateComponent stateDir = do
+ st <- openLocalStateFrom (stateDir > "db" > "Vouch") (VouchData mempty mempty)
+ let initialVouchData = VouchData mempty mempty
+ restore =
+ RestoreBackup
+ { restoreEntry = error "Unexpected backup entry"
+ , restoreFinalize = return initialVouchData
+ }
+ pure StateComponent
+ { stateDesc = "Keeps track of vouches"
+ , stateHandle = st
+ , getState = query st GetVouchesData
+ , putState = update st . ReplaceVouchesData
+ , backupState = \_ _ -> []
+ , restoreState = restore
+ , resetState = vouchStateComponent
+ }
+
+data VouchFeature =
+ VouchFeature
+ { vouchFeatureInterface :: HackageFeature
+ , drainQueuedNotifications :: forall m. MonadIO m => m [UserId]
+ }
+
+instance IsHackageFeature VouchFeature where
+ getFeatureInterface = vouchFeatureInterface
+
+requiredCountOfVouches :: Int
+requiredCountOfVouches = 2
+
+isWithinLastMonth :: UTCTime -> (UserId, UTCTime) -> Bool
+isWithinLastMonth now (_, vouchTime) =
+ addUTCTime (30 * nominalDay) vouchTime >= now
+
+data VouchError
+ = NotAnUploader
+ | You'reTooNew
+ | VoucheeAlreadyUploader
+ | AlreadySufficientlyVouched
+ | YouAlreadyVouched
+ deriving stock (Show, Eq)
+
+data VouchSuccess = AddVouchComplete | AddVouchIncomplete Int
+ deriving stock (Show, Eq)
+
+judgeVouch
+ :: Group.UserIdSet
+ -> UTCTime
+ -> UserId
+ -> [(UserId, UTCTime)]
+ -> [(UserId, UTCTime)]
+ -> UserId
+ -> Either VouchError VouchSuccess
+judgeVouch ugroup now vouchee vouchersForVoucher existingVouchers voucher = join . runExceptT $ do
+ when (not (voucher `Group.member` ugroup)) $
+ throwError NotAnUploader
+ -- You can only vouch for non-uploaders, so if this list has items, the user is uploader because of these vouches.
+ -- Make sure none of them are too recent.
+ when (length vouchersForVoucher >= requiredCountOfVouches && any (isWithinLastMonth now) vouchersForVoucher) $
+ throwError You'reTooNew
+ when (vouchee `Group.member` ugroup) $
+ throwError VoucheeAlreadyUploader
+ when (length existingVouchers >= requiredCountOfVouches) $
+ throwError AlreadySufficientlyVouched
+ when (voucher `elem` map fst existingVouchers) $
+ throwError YouAlreadyVouched
+ pure $
+ if length existingVouchers == requiredCountOfVouches - 1
+ then AddVouchComplete
+ else
+ let stillRequired = requiredCountOfVouches - length existingVouchers - 1
+ in AddVouchIncomplete stillRequired
+
+renderToLBS :: (UserId -> ServerPartE UserInfo) -> [(UserId, UTCTime)] -> ServerPartE TemplateAttr
+renderToLBS lookupUserInfo vouches = do
+ rendered <- traverse (renderVouchers lookupUserInfo) vouches
+ pure $
+ templateUnescaped "vouches" $
+ if null rendered
+ then LBS.pack "Nobody has endorsed yet."
+ else LBS.intercalate mempty rendered
+
+renderVouchers :: (UserId -> ServerPartE UserInfo) -> (UserId, UTCTime) -> ServerPartE LBS.ByteString
+renderVouchers lookupUserInfo (uid, timestamp) = do
+ info <- lookupUserInfo uid
+ let UserName name = userName info
+ -- We don't need to show millisecond precision
+ -- So we truncate it off here
+ truncated = truncate $ utctDayTime timestamp
+ newUTCTime = timestamp {utctDayTime = secondsToDiffTime truncated}
+ pure . toUTF8LBS . prettyHtmlFragment . li . stringToHtml $ name <> " vouched on " <> formatShow iso8601Format newUTCTime
+
+initVouchFeature :: ServerEnv -> IO (UserFeature -> UploadFeature -> IO VouchFeature)
+initVouchFeature ServerEnv{serverStateDir, serverTemplatesDir, serverTemplatesMode} = do
+ vouchState <- vouchStateComponent serverStateDir
+ templates <- loadTemplates serverTemplatesMode [ serverTemplatesDir, serverTemplatesDir > "Html"]
+ ["vouch.html"]
+ vouchTemplate <- getTemplate templates "vouch.html"
+ return $ \UserFeature{userNameInPath, lookupUserName, lookupUserInfo, guardAuthenticated}
+ UploadFeature{uploadersGroup} -> do
+ let
+ handleGetVouches :: DynamicPath -> ServerPartE Response
+ handleGetVouches dpath = do
+ uid <- lookupUserName =<< userNameInPath dpath
+ vouches <- queryState vouchState $ GetVouchesFor uid
+ param <- renderToLBS lookupUserInfo vouches
+ pure . toResponse $ vouchTemplate
+ [ "msg" $= ""
+ , "requiredNumber" $= show requiredCountOfVouches
+ , param
+ ]
+ handlePostVouch :: DynamicPath -> ServerPartE Response
+ handlePostVouch dpath = do
+ voucher <- guardAuthenticated
+ ugroup <- liftIO $ Group.queryUserGroup uploadersGroup
+ now <- liftIO getCurrentTime
+ vouchee <- lookupUserName =<< userNameInPath dpath
+ vouchersForVoucher <- queryState vouchState $ GetVouchesFor voucher
+ existingVouchers <- queryState vouchState $ GetVouchesFor vouchee
+ case judgeVouch ugroup now vouchee vouchersForVoucher existingVouchers voucher of
+ Left NotAnUploader ->
+ errBadRequest "Not an uploader" [MText "You must be an uploader yourself to endorse other users."]
+ Left You'reTooNew ->
+ errBadRequest "You're too new" [MText "The latest of the endorsements for your user must be at least 30 days old."]
+ Left VoucheeAlreadyUploader ->
+ errBadRequest "Endorsee already uploader" [MText "You can't endorse this user, since they are already an uploader."]
+ Left AlreadySufficientlyVouched ->
+ errBadRequest "Already sufficiently endorsed" [MText "There are already a sufficient number of endorsements for this user."]
+ Left YouAlreadyVouched ->
+ errBadRequest "Already endorsed" [MText "You have already endorsed this user."]
+ Right result -> do
+ updateState vouchState $ PutVouch vouchee (voucher, now)
+ param <- renderToLBS lookupUserInfo $ existingVouchers ++ [(voucher, now)]
+ case result of
+ AddVouchComplete -> do
+ -- enqueue vouching completed notification
+ -- which will be read using drainQueuedNotifications
+ VouchData vouches notNotified <-
+ queryState vouchState GetVouchesData
+ let newState = VouchData vouches (Set.insert vouchee notNotified)
+ updateState vouchState $ ReplaceVouchesData newState
+
+ liftIO $ Group.addUserToGroup uploadersGroup vouchee
+ pure . toResponse $ vouchTemplate
+ [ "msg" $= "Added endorsement. User is now an uploader!"
+ , "requiredNumber" $= show requiredCountOfVouches
+ , param
+ ]
+ AddVouchIncomplete stillRequired ->
+ pure . toResponse $ vouchTemplate
+ [ "msg" $=
+ "Added endorsement. User still needs "
+ <> show stillRequired
+ <> if stillRequired == 1 then " endorsement" else " endorsements"
+ <> " to become uploader."
+ , param
+ ]
+ return $ VouchFeature {
+ vouchFeatureInterface =
+ (emptyHackageFeature "endorse")
+ { featureDesc = "Endorsing users such that they get upload permission."
+ , featureResources =
+ [(resourceAt "/user/:username/endorse")
+ { resourceDesc = [(GET, "list people endorsing")
+ ,(POST, "endorse for user")
+ ]
+ , resourceGet = [("html", handleGetVouches)]
+ , resourcePost = [("html", handlePostVouch)]
+ }
+ ]
+ , featureState = [ abstractAcidStateComponent vouchState ]
+ , featureReloadFiles = reloadTemplates templates
+ },
+ drainQueuedNotifications = do
+ VouchData vouches notNotified <-
+ queryState vouchState GetVouchesData
+ let newState = VouchData vouches mempty
+ updateState vouchState $ ReplaceVouchesData newState
+ pure $ Set.toList notNotified
+ }
diff --git a/tests/ReverseDependenciesTest.hs b/tests/ReverseDependenciesTest.hs
index 5b0333a0..fa78807d 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/VouchTest.hs b/tests/VouchTest.hs
new file mode 100644
index 00000000..ece72d57
--- /dev/null
+++ b/tests/VouchTest.hs
@@ -0,0 +1,96 @@
+module Main where
+
+import Data.Time (UTCTime(UTCTime), fromGregorian)
+
+import Distribution.Server.Features.Vouch (VouchError(..), VouchSuccess(..), judgeVouch)
+import Distribution.Server.Users.UserIdSet (fromList)
+import Distribution.Server.Users.Types (UserId(UserId))
+
+import Test.Tasty (TestTree, defaultMain, testGroup)
+import Test.Tasty.HUnit (assertEqual, testCase)
+
+allTests :: TestTree
+allTests = testGroup "VouchTest"
+ [ testCase "happy path, vouch added, but more vouches needed" $ do
+ let ref = Right (AddVouchIncomplete 1)
+ voucher = UserId 1
+ vouchee = UserId 2
+ assertEqual "must match" ref $
+ judgeVouch
+ (fromList [voucher]) -- uploaders. Can't vouch if user is not a voucher
+ (UTCTime (fromGregorian 2020 1 1) 0)
+ vouchee
+ [] -- vouchers for voucher. If this short enough, voucher is assumed to be old enough to vouch themselves.
+ [] -- no existing vouchers
+ voucher
+ , testCase "happy path, vouch added, no more vouches needed" $ do
+ let ref = Right AddVouchComplete
+ voucher = UserId 1
+ vouchee = UserId 2
+ otherVoucherForVouchee = UserId 4
+ assertEqual "must match" ref $
+ judgeVouch
+ (fromList [voucher])
+ (UTCTime (fromGregorian 2020 1 1) 0)
+ vouchee
+ []
+ [(otherVoucherForVouchee, UTCTime (fromGregorian 2020 1 1) 0)]
+ voucher
+ , testCase "non-uploader tried to vouch" $ do
+ let ref = Left NotAnUploader
+ voucher = UserId 1
+ vouchee = UserId 2
+ assertEqual "must match" ref $
+ judgeVouch
+ (fromList []) -- empty. Should contain voucher for operation to proceed.
+ (UTCTime (fromGregorian 2020 1 1) 0)
+ vouchee
+ []
+ []
+ voucher
+ , testCase "voucher too new" $ do
+ let ref = Left You'reTooNew
+ voucher = UserId 1
+ vouchee = UserId 2
+ fstVoucherForVoucher = UserId 3
+ sndVoucherForVoucher = UserId 4
+ now = UTCTime (fromGregorian 2020 1 1) 0
+ assertEqual "must match" ref $
+ judgeVouch
+ (fromList [voucher])
+ now
+ vouchee
+ [ (fstVoucherForVoucher, now) -- These two timestamps are too new
+ , (sndVoucherForVoucher, now)
+ ]
+ []
+ voucher
+ , testCase "vouchee already uploader" $ do
+ let ref = Left VoucheeAlreadyUploader
+ voucher = UserId 1
+ vouchee = UserId 2
+ now = UTCTime (fromGregorian 2020 1 1) 0
+ assertEqual "must match" ref $
+ judgeVouch
+ (fromList [voucher, vouchee]) -- vouchee is here. So they're already an uploader.
+ now
+ vouchee
+ []
+ []
+ voucher
+ , testCase "already vouched" $ do
+ let ref = Left YouAlreadyVouched
+ voucher = UserId 1
+ vouchee = UserId 2
+ assertEqual "must match" ref $
+ judgeVouch
+ (fromList [voucher])
+ (UTCTime (fromGregorian 2020 1 1) 0)
+ vouchee
+ []
+ [(voucher, UTCTime (fromGregorian 2020 1 1) 0)] -- voucher is here. So they already vouched
+ voucher
+ ]
+
+main :: IO ()
+main = defaultMain allTests
diff --git a/tests/golden/ReverseDependenciesTest/getNotificationEmails-NotifyVouchingCompleted.golden b/tests/golden/ReverseDependenciesTest/getNotificationEmails-NotifyVouchingCompleted.golden
new file mode 100644
index 00000000..b45e64f2
--- /dev/null
+++ b/tests/golden/ReverseDependenciesTest/getNotificationEmails-NotifyVouchingCompleted.golden
@@ -0,0 +1,35 @@
+From: =?utf-8?Q?Hackage_website?=