Skip to content

Commit 3c82d01

Browse files
ysangkokysangkok
committed
Vouching: Address review comments, add tests
1 parent bf8ee3a commit 3c82d01

File tree

3 files changed

+139
-25
lines changed

3 files changed

+139
-25
lines changed

‎hackage-server.cabal‎

Lines changed: 8 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -574,6 +574,14 @@ test-suite HighLevelTest
574574
, io-streams ^>= 1.5.0.1
575575
, http-io-streams ^>= 0.1.6.1
576576

577+
test-suite VouchTest
578+
import: test-defaults
579+
type: exitcode-stdio-1.0
580+
main-is: VouchTest.hs
581+
build-depends:
582+
, tasty ^>= 1.4
583+
, tasty-hunit ^>= 0.10
584+
577585
test-suite ReverseDependenciesTest
578586
import: test-defaults
579587
type: exitcode-stdio-1.0

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

Lines changed: 35 additions & 25 deletions
Original file line numberDiff line numberDiff line change
@@ -3,7 +3,7 @@
33
{-# LANGUAGE TemplateHaskell #-}
44
{-# LANGUAGE TypeFamilies #-}
55
{-# LANGUAGE DerivingStrategies #-}
6-
module Distribution.Server.Features.Vouch where
6+
module Distribution.Server.Features.Vouch (VouchError(..), VouchSuccess(..), initVouchFeature, judgeVouch) where
77

88
import Control.Monad (when, join)
99
import Control.Monad.Except (runExceptT, throwError)
@@ -91,23 +91,32 @@ instance IsHackageFeature VouchFeature where
9191
getFeatureInterface = vouchFeatureInterface
9292

9393
requiredCountOfVouches :: Int
94-
requiredCountOfVouches = 3
94+
requiredCountOfVouches = 2
9595

9696
isWithinLastMonth :: UTCTime -> (UserId, UTCTime) -> Bool
9797
isWithinLastMonth now (_, vouchTime) =
98-
addUTCTime (30 * nominalDay) vouchTime < now
98+
addUTCTime (30 * nominalDay) vouchTime >= now
9999

100-
data Err
100+
data VouchError
101101
= NotAnUploader
102102
| You'reTooNew
103103
| VoucheeAlreadyUploader
104104
| AlreadySufficientlyVouched
105105
| 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
106+
deriving stock (Show, Eq)
107+
108+
data VouchSuccess = AddVouchComplete | AddVouchIncomplete Int
109+
deriving stock (Show, Eq)
110+
111+
judgeVouch
112+
:: Group.UserIdSet
113+
-> UTCTime
114+
-> UserId
115+
-> [(UserId, UTCTime)]
116+
-> [(UserId, UTCTime)]
117+
-> UserId
118+
-> Either VouchError VouchSuccess
119+
judgeVouch ugroup now vouchee vouchersForVoucher existingVouchers voucher = join . runExceptT $ do
111120
when (not (voucher `Group.member` ugroup)) $
112121
throwError NotAnUploader
113122
-- 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
116125
throwError You'reTooNew
117126
when (vouchee `Group.member` ugroup) $
118127
throwError VoucheeAlreadyUploader
119-
when (length existingVouchers >= 3) $
128+
when (length existingVouchers >= requiredCountOfVouches) $
120129
throwError AlreadySufficientlyVouched
121130
when (voucher `elem` map fst existingVouchers) $
122131
throwError YouAlreadyVouched
123132
pure $
124133
if length existingVouchers == requiredCountOfVouches - 1
125134
then AddVouchComplete
126-
else AddVouchIncomplete
135+
else
136+
let stillRequired = requiredCountOfVouches - length existingVouchers - 1
137+
in AddVouchIncomplete stillRequired
127138

128139
renderToLBS :: (UserId -> ServerPartE UserInfo) -> [(UserId, UTCTime)] -> ServerPartE TemplateAttr
129140
renderToLBS lookupUserInfo vouches = do
130-
rendered <- traverse renderVouchers vouches
141+
rendered <- traverse (renderVouchers lookupUserInfo) vouches
131142
pure $
132143
templateUnescaped "vouches" $
133144
if null rendered
134145
then LBS.pack "Nobody has vouched yet."
135146
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
147+
148+
renderVouchers :: (UserId -> ServerPartE UserInfo) -> (UserId, UTCTime) -> ServerPartE LBS.ByteString
149+
renderVouchers lookupUserInfo (uid, timestamp) = do
150+
info <- lookupUserInfo uid
151+
let UserName name = userName info
152+
-- We don't need to show millisecond precision
153+
-- So we truncate it off here
154+
truncated = truncate $ utctDayTime timestamp
155+
newUTCTime = timestamp {utctDayTime = secondsToDiffTime truncated}
156+
pure . toUTF8LBS . prettyHtmlFragment . li . stringToHtml $ name <> " vouched on " <> formatShow iso8601Format newUTCTime
146157

147158
initVouchFeature :: ServerEnv -> IO (UserFeature -> UploadFeature -> IO VouchFeature)
148159
initVouchFeature ServerEnv{serverStateDir, serverTemplatesDir, serverTemplatesMode} = do
@@ -170,7 +181,7 @@ initVouchFeature ServerEnv{serverStateDir, serverTemplatesDir, serverTemplatesMo
170181
vouchee <- lookupUserName =<< userNameInPath dpath
171182
vouchersForVoucher <- queryState vouchState $ GetVouchesFor voucher
172183
existingVouchers <- queryState vouchState $ GetVouchesFor vouchee
173-
case join $ judge ugroup now vouchee vouchersForVoucher existingVouchers voucher of
184+
case judgeVouch ugroup now vouchee vouchersForVoucher existingVouchers voucher of
174185
Left NotAnUploader ->
175186
errBadRequest "Not an uploader" [MText "You must be an uploader yourself to vouch for other users."]
176187
Left You'reTooNew ->
@@ -191,8 +202,7 @@ initVouchFeature ServerEnv{serverStateDir, serverTemplatesDir, serverTemplatesMo
191202
[ "msg" $= "Added vouch. User is now an uploader!"
192203
, param
193204
]
194-
AddVouchIncomplete -> do
195-
let stillRequired = requiredCountOfVouches - length existingVouchers - 1
205+
AddVouchIncomplete stillRequired ->
196206
pure . toResponse $ vouchTemplate
197207
[ "msg" $=
198208
"Added vouch. User still needs "

‎tests/VouchTest.hs‎

Lines changed: 96 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,96 @@
1+
module Main where
2+
3+
import Data.Time (UTCTime(UTCTime), fromGregorian)
4+
5+
import Distribution.Server.Features.Vouch (VouchError(..), VouchSuccess(..), judgeVouch)
6+
import Distribution.Server.Users.UserIdSet (fromList)
7+
import Distribution.Server.Users.Types (UserId(UserId))
8+
9+
import Test.Tasty (TestTree, defaultMain, testGroup)
10+
import Test.Tasty.HUnit (assertEqual, testCase)
11+
12+
allTests :: TestTree
13+
allTests = testGroup "VouchTest"
14+
[ testCase "happy path, vouch added, but more vouches needed" $ do
15+
let ref = Right (AddVouchIncomplete 1)
16+
voucher = UserId 1
17+
vouchee = UserId 2
18+
assertEqual "must match" ref $
19+
judgeVouch
20+
(fromList [voucher]) -- uploaders. Can't vouch if user is not a voucher
21+
(UTCTime (fromGregorian 2020 1 1) 0)
22+
vouchee
23+
[] -- vouchers for voucher. If this short enough, voucher is assumed to be old enough to vouch themselves.
24+
[] -- no existing vouchers
25+
voucher
26+
, testCase "happy path, vouch added, no more vouches needed" $ do
27+
let ref = Right AddVouchComplete
28+
voucher = UserId 1
29+
vouchee = UserId 2
30+
otherVoucherForVouchee = UserId 4
31+
assertEqual "must match" ref $
32+
judgeVouch
33+
(fromList [voucher])
34+
(UTCTime (fromGregorian 2020 1 1) 0)
35+
vouchee
36+
[]
37+
[(otherVoucherForVouchee, UTCTime (fromGregorian 2020 1 1) 0)]
38+
voucher
39+
, testCase "non-uploader tried to vouch" $ do
40+
let ref = Left NotAnUploader
41+
voucher = UserId 1
42+
vouchee = UserId 2
43+
assertEqual "must match" ref $
44+
judgeVouch
45+
(fromList []) -- empty. Should contain voucher for operation to proceed.
46+
(UTCTime (fromGregorian 2020 1 1) 0)
47+
vouchee
48+
[]
49+
[]
50+
voucher
51+
, testCase "voucher too new" $ do
52+
let ref = Left You'reTooNew
53+
voucher = UserId 1
54+
vouchee = UserId 2
55+
fstVoucherForVoucher = UserId 3
56+
sndVoucherForVoucher = UserId 4
57+
now = UTCTime (fromGregorian 2020 1 1) 0
58+
assertEqual "must match" ref $
59+
judgeVouch
60+
(fromList [voucher])
61+
now
62+
vouchee
63+
[ (fstVoucherForVoucher, now) -- These two timestamps are too new
64+
, (sndVoucherForVoucher, now)
65+
]
66+
[]
67+
voucher
68+
, testCase "vouchee already uploader" $ do
69+
let ref = Left VoucheeAlreadyUploader
70+
voucher = UserId 1
71+
vouchee = UserId 2
72+
now = UTCTime (fromGregorian 2020 1 1) 0
73+
assertEqual "must match" ref $
74+
judgeVouch
75+
(fromList [voucher, vouchee]) -- vouchee is here. So they're already an uploader.
76+
now
77+
vouchee
78+
[]
79+
[]
80+
voucher
81+
, testCase "already vouched" $ do
82+
let ref = Left YouAlreadyVouched
83+
voucher = UserId 1
84+
vouchee = UserId 2
85+
assertEqual "must match" ref $
86+
judgeVouch
87+
(fromList [voucher])
88+
(UTCTime (fromGregorian 2020 1 1) 0)
89+
vouchee
90+
[]
91+
[(voucher, UTCTime (fromGregorian 2020 1 1) 0)] -- voucher is here. So they already vouched
92+
voucher
93+
]
94+
95+
main :: IO ()
96+
main = defaultMain allTests

0 commit comments

Comments
 (0)