From 0d610ccf4459ab929d18ab7285dd080b51394ad2 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Mon, 29 Jul 2019 10:55:23 +0200 Subject: [PATCH] feat(users): switching between AuthModes & password changing --- messages/uniworx/de.msg | 49 +++++- package.yaml | 1 + routes | 4 + src/Foundation.hs | 45 ++++- src/Handler/Users.hs | 156 ++++++++++++++++-- src/Handler/Utils/Invitations.hs | 2 +- src/Handler/Utils/Tokens.hs | 19 ++- src/Handler/Utils/Users.hs | 17 ++ src/Jobs.hs | 1 + src/Jobs/Handler/QueueNotification.hs | 6 +- src/Jobs/Handler/SendNotification.hs | 1 + .../SendNotification/UserAuthModeUpdate.hs | 26 +++ src/Jobs/Handler/SendPasswordReset.hs | 41 +++++ src/Jobs/Types.hs | 5 +- src/Model/Types/Mail.hs | 2 + src/Model/Types/Security.hs | 4 + src/Utils/Form.hs | 5 + src/Utils/Lens.hs | 2 + templates/adminUser.hamlet | 21 ++- templates/mail/passwordReset.hamlet | 15 ++ templates/mail/userAuthModeUpdate.hamlet | 25 +++ .../widgets/data-delete/data-delete.hamlet | 2 +- 22 files changed, 417 insertions(+), 32 deletions(-) create mode 100644 src/Handler/Utils/Users.hs create mode 100644 src/Jobs/Handler/SendNotification/UserAuthModeUpdate.hs create mode 100644 src/Jobs/Handler/SendPasswordReset.hs create mode 100644 templates/mail/passwordReset.hamlet create mode 100644 templates/mail/userAuthModeUpdate.hamlet diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 250ebf672..ff257f027 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -312,6 +312,10 @@ UnauthorizedTutorialTutor: Sie sind nicht Tutor für dieses Tutorium. UnauthorizedCourseTutor: Sie sind nicht Tutor für diesen Kurs. UnauthorizedTutor: Sie sind nicht Tutor. UnauthorizedTutorialRegisterGroup: Sie sind bereits in einem Tutorium mit derselben Registrierungs-Gruppe. +UnauthorizedLDAP: Angegebener Nutzer meldet sich nicht mit Campus-Kennung an. +UnauthorizedPWHash: Angegebener Nutzer meldet sich nicht mit Uni2work-Kennung an. + +UnauthorizedPasswordResetToken: Dieses Authorisierungs-Token kann nicht mehr zum Passwort ändern benutzt werden EMail: E-Mail EMailUnknown email@UserEmail: E-Mail #{email} gehört zu keinem bekannten Benutzer. @@ -502,7 +506,9 @@ NoUpcomingExams: In den nächsten 14 Tagen gibt es keine Klausur mit offener Reg AdminHeading: Administration AdminUserHeading: Benutzeradministration -AccessRightsFor: Berechtigungen für +AdminUserRightsHeading: Benutzerrechte +AdminUserAuthHeading: Benutzer-Authentifizierung +AdminUserHeadingFor: Benuterprofil für AdminFor: Administrator LecturerFor: Dozent LecturersFor: Dozenten @@ -651,6 +657,13 @@ 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 +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. +PasswordResetEmailIncoming: Einen Link um ihr Passwort zu setzen bzw. zu ändern bekommen Sie, aus Sicherheitsgründen, in einer separaten E-Mail. MailEditNotifications: Benachrichtigungen ein-/ausschalten MailSubjectSupport: Supportanfrage @@ -672,6 +685,8 @@ MailSubjectExamRegistrationInvitation tid@TermId ssh@SchoolId csh@CourseShorthan MailSubjectSubmissionUserInvitation tid@TermId ssh@SchoolId csh@CourseShorthand shn@SheetName: [#{tid}-#{ssh}-#{csh}] Einladung zu einer Abgabe für #{shn} +MailSubjectPasswordReset: Uni2work-Passwort ändern bzw. setzen + SheetGrading: Bewertung SheetGradingPoints maxPoints@Points: #{maxPoints} Punkte SheetGradingPassPoints maxPoints@Points passingPoints@Points: Bestanden ab #{passingPoints} von #{maxPoints} Punkten @@ -720,6 +735,7 @@ NotificationTriggerSheetInactive: Abgabezeitraum eines meiner Übungsblätter is NotificationTriggerCorrectionsAssigned: Mir wurden Abgaben zur Korrektur zugeteilt NotificationTriggerCorrectionsNotDistributed: Nicht alle Abgaben eines meiner Übungsblätter konnten einem Korrektor zugeteilt werden NotificationTriggerUserRightsUpdate: Meine Berechtigungen wurden geändert +NotificationTriggerUserAuthModeUpdate: Mein Anmelde-Modus wurde geändert CorrCreate: Abgaben erstellen UnknownPseudonymWord pseudonymWord@Text: Unbekanntes Pseudonym-Wort "#{pseudonymWord}" @@ -836,6 +852,7 @@ MenuTermShow: Semester MenuSubmissionDelete: Abgabe löschen MenuUsers: Benutzer MenuUserNotifications: Benachrichtigungs-Einstellungen +MenuUserPassword: Passwort MenuAdminTest: Admin-Demo MenuMessageList: Systemnachrichten MenuAdminErrMsg: Fehlermeldung entschlüsseln @@ -909,6 +926,8 @@ AuthTagRated: Korrektur ist bewertet AuthTagUserSubmissions: Abgaben erfolgen durch Kursteilnehmer AuthTagCorrectorSubmissions: Abgaben erfolgen durch Korrektoren AuthTagSelf: Nutzer greift nur auf eigene Daten zu +AuthTagIsLDAP: Nutzer meldet sich mit Campus-Kennung an +AuthTagIsPWHash: Nutzer meldet sich mit Uni2work-Kennung an AuthTagAuthentication: Nutzer ist angemeldet, falls erforderlich AuthTagRead: Zugriff ist nur lesend AuthTagWrite: Zugriff ist i.A. schreibend @@ -1278,4 +1297,30 @@ TableHeadingCsvExport: CSV-Export ExamResultAttended: Teilgenommen ExamResultNoShow: Nicht erschienen ExamResultVoided: Entwertet -ExamResultNone: Kein Klausurergebnis \ No newline at end of file +ExamResultNone: Kein Klausurergebnis + +BtnAuthLDAP: Auf Campus-Kennung umstellen +BtnAuthPWHash: Auf Uni2work-Kennung umstellen +BtnPasswordReset: Passwort zurücksetzen + +AuthLDAPLookupFailed: Nutzer konnte aufgrund eines LDAP-Fehlers nicht nachgeschlagen werden +AuthLDAPInvalidLookup: Bestehender Nutzer konnte nicht eindeutig einem LDAP-Eintrag zugeordnet werden +AuthLDAPAlreadyConfigured: Nutzer meldet sich bereits per Campus-Kennung an +AuthLDAPConfigured: Nutzer meldet sich nun per Campus-Kennung an + +AuthPWHashAlreadyConfigured: Nutzer meldet sich bereits per Uni2work-Kennung an +AuthPWHashConfigured: Nutzer meldet sich nun per Uni2work-Kennung an + +PasswordResetQueued: Link zum Passwort-Zurücksetzen versandt +ResetPassword: Uni2work-Passwort ändern bzw. setzen + +AuthMode: Authentifizierung +AuthLDAP: Campus +AuthPWHash pwHash@Text: Uni2work +CurrentPassword: Aktuelles Passwort +NewPassword: Neues Passwort +NewPasswordRepeat: Wiederholung +CurrentPasswordInvalid: Aktuelles Passwort ist inkorrekt +PasswordRepeatInvalid: Wiederholung stimmt nicht mit neuem Passwort überein +UserPasswordHeadingFor: Passwort ändern für +PasswordChangedSuccess: Passwort erfolgreich geändert \ No newline at end of file diff --git a/package.yaml b/package.yaml index 1199d655d..a935edb8d 100644 --- a/package.yaml +++ b/package.yaml @@ -133,6 +133,7 @@ dependencies: - cassava - cassava-conduit - constraints + - memory other-extensions: - GeneralizedNewtypeDeriving diff --git a/routes b/routes index 3b1aa5262..de39aeca9 100644 --- a/routes +++ b/routes @@ -24,6 +24,9 @@ -- !capacity -- course this route is associated with has at least one unit of participant capacity -- !empty -- course this route is associated with has no participants whatsoever -- +-- !is-ldap -- user has authentication mode set to LDAP +-- !is-pw-hash -- user has authentication mode set to PWHash +-- -- !materials -- only if course allows all materials to be free (no meaning outside of courses) -- !time -- access depends on time somehow -- !read -- only if it is read-only access (i.e. GET but not POST) @@ -45,6 +48,7 @@ /users/#CryptoUUIDUser/delete AdminUserDeleteR POST /users/#CryptoUUIDUser/hijack AdminHijackUserR POST !adminANDno-escalation /users/#CryptoUUIDUser/notifications UserNotificationR GET POST !self +/users/#CryptoUUIDUser/password UserPasswordR GET POST !selfANDis-pw-hash /admin AdminR GET /admin/features AdminFeaturesR GET POST /admin/test AdminTestR GET POST diff --git a/src/Foundation.hs b/src/Foundation.hs index f00ac3484..2206317f1 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -296,6 +296,7 @@ embedRenderMessage ''UniWorX ''UploadModeDescr id embedRenderMessage ''UniWorX ''SecretJSONFieldException id embedRenderMessage ''UniWorX ''AFormMessage $ concat . drop 2 . splitCamel +embedRenderMessage ''UniWorX ''AuthenticationMode id newtype SheetTypeHeader = SheetTypeHeader SheetType embedRenderMessageVariant ''UniWorX ''SheetTypeHeader ("SheetType" <>) @@ -1001,6 +1002,7 @@ tagAccessPredicate AuthSelf = APHandler $ \mAuthId route _ -> exceptT return ret AdminUserDeleteR cID -> return cID AdminHijackUserR cID -> return cID UserNotificationR cID -> return cID + UserPasswordR cID -> return cID CourseR _ _ _ (CUserR cID) -> return cID _other -> throwError =<< $unsupportedAuthPredicate AuthSelf route referencedUser' <- decrypt referencedUser @@ -1009,6 +1011,34 @@ tagAccessPredicate AuthSelf = APHandler $ \mAuthId route _ -> exceptT return ret | uid == referencedUser' -> return Authorized Nothing -> return AuthenticationRequired _other -> unauthorizedI MsgUnauthorizedSelf +tagAccessPredicate AuthIsLDAP = APDB $ \_ route _ -> exceptT return return $ do + referencedUser <- case route of + AdminUserR cID -> return cID + AdminUserDeleteR cID -> return cID + AdminHijackUserR cID -> return cID + UserNotificationR cID -> return cID + UserPasswordR cID -> return cID + CourseR _ _ _ (CUserR cID) -> return cID + _other -> throwError =<< $unsupportedAuthPredicate AuthIsLDAP route + referencedUser' <- decrypt referencedUser + maybeTMExceptT (unauthorizedI MsgUnauthorizedLDAP) $ do + User{..} <- MaybeT $ get referencedUser' + guard $ userAuthentication == AuthLDAP + return Authorized +tagAccessPredicate AuthIsPWHash = APDB $ \_ route _ -> exceptT return return $ do + referencedUser <- case route of + AdminUserR cID -> return cID + AdminUserDeleteR cID -> return cID + AdminHijackUserR cID -> return cID + UserNotificationR cID -> return cID + UserPasswordR cID -> return cID + CourseR _ _ _ (CUserR cID) -> return cID + _other -> throwError =<< $unsupportedAuthPredicate AuthIsPWHash route + referencedUser' <- decrypt referencedUser + maybeTMExceptT (unauthorizedI MsgUnauthorizedPWHash) $ do + User{..} <- MaybeT $ get referencedUser' + guard $ is _AuthPWHash userAuthentication + return Authorized tagAccessPredicate AuthAuthentication = APDB $ \mAuthId route _ -> case route of MessageR cID -> maybeT (unauthorizedI MsgUnauthorizedSystemMessageAuth) $ do smId <- decrypt cID @@ -1802,8 +1832,8 @@ pageActions (AdminR) = , menuItemAccessCallback' = return True } ] -pageActions (AdminUserR cID) = [ - MenuItem +pageActions (AdminUserR cID) = + [ MenuItem { menuItemType = PageActionPrime , menuItemLabel = MsgMenuUserNotifications , menuItemIcon = Nothing @@ -1811,6 +1841,17 @@ pageActions (AdminUserR cID) = [ , menuItemModal = True , menuItemAccessCallback' = return True } + , MenuItem + { menuItemType = PageActionPrime + , menuItemLabel = MsgMenuUserPassword + , menuItemIcon = Nothing + , menuItemRoute = SomeRoute $ UserPasswordR cID + , menuItemModal = True + , menuItemAccessCallback' = do + uid <- decrypt cID + User{userAuthentication} <- runDB $ get404 uid + return $ is _AuthPWHash userAuthentication + } ] pageActions (InfoR) = [ MenuItem diff --git a/src/Handler/Users.hs b/src/Handler/Users.hs index 30470cf3a..67f2e60b0 100644 --- a/src/Handler/Users.hs +++ b/src/Handler/Users.hs @@ -5,6 +5,10 @@ import Import import Jobs -- import Data.Text import Handler.Utils +import Handler.Utils.Tokens +import Handler.Utils.Users + +import qualified Auth.LDAP as Auth import Utils.Lens @@ -18,6 +22,10 @@ import qualified Database.Esqueleto.Utils as E import Handler.Profile (makeProfileData) +import qualified Yesod.Auth.Util.PasswordStore as PWStore + +import qualified Data.ByteString.Base64 as Base64 + hijackUserForm :: CryptoUUIDUser -> Form () hijackUserForm cID csrf = do @@ -45,6 +53,7 @@ getUsersR = do -- , sortable (Just "last-name") (i18nCell MsgName) $ \DBRow{ dbrOutput = Entity uid User{..} } -> anchorCellM -- (AdminUserR <$> encrypt uid) -- (toWidget . display $ last $ impureNonNull $ words $ userDisplayName) + , sortable (Just "auth-ldap") (i18nCell MsgAuthMode) $ \DBRow{ dbrOutput = Entity _ User{..} } -> i18nCell userAuthentication , sortable Nothing (i18nCell MsgAdminFor) $ \DBRow{ dbrOutput = Entity uid _ } -> flip (set' cellContents) mempty $ do schools <- lift . E.select . E.from $ \(school `E.InnerJoin` userAdmin) -> do E.on $ school E.^. SchoolId E.==. userAdmin E.^. UserAdminSchool @@ -106,6 +115,9 @@ getUsersR = do , ( "matriculation" , SortColumn $ \user -> user E.^. UserMatrikelnummer ) + , ( "auth-ldap" + , SortColumn $ \user -> user E.^. UserAuthentication E.!=. E.val AuthLDAP + ) ] , dbtFilter = Map.fromList -- OverloadedLists does not work with the templates [ ( "user-search", FilterColumn $ \user (criteria :: Set.Set Text) -> @@ -117,6 +129,12 @@ getUsersR = do | Set.null criteria -> E.true -- TODO: why can this be eFalse and work still? | otherwise -> E.any (\c -> user E.^. UserMatrikelnummer `E.hasInfix` E.val c) criteria ) + , ( "auth-ldap", FilterColumn $ \user (criterion :: Last Bool) -> if + | Just crit <- getLast criterion + -> (user E.^. UserAuthentication E.==. E.val AuthLDAP) E.==. E.val crit + | otherwise + -> E.true + ) , ( "school", FilterColumn $ \user criterion -> if | Set.null criterion -> E.val True :: E.SqlExpr (E.Value Bool) | otherwise -> let schools = E.valList (Set.toList criterion) in @@ -134,7 +152,7 @@ getUsersR = do [ prismAForm (singletonFilter "user-search") mPrev $ aopt textField (fslI MsgName) -- , prismAForm (singletonFilter "matriculation" ) mPrev $ aopt textField (fslI MsgMatrikelNr) , prismAForm (singletonFilter "matriculation" ) mPrev $ aopt matriculationField (fslI MsgMatrikelNr) - + , prismAForm (singletonFilter "auth-ldap" . maybePrism _PathPiece) mPrev $ aopt (lift `hoistField` radioFieldList [(MsgAuthPWHash "", False), (MsgAuthLDAP, True)]) (fslI MsgAuthMode) , prismAForm (singletonFilter "school" ) mPrev $ aopt (lift `hoistField` selectFieldList schoolOptions) (fslI MsgCourseSchool) ] , dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } @@ -160,6 +178,18 @@ postAdminHijackUserR cID = do maybe (redirect UsersR) return ret +data ButtonAuthMode = BtnAuthLDAP | BtnAuthPWHash | BtnPasswordReset + deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) +instance Universe ButtonAuthMode +instance Finite ButtonAuthMode + +nullaryPathPiece ''ButtonAuthMode $ camelToPathPiece' 1 +embedRenderMessage ''UniWorX ''ButtonAuthMode id + +instance Button UniWorX ButtonAuthMode where + btnClasses _ = [BCIsButton] + + getAdminUserR, postAdminUserR :: CryptoUUIDUser -> Handler Html getAdminUserR = postAdminUserR postAdminUserR uuid = do @@ -196,9 +226,13 @@ postAdminUserR uuid = do let result = forM boxRights $ \(Entity sid _, (resAdmin,_), (resLecturer, _)) -> (,,) <$> pure sid <*> resAdmin <*> resLecturer return (result,$(widgetFile "widgets/user-rights-form/user-rights-form")) + userAuthenticationForm :: Form ButtonAuthMode + userAuthenticationForm = buttonForm' $ if + | userAuthentication == AuthLDAP -> [BtnAuthPWHash] + | otherwise -> [BtnAuthLDAP, BtnPasswordReset] let userRightsAction changes = do - void . runDB $ - forM changes $ \(sid, userAdmin, userLecturer) -> + runDBJobs $ do + forM_ changes $ \(sid, userAdmin, userLecturer) -> if Set.notMember sid adminSchools then return () else do @@ -209,21 +243,70 @@ postAdminUserR uuid = do then void . insertUnique $ UserLecturer uid sid else deleteBy $ UniqueSchoolLecturer uid sid -- Note: deleteWhere would not work well here since we filter by adminSchools - queueJob' . JobQueueNotification $ NotificationUserRightsUpdate uid (over _1 (schoolShorthand . entityVal) <$> userRights) -- original rights to check for difference + queueDBJob . JobQueueNotification $ NotificationUserRightsUpdate uid (over _1 (schoolShorthand . entityVal) <$> userRights) -- original rights to check for difference addMessageI Info MsgAccessRightsSaved - ((result, formWidget),formEnctype) <- runFormPost userRightsForm - let form = wrapForm formWidget def + redirect $ AdminUserR uuid + + userAuthenticationAction = \case + BtnAuthLDAP -> do + let + campusHandler :: MonadPlus m => Auth.CampusUserException -> m a + campusHandler _ = mzero + campusResult <- runMaybeT . handle campusHandler $ do + (Just pool, Just conf) <- getsYesod $ (,) <$> view _appLdapPool <*> view _appLdapConf + let + campusLogin :: AuthPlugin UniWorX + campusLogin = Auth.campusLogin conf pool + void . Auth.campusUser conf pool $ Creds (apName campusLogin) (CI.original userIdent) [] + case campusResult of + Nothing -> addMessageI Error MsgAuthLDAPInvalidLookup + _other + | is _AuthLDAP userAuthentication + -> addMessageI Info MsgAuthLDAPAlreadyConfigured + Just () -> do + runDBJobs $ do + update uid [ UserAuthentication =. AuthLDAP ] + queueDBJob . JobQueueNotification $ NotificationUserAuthModeUpdate uid userAuthentication + + addMessageI Success MsgAuthLDAPConfigured + redirect $ AdminUserR uuid + BtnAuthPWHash -> do + if + | is _AuthPWHash userAuthentication + -> addMessageI Info MsgAuthPWHashAlreadyConfigured + | otherwise + -> do + runDBJobs $ do + update uid [ UserAuthentication =. AuthPWHash "" ] + queueDBJob . JobQueueNotification $ NotificationUserAuthModeUpdate uid userAuthentication + queueDBJob $ JobSendPasswordReset uid + + addMessageI Success MsgAuthPWHashConfigured + redirect $ AdminUserR uuid + BtnPasswordReset -> do + queueJob' $ JobSendPasswordReset uid + addMessageI Success MsgPasswordResetQueued + redirect $ AdminUserR uuid + ((rightsResult, rightsFormWidget),rightsFormEnctype) <- runFormPost userRightsForm + ((authResult, authFormWidget),authFormEnctype) <- runFormPost userAuthenticationForm + let rightsForm = wrapForm rightsFormWidget def { formAction = Just . SomeRoute $ AdminUserR uuid - , formEncoding = formEnctype + , formEncoding = rightsFormEnctype } - formResult result userRightsAction + authForm = wrapForm authFormWidget def + { formAction = Just . SomeRoute $ AdminUserR uuid + , formEncoding = authFormEnctype + , formSubmit = FormNoSubmit + } + formResult rightsResult userRightsAction + formResult authResult userAuthenticationAction let heading = - [whamlet|_{MsgAccessRightsFor} ^{nameWidget userDisplayName userSurname}|] + [whamlet|_{MsgAdminUserHeadingFor} ^{nameEmailWidget userEmail userDisplayName userSurname}|] -- Delete Button needed in data-delete - (btnWgt, btnEnctype) <- generateFormPost (identifyForm FIDUserDelete buttonForm :: Form ButtonDelete) - let btnForm = wrapForm btnWgt def + (deleteWgt, deleteEnctype) <- generateFormPost (identifyForm FIDUserDelete buttonForm :: Form ButtonDelete) + let deleteForm = wrapForm deleteWgt def { formAction = Just $ SomeRoute $ AdminUserDeleteR uuid - , formEncoding = btnEnctype + , formEncoding = deleteEnctype , formSubmit = FormNoSubmit } userDataWidget <- runDB $ makeProfileData $ Entity uid user @@ -300,3 +383,52 @@ deleteUser duid = do E.where_ $ subGroupUser E.^. SubmissionGroupUserSubmissionGroup E.==. submissionGroup E.^. SubmissionGroupId E.&&. subGroupUser E.^. SubmissionGroupUserUser E.!=. E.val duid + +getUserPasswordR, postUserPasswordR :: CryptoUUIDUser -> Handler Html +getUserPasswordR = postUserPasswordR +postUserPasswordR cID = do + tUid <- decrypt cID + User{..} <- runDB $ get404 tUid + PWHashConf{..} <- getsYesod $ view _appAuthPWHash + isModal <- hasCustomHeader HeaderIsModal + + isAdmin <- hasWriteAccessTo $ AdminUserR cID + + requireCurrent <- maybeT (return True) $ asum + [ False <$ guard (isn't _AuthPWHash userAuthentication) + , False <$ guard isAdmin + , do + authMode <- Base64.decodeLenient . encodeUtf8 <$> MaybeT maybeCurrentTokenRestrictions + unless (authMode `constEq` computeUserAuthenticationDigest userAuthentication) . lift $ + invalidArgsI [MsgUnauthorizedPasswordResetToken] + return False + ] + + ((passResult, passFormWidget), passEnctype) <- runFormPost . formEmbedJwtPost . renderAForm FormStandard . wFormToAForm $ do + currentResult <- if + | AuthPWHash (encodeUtf8 -> pwHash) <- userAuthentication + , requireCurrent + -> wreq + (checkMap (bool (Left MsgCurrentPasswordInvalid) (Right ()) . flip (PWStore.verifyPasswordWith pwHashAlgorithm (2^)) pwHash . encodeUtf8) (const "") passwordField) + (fslI MsgCurrentPassword) + Nothing + | otherwise + -> return $ FormSuccess () + + newResult <- do + resA <- wreq passwordField (fslI MsgNewPassword) Nothing + wreq (checkBool ((== resA) . FormSuccess) MsgPasswordRepeatInvalid passwordField) (fslI MsgNewPasswordRepeat) Nothing + + return . fmap encodeUtf8 $ currentResult *> newResult + + formResultModal passResult (bool ProfileR (UserPasswordR cID) isAdmin) $ \newPass -> do + newHash <- fmap decodeUtf8 . liftIO $ PWStore.makePasswordWith pwHashAlgorithm newPass pwHashStrength + liftHandlerT . runDB $ update tUid [ UserAuthentication =. AuthPWHash newHash ] + tell . pure =<< messageI Success MsgPasswordChangedSuccess + + siteLayout [whamlet|_{MsgUserPasswordHeadingFor} ^{nameEmailWidget userEmail userDisplayName userSurname}|] $ + wrapForm passFormWidget def + { formAction = Just . SomeRoute $ UserPasswordR cID + , formEncoding = passEnctype + , formAttrs = [ asyncSubmitAttr | isModal ] + } diff --git a/src/Handler/Utils/Invitations.hs b/src/Handler/Utils/Invitations.hs index 2a582f6e3..8fa20a93b 100644 --- a/src/Handler/Utils/Invitations.hs +++ b/src/Handler/Utils/Invitations.hs @@ -282,7 +282,7 @@ invitationR' :: forall junction m. -> m Html -- | Generic handler for incoming invitations invitationR' InvitationConfig{..} = liftHandlerT $ do - InvitationTokenRestriction{..} <- maybeM (invalidArgsI [MsgInvitationMissingRestrictions]) return currentTokenRestrictions :: Handler (InvitationTokenRestriction junction) + InvitationTokenRestriction{..} <- maybeM (invalidArgsI [MsgInvitationMissingRestrictions]) return requireCurrentTokenRestrictions :: Handler (InvitationTokenRestriction junction) invitee <- requireAuthId Just cRoute <- getCurrentRoute diff --git a/src/Handler/Utils/Tokens.hs b/src/Handler/Utils/Tokens.hs index 736bb929a..88870f28e 100644 --- a/src/Handler/Utils/Tokens.hs +++ b/src/Handler/Utils/Tokens.hs @@ -1,6 +1,6 @@ module Handler.Utils.Tokens ( maybeBearerToken, requireBearerToken - , currentTokenRestrictions + , maybeCurrentTokenRestrictions, requireCurrentTokenRestrictions ) where import Import @@ -27,8 +27,19 @@ requireBearerToken = liftHandlerT $ do guardAuthResult <=< runDB $ validateToken mAuthId currentRoute isWrite token return token -currentTokenRestrictions :: (MonadHandler m, HandlerSite m ~ UniWorX, MonadCatch m, MonadLogger m, FromJSON a, ToJSON a) => m (Maybe a) -currentTokenRestrictions = runMaybeT $ do +maybeCurrentTokenRestrictions, requireCurrentTokenRestrictions :: ( MonadHandler m + , HandlerSite m ~ UniWorX + , MonadCatch m + , MonadLogger m + , FromJSON a + , ToJSON a + ) + => m (Maybe a) +requireCurrentTokenRestrictions = runMaybeT $ do token <- requireBearerToken route <- MaybeT getCurrentRoute - hoistMaybe $ preview (_tokenRestrictionIx route) token + hoistMaybe $ token ^? _tokenRestrictionIx route +maybeCurrentTokenRestrictions = runMaybeT $ do + token <- MaybeT maybeBearerToken + route <- MaybeT getCurrentRoute + hoistMaybe $ token ^? _tokenRestrictionIx route diff --git a/src/Handler/Utils/Users.hs b/src/Handler/Utils/Users.hs new file mode 100644 index 000000000..f7fdfda79 --- /dev/null +++ b/src/Handler/Utils/Users.hs @@ -0,0 +1,17 @@ +module Handler.Utils.Users + ( computeUserAuthenticationDigest + , Digest, SHA3_256 + , constEq + ) where + +import Import + +import Crypto.Hash (Digest, SHA3_256, hashlazy) + +import Data.ByteArray (constEq) + +import qualified Data.Aeson as JSON + + +computeUserAuthenticationDigest :: AuthenticationMode -> Digest SHA3_256 +computeUserAuthenticationDigest = hashlazy . JSON.encode diff --git a/src/Jobs.hs b/src/Jobs.hs index 4769178ff..63fc3f75d 100644 --- a/src/Jobs.hs +++ b/src/Jobs.hs @@ -66,6 +66,7 @@ import Jobs.Handler.SetLogSettings import Jobs.Handler.DistributeCorrections import Jobs.Handler.SendCourseCommunication import Jobs.Handler.Invitation +import Jobs.Handler.SendPasswordReset import Jobs.HealthReport diff --git a/src/Jobs/Handler/QueueNotification.hs b/src/Jobs/Handler/QueueNotification.hs index 3d226f72a..e10494b3b 100644 --- a/src/Jobs/Handler/QueueNotification.hs +++ b/src/Jobs/Handler/QueueNotification.hs @@ -61,13 +61,15 @@ determineNotificationCandidates NotificationUserRightsUpdate{..} affectedUser <- selectList [UserId ==. nUser] [] -- send to same-school admins only if there was an update currentAdminSchools <- fmap (userAdminSchool . entityVal) <$> selectList [UserAdminUser ==. nUser] [] - let oldAdminSchools = [ SchoolKey ssh | (ssh, True, _) <- originalRights ] + let oldAdminSchools = [ SchoolKey ssh | (ssh, True, _) <- nOriginalRights ] newAdminSchools = currentAdminSchools \\ oldAdminSchools affectedAdmins <- E.select . E.from $ \(user `E.InnerJoin` admin) -> do E.on $ admin E.^. UserAdminUser E.==. user E.^. UserId E.where_ $ admin E.^. UserAdminSchool `E.in_` E.valList newAdminSchools return user return $ nub $ affectedUser <> affectedAdmins +determineNotificationCandidates NotificationUserAuthModeUpdate{..} + = selectList [UserId ==. nUser] [] classifyNotification :: Notification -> DB NotificationTrigger @@ -82,5 +84,5 @@ classifyNotification NotificationSheetInactive{} = return NTSheetInactive classifyNotification NotificationCorrectionsAssigned{} = return NTCorrectionsAssigned classifyNotification NotificationCorrectionsNotDistributed{} = return NTCorrectionsNotDistributed classifyNotification NotificationUserRightsUpdate{} = return NTUserRightsUpdate - +classifyNotification NotificationUserAuthModeUpdate{} = return NTUserAuthModeUpdate diff --git a/src/Jobs/Handler/SendNotification.hs b/src/Jobs/Handler/SendNotification.hs index 64921e118..121305c78 100644 --- a/src/Jobs/Handler/SendNotification.hs +++ b/src/Jobs/Handler/SendNotification.hs @@ -13,6 +13,7 @@ import Jobs.Handler.SendNotification.SheetInactive import Jobs.Handler.SendNotification.CorrectionsAssigned import Jobs.Handler.SendNotification.CorrectionsNotDistributed import Jobs.Handler.SendNotification.UserRightsUpdate +import Jobs.Handler.SendNotification.UserAuthModeUpdate dispatchJobSendNotification :: UserId -> Notification -> Handler () diff --git a/src/Jobs/Handler/SendNotification/UserAuthModeUpdate.hs b/src/Jobs/Handler/SendNotification/UserAuthModeUpdate.hs new file mode 100644 index 000000000..eb7552f34 --- /dev/null +++ b/src/Jobs/Handler/SendNotification/UserAuthModeUpdate.hs @@ -0,0 +1,26 @@ +{-# OPTIONS_GHC -fno-warn-unused-do-bind #-} -- ihamletFile discards do results + +module Jobs.Handler.SendNotification.UserAuthModeUpdate + ( dispatchNotificationUserAuthModeUpdate + ) where + +import Import +import Utils.Lens + +import Handler.Utils.Mail +import Jobs.Handler.SendNotification.Utils + +import Text.Hamlet +-- import qualified Data.CaseInsensitive as CI + +dispatchNotificationUserAuthModeUpdate :: UserId -> AuthenticationMode -> UserId -> Handler () +dispatchNotificationUserAuthModeUpdate nUser _nOriginalAuthMode jRecipient = userMailT jRecipient $ do + User{..} <- liftHandlerT . runDB $ getJust nUser + replaceMailHeader "Auto-Submitted" $ Just "auto-generated" + setSubjectI MsgMailSubjectUserAuthModeUpdate + + editNotifications <- mkEditNotifications jRecipient + + addAlternatives $ + providePreferredAlternative ($(ihamletFile "templates/mail/userAuthModeUpdate.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX)) + diff --git a/src/Jobs/Handler/SendPasswordReset.hs b/src/Jobs/Handler/SendPasswordReset.hs new file mode 100644 index 000000000..96ecddb69 --- /dev/null +++ b/src/Jobs/Handler/SendPasswordReset.hs @@ -0,0 +1,41 @@ +module Jobs.Handler.SendPasswordReset + ( dispatchJobSendPasswordReset + ) where + +import Import + +import Utils.Lens +import Handler.Utils +import Handler.Utils.Users + +import qualified Data.ByteString.Base64 as Base64 +import qualified Data.ByteArray as BA +import qualified Data.HashSet as HashSet + +import Text.Hamlet + +dispatchJobSendPasswordReset :: UserId + -> Handler () +dispatchJobSendPasswordReset jRecipient = userMailT jRecipient $ do + cID <- encrypt jRecipient + User{..} <- liftHandlerT . runDB $ getJust jRecipient + + replaceMailHeader "Auto-Submitted" $ Just "auto-generated" + setSubjectI MsgMailSubjectPasswordReset + + now <- liftIO getCurrentTime + let + localNow = utcToLocalTime now + tomorrowEndOfDay = case localTimeToUTC (LocalTime (addDays 2 $ localDay localNow) midnight) of + LTUUnique utc' _ -> utc' + _other -> UTCTime (addDays 2 $ utctDay now) 0 + + resetToken' <- bearerToken jRecipient (Just . HashSet.singleton $ UserPasswordR cID) Nothing (Just $ Just tomorrowEndOfDay) Nothing + let resetToken = resetToken' + & tokenRestrict (UserPasswordR cID) (decodeUtf8 . Base64.encode . BA.convert $ computeUserAuthenticationDigest userAuthentication) + encodedToken <- encodeToken resetToken + + resetUrl <- toTextUrl (UserPasswordR cID, [(toPathPiece GetBearer, toPathPiece encodedToken)]) + + addAlternatives $ + providePreferredAlternative ($(ihamletFile "templates/mail/passwordReset.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX)) diff --git a/src/Jobs/Types.hs b/src/Jobs/Types.hs index 74fd7afe3..f88986fee 100644 --- a/src/Jobs/Types.hs +++ b/src/Jobs/Types.hs @@ -46,6 +46,8 @@ data Job = JobSendNotification { jRecipient :: UserId, jNotification :: Notifica , jInvitationSubject :: Text , jInvitationExplanation :: Html } + | JobSendPasswordReset { jRecipient :: UserId + } deriving (Eq, Ord, Show, Read, Generic, Typeable) data Notification = NotificationSubmissionRated { nSubmission :: SubmissionId } | NotificationSheetActive { nSheet :: SheetId } @@ -53,7 +55,8 @@ data Notification = NotificationSubmissionRated { nSubmission :: SubmissionId } | NotificationSheetInactive { nSheet :: SheetId } | NotificationCorrectionsAssigned { nUser :: UserId, nSheet :: SheetId } | NotificationCorrectionsNotDistributed { nSheet :: SheetId } - | NotificationUserRightsUpdate { nUser :: UserId, originalRights :: [(SchoolShorthand,Bool,Bool)] } -- User rights (admin, lecturer,...) were changed somehow + | NotificationUserRightsUpdate { nUser :: UserId, nOriginalRights :: [(SchoolShorthand,Bool,Bool)] } -- User rights (admin, lecturer,...) were changed somehow + | NotificationUserAuthModeUpdate { nUser :: UserId, nOriginalAuthMode :: AuthenticationMode } deriving (Eq, Ord, Show, Read, Generic, Typeable) instance Hashable Job diff --git a/src/Model/Types/Mail.hs b/src/Model/Types/Mail.hs index d2507e6f9..3f670b4fe 100644 --- a/src/Model/Types/Mail.hs +++ b/src/Model/Types/Mail.hs @@ -29,6 +29,7 @@ data NotificationTrigger | NTCorrectionsAssigned | NTCorrectionsNotDistributed | NTUserRightsUpdate + | NTUserAuthModeUpdate deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) instance Universe NotificationTrigger @@ -61,6 +62,7 @@ instance Default NotificationSettings where NTCorrectionsAssigned -> True NTCorrectionsNotDistributed -> True NTUserRightsUpdate -> True + NTUserAuthModeUpdate -> True instance ToJSON NotificationSettings where toJSON v = toJSON . HashMap.fromList $ map (id &&& notificationAllowed v) universeF diff --git a/src/Model/Types/Security.hs b/src/Model/Types/Security.hs index 805e7d96d..93bafc1b5 100644 --- a/src/Model/Types/Security.hs +++ b/src/Model/Types/Security.hs @@ -26,6 +26,8 @@ data AuthenticationMode = AuthLDAP | AuthPWHash { authPWHash :: Text } deriving (Eq, Ord, Read, Show, Generic) +instance Hashable AuthenticationMode + deriveJSON defaultOptions { constructorTagModifier = intercalate "-" . map toLower . drop 1 . splitCamel , fieldLabelModifier = intercalate "-" . map toLower . drop 1 . splitCamel @@ -54,6 +56,8 @@ data AuthTag -- sortiert nach gewünschter Reihenfolge auf /authpreds, d.h. Prä | AuthRegisterGroup | AuthEmpty | AuthSelf + | AuthIsLDAP + | AuthIsPWHash | AuthAuthentication | AuthNoEscalation | AuthRead diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index e1a2a24b4..c0ac56f28 100644 --- a/src/Utils/Form.hs +++ b/src/Utils/Form.hs @@ -210,6 +210,7 @@ data FormIdentifier | FIDUserDelete | FIDCommunication | FIDAssignSubmissions + | FIDUserAuthMode deriving (Eq, Ord, Read, Show) instance PathPiece FormIdentifier where @@ -616,6 +617,10 @@ fileFieldMultiple = Field , fieldEnctype = Multipart } +checkMap :: (Monad m, RenderMessage (HandlerSite m) msg) => (a -> Either msg b) -> (b -> a) -> Field m a -> Field m b +checkMap f = checkMMap (return . f) + + ----------- -- Forms -- ----------- diff --git a/src/Utils/Lens.hs b/src/Utils/Lens.hs index 797b59472..7ef4d33a7 100644 --- a/src/Utils/Lens.hs +++ b/src/Utils/Lens.hs @@ -146,6 +146,8 @@ makeLenses_ ''UTCTime makeLenses_ ''ExamOccurrence +makePrisms ''AuthenticationMode + -- makeClassy_ ''Load diff --git a/templates/adminUser.hamlet b/templates/adminUser.hamlet index c4293d5a4..8dd325c44 100644 --- a/templates/adminUser.hamlet +++ b/templates/adminUser.hamlet @@ -1,11 +1,18 @@ -
- ^{mailtoHtml userEmail} - ^{form}
^{userDataWidget} +

+ _{MsgAdminUserRightsHeading} + ^{rightsForm} +
+

+ _{MsgAdminUserAuthHeading} + ^{authForm} +
+

+ Achtung, dieser Link löscht momentan noch den kompletten Benutzer + unwiderruflich aus der Live-Datenbank mit + DELETE CASCADE uid + \ Klausurdaten müssen jedoch langfristig gespeichert werden! +

^{modal "Benutzer löschen" (Right deleteWidget)} - Achtung, dieser Link löscht momentan noch den kompletten Benutzer - unwiderruflich aus der Live-Datenbank mit - DELETE CASCADE uid - \ Klausurdaten müssen jedoch langfristig gespeichert werden! diff --git a/templates/mail/passwordReset.hamlet b/templates/mail/passwordReset.hamlet new file mode 100644 index 000000000..34da2d3d2 --- /dev/null +++ b/templates/mail/passwordReset.hamlet @@ -0,0 +1,15 @@ +$newline never +\ + + + +