Skip to content

Commit bf8ee3a

Browse files
ysangkokysangkok
committed
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.
1 parent 30a4d84 commit bf8ee3a

File tree

4 files changed

+257
-1
lines changed

4 files changed

+257
-1
lines changed

‎datafiles/templates/Html/vouch.html.st

Lines changed: 29 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,29 @@
1+
<!DOCTYPE html>
2+
<html>
3+
<head>
4+
$hackageCssTheme()$
5+
<title>Vouch for user | Hackage</title>
6+
</head>
7+
8+
<body>
9+
$hackagePageHeader()$
10+
11+
<div id="content">
12+
<h2>Vouch for user</h2>
13+
14+
<p>$msg$</p>
15+
16+
<form action="" method=POST>
17+
<input type=submit value="Vouch for this user">
18+
</form>
19+
20+
<p>Vouching cannot be undone! When the user has three vouches, the user
21+
can upload packages. Note that users are, to a certain degree, held accountable
22+
for the actions of the users they vouch for. Only vouch for people you know.</p>
23+
24+
<ul>
25+
$vouches$
26+
</ul>
27+
28+
</div>
29+
</body></html>

‎hackage-server.cabal

Lines changed: 2 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -373,8 +373,9 @@ library lib-server
373373
Distribution.Server.Features.Search.TermBag
374374
Distribution.Server.Features.Sitemap.Functions
375375
Distribution.Server.Features.Votes
376-
Distribution.Server.Features.Votes.State
377376
Distribution.Server.Features.Votes.Render
377+
Distribution.Server.Features.Votes.State
378+
Distribution.Server.Features.Vouch
378379
Distribution.Server.Features.RecentPackages
379380
Distribution.Server.Features.PreferredVersions
380381
Distribution.Server.Features.PreferredVersions.State

‎src/Distribution/Server/Features.hs

Lines changed: 8 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -51,6 +51,7 @@ import Distribution.Server.Features.Votes (initVotesFeature)
5151
import Distribution.Server.Features.Sitemap (initSitemapFeature)
5252
import Distribution.Server.Features.UserNotify (initUserNotifyFeature)
5353
import Distribution.Server.Features.PackageFeed (initPackageFeedFeature)
54+
import Distribution.Server.Features.Vouch (initVouchFeature)
5455
#endif
5556
import Distribution.Server.Features.ServerIntrospect (serverIntrospectFeature)
5657

@@ -159,6 +160,8 @@ initHackageFeatures env@ServerEnv{serverVerbosity = verbosity} = do
159160
initUserNotifyFeature env
160161
mkPackageFeedFeature <- logStartup "package feed" $
161162
initPackageFeedFeature env
163+
mkVouchFeature <- logStartup "vouch" $
164+
initVouchFeature env
162165
mkBrowseFeature <- logStartup "browse" $
163166
initBrowseFeature env
164167
mkPackageJSONFeature <- logStartup "package info JSON" $
@@ -359,6 +362,10 @@ initHackageFeatures env@ServerEnv{serverVerbosity = verbosity} = do
359362
usersFeature
360363
tarIndexCacheFeature
361364

365+
vouchFeature <- mkVouchFeature
366+
usersFeature
367+
uploadFeature
368+
362369
browseFeature <- mkBrowseFeature
363370
coreFeature
364371
usersFeature
@@ -415,6 +422,7 @@ initHackageFeatures env@ServerEnv{serverVerbosity = verbosity} = do
415422
, getFeatureInterface userNotifyFeature
416423
, getFeatureInterface packageFeedFeature
417424
, getFeatureInterface packageInfoJSONFeature
425+
, getFeatureInterface vouchFeature
418426
#endif
419427
, staticFilesFeature
420428
, serverIntrospectFeature allFeatures

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

Lines changed: 218 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,218 @@
1+
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
2+
{-# LANGUAGE NamedFieldPuns #-}
3+
{-# LANGUAGE TemplateHaskell #-}
4+
{-# LANGUAGE TypeFamilies #-}
5+
{-# LANGUAGE DerivingStrategies #-}
6+
module Distribution.Server.Features.Vouch where
7+
8+
import Control.Monad (when, join)
9+
import Control.Monad.Except (runExceptT, throwError)
10+
import Control.Monad.Reader (ask)
11+
import Control.Monad.State (get, put)
12+
import qualified Data.ByteString.Lazy.Char8 as LBS
13+
import qualified Data.Map.Strict as Map
14+
import Data.Maybe (fromMaybe)
15+
import Data.Time (UTCTime(..), addUTCTime, getCurrentTime, nominalDay, secondsToDiffTime)
16+
import Data.Time.Format.ISO8601 (formatShow, iso8601Format)
17+
import Text.XHtml.Strict (prettyHtmlFragment, stringToHtml, li)
18+
19+
import Data.SafeCopy (base, deriveSafeCopy)
20+
import Distribution.Server.Framework ((</>), AcidState, DynamicPath, HackageFeature, IsHackageFeature, IsHackageFeature(..), MemSize)
21+
import Distribution.Server.Framework (MessageSpan(MText), Method(..), Query, Response, ServerEnv(..), ServerPartE, StateComponent(..), Update)
22+
import Distribution.Server.Framework (abstractAcidStateComponent, emptyHackageFeature, errBadRequest)
23+
import Distribution.Server.Framework (featureDesc, featureReloadFiles, featureResources, featureState)
24+
import Distribution.Server.Framework (liftIO, makeAcidic, openLocalStateFrom, query, queryState, resourceAt, resourceDesc, resourceGet)
25+
import Distribution.Server.Framework (resourcePost, toResponse, update, updateState)
26+
import Distribution.Server.Framework.BackupRestore (RestoreBackup(..))
27+
import Distribution.Server.Framework.Templating (($=), TemplateAttr, getTemplate, loadTemplates, reloadTemplates, templateUnescaped)
28+
import qualified Distribution.Server.Users.Group as Group
29+
import Distribution.Server.Users.Types (UserId(..), UserInfo, UserName(..), userName)
30+
import Distribution.Server.Features.Upload(UploadFeature(..))
31+
import Distribution.Server.Features.Users (UserFeature(..))
32+
import Distribution.Simple.Utils (toUTF8LBS)
33+
34+
newtype VouchData = VouchData (Map.Map UserId [(UserId, UTCTime)])
35+
deriving (Show, Eq)
36+
deriving newtype MemSize
37+
38+
putVouch :: UserId -> (UserId, UTCTime) -> Update VouchData ()
39+
putVouch vouchee (voucher, now) = do
40+
VouchData tbl <- get
41+
let oldMap = fromMaybe [] (Map.lookup vouchee tbl)
42+
newMap = (voucher, now) : oldMap
43+
put $ VouchData (Map.insert vouchee newMap tbl)
44+
45+
getVouchesFor :: UserId -> Query VouchData [(UserId, UTCTime)]
46+
getVouchesFor needle = do
47+
VouchData tbl <- ask
48+
pure . fromMaybe [] $ Map.lookup needle tbl
49+
50+
getVouchesData :: Query VouchData VouchData
51+
getVouchesData = ask
52+
53+
replaceVouchesData :: VouchData -> Update VouchData ()
54+
replaceVouchesData = put
55+
56+
$(deriveSafeCopy 0 'base ''VouchData)
57+
58+
makeAcidic ''VouchData
59+
[ 'putVouch
60+
, 'getVouchesFor
61+
-- Stock
62+
, 'getVouchesData
63+
, 'replaceVouchesData
64+
]
65+
66+
vouchStateComponent :: FilePath -> IO (StateComponent AcidState VouchData)
67+
vouchStateComponent stateDir = do
68+
st <- openLocalStateFrom (stateDir </> "db" </> "Vouch") (VouchData mempty)
69+
let initialVouchData = VouchData mempty
70+
restore =
71+
RestoreBackup
72+
{ restoreEntry = error "Unexpected backup entry"
73+
, restoreFinalize = return initialVouchData
74+
}
75+
pure StateComponent
76+
{ stateDesc = "Keeps track of vouches"
77+
, stateHandle = st
78+
, getState = query st GetVouchesData
79+
, putState = update st . ReplaceVouchesData
80+
, backupState = \_ _ -> []
81+
, restoreState = restore
82+
, resetState = vouchStateComponent
83+
}
84+
85+
data VouchFeature =
86+
VouchFeature
87+
{ vouchFeatureInterface :: HackageFeature
88+
}
89+
90+
instance IsHackageFeature VouchFeature where
91+
getFeatureInterface = vouchFeatureInterface
92+
93+
requiredCountOfVouches :: Int
94+
requiredCountOfVouches = 3
95+
96+
isWithinLastMonth :: UTCTime -> (UserId, UTCTime) -> Bool
97+
isWithinLastMonth now (_, vouchTime) =
98+
addUTCTime (30 * nominalDay) vouchTime < now
99+
100+
data Err
101+
= NotAnUploader
102+
| You'reTooNew
103+
| VoucheeAlreadyUploader
104+
| AlreadySufficientlyVouched
105+
| YouAlreadyVouched
106+
107+
data Success = AddVouchComplete | AddVouchIncomplete
108+
109+
judge :: Group.UserIdSet -> UTCTime -> UserId -> [(UserId, UTCTime)] -> [(UserId, UTCTime)] -> UserId -> Either Err (Either Err Success)
110+
judge ugroup now vouchee vouchersForVoucher existingVouchers voucher = runExceptT $ do
111+
when (not (voucher `Group.member` ugroup)) $
112+
throwError NotAnUploader
113+
-- You can only vouch for non-uploaders, so if this list has items, the user is uploader because of these vouches.
114+
-- Make sure none of them are too recent.
115+
when (length vouchersForVoucher >= requiredCountOfVouches && any (isWithinLastMonth now) vouchersForVoucher) $
116+
throwError You'reTooNew
117+
when (vouchee `Group.member` ugroup) $
118+
throwError VoucheeAlreadyUploader
119+
when (length existingVouchers >= 3) $
120+
throwError AlreadySufficientlyVouched
121+
when (voucher `elem` map fst existingVouchers) $
122+
throwError YouAlreadyVouched
123+
pure $
124+
if length existingVouchers == requiredCountOfVouches - 1
125+
then AddVouchComplete
126+
else AddVouchIncomplete
127+
128+
renderToLBS :: (UserId -> ServerPartE UserInfo) -> [(UserId, UTCTime)] -> ServerPartE TemplateAttr
129+
renderToLBS lookupUserInfo vouches = do
130+
rendered <- traverse renderVouchers vouches
131+
pure $
132+
templateUnescaped "vouches" $
133+
if null rendered
134+
then LBS.pack "Nobody has vouched yet."
135+
else LBS.intercalate mempty rendered
136+
where
137+
renderVouchers :: (UserId, UTCTime) -> ServerPartE LBS.ByteString
138+
renderVouchers (uid, timestamp) = do
139+
info <- lookupUserInfo uid
140+
let UserName name = userName info
141+
-- We don't need to show millisecond precision
142+
-- So we truncate it off here
143+
truncated = truncate $ utctDayTime timestamp
144+
newUTCTime = timestamp {utctDayTime = secondsToDiffTime truncated}
145+
pure . toUTF8LBS . prettyHtmlFragment . li . stringToHtml $ name <> " vouched on " <> formatShow iso8601Format newUTCTime
146+
147+
initVouchFeature :: ServerEnv -> IO (UserFeature -> UploadFeature -> IO VouchFeature)
148+
initVouchFeature ServerEnv{serverStateDir, serverTemplatesDir, serverTemplatesMode} = do
149+
vouchState <- vouchStateComponent serverStateDir
150+
templates <- loadTemplates serverTemplatesMode [ serverTemplatesDir, serverTemplatesDir </> "Html"]
151+
["vouch.html"]
152+
vouchTemplate <- getTemplate templates "vouch.html"
153+
return $ \UserFeature{userNameInPath, lookupUserName, lookupUserInfo, guardAuthenticated}
154+
UploadFeature{uploadersGroup} -> do
155+
let
156+
handleGetVouches :: DynamicPath -> ServerPartE Response
157+
handleGetVouches dpath = do
158+
uid <- lookupUserName =<< userNameInPath dpath
159+
userIds <- queryState vouchState $ GetVouchesFor uid
160+
param <- renderToLBS lookupUserInfo userIds
161+
pure . toResponse $ vouchTemplate
162+
[ "msg" $= ""
163+
, param
164+
]
165+
handlePostVouch :: DynamicPath -> ServerPartE Response
166+
handlePostVouch dpath = do
167+
voucher <- guardAuthenticated
168+
ugroup <- liftIO $ Group.queryUserGroup uploadersGroup
169+
now <- liftIO getCurrentTime
170+
vouchee <- lookupUserName =<< userNameInPath dpath
171+
vouchersForVoucher <- queryState vouchState $ GetVouchesFor voucher
172+
existingVouchers <- queryState vouchState $ GetVouchesFor vouchee
173+
case join $ judge ugroup now vouchee vouchersForVoucher existingVouchers voucher of
174+
Left NotAnUploader ->
175+
errBadRequest "Not an uploader" [MText "You must be an uploader yourself to vouch for other users."]
176+
Left You'reTooNew ->
177+
errBadRequest "You're too new" [MText "The latest of the vouches for your user must be at least 30 days old."]
178+
Left VoucheeAlreadyUploader ->
179+
errBadRequest "Vouchee already uploader" [MText "You can't vouch for this user, since they are already an uploader."]
180+
Left AlreadySufficientlyVouched ->
181+
errBadRequest "Already sufficiently vouched" [MText "There are already a sufficient number of vouches for this user."]
182+
Left YouAlreadyVouched ->
183+
errBadRequest "Already vouched" [MText "You have already vouched for this user."]
184+
Right result -> do
185+
updateState vouchState $ PutVouch vouchee (voucher, now)
186+
param <- renderToLBS lookupUserInfo $ existingVouchers ++ [(voucher, now)]
187+
case result of
188+
AddVouchComplete -> do
189+
liftIO $ Group.addUserToGroup uploadersGroup vouchee
190+
pure . toResponse $ vouchTemplate
191+
[ "msg" $= "Added vouch. User is now an uploader!"
192+
, param
193+
]
194+
AddVouchIncomplete -> do
195+
let stillRequired = requiredCountOfVouches - length existingVouchers - 1
196+
pure . toResponse $ vouchTemplate
197+
[ "msg" $=
198+
"Added vouch. User still needs "
199+
<> show stillRequired
200+
<> if stillRequired == 1 then " vouch" else " vouches"
201+
<> " to become uploader."
202+
, param
203+
]
204+
return $ VouchFeature $
205+
(emptyHackageFeature "vouch")
206+
{ featureDesc = "Vouching for users getting upload permission."
207+
, featureResources =
208+
[(resourceAt "/user/:username/vouch")
209+
{ resourceDesc = [(GET, "list people vouching")
210+
,(POST, "vouch for user")
211+
]
212+
, resourceGet = [("html", handleGetVouches)]
213+
, resourcePost = [("html", handlePostVouch)]
214+
}
215+
]
216+
, featureState = [ abstractAcidStateComponent vouchState ]
217+
, featureReloadFiles = reloadTemplates templates
218+
}

0 commit comments

Comments
 (0)