ID and SSH pub key can be set by the user

Foundation.hs

@@ -173,6 +173,8 @@ instance YesodAuth App where
                     , userPassword = Nothing
                     , userName = Nothing
                     , userIsAdmin = False
+                    , userLocalId = Nothing
+                    , userSshPubKey = Nothing
                     }
 
     -- You can add other plugins like BrowserID, email or OAuth here

Handler/YourAccount.hs

@@ -7,11 +7,13 @@ import Yesod.Form.Bootstrap3 (BootstrapFormLayout (..), renderBootstrap3,
 import Handler.Shared
 import Handler.Extract
 
+import Text.Regex.TDFA
+
 getYourAccountR :: Handler Html
 getYourAccountR = do
     userId <- requireAuthId
     user <- runDB $ get404 userId
-    (formWidget, formEnctype) <- generateFormPost (yourAccountForm $ userName user)
+    (formWidget, formEnctype) <- generateFormPost (yourAccountForm (userName user) (userLocalId user) (userSshPubKey user))
     let submission = Nothing :: Maybe (Import.FileInfo, Text)
         handlerName = "getYourAccountR" :: Text
     defaultLayout $ do
@@ -21,22 +23,67 @@ getYourAccountR = do
 
 postYourAccountR :: Handler Html
 postYourAccountR = do
-    ((result, formWidget), formEnctype) <- runFormPost (yourAccountForm Nothing)
+    ((result, formWidget), formEnctype) <- runFormPost (yourAccountForm Nothing Nothing Nothing)
     let handlerName = "postYourAccountR" :: Text
         accountData = case result of
             FormSuccess res -> Just res
             _ -> Nothing
-        Just (name, aboutMe) = accountData
+        Just (name, localId, sshPubKey) = accountData
     userId <- requireAuthId
-    runDB $ update userId [UserName =. name]
+    updateUserAccount userId name localId sshPubKey
     user <- runDB $ get404 userId
     defaultLayout $ do
         aDomId <- newIdent
         setTitle "Your account"
         $(widgetFile "your-account")
 
-
+yourAccountForm :: Maybe Text -> Maybe Text -> Maybe Text -> Form (Maybe Text, Maybe Text, Maybe Text)
-yourAccountForm :: Maybe Text -> Form (Maybe Text, Maybe Text)
+yourAccountForm maybeName maybeLocalId maybeSshPubKey = renderBootstrap3 BootstrapBasicForm $ (,,)
-yourAccountForm maybeName = renderBootstrap3 BootstrapBasicForm $ (,)
     <$> aopt textField (fieldSettingsLabel MsgAccountName) (Just maybeName)
-    <*> aopt textField (fieldSettingsLabel MsgAboutMe) Nothing
+    <*> aopt textField (fieldSettingsLabel MsgId) (Just maybeLocalId)
+    <*> aopt textField (fieldSettingsLabel MsgSshPubKey) (Just maybeSshPubKey)
+
+localIdRegexp = makeRegexOpts defaultCompOpt{newSyntax=True} defaultExecOpt ("\\`[a-z][-a-z0-9]{0,31}\\'" ::String)
+
+unwantedLocalIds :: [Text]
+unwantedLocalIds = ["git",
+                    "gitolite",
+                    "admin",
+                    "root",
+                    "filipg"]
+
+isLocalIdAcceptable :: Text -> Bool
+isLocalIdAcceptable localId =
+  match localIdRegexp (unpack localId) && not (localId `elem` unwantedLocalIds)
+
+updateUserAccount :: Key User -> Maybe Text -> Maybe Text -> Maybe Text -> Handler ()
+updateUserAccount userId name maybeLocalId maybeSshPubKey = do
+  updateJustName userId name
+  updateLocalIdAndPubKey userId maybeLocalId maybeSshPubKey
+
+updateLocalIdAndPubKey :: Key User -> Maybe Text -> Maybe Text -> Handler ()
+updateLocalIdAndPubKey userId (Just localId) maybeSshPubKey = do
+  if isLocalIdAcceptable localId
+    then
+     do
+      otherTheSame <- runDB $ selectFirst [UserLocalId ==. (Just localId), UserId !=. userId] []
+      case otherTheSame of
+        Just _ -> do
+          setMessage $ toHtml ("ID already used" :: Text)
+        Nothing -> do
+          user <- runDB $ get404 userId
+          case userLocalId user of
+             Just prevLocalId -> do
+               unless (prevLocalId == localId) $ setMessage $ toHtml ("only the administrator can change your ID" :: Text)
+             Nothing -> do
+               runDB $ update userId [UserLocalId =. (Just localId), UserSshPubKey =. maybeSshPubKey]
+    else
+      setMessage $ toHtml ("unexpected ID (use only lower-case letters, digits and hyphens, start with a letter)" :: Text)
+
+updateLocalIdAndPubKey _ Nothing (Just _) = do
+  setMessage $ toHtml ("SSH public key cannot be added without an ID" :: Text)
+
+updateLocalIdAndPubKey _ Nothing Nothing = return ()
+
+updateJustName :: Key User -> Maybe Text -> Handler ()
+updateJustName userId name = runDB $ update userId [UserName =. name]

config/models

@@ -4,6 +4,8 @@ User
     UniqueUser ident
     name Text Maybe
     isAdmin Bool default=True
+    localId Text Maybe
+    sshPubKey Text Maybe
     deriving Typeable
 Email
     email Text

gonito.cabal

@@ -112,6 +112,7 @@ library
                  , geval
                  , filepath
                  , yesod-table
+                 , regex-tdfa
 
 executable         gonito
     if flag(library-only)

messages/en.msg

@@ -16,3 +16,5 @@ SubmissionDescription: Submission description
 YourAccount: your account
 AboutMe: about me
 AccountName: name
+Id: ID
+SshPubKey: your SSH public key