From 67f120120f616377c8b5ab34b63941475195fcac Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Thu, 12 Sep 2019 10:36:39 +0200 Subject: [PATCH] feat(admin-users): allow adding users --- messages/uniworx/de.msg | 22 +++- routes | 1 + src/Foundation.hs | 9 ++ src/Handler/Users.hs | 6 +- src/Handler/Users/Add.hs | 108 ++++++++++++++++++ .../SendNotification/UserAuthModeUpdate.hs | 6 +- templates/mail/userAuthModeUpdate.hamlet | 17 ++- 7 files changed, 156 insertions(+), 13 deletions(-) create mode 100644 src/Handler/Users/Add.hs diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 350bc2047..add0b278e 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -781,9 +781,9 @@ MailUserRightsIntro name@Text email@UserEmail: #{name} <#{email}> hat folgende U MailNoLecturerRights: Sie haben derzeit keine Dozenten-Rechte. MailLecturerRights n@Int: Als Dozent dürfen Sie Veranstaltungen innerhalb #{pluralDE n "Ihres Instituts" "Ihrer Institute"} anlegen. -MailSubjectUserAuthModeUpdate: Änderung Ihres Uni2work-Anmeldemodus -UserAuthModePWHashChangedToLDAP: Sie melden sich nun mit Ihrer Campus-Kennung an -UserAuthModeLDAPChangedToPWHash: Sie melden sich nun mit einer Uni2work-internen Kennung an +MailSubjectUserAuthModeUpdate: Ihr Uni2work-Login +UserAuthModePWHashChangedToLDAP: Sie können sich nun mit Ihrer Campus-Kennung in Uni2work einloggen +UserAuthModeLDAPChangedToPWHash: Sie können sich nun mit einer Uni2work-internen Kennung in Uni2work einloggen NewPasswordLinkTip: Das Passwort Ihrer Uni2work-internen Kennung können Sie auf der folgenden Seite setzen: NewPasswordLink: Neues Passwort setzen AuthPWHashTip: Sie müssen nun das mit "Uni2work-Login" beschriftete Login-Formular verwenden. Stellen Sie bitte sicher, dass Sie ein Passwort gesetzt haben, bevor Sie versuchen sich anzumelden. @@ -1000,6 +1000,7 @@ MenuCourseApplications: Bewerbungen MenuTermShow: Semester MenuSubmissionDelete: Abgabe löschen MenuUsers: Benutzer +MenuUserAdd: Benutzer anlegen MenuUserNotifications: Benachrichtigungs-Einstellungen MenuUserPassword: Passwort MenuAdminTest: Admin-Demo @@ -1631,4 +1632,17 @@ MailAllocationUnratedApplications: Für die unten aufgeführten Kurse liegen Bew MailSubjectAllocationOutdatedRatings allocation@AllocationName: Bereits bewertete Bewerbungen für ihre Kurse in der Zentralanmeldung „#{allocation}“ haben sich geändert MailAllocationOutdatedRatings: Für die unten aufgeführten Kurse liegen Bewerbungen vor, die im Rahmen der Zentralanmeldung an den jeweiligen Kurs gestellt wurden, die sich verändert haben, seit sie zuletzt bewertet wurden. -MailAllocationOutdatedRatingsWarning: Bewerbungen deren Bewertung veraltet ist (d.h. die Bewerbung wurde nach der Bewertung verändert) zählen als nicht bewertet. \ No newline at end of file +MailAllocationOutdatedRatingsWarning: Bewerbungen deren Bewertung veraltet ist (d.h. die Bewerbung wurde nach der Bewertung verändert) zählen als nicht bewertet. + +AdminUserTitle: Titel +AdminUserFirstName: Vorname +AdminUserSurname: Nachname +AdminUserDisplayName: Anzeige-Name +AdminUserEmail: E-Mail Addresse +AdminUserIdent: Identifikation +AdminUserAuth: Authentifizierung +AdminUserMatriculation: Matrikelnummer +AuthKindLDAP: Campus-Kennung +AuthKindPWHash: Uni2work-Kennung +UserAdded: Benutzer erfolgreich angelegt +UserCollision: Benutzer konnte wegen Eindeutigkeit nicht angelegt werden \ No newline at end of file diff --git a/routes b/routes index 293577bf9..9ff5066c9 100644 --- a/routes +++ b/routes @@ -51,6 +51,7 @@ /users/#CryptoUUIDUser/password UserPasswordR GET POST !selfANDis-pw-hash !/users/functionary-invite/new AdminNewFunctionaryInviteR GET POST !/users/functionary-invite AdminFunctionaryInviteR GET POST +!/users/add AdminUserAddR GET POST /admin AdminR GET /admin/features AdminFeaturesR GET POST /admin/test AdminTestR GET POST diff --git a/src/Foundation.hs b/src/Foundation.hs index 740fc2f45..72eb97237 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -1752,6 +1752,7 @@ instance YesodBreadcrumbs UniWorX where breadcrumb (AuthR _) = return ("Login" , Just HomeR) breadcrumb HomeR = return ("Uni2work" , Nothing) breadcrumb UsersR = return ("Benutzer" , Just AdminR) + breadcrumb AdminUserAddR = return ("Benutzer anlegen", Just UsersR) breadcrumb (AdminUserR _) = return ("Users" , Just UsersR) breadcrumb AdminR = return ("Administration", Nothing) breadcrumb AdminFeaturesR = return ("Test" , Just AdminR) @@ -2096,6 +2097,14 @@ pageActions (UsersR) = , menuItemModal = True , menuItemAccessCallback' = return True } + , MenuItem + { menuItemType = PageActionPrime + , menuItemLabel = MsgMenuUserAdd + , menuItemIcon = Nothing + , menuItemRoute = SomeRoute AdminUserAddR + , menuItemModal = True + , menuItemAccessCallback' = return True + } ] pageActions (AdminUserR cID) = [ MenuItem diff --git a/src/Handler/Users.hs b/src/Handler/Users.hs index a9d46dfae..be223fa7c 100644 --- a/src/Handler/Users.hs +++ b/src/Handler/Users.hs @@ -1,6 +1,8 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} -module Handler.Users where +module Handler.Users + ( module Handler.Users + ) where import Import @@ -31,6 +33,8 @@ import qualified Data.ByteString.Base64 as Base64 import Text.Hamlet (ihamlet) import Data.Aeson hiding (Result(..)) +import Handler.Users.Add as Handler.Users + hijackUserForm :: Form () hijackUserForm csrf = do diff --git a/src/Handler/Users/Add.hs b/src/Handler/Users/Add.hs new file mode 100644 index 000000000..42834eb2e --- /dev/null +++ b/src/Handler/Users/Add.hs @@ -0,0 +1,108 @@ +module Handler.Users.Add + ( AuthenticationKind(..) + , classifyAuth, mkAuthMode + , AdminUserForm(..), adminUserForm + , getAdminUserAddR, postAdminUserAddR + ) where + + +import Import +import Handler.Utils +import Jobs + + +data AdminUserForm = AdminUserForm + { aufTitle :: Maybe Text + , aufFirstName :: Text + , aufSurname :: UserSurname + , aufDisplayName :: UserDisplayName + , aufMatriculation :: Maybe UserMatriculation + , aufEmail :: UserEmail + , aufIdent :: UserIdent + , aufAuth :: AuthenticationKind + } + +data AuthenticationKind = AuthKindLDAP | AuthKindPWHash + deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) +instance Universe AuthenticationKind +instance Finite AuthenticationKind +embedRenderMessage ''UniWorX ''AuthenticationKind id +nullaryPathPiece ''AuthenticationKind $ camelToPathPiece' 2 + +classifyAuth :: AuthenticationMode -> AuthenticationKind +classifyAuth AuthLDAP = AuthKindLDAP +classifyAuth AuthPWHash{} = AuthKindPWHash + +mkAuthMode :: AuthenticationKind -> AuthenticationMode +mkAuthMode AuthKindLDAP = AuthLDAP +mkAuthMode AuthKindPWHash = AuthPWHash "" + +adminUserForm :: Maybe AdminUserForm -> Form AdminUserForm +adminUserForm template = renderAForm FormStandard + $ AdminUserForm + <$> aopt (textField & cfStrip) (fslI MsgAdminUserTitle) (aufTitle <$> template) + <*> areq (textField & cfStrip) (fslI MsgAdminUserFirstName) (aufFirstName <$> template) + <*> areq (textField & cfStrip) (fslI MsgAdminUserSurname) (aufSurname <$> template) + <*> areq (textField & cfStrip) (fslI MsgAdminUserDisplayName) (aufDisplayName <$> template) + <*> aopt (textField & cfStrip) (fslI MsgAdminUserMatriculation) (aufMatriculation <$> template) + <*> areq (emailField & cfCI) (fslI MsgAdminUserEmail) (aufEmail <$> template) + <*> areq (textField & cfStrip & cfCI) (fslI MsgAdminUserIdent) (aufIdent <$> template) + <*> areq (selectField optionsFinite) (fslI MsgAdminUserAuth) (aufAuth <$> template <|> Just AuthKindLDAP) + + +getAdminUserAddR, postAdminUserAddR :: Handler Html +getAdminUserAddR = postAdminUserAddR +postAdminUserAddR = do + ((userRes, userView), userEnctype) <- runFormPost $ adminUserForm Nothing + + formResult userRes $ \AdminUserForm{..} -> do + now <- liftIO getCurrentTime + UserDefaultConf{..} <- getsYesod $ view _appUserDefaults + + let + newUser@User{..} = User + { userIdent = aufIdent + , userMaxFavourites = userDefaultMaxFavourites + , userTheme = userDefaultTheme + , userDateTimeFormat = userDefaultDateTimeFormat + , userDateFormat = userDefaultDateFormat + , userTimeFormat = userDefaultTimeFormat + , userDownloadFiles = userDefaultDownloadFiles + , userWarningDays = userDefaultWarningDays + , userNotificationSettings = def + , userMailLanguages = def + , userTokensIssuedAfter = Nothing + , userCreated = now + , userLastLdapSynchronisation = Nothing + , userLastAuthentication = Nothing + , userEmail = aufEmail + , userDisplayName = aufDisplayName + , userFirstName = aufFirstName + , userSurname = aufSurname + , userTitle = aufTitle + , userMatrikelnummer = aufMatriculation + , userAuthentication = mkAuthMode aufAuth + } + + didInsert <- runDBJobs . runMaybeT $ do + uid <- MaybeT $ insertUnique newUser + lift . queueDBJob $ JobSynchroniseLdapUser uid + lift . queueDBJob . JobQueueNotification $ NotificationUserAuthModeUpdate uid userAuthentication + when (aufAuth == AuthKindPWHash) $ + lift . queueDBJob $ JobSendPasswordReset uid + return uid + + case didInsert of + Just uid -> do + addMessageI Success MsgUserAdded + cID <- encrypt uid + redirect $ AdminUserR cID + Nothing -> + addMessageI Error MsgUserCollision + + siteLayoutMsg MsgMenuUserAdd $ do + setTitleI MsgMenuUserAdd + wrapForm userView def + { formAction = Just $ SomeRoute AdminUserAddR + , formEncoding = userEnctype + } diff --git a/src/Jobs/Handler/SendNotification/UserAuthModeUpdate.hs b/src/Jobs/Handler/SendNotification/UserAuthModeUpdate.hs index a2f7cb5b5..73629874d 100644 --- a/src/Jobs/Handler/SendNotification/UserAuthModeUpdate.hs +++ b/src/Jobs/Handler/SendNotification/UserAuthModeUpdate.hs @@ -6,6 +6,8 @@ module Jobs.Handler.SendNotification.UserAuthModeUpdate import Import +import Auth.PWHash (PWHashMessage(..)) + import Handler.Utils.Mail import Jobs.Handler.SendNotification.Utils @@ -18,8 +20,8 @@ dispatchNotificationUserAuthModeUpdate nUser _nOriginalAuthMode jRecipient = us replaceMailHeader "Auto-Submitted" $ Just "auto-generated" setSubjectI MsgMailSubjectUserAuthModeUpdate - editNotifications <- mkEditNotifications jRecipient + editNotifications <- ihamletSomeMessage <$> mkEditNotifications jRecipient addAlternatives $ - providePreferredAlternative ($(ihamletFile "templates/mail/userAuthModeUpdate.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX)) + providePreferredAlternative ($(ihamletFile "templates/mail/userAuthModeUpdate.hamlet") :: HtmlUrlI18n (SomeMessage UniWorX) (Route UniWorX)) diff --git a/templates/mail/userAuthModeUpdate.hamlet b/templates/mail/userAuthModeUpdate.hamlet index 79ba9c8ef..d128ab4db 100644 --- a/templates/mail/userAuthModeUpdate.hamlet +++ b/templates/mail/userAuthModeUpdate.hamlet @@ -13,13 +13,18 @@ $newline never

$case userAuthentication $of AuthLDAP - _{MsgUserAuthModePWHashChangedToLDAP} + _{SomeMessage MsgUserAuthModePWHashChangedToLDAP} $of AuthPWHash _ - _{MsgUserAuthModeLDAPChangedToPWHash} + _{SomeMessage MsgUserAuthModeLDAPChangedToPWHash} $if is _AuthPWHash userAuthentication

- _{MsgAuthPWHashTip} -

- _{MsgPasswordResetEmailIncoming} + _{SomeMessage MsgAuthPWHashTip} +

+
_{SomeMessage MsgPWHashIdent} +
#{userIdent} +
_{SomeMessage MsgPWHashPassword} +
+ _{SomeMessage MsgPasswordResetEmailIncoming} - ^{editNotifications} + $if is _Just userLastAuthentication + ^{editNotifications}