diff --git a/messages/uniworx/categories/settings/de-de-formal.msg b/messages/uniworx/categories/settings/de-de-formal.msg index 3e28acf22..d4b9aff9e 100644 --- a/messages/uniworx/categories/settings/de-de-formal.msg +++ b/messages/uniworx/categories/settings/de-de-formal.msg @@ -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 diff --git a/messages/uniworx/categories/settings/en-eu.msg b/messages/uniworx/categories/settings/en-eu.msg index aabf912ab..93bcb934c 100644 --- a/messages/uniworx/categories/settings/en-eu.msg +++ b/messages/uniworx/categories/settings/en-eu.msg @@ -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 diff --git a/routes b/routes index b44324da6..8f1da5937 100644 --- a/routes +++ b/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 diff --git a/src/Foundation/Authorization.hs b/src/Foundation/Authorization.hs index f77635ce8..fa1fbbe50 100644 --- a/src/Foundation/Authorization.hs +++ b/src/Foundation/Authorization.hs @@ -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 diff --git a/src/Foundation/Navigation.hs b/src/Foundation/Navigation.hs index 1a80d4049..da2c4b94f 100644 --- a/src/Foundation/Navigation.hs +++ b/src/Foundation/Navigation.hs @@ -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 diff --git a/src/Handler/LMS.hs b/src/Handler/LMS.hs index 8a925bb14..521fb6f5c 100644 --- a/src/Handler/LMS.hs +++ b/src/Handler/LMS.hs @@ -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 diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs index e953e9d47..ad60473fd 100644 --- a/src/Handler/Profile.hs +++ b/src/Handler/Profile.hs @@ -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] []