fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

feat(users): switching between AuthModes & password changing

Browse Source
This commit is contained in:
Gregor Kleen 2019-07-29 10:55:23 +02:00
parent 54af6cd050
commit 0d610ccf44
22 changed files with 417 additions and 32 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

49
messages/uniworx/de.msg
View File

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

1
package.yaml
View File

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

4
routes
View File

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

45
src/Foundation.hs
View File

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

156
src/Handler/Users.hs
View File

@ -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 ]
}

2
src/Handler/Utils/Invitations.hs
View File

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

19
src/Handler/Utils/Tokens.hs
View File

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

17
src/Handler/Utils/Users.hs Normal file
View File

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

1
src/Jobs.hs
View File

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

6
src/Jobs/Handler/QueueNotification.hs
View File

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

1
src/Jobs/Handler/SendNotification.hs
View File

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

26
src/Jobs/Handler/SendNotification/UserAuthModeUpdate.hs Normal file
View File

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

41
src/Jobs/Handler/SendPasswordReset.hs Normal file
View File

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

5
src/Jobs/Types.hs
View File

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

2
src/Model/Types/Mail.hs
View File

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

4
src/Model/Types/Security.hs
View File

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

5
src/Utils/Form.hs
View File

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

2
src/Utils/Lens.hs
View File

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

21
templates/adminUser.hamlet
View File

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

15
templates/mail/passwordReset.hamlet Normal file
View File

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

25
templates/mail/userAuthModeUpdate.hamlet Normal file
View File

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

2
templates/widgets/data-delete/data-delete.hamlet
View File

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