feat(users): switching between AuthModes & password changing

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
@@ -1279,3 +1298,29 @@ ExamResultAttended: Teilgenommen
 ExamResultNoShow: Nicht erschienen
 ExamResultVoided: Entwertet
 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

package.yaml

@@ -133,6 +133,7 @@ dependencies:
   - cassava
   - cassava-conduit
   - constraints
+  - memory
 
 other-extensions:
   - GeneralizedNewtypeDeriving

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

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) = [
+pageActions (AdminUserR cID) =
-    MenuItem
+  [ 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

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 $
+          runDBJobs $ do
-            forM changes $ \(sid, userAdmin, userLecturer) ->
+            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
+          redirect $ AdminUserR uuid
-    let form = wrapForm formWidget def
+          
+        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)
+    (deleteWgt, deleteEnctype) <- generateFormPost (identifyForm FIDUserDelete buttonForm :: Form ButtonDelete)
-    let btnForm = wrapForm btnWgt def
+    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 ]
+      }

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
 

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)
+maybeCurrentTokenRestrictions, requireCurrentTokenRestrictions :: ( MonadHandler m
-currentTokenRestrictions = runMaybeT $ do
+                                                                  , 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

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

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
 

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
 

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 ()

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))
+

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))

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

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

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

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 --
 -----------

src/Utils/Lens.hs

@@ -146,6 +146,8 @@ makeLenses_ ''UTCTime
 
 makeLenses_ ''ExamOccurrence
 
+makePrisms ''AuthenticationMode
+
 
 -- makeClassy_ ''Load
 

templates/adminUser.hamlet

@@ -1,11 +1,18 @@
-<section>
-  ^{mailtoHtml userEmail}
-  ^{form}
 <section>
   ^{userDataWidget}
+<section>
   <h3>
+    _{MsgAdminUserRightsHeading}
+  ^{rightsForm}
+<section>
+  <h3>
+    _{MsgAdminUserAuthHeading}
+  ^{authForm}
+<section>
+  <p>
+    Achtung, dieser Link löscht momentan noch den kompletten Benutzer
+    unwiderruflich aus der Live-Datenbank mit
+    <code>DELETE CASCADE uid
+    \ Klausurdaten müssen jedoch langfristig gespeichert werden!
+  <p>
     ^{modal "Benutzer löschen" (Right deleteWidget)}
-  Achtung, dieser Link löscht momentan noch den kompletten Benutzer
-  unwiderruflich aus der Live-Datenbank mit
-  <code>DELETE CASCADE uid
-  \ Klausurdaten müssen jedoch langfristig gespeichert werden!

templates/mail/passwordReset.hamlet

@@ -0,0 +1,15 @@
+$newline never
+\<!doctype html>
+<html>
+  <head>
+    <meta charset="UTF-8">
+    <style>
+      h1 {
+        font-size: 1.25em;
+        font-variant: small-caps;
+        font-weight: normal;
+      }
+  <body>
+    <h1>
+      <a href=#{resetUrl}>
+        _{MsgResetPassword}

templates/mail/userAuthModeUpdate.hamlet

@@ -0,0 +1,25 @@
+$newline never
+\<!doctype html>
+<html>
+  <head>
+    <meta charset="UTF-8">
+    <style>
+      h1 {
+        font-size: 1.25em;
+        font-variant: small-caps;
+        font-weight: normal;
+      }
+  <body>
+    <h1>
+      $case userAuthentication
+        $of AuthLDAP
+          _{MsgUserAuthModePWHashChangedToLDAP}
+        $of AuthPWHash _
+          _{MsgUserAuthModeLDAPChangedToPWHash}
+    $if is _AuthPWHash userAuthentication
+      <p>
+        _{MsgAuthPWHashTip}
+      <p>
+        _{MsgPasswordResetEmailIncoming}
+
+    ^{editNotifications}

templates/widgets/data-delete/data-delete.hamlet

@@ -24,4 +24,4 @@
     (Verbuchte Noten sollten dadurch nicht betroffen sein, aber in einem etwaigen
     Streitfall konnen die per Uni2work verwalteten Hausaufgaben dann
     auch nicht mehr rekonstruiert/berücksichtigt werden.)
-^{btnForm}
+^{deleteForm}