chore(supervisor): add profile pages for supervisors

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

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

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/upload  LmsUserlistUploadR	  GET POST  --   development
-/lms/#SchoolId/#QualificationShorthand/userlist/direct  LmsUserlistDirectR	      POST  !token
+/lms/#SchoolId/#QualificationShorthand/userlist/direct  LmsUserlistDirectR	      POST  --   token
-/lms/#SchoolId/#QualificationShorthand/result           LmsResultR            GET POST  
+/lms/#SchoolId/#QualificationShorthand/result           LmsResultR            GET POST   
-/lms/#SchoolId/#QualificationShorthand/result/upload    LmsResultUploadR      GET POST  !development
+/lms/#SchoolId/#QualificationShorthand/result/upload    LmsResultUploadR      GET POST  --   development
-/lms/#SchoolId/#QualificationShorthand/result/direct    LmsResultDirectR          POST  !token
+/lms/#SchoolId/#QualificationShorthand/result/direct    LmsResultDirectR          POST  --   token
-/lms/#SchoolId/#QualificationShorthand/fake             LmsFakeR              GET POST  !development -- TODO: delete this testing URL
+/lms/#SchoolId/#QualificationShorthand/fake             LmsFakeR              GET POST  --   development -- TODO: delete this testing URL
 
 /api           ApiDocsR              GET      !free
 /swagger       SwaggerR              GET      !free

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

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 ProfileR               = i18nCrumb MsgBreadcrumbProfile   Nothing
-breadcrumb SetDisplayEmailR = i18nCrumb MsgUserDisplayEmail  $ Just ProfileR
+breadcrumb ForProfileR{}          = i18nCrumb MsgBreadcrumbProfile   Nothing
-breadcrumb ProfileDataR     = i18nCrumb MsgMenuProfileData   $ Just ProfileR
+breadcrumb SetDisplayEmailR       = i18nCrumb MsgUserDisplayEmail  $ Just ProfileR
-breadcrumb AuthPredsR       = i18nCrumb MsgMenuAuthPreds     $ Just ProfileR
+breadcrumb ProfileDataR           = i18nCrumb MsgMenuProfileData   $ Just ProfileR
-breadcrumb CsvOptionsR      = i18nCrumb MsgCsvOptions        $ Just ProfileR
+breadcrumb (ForProfileDataR cID)  = i18nCrumb MsgMenuProfileData   $ Just (ForProfileR cID)
-breadcrumb LangR            = i18nCrumb MsgMenuLanguage      $ Just ProfileR
+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

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

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
+getForProfileR , postForProfileR :: CryptoUUIDUser -> Handler Html
-getProfileR = postProfileR
+getForProfileR = postForProfileR
-postProfileR = do
+postForProfileR cID = do 
-  (uid, user@User{..}) <- requireAuthPair
+  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] []