chore(supervisor): add profile pages for supervisors
This commit is contained in:
Steffen Jost
parent
1f8e76d68b
commit
f36b5ee4d0
@ -115,6 +115,7 @@ SettingsUpdate: Einstellungen erfolgreich gespeichert
|
||||
TokensResetSuccess: Authorisierungs-Tokens invalidiert
|
||||
ProfileTitle: Benutzereinstellungen
|
||||
HeadingProfileData: Persönliche Daten
|
||||
HeadingForProfileData udn@UserDisplayName: Persönliche Daten von #{udn}
|
||||
ProfileRegistered: Angemeldet
|
||||
LastEditByUser: Ihre letzte Bearbeitung
|
||||
SubmissionGroupName: Gruppenname
|
||||
|
||||
@ -115,6 +115,7 @@ SettingsUpdate: Successfully updated settings
|
||||
TokensResetSuccess: Successfully invalidated all authorisation tokens
|
||||
ProfileTitle: Settings
|
||||
HeadingProfileData: Personal information
|
||||
HeadingForProfileData udn: Personal information of #{udn}
|
||||
ProfileRegistered: Registered
|
||||
LastEditByUser: Your last edit
|
||||
SubmissionGroupName: Group name
|
||||
|
||||
16
routes
16
routes
@ -93,7 +93,7 @@
|
||||
/user/storage-key StorageKeyR POST !free
|
||||
|
||||
/user/for/#CryptoUUIDUser ForProfileR GET POST !supervisor
|
||||
/user/profile/for/#CryptoUUIDUser ForProfuleDataR GET !supervisor
|
||||
/user/profile/for/#CryptoUUIDUser ForProfileDataR GET !supervisor
|
||||
|
||||
|
||||
/exam-office ExamOfficeR !exam-office:
|
||||
@ -278,14 +278,14 @@
|
||||
/lms/#SchoolId/#QualificationShorthand LmsR GET POST !free -- TODO verify that this is ok
|
||||
/lms/#SchoolId/#QualificationShorthand/edit LmsEditR GET POST
|
||||
/lms/#SchoolId/#QualificationShorthand/users LmsUsersR GET
|
||||
/lms/#SchoolId/#QualificationShorthand/users/direct LmsUsersDirectR GET !development
|
||||
/lms/#SchoolId/#QualificationShorthand/users/direct LmsUsersDirectR GET -- development
|
||||
/lms/#SchoolId/#QualificationShorthand/userlist LmsUserlistR GET POST
|
||||
/lms/#SchoolId/#QualificationShorthand/userlist/upload LmsUserlistUploadR GET POST !development
|
||||
/lms/#SchoolId/#QualificationShorthand/userlist/direct LmsUserlistDirectR POST !token
|
||||
/lms/#SchoolId/#QualificationShorthand/result LmsResultR GET POST
|
||||
/lms/#SchoolId/#QualificationShorthand/result/upload LmsResultUploadR GET POST !development
|
||||
/lms/#SchoolId/#QualificationShorthand/result/direct LmsResultDirectR POST !token
|
||||
/lms/#SchoolId/#QualificationShorthand/fake LmsFakeR GET POST !development -- TODO: delete this testing URL
|
||||
/lms/#SchoolId/#QualificationShorthand/userlist/upload LmsUserlistUploadR GET POST -- development
|
||||
/lms/#SchoolId/#QualificationShorthand/userlist/direct LmsUserlistDirectR POST -- token
|
||||
/lms/#SchoolId/#QualificationShorthand/result LmsResultR GET POST
|
||||
/lms/#SchoolId/#QualificationShorthand/result/upload LmsResultUploadR GET POST -- development
|
||||
/lms/#SchoolId/#QualificationShorthand/result/direct LmsResultDirectR POST -- token
|
||||
/lms/#SchoolId/#QualificationShorthand/fake LmsFakeR GET POST -- development -- TODO: delete this testing URL
|
||||
|
||||
/api ApiDocsR GET !free
|
||||
/swagger SwaggerR GET !free
|
||||
|
||||
@ -238,9 +238,9 @@ trueAR, falseAR :: MsgRendererS UniWorX -> AuthResult
|
||||
trueAR = const Authorized
|
||||
falseAR = Unauthorized . ($ MsgUnauthorized) . render
|
||||
|
||||
trueAP, _falseAP :: AccessPredicate
|
||||
trueAP, falseAP :: AccessPredicate
|
||||
trueAP = APPure . const . const . const $ trueAR <$> ask
|
||||
_falseAP = APPure . const . const . const $ falseAR <$> ask -- included for completeness
|
||||
falseAP = APPure . const . const . const $ falseAR <$> ask -- included for completeness
|
||||
|
||||
|
||||
data AuthContext = AuthContext
|
||||
@ -546,6 +546,23 @@ tagAccessPredicate AuthAdmin = cacheAPSchoolFunction SchoolAdmin (Just $ Right d
|
||||
adrights <- lift $ selectFirst [UserFunctionUser ==. authId, UserFunctionFunction ==. SchoolAdmin] []
|
||||
guardMExceptT (isJust adrights) (unauthorizedI MsgUnauthorizedSiteAdmin)
|
||||
return Authorized
|
||||
tagAccessPredicate AuthSupervisor = falseAP
|
||||
{- cacheAPDB -- TODO: use memcachedByInvalidate to invalidate Cache on change
|
||||
|
||||
I'm to dumb to figure this out. :(
|
||||
|
||||
cacheAPSystemFunction SystemPrinter (Just $ Right diffHour) $ \mAuthId' _ _ printerList -> if
|
||||
| maybe True (`Set.notMember` printerList) mAuthId' -> Right $ if
|
||||
| is _Nothing mAuthId' -> return AuthenticationRequired
|
||||
| otherwise -> unauthorizedI MsgUnauthorizedSystemPrinter
|
||||
| otherwise -> Left $ APDB $ \_ _ mAuthId _ _ -> $cachedHereBinary mAuthId . exceptT return return $ do
|
||||
authId <- maybeExceptT AuthenticationRequired $ return mAuthId
|
||||
isPrinter <- lift $ exists [UserSystemFunctionUser ==. authId, UserSystemFunctionFunction ==. SystemPrinter, UserSystemFunctionIsOptOut ==. False]
|
||||
guardMExceptT isPrinter $ unauthorizedI MsgUnauthorizedSystemPrinter
|
||||
return Authorized
|
||||
SchoolR ssh _ -> $cachedHereBinary (mAuthId, ssh) . exceptT return return $ do
|
||||
-}
|
||||
|
||||
tagAccessPredicate AuthSystemExamOffice = cacheAPSystemFunction SystemExamOffice (Just $ Right diffHour) $ \mAuthId' _ _ examOfficeList -> if
|
||||
| maybe True (`Set.notMember` examOfficeList) mAuthId' -> Right $ if
|
||||
| is _Nothing mAuthId' -> return AuthenticationRequired
|
||||
|
||||
@ -170,14 +170,16 @@ breadcrumb (LmsResultUploadR ssh qsh) = i18nCrumb MsgMenuLmsUpload $ Jus
|
||||
breadcrumb (LmsResultDirectR ssh qsh) = i18nCrumb MsgMenuLmsUpload $ Just $ LmsResultR ssh qsh -- never displayed
|
||||
breadcrumb (LmsFakeR ssh qsh) = i18nCrumb MsgMenuLmsFake $ Just $ LmsR ssh qsh -- TODO: remove in production
|
||||
|
||||
breadcrumb ProfileR = i18nCrumb MsgBreadcrumbProfile Nothing
|
||||
breadcrumb SetDisplayEmailR = i18nCrumb MsgUserDisplayEmail $ Just ProfileR
|
||||
breadcrumb ProfileDataR = i18nCrumb MsgMenuProfileData $ Just ProfileR
|
||||
breadcrumb AuthPredsR = i18nCrumb MsgMenuAuthPreds $ Just ProfileR
|
||||
breadcrumb CsvOptionsR = i18nCrumb MsgCsvOptions $ Just ProfileR
|
||||
breadcrumb LangR = i18nCrumb MsgMenuLanguage $ Just ProfileR
|
||||
breadcrumb ProfileR = i18nCrumb MsgBreadcrumbProfile Nothing
|
||||
breadcrumb ForProfileR{} = i18nCrumb MsgBreadcrumbProfile Nothing
|
||||
breadcrumb SetDisplayEmailR = i18nCrumb MsgUserDisplayEmail $ Just ProfileR
|
||||
breadcrumb ProfileDataR = i18nCrumb MsgMenuProfileData $ Just ProfileR
|
||||
breadcrumb (ForProfileDataR cID) = i18nCrumb MsgMenuProfileData $ Just (ForProfileR cID)
|
||||
breadcrumb AuthPredsR = i18nCrumb MsgMenuAuthPreds $ Just ProfileR
|
||||
breadcrumb CsvOptionsR = i18nCrumb MsgCsvOptions $ Just ProfileR
|
||||
breadcrumb LangR = i18nCrumb MsgMenuLanguage $ Just ProfileR
|
||||
|
||||
breadcrumb StorageKeyR = i18nCrumb MsgBreadcrumbStorageKey Nothing
|
||||
breadcrumb StorageKeyR = i18nCrumb MsgBreadcrumbStorageKey Nothing
|
||||
|
||||
breadcrumb TermShowR = i18nCrumb MsgMenuTermShow $ Just NewsR
|
||||
breadcrumb TermCurrentR = i18nCrumb MsgMenuTermCurrent $ Just TermShowR
|
||||
@ -1399,6 +1401,19 @@ pageActions ProfileR = return
|
||||
, navChildren = []
|
||||
}
|
||||
]
|
||||
pageActions (ForProfileR cID) = return
|
||||
[ NavPageActionPrimary
|
||||
{ navLink = NavLink
|
||||
{ navLabel = MsgMenuProfileData
|
||||
, navRoute = ForProfileDataR cID
|
||||
, navAccess' = NavAccessTrue
|
||||
, navType = NavTypeLink { navModal = False }
|
||||
, navQuick' = mempty
|
||||
, navForceActive = False
|
||||
}
|
||||
, navChildren = []
|
||||
}
|
||||
]
|
||||
pageActions TermShowR = do
|
||||
participantsSecondary <- pageQuickActions NavQuickViewPageActionSecondary ParticipantsListR
|
||||
return
|
||||
|
||||
@ -363,7 +363,7 @@ mkLmsTable (Entity qid quali) acts restrict cols psValidator = do
|
||||
pjob <- preview $ _dbtProjRow . resultPrintJob
|
||||
forMM_ (view $ _dbtProjFilter . _ltProjFilterMayAccess) $ \b -> do
|
||||
euid <- encrypt $ user ^. _entityKey
|
||||
guardM . lift . lift . fmap (== b) . hasReadAccessTo . urlRoute $ ForProfuleDataR euid -- TODO create a page with proper rights; this is only for admins!
|
||||
guardM . lift . lift . fmap (== b) . hasReadAccessTo . urlRoute $ ForProfileDataR euid -- TODO create a page with proper rights; this is only for admins!
|
||||
return (qusr,user,lusr,pjob)
|
||||
|
||||
dbtColonnade = cols
|
||||
|
||||
@ -1,6 +1,8 @@
|
||||
module Handler.Profile
|
||||
( getProfileR, postProfileR
|
||||
, getProfileDataR, makeProfileData
|
||||
, getForProfileR, postForProfileR
|
||||
, getProfileDataR, makeProfileData
|
||||
, getForProfileDataR
|
||||
, getAuthPredsR, postAuthPredsR
|
||||
, getUserNotificationR, postUserNotificationR
|
||||
, getSetDisplayEmailR, postSetDisplayEmailR
|
||||
@ -478,10 +480,19 @@ instance Finite ProfileAnchor
|
||||
nullaryPathPiece ''ProfileAnchor $ camelToPathPiece' 1
|
||||
|
||||
|
||||
getProfileR, postProfileR :: Handler Html
|
||||
getProfileR = postProfileR
|
||||
postProfileR = do
|
||||
(uid, user@User{..}) <- requireAuthPair
|
||||
getForProfileR , postForProfileR :: CryptoUUIDUser -> Handler Html
|
||||
getForProfileR = postForProfileR
|
||||
postForProfileR cID = do
|
||||
uid <- decrypt cID
|
||||
user <- runDB $ get404 uid
|
||||
serveProfileR (uid, user)
|
||||
|
||||
getProfileR, postProfileR :: Handler Html
|
||||
getProfileR = postProfileR
|
||||
postProfileR = requireAuthPair >>= serveProfileR
|
||||
|
||||
serveProfileR :: (UserId, User) -> Handler Html
|
||||
serveProfileR (uid, user@User{..}) = do
|
||||
(userSchools, userExamOfficeLabels) <- runDB $ do
|
||||
userSchools <- fmap (setOf $ folded . _Value) . E.select . E.from $ \school -> do
|
||||
E.where_ . E.exists . E.from $ \userSchool ->
|
||||
@ -628,6 +639,14 @@ getProfileDataR = do
|
||||
setTitleI MsgHeadingProfileData
|
||||
dataWidget
|
||||
|
||||
getForProfileDataR :: CryptoUUIDUser -> Handler Html
|
||||
getForProfileDataR cID = do
|
||||
uid <- decrypt cID
|
||||
(user,dataWidget) <- runDB $ bind2 (get404 uid) $ makeProfileData . Entity uid
|
||||
defaultLayout $ do
|
||||
setTitleI $ MsgHeadingForProfileData $ userDisplayName user
|
||||
dataWidget
|
||||
|
||||
makeProfileData :: Entity User -> DB Widget
|
||||
makeProfileData (Entity uid User{..}) = do
|
||||
functions <- Map.fromListWith Set.union . map (\(Entity _ UserFunction{..}) -> (userFunctionFunction, Set.singleton userFunctionSchool)) <$> selectList [UserFunctionUser ==. uid] []
|
||||
|
||||
Loading…
Reference in New Issue
Block a user