haskell · gbaz · May 14, 2022 · Apr 2, 2022 · Apr 4, 2022 · Apr 30, 2022
diff --git a/datafiles/templates/UserDetails/user-details-form.html.st b/datafiles/templates/UserDetails/user-details-form.html.st
@@ -0,0 +1,34 @@
+<!DOCTYPE html>
+<html>
+<head>
+$hackageCssTheme()$
+<title>Set user details | Hackage</title>
+</head>
+
+<body>
+$hackagePageHeader()$
+
+<div id="content">
+<h2>Change full name or e-mail address</h2>
+
+$if(showConfirmationOfSave)$
+  <p class=box>
+  User details saved! The updated details are shown below.
+  </p>
+$endif$
+
+<p>
+  The email is used e.g. to contact you regarding the packages you maintain, or for account recovery.<br/>
+  Make sure you have access to the new e-mail address, because <strong>no confirmation mail is sent</strong> when this form is submitted.
+</p>
+
+<form action="/user/$username$/name-contact" method=POST enctype="multipart/form-data">
+  <input type="hidden" name="_method" value="PUT"/>
+  <input type="hidden" name="_return" value="/user/$username$/name-contact?showConfirmationOfSave=True"/>
+  <input type="hidden" name="_transform" value="form2json"/>
+  <label>New full name: <input name="name=%s" value="$name$" /></label><br />
+  <label>New e-mail address: <input type="email" name="contactEmailAddress=%s" value="$contactEmailAddress$" required="required" /></label><br />
+  <input type="submit" value="Save user details" />
+</form>
+</div>
+</body></html>
diff --git a/datafiles/templates/Users/manage.html.st b/datafiles/templates/Users/manage.html.st
@@ -12,6 +12,9 @@ $hackagePageHeader(deauthUser="1")$
 <h2>Manage user account $username$</h2>
 <p>This site collects operations you can do to manage your user account</p>
 
+<h3>Change full name or e-mail address</h3>
+<p>You can <a href="/user/$username$/name-contact">change your full name or e-mail address</a>.</p>
+
 <h3>Authentication Tokens</h3>
 <p>
   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.

diff --git a/hackage-server.cabal b/hackage-server.cabal
@@ -246,6 +246,7 @@ library lib-server
     Distribution.Server.Util.DocMeta
     Distribution.Server.Util.Parse
     Distribution.Server.Util.ServeTarball
+    Distribution.Server.Util.Validators
     -- [unused] Distribution.Server.Util.TarIndex
     Distribution.Server.Util.GZip
     Distribution.Server.Util.ContentType

diff --git a/src/Distribution/Server/Features.hs b/src/Distribution/Server/Features.hs
@@ -197,6 +197,7 @@ initHackageFeatures env@ServerEnv{serverVerbosity = verbosity} = do
     userDetailsFeature <- mkUserDetailsFeature
                             usersFeature
                             coreFeature
+                            uploadFeature
 
     userSignupFeature <- mkUserSignupFeature
                            usersFeature

diff --git a/src/Distribution/Server/Features/UserDetails.hs b/src/Distribution/Server/Features/UserDetails.hs
@@ -1,5 +1,5 @@
 {-# LANGUAGE DeriveDataTypeable, TypeFamilies, TemplateHaskell, RankNTypes,
-    NamedFieldPuns, RecordWildCards, RecursiveDo, BangPatterns #-}
+    NamedFieldPuns, RecordWildCards, RecursiveDo, BangPatterns, OverloadedStrings #-}
 module Distribution.Server.Features.UserDetails (
     initUserDetailsFeature,
     UserDetailsFeature(..),
@@ -11,11 +11,14 @@ module Distribution.Server.Features.UserDetails (
 import Distribution.Server.Framework
 import Distribution.Server.Framework.BackupDump
 import Distribution.Server.Framework.BackupRestore
+import Distribution.Server.Framework.Templating
 
 import Distribution.Server.Features.Users
+import Distribution.Server.Features.Upload
 import Distribution.Server.Features.Core
 
 import Distribution.Server.Users.Types
+import Distribution.Server.Util.Validators (guardValidLookingEmail, guardValidLookingName)
 
 import Data.SafeCopy (base, deriveSafeCopy)
 
@@ -250,23 +253,31 @@ userDetailsToCSV backuptype (UserDetailsTable tbl)
 initUserDetailsFeature :: ServerEnv
                        -> IO (UserFeature
                            -> CoreFeature
+                           -> UploadFeature
                            -> IO UserDetailsFeature)
-initUserDetailsFeature ServerEnv{serverStateDir} = do
+initUserDetailsFeature ServerEnv{serverStateDir, serverTemplatesDir, serverTemplatesMode} = do
     -- Canonical state
     usersDetailsState <- userDetailsStateComponent serverStateDir
 
     --TODO: link up to user feature to delete
 
-    return $ \users core -> do
-      let feature = userDetailsFeature usersDetailsState users core
+    templates <-
+      loadTemplates serverTemplatesMode
+      [serverTemplatesDir, serverTemplatesDir </> "UserDetails"]
+      [ "user-details-form.html" ]
+
+    return $ \users core upload -> do
+      let feature = userDetailsFeature templates usersDetailsState users core upload
       return feature
 
 
-userDetailsFeature :: StateComponent AcidState UserDetailsTable
+userDetailsFeature :: Templates
+                   -> StateComponent AcidState UserDetailsTable
                    -> UserFeature
                    -> CoreFeature
+                   -> UploadFeature
                    -> UserDetailsFeature
-userDetailsFeature userDetailsState UserFeature{..} CoreFeature{..}
+userDetailsFeature templates userDetailsState UserFeature{..} CoreFeature{..} UploadFeature{uploadersGroup}
   = UserDetailsFeature {..}
 
   where
@@ -286,7 +297,9 @@ userDetailsFeature userDetailsState UserFeature{..} CoreFeature{..}
                          , (PUT,    "set the name and contact details of a user account")
                          , (DELETE, "delete the name and contact details of a user account")
                          ]
-      , resourceGet    = [ ("json", handlerGetUserNameContact) ]
+      , resourceGet    = [ ("json", handlerGetUserNameContact)
+                         , ("html", handlerGetUserNameContactHtml)
+                         ]
       , resourcePut    = [ ("json", handlerPutUserNameContact) ]
       , resourceDelete = [ ("",     handlerDeleteUserNameContact) ]
       }
@@ -314,6 +327,30 @@ userDetailsFeature userDetailsState UserFeature{..} CoreFeature{..}
 
     -- Request handlers
     --
+    handlerGetUserNameContactHtml :: DynamicPath -> ServerPartE Response
+    handlerGetUserNameContactHtml dpath = do
+      (uid, uinfo) <- lookupUserNameFull =<< userNameInPath dpath
+      template <- getTemplate templates "user-details-form.html"
+      udetails <- queryUserDetails uid
+      showConfirmationOfSave <- not . null <$> queryString (lookBSs "showConfirmationOfSave")
+      let
+        emailTxt = maybe "" accountContactEmail udetails
+        nameTxt  = maybe "" accountName         udetails
+      cacheControl
+        [Private]
+        (etagFromHash
+          ( emailTxt
+          , nameTxt
+          , showConfirmationOfSave
+          )
+        )
+      ok . toResponse $
+        template
+          [ "username" $= display (userName uinfo)
+          , "contactEmailAddress" $= emailTxt
+          , "name" $= nameTxt
+          , "showConfirmationOfSave" $= showConfirmationOfSave
+          ]
 
     handlerGetUserNameContact :: DynamicPath -> ServerPartE Response
     handlerGetUserNameContact dpath = do
@@ -333,7 +370,10 @@ userDetailsFeature userDetailsState UserFeature{..} CoreFeature{..}
     handlerPutUserNameContact dpath = do
         uid <- lookupUserName =<< userNameInPath dpath
         guardAuthorised_ [IsUserId uid, InGroup adminGroup]
+        void $ guardAuthorisedWhenInAnyGroup [uploadersGroup, adminGroup]
         NameAndContact name email <- expectAesonContent
+        guardValidLookingName name
+        guardValidLookingEmail email
         updateState userDetailsState (SetUserNameContact uid name email)
         noContent $ toResponse ()
 

diff --git a/src/Distribution/Server/Features/UserSignup.hs b/src/Distribution/Server/Features/UserSignup.hs
@@ -21,14 +21,14 @@ import Distribution.Server.Features.UserDetails
 import Distribution.Server.Users.Group
 import Distribution.Server.Users.Types
 import Distribution.Server.Util.Nonce
+import Distribution.Server.Util.Validators
 import qualified Distribution.Server.Users.Users as Users
 
 import Data.Map (Map)
 import qualified Data.Map as Map
 import Data.Text (Text)
 import qualified Data.Text as T
 import qualified Data.ByteString.Char8 as BS -- Only used for ASCII data
-import Data.Char (isSpace, isPrint)
 
 import Data.Typeable (Typeable)
 import Control.Monad.Reader (ask)
@@ -475,32 +475,6 @@ userSignupFeature ServerEnv{serverBaseURI, serverCron}
 
           return (username, realname, useremail)
 
-        guardValidLookingName str = either errBadUserName return $ do
-          guard (T.length str <= 70) ?! "Sorry, we didn't expect names to be longer than 70 characters."
-          guard (T.all isPrint str)  ?! "Unexpected character in name, please use only printable Unicode characters."
-
-        guardValidLookingUserName str = either errBadRealName return $ do
-          guard (T.length str <= 50)    ?! "Sorry, we didn't expect login names to be longer than 50 characters."
-          guard (T.all isValidUserNameChar str) ?! "Sorry, login names have to be ASCII characters only or _, no spaces or other symbols."
-
-        guardValidLookingEmail str = either errBadEmail return $ do
-          guard (T.length str <= 100)     ?! "Sorry, we didn't expect email addresses to be longer than 100 characters."
-          guard (T.all isPrint str)       ?! "Unexpected character in email address, please use only printable Unicode characters."
-          guard hasAtSomewhere            ?! "Oops, that doesn't look like an email address."
-          guard (T.all (not.isSpace) str) ?! "Oops, no spaces in email addresses please."
-          guard (T.all (not.isAngle) str) ?! "Please use just the email address, not \"name\" <[email protected]> style."
-          where
-            isAngle c = c == '<' || c == '>'
-            hasAtSomewhere =
-              let (before, after) = T.span (/= '@') str
-               in T.length before >= 1
-               && T.length after  >  1
-
-        errBadUserName err = errBadRequest "Problem with login name" [MText err]
-        errBadRealName err = errBadRequest "Problem with name"[MText err]
-        errBadEmail    err = errBadRequest "Problem with email address" [MText err]
-
-
     handlerGetSignupRequestOutstanding :: DynamicPath -> ServerPartE Response
     handlerGetSignupRequestOutstanding dpath = do
         nonce <- nonceInPath dpath

diff --git a/src/Distribution/Server/Util/Validators.hs b/src/Distribution/Server/Util/Validators.hs
@@ -0,0 +1,42 @@
+module Distribution.Server.Util.Validators
+  ( guardValidLookingName
+  , guardValidLookingUserName
+  , guardValidLookingEmail
+  ) where
+
+import           Data.Char (isSpace, isPrint)
+import qualified Data.Text as T
+
+import           Distribution.Server.Framework
+import           Distribution.Server.Users.Types (isValidUserNameChar)
+
+guardValidLookingName :: T.Text -> ServerPartE ()
+guardValidLookingName str = either errBadUserName return $ do
+  guard (T.length str <= 70) ?! "Sorry, we didn't expect names to be longer than 70 characters."
+  guard (T.all isPrint str)  ?! "Unexpected character in name, please use only printable Unicode characters."
+
+guardValidLookingUserName :: T.Text -> ServerPartE ()
+guardValidLookingUserName str = either errBadRealName return $ do
+  guard (T.length str <= 50)    ?! "Sorry, we didn't expect login names to be longer than 50 characters."
+  guard (T.all isValidUserNameChar str) ?! "Sorry, login names have to be ASCII characters only or _, no spaces or other symbols."
+
+-- Make sure this roughly corresponds to the frontend validation in user-details-form.html.st
+guardValidLookingEmail :: T.Text -> ServerPartE ()
+guardValidLookingEmail str = either errBadEmail return $ do
+  guard (T.length str <= 100)     ?! "Sorry, we didn't expect email addresses to be longer than 100 characters."
+  guard (T.all isPrint str)       ?! "Unexpected character in email address, please use only printable Unicode characters."
+  guard hasAtSomewhere            ?! "Oops, that doesn't look like an email address."
+  guard (T.all (not.isSpace) str) ?! "Oops, no spaces in email addresses please."
+  guard (T.all (not.isAngle) str) ?! "Please use just the email address, not \"name\" <[email protected]> style."
+  where
+    isAngle c = c == '<' || c == '>'
+    hasAtSomewhere =
+      let (before, after) = T.span (/= '@') str
+       in T.length before >= 1
+       && T.length after  >  1
+       && not ('@' `T.elem` after)
+
+errBadUserName, errBadRealName, errBadEmail :: String -> ServerPartE a
+errBadUserName err = errBadRequest "Problem with login name" [MText err]
+errBadRealName err = errBadRequest "Problem with name" [MText err]
+errBadEmail    err = errBadRequest "Problem with email address" [MText err]