Skip to content

Commit cf4ed45

Browse files
ysangkokysangkok
authored
Add form to update full name and email of user (#1047)
* Add form to update full name and email of user * Add cache-control for user details form * Only allow uploaders to change name/email * Validate new name/email in UserDetails * Simpler count of at-signs
1 parent adc0344 commit cf4ed45

File tree

7 files changed

+129
-34
lines changed

7 files changed

+129
-34
lines changed

‎datafiles/templates/UserDetails/user-details-form.html.st

Lines changed: 34 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,34 @@
1+
<!DOCTYPE html>
2+
<html>
3+
<head>
4+
$hackageCssTheme()$
5+
<title>Set user details | Hackage</title>
6+
</head>
7+
8+
<body>
9+
$hackagePageHeader()$
10+
11+
<div id="content">
12+
<h2>Change full name or e-mail address</h2>
13+
14+
$if(showConfirmationOfSave)$
15+
<p class=box>
16+
User details saved! The updated details are shown below.
17+
</p>
18+
$endif$
19+
20+
<p>
21+
The email is used e.g. to contact you regarding the packages you maintain, or for account recovery.<br/>
22+
Make sure you have access to the new e-mail address, because <strong>no confirmation mail is sent</strong> when this form is submitted.
23+
</p>
24+
25+
<form action="/user/$username$/name-contact" method=POST enctype="multipart/form-data">
26+
<input type="hidden" name="_method" value="PUT"/>
27+
<input type="hidden" name="_return" value="/user/$username$/name-contact?showConfirmationOfSave=True"/>
28+
<input type="hidden" name="_transform" value="form2json"/>
29+
<label>New full name: <input name="name=%s" value="$name$" /></label><br />
30+
<label>New e-mail address: <input type="email" name="contactEmailAddress=%s" value="$contactEmailAddress$" required="required" /></label><br />
31+
<input type="submit" value="Save user details" />
32+
</form>
33+
</div>
34+
</body></html>

‎datafiles/templates/Users/manage.html.st

Lines changed: 3 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -12,6 +12,9 @@ $hackagePageHeader(deauthUser="1")$
1212
<h2>Manage user account $username$</h2>
1313
<p>This site collects operations you can do to manage your user account</p>
1414

15+
<h3>Change full name or e-mail address</h3>
16+
<p>You can <a href="/user/$username$/name-contact">change your full name or e-mail address</a>.</p>
17+
1518
<h3>Authentication Tokens</h3>
1619
<p>
1720
You can register API authentication token to use them to for example have services like continuous integration upload packages on your behalf without providing them your username and/or password.

‎hackage-server.cabal

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -246,6 +246,7 @@ library lib-server
246246
Distribution.Server.Util.DocMeta
247247
Distribution.Server.Util.Parse
248248
Distribution.Server.Util.ServeTarball
249+
Distribution.Server.Util.Validators
249250
-- [unused] Distribution.Server.Util.TarIndex
250251
Distribution.Server.Util.GZip
251252
Distribution.Server.Util.ContentType

‎src/Distribution/Server/Features.hs

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -197,6 +197,7 @@ initHackageFeatures env@ServerEnv{serverVerbosity = verbosity} = do
197197
userDetailsFeature <- mkUserDetailsFeature
198198
usersFeature
199199
coreFeature
200+
uploadFeature
200201

201202
userSignupFeature <- mkUserSignupFeature
202203
usersFeature

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

Lines changed: 47 additions & 7 deletions
Original file line numberDiff line numberDiff line change
@@ -1,5 +1,5 @@
11
{-# LANGUAGE DeriveDataTypeable, TypeFamilies, TemplateHaskell, RankNTypes,
2-
NamedFieldPuns, RecordWildCards, RecursiveDo, BangPatterns #-}
2+
NamedFieldPuns, RecordWildCards, RecursiveDo, BangPatterns, OverloadedStrings #-}
33
module Distribution.Server.Features.UserDetails (
44
initUserDetailsFeature,
55
UserDetailsFeature(..),
@@ -11,11 +11,14 @@ module Distribution.Server.Features.UserDetails (
1111
import Distribution.Server.Framework
1212
import Distribution.Server.Framework.BackupDump
1313
import Distribution.Server.Framework.BackupRestore
14+
import Distribution.Server.Framework.Templating
1415

1516
import Distribution.Server.Features.Users
17+
import Distribution.Server.Features.Upload
1618
import Distribution.Server.Features.Core
1719

1820
import Distribution.Server.Users.Types
21+
import Distribution.Server.Util.Validators (guardValidLookingEmail, guardValidLookingName)
1922

2023
import Data.SafeCopy (base, deriveSafeCopy)
2124

@@ -250,23 +253,31 @@ userDetailsToCSV backuptype (UserDetailsTable tbl)
250253
initUserDetailsFeature :: ServerEnv
251254
-> IO (UserFeature
252255
-> CoreFeature
256+
-> UploadFeature
253257
-> IO UserDetailsFeature)
254-
initUserDetailsFeature ServerEnv{serverStateDir} = do
258+
initUserDetailsFeature ServerEnv{serverStateDir, serverTemplatesDir, serverTemplatesMode} = do
255259
-- Canonical state
256260
usersDetailsState <- userDetailsStateComponent serverStateDir
257261

258262
--TODO: link up to user feature to delete
259263

260-
return $ \users core -> do
261-
let feature = userDetailsFeature usersDetailsState users core
264+
templates <-
265+
loadTemplates serverTemplatesMode
266+
[serverTemplatesDir, serverTemplatesDir </> "UserDetails"]
267+
[ "user-details-form.html" ]
268+
269+
return $ \users core upload -> do
270+
let feature = userDetailsFeature templates usersDetailsState users core upload
262271
return feature
263272

264273

265-
userDetailsFeature :: StateComponent AcidState UserDetailsTable
274+
userDetailsFeature :: Templates
275+
-> StateComponent AcidState UserDetailsTable
266276
-> UserFeature
267277
-> CoreFeature
278+
-> UploadFeature
268279
-> UserDetailsFeature
269-
userDetailsFeature userDetailsState UserFeature{..} CoreFeature{..}
280+
userDetailsFeature templates userDetailsState UserFeature{..} CoreFeature{..} UploadFeature{uploadersGroup}
270281
= UserDetailsFeature {..}
271282

272283
where
@@ -286,7 +297,9 @@ userDetailsFeature userDetailsState UserFeature{..} CoreFeature{..}
286297
, (PUT, "set the name and contact details of a user account")
287298
, (DELETE, "delete the name and contact details of a user account")
288299
]
289-
, resourceGet = [ ("json", handlerGetUserNameContact) ]
300+
, resourceGet = [ ("json", handlerGetUserNameContact)
301+
, ("html", handlerGetUserNameContactHtml)
302+
]
290303
, resourcePut = [ ("json", handlerPutUserNameContact) ]
291304
, resourceDelete = [ ("", handlerDeleteUserNameContact) ]
292305
}
@@ -314,6 +327,30 @@ userDetailsFeature userDetailsState UserFeature{..} CoreFeature{..}
314327

315328
-- Request handlers
316329
--
330+
handlerGetUserNameContactHtml :: DynamicPath -> ServerPartE Response
331+
handlerGetUserNameContactHtml dpath = do
332+
(uid, uinfo) <- lookupUserNameFull =<< userNameInPath dpath
333+
template <- getTemplate templates "user-details-form.html"
334+
udetails <- queryUserDetails uid
335+
showConfirmationOfSave <- not . null <$> queryString (lookBSs "showConfirmationOfSave")
336+
let
337+
emailTxt = maybe "" accountContactEmail udetails
338+
nameTxt = maybe "" accountName udetails
339+
cacheControl
340+
[Private]
341+
(etagFromHash
342+
( emailTxt
343+
, nameTxt
344+
, showConfirmationOfSave
345+
)
346+
)
347+
ok . toResponse $
348+
template
349+
[ "username" $= display (userName uinfo)
350+
, "contactEmailAddress" $= emailTxt
351+
, "name" $= nameTxt
352+
, "showConfirmationOfSave" $= showConfirmationOfSave
353+
]
317354

318355
handlerGetUserNameContact :: DynamicPath -> ServerPartE Response
319356
handlerGetUserNameContact dpath = do
@@ -333,7 +370,10 @@ userDetailsFeature userDetailsState UserFeature{..} CoreFeature{..}
333370
handlerPutUserNameContact dpath = do
334371
uid <- lookupUserName =<< userNameInPath dpath
335372
guardAuthorised_ [IsUserId uid, InGroup adminGroup]
373+
void $ guardAuthorisedWhenInAnyGroup [uploadersGroup, adminGroup]
336374
NameAndContact name email <- expectAesonContent
375+
guardValidLookingName name
376+
guardValidLookingEmail email
337377
updateState userDetailsState (SetUserNameContact uid name email)
338378
noContent $ toResponse ()
339379

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

Lines changed: 1 addition & 27 deletions
Original file line numberDiff line numberDiff line change
@@ -21,14 +21,14 @@ import Distribution.Server.Features.UserDetails
2121
import Distribution.Server.Users.Group
2222
import Distribution.Server.Users.Types
2323
import Distribution.Server.Util.Nonce
24+
import Distribution.Server.Util.Validators
2425
import qualified Distribution.Server.Users.Users as Users
2526

2627
import Data.Map (Map)
2728
import qualified Data.Map as Map
2829
import Data.Text (Text)
2930
import qualified Data.Text as T
3031
import qualified Data.ByteString.Char8 as BS -- Only used for ASCII data
31-
import Data.Char (isSpace, isPrint)
3232

3333
import Data.Typeable (Typeable)
3434
import Control.Monad.Reader (ask)
@@ -475,32 +475,6 @@ userSignupFeature ServerEnv{serverBaseURI, serverCron}
475475

476476
return (username, realname, useremail)
477477

478-
guardValidLookingName str = either errBadUserName return $ do
479-
guard (T.length str <= 70) ?! "Sorry, we didn't expect names to be longer than 70 characters."
480-
guard (T.all isPrint str) ?! "Unexpected character in name, please use only printable Unicode characters."
481-
482-
guardValidLookingUserName str = either errBadRealName return $ do
483-
guard (T.length str <= 50) ?! "Sorry, we didn't expect login names to be longer than 50 characters."
484-
guard (T.all isValidUserNameChar str) ?! "Sorry, login names have to be ASCII characters only or _, no spaces or other symbols."
485-
486-
guardValidLookingEmail str = either errBadEmail return $ do
487-
guard (T.length str <= 100) ?! "Sorry, we didn't expect email addresses to be longer than 100 characters."
488-
guard (T.all isPrint str) ?! "Unexpected character in email address, please use only printable Unicode characters."
489-
guard hasAtSomewhere ?! "Oops, that doesn't look like an email address."
490-
guard (T.all (not.isSpace) str) ?! "Oops, no spaces in email addresses please."
491-
guard (T.all (not.isAngle) str) ?! "Please use just the email address, not \"name\" <[email protected]> style."
492-
where
493-
isAngle c = c == '<' || c == '>'
494-
hasAtSomewhere =
495-
let (before, after) = T.span (/= '@') str
496-
in T.length before >= 1
497-
&& T.length after > 1
498-
499-
errBadUserName err = errBadRequest "Problem with login name" [MText err]
500-
errBadRealName err = errBadRequest "Problem with name"[MText err]
501-
errBadEmail err = errBadRequest "Problem with email address" [MText err]
502-
503-
504478
handlerGetSignupRequestOutstanding :: DynamicPath -> ServerPartE Response
505479
handlerGetSignupRequestOutstanding dpath = do
506480
nonce <- nonceInPath dpath

‎src/Distribution/Server/Util/Validators.hs

Lines changed: 42 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,42 @@
1+
module Distribution.Server.Util.Validators
2+
( guardValidLookingName
3+
, guardValidLookingUserName
4+
, guardValidLookingEmail
5+
) where
6+
7+
import Data.Char (isSpace, isPrint)
8+
import qualified Data.Text as T
9+
10+
import Distribution.Server.Framework
11+
import Distribution.Server.Users.Types (isValidUserNameChar)
12+
13+
guardValidLookingName :: T.Text -> ServerPartE ()
14+
guardValidLookingName str = either errBadUserName return $ do
15+
guard (T.length str <= 70) ?! "Sorry, we didn't expect names to be longer than 70 characters."
16+
guard (T.all isPrint str) ?! "Unexpected character in name, please use only printable Unicode characters."
17+
18+
guardValidLookingUserName :: T.Text -> ServerPartE ()
19+
guardValidLookingUserName str = either errBadRealName return $ do
20+
guard (T.length str <= 50) ?! "Sorry, we didn't expect login names to be longer than 50 characters."
21+
guard (T.all isValidUserNameChar str) ?! "Sorry, login names have to be ASCII characters only or _, no spaces or other symbols."
22+
23+
-- Make sure this roughly corresponds to the frontend validation in user-details-form.html.st
24+
guardValidLookingEmail :: T.Text -> ServerPartE ()
25+
guardValidLookingEmail str = either errBadEmail return $ do
26+
guard (T.length str <= 100) ?! "Sorry, we didn't expect email addresses to be longer than 100 characters."
27+
guard (T.all isPrint str) ?! "Unexpected character in email address, please use only printable Unicode characters."
28+
guard hasAtSomewhere ?! "Oops, that doesn't look like an email address."
29+
guard (T.all (not.isSpace) str) ?! "Oops, no spaces in email addresses please."
30+
guard (T.all (not.isAngle) str) ?! "Please use just the email address, not \"name\" <[email protected]> style."
31+
where
32+
isAngle c = c == '<' || c == '>'
33+
hasAtSomewhere =
34+
let (before, after) = T.span (/= '@') str
35+
in T.length before >= 1
36+
&& T.length after > 1
37+
&& not ('@' `T.elem` after)
38+
39+
errBadUserName, errBadRealName, errBadEmail :: String -> ServerPartE a
40+
errBadUserName err = errBadRequest "Problem with login name" [MText err]
41+
errBadRealName err = errBadRequest "Problem with name" [MText err]
42+
errBadEmail err = errBadRequest "Problem with email address" [MText err]

0 commit comments

Comments
 (0)