From 61991aadc40fbbd24930b7e50c7e914c5a348a5e Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 7 Oct 2022 16:17:46 +0200 Subject: [PATCH 01/41] chore(avs): wip refactor qualifications view --- models/avs.model | 19 +++++++++++++++---- routes | 30 +++++++++++++++++------------- src/Auth/LDAP.hs | 4 +++- src/Handler/LMS.hs | 23 +++++++++++++++++++++-- src/Utils/Avs.hs | 1 + 5 files changed, 57 insertions(+), 20 deletions(-) diff --git a/models/avs.model b/models/avs.model index 5ce175d1a..c03fc538b 100644 --- a/models/avs.model +++ b/models/avs.model @@ -1,14 +1,25 @@ -- Tables to save data received AVS --- Purpose is to detect external changes in qualifications and postal addresses + +-- When creating an AvsUser the following cases are possible: +-- 1. User does not exist, hence a new UserId ought to be created. +-- 2. User does exists and can be matched by UserCompanyPersonalNumber +-- 3. User does exists but cannot be matched now :( +-- How can the matching be performed later? +-- Do we need to merge users? +-- > Handler.Utils.UsersassimilateUser + + UserAvs personId AvsPersonId -- unique identifier for user throughout avs - user UserId + user UserId UniqueUserAvsUser user - UniqueUserAvsId personId + UniqueUserAvsId personId deriving Generic +-- Multiple UserAvsCards per UserAvs is possible and not too uncommon. +-- Purpose of saving cards is to detect external changes in qualifications and postal addresses UserAvsCard - personId AvsPersonId + personId AvsPersonId cardNo AvsCardNo card AvsDataPersonCard lastSynch UTCTime diff --git a/routes b/routes index d1ec9cf1b..750a1703a 100644 --- a/routes +++ b/routes @@ -84,13 +84,17 @@ /external-apis ExternalApisR ServantApiExternalApis getServantApi -/user ProfileR GET POST !free -/user/profile ProfileDataR GET !free -/user/authpreds AuthPredsR GET POST !free -/user/set-display-email SetDisplayEmailR GET POST !free -/user/csv-options CsvOptionsR GET POST !free -/user/lang LangR POST !free -/user/storage-key StorageKeyR POST !free +/user ProfileR GET POST !free +/user/profile ProfileDataR GET !free +/user/authpreds AuthPredsR GET POST !free +/user/set-display-email SetDisplayEmailR GET POST !free +/user/csv-options CsvOptionsR GET POST !free +/user/lang LangR POST !free +/user/storage-key StorageKeyR POST !free + +-- /user/for/#CryptoUUIDUser ForProfileR GET POST !supervisor +-- /user/profile/for/#CryptoUUIDUser ForProfuleDataR GET !supervisor + /exam-office ExamOfficeR !exam-office: / EOExamsR GET POST !system-exam-office @@ -265,13 +269,13 @@ -- !/*{CI FilePath} CryptoFileNameDispatchR GET !free -- Disabled until preliminary check for valid cID exists -- for users -/qualification QualificationAllR GET !free -/qualification/#SchoolId QualificationSchoolR GET !free -- TODO -/qualification/#SchoolId/#QualificationShorthand QualificationR GET -- TODO make !free again after repurpose +/qualification QualificationAllR GET !free -- TODO repurpose +/qualification/#SchoolId QualificationSchoolR GET !free -- TODO repurpose +/qualification/#SchoolId/#QualificationShorthand QualificationR GET !free -- TODO repurpose -- OSIS CSV Export Demo -/lms LmsAllR GET POST -/lms/#SchoolId LmsSchoolR GET -/lms/#SchoolId/#QualificationShorthand LmsR GET POST +/lms LmsAllR GET POST !free -- TODO verify that this is ok +/lms/#SchoolId LmsSchoolR GET !free -- TODO verify that this is ok +/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 diff --git a/src/Auth/LDAP.hs b/src/Auth/LDAP.hs index 1990b40a3..2bfc7587c 100644 --- a/src/Auth/LDAP.hs +++ b/src/Auth/LDAP.hs @@ -59,8 +59,10 @@ findUser conf@LdapConf{..} ldap ident retAttrs = fromMaybe [] <$> findM (assertM [ ldapUserEmail' Ldap.:= Text.encodeUtf8 ident' | ident' <- [ident, [st|#{ident}@lmu.de|], [st|#{ident}@fraport.de|]] , ldapUserEmail' <- toList ldapUserEmail + -- ] ++ + -- [ ldapUserDisplayName Ldap.:= Text.encodeUtf8 ident -- for Fraport, userDisplayName has the pattern "Surname, Firstnames" ] ++ - [ ldapUserDisplayName Ldap.:= Text.encodeUtf8 ident + [ ldapUserFraportPersonalnummer Ldap.:= Text.encodeUtf8 ident ] findUserMatr :: LdapConf -> Ldap -> Text -> [Ldap.Attr] -> IO [Ldap.SearchEntry] diff --git a/src/Handler/LMS.hs b/src/Handler/LMS.hs index 116d864e0..d75ed1010 100644 --- a/src/Handler/LMS.hs +++ b/src/Handler/LMS.hs @@ -324,6 +324,14 @@ lmsTableQuery qid (qualUser `E.InnerJoin` user `E.LeftOuterJoin` lmsUser `E.Left return (qualUser, user, lmsUser, printJob) +newtype LmsTableFilterProj = LmsTableFilterProj { ltProjFilterMayAccess :: Maybe Bool } + +instance Default LmsTableFilterProj where + def = LmsTableFilterProj + { ltProjFilterMayAccess = Nothing } + +makeLenses_ ''LmsTableFilterProj + mkLmsTable :: forall h p cols act act'. ( Functor h, ToSortable h , Ord act, PathPiece act, RenderMessage UniWorX act @@ -347,7 +355,17 @@ mkLmsTable (Entity qid quali) acts restrict cols psValidator = do dbtIdent = "qualification" dbtSQLQuery q = lmsTableQuery qid q <* E.where_ (restrict q) dbtRowKey = queryUser >>> (E.^. UserId) - dbtProj = dbtProjFilteredPostId + --dbtProj = dbtProjFilteredPostId + dbtProj = (views _dbtProjRow . set _dbrOutput) =<< do + qusr <- view $ _dbtProjRow . resultQualUser + user <- view $ _dbtProjRow . resultUser + lusr <- preview $ _dbtProjRow . resultLmsUser + pjob <- preview $ _dbtProjRow . resultPrintJob + forMM_ (view $ _dbtProjFilter . _ltProjFilterMayAccess) $ \b -> do + euid <- encrypt $ user ^. _entityKey + guardM . lift . lift . fmap (== b) . hasReadAccessTo . urlRoute $ AdminUserR euid -- TODO create a page with proper rights; this is only for admins! + return (qusr,user,lusr,pjob) + dbtColonnade = cols dbtSorting = mconcat [ single $ sortUserNameLink queryUser @@ -367,7 +385,8 @@ mkLmsTable (Entity qid quali) acts restrict cols psValidator = do , single ("lms-ended" , SortColumn $ queryLmsUser >>> (E.?. LmsUserEnded)) ] dbtFilter = mconcat - [ single $ fltrUserNameEmail queryUser + [ single ("may-access" , FilterProjected $ (_ltProjFilterMayAccess ?~) . getAny) + , single $ fltrUserNameEmail queryUser , single ("lms-ident" , FilterColumn . E.mkContainsFilterWith (Just . LmsIdent) $ views (to queryLmsUser) (E.?. LmsUserIdent)) -- , single ("lms-status" , FilterColumn . E.mkExactFilterLast $ views (to queryLmsUser) ((E.>=. E.val nowaday) . (E.^. LmsUserStatus))) -- LmsStatus cannot be filtered easily within the DB , single ("validity" , FilterColumn . E.mkExactFilterLast $ views (to queryQualUser) ((E.>=. E.val nowaday) . (E.^. QualificationUserValidUntil))) diff --git a/src/Utils/Avs.hs b/src/Utils/Avs.hs index 15b65b39a..6799ac701 100644 --- a/src/Utils/Avs.hs +++ b/src/Utils/Avs.hs @@ -128,6 +128,7 @@ bestAddress :: AvsDataPersonCard -> AvsDataPersonCard -> Ordering compareBy f = compare `on` f a b -} +-- Merges several answers by AvsPersonId, preserving all AvsPersonCards mergeByPersonId :: Set AvsDataPerson -> Map AvsPersonId AvsDataPerson -> Map AvsPersonId AvsDataPerson mergeByPersonId = flip $ Set.foldr aux where From 1f8e76d68b1591a68d1f462c89929c18681ba97b Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 7 Oct 2022 17:49:38 +0200 Subject: [PATCH 02/41] chore(supervisor): adding a supervisor auth tag WIP --- .../settings/auth_settings/de-de-formal.msg | 1 + .../settings/auth_settings/en-eu.msg | 1 + routes | 18 +++++++++--------- src/Handler/LMS.hs | 2 +- src/Model/Types/Security.hs | 1 + 5 files changed, 13 insertions(+), 10 deletions(-) diff --git a/messages/uniworx/categories/settings/auth_settings/de-de-formal.msg b/messages/uniworx/categories/settings/auth_settings/de-de-formal.msg index 95f1a6d85..e7cce8c1d 100644 --- a/messages/uniworx/categories/settings/auth_settings/de-de-formal.msg +++ b/messages/uniworx/categories/settings/auth_settings/de-de-formal.msg @@ -54,3 +54,4 @@ AuthTagSubmissionGroup: Nutzer:in ist Mitglied in registrierter Abgabegruppe AuthTagWorkflow: Nutzer:in hat passende Workflow-Rolle AuthTagStudent: Nutzer:in ist Student:in AuthTagExamTime: Zeitliche Einschränkungen durch relevante Prüfung sind erfüllt +AuthTagSupervisor: Nutzer:in ist Ansprechpartner für jemand anderes \ No newline at end of file diff --git a/messages/uniworx/categories/settings/auth_settings/en-eu.msg b/messages/uniworx/categories/settings/auth_settings/en-eu.msg index 98dcfe1ac..b66c53d1b 100644 --- a/messages/uniworx/categories/settings/auth_settings/en-eu.msg +++ b/messages/uniworx/categories/settings/auth_settings/en-eu.msg @@ -54,3 +54,4 @@ AuthTagSubmissionGroup: User is part of a submission group AuthTagWorkflow: User has matching workflow role AuthTagStudent: User is a student AuthTagExamTime: Exam time restrictions are satisfied +AuthTagSupervisor: User is supervisor for someone else diff --git a/routes b/routes index 750a1703a..b44324da6 100644 --- a/routes +++ b/routes @@ -92,8 +92,8 @@ /user/lang LangR POST !free /user/storage-key StorageKeyR POST !free --- /user/for/#CryptoUUIDUser ForProfileR GET POST !supervisor --- /user/profile/for/#CryptoUUIDUser ForProfuleDataR GET !supervisor +/user/for/#CryptoUUIDUser ForProfileR GET POST !supervisor +/user/profile/for/#CryptoUUIDUser ForProfuleDataR 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 +/lms/#SchoolId/#QualificationShorthand/users/direct LmsUsersDirectR GET !development /lms/#SchoolId/#QualificationShorthand/userlist LmsUserlistR GET POST -/lms/#SchoolId/#QualificationShorthand/userlist/upload LmsUserlistUploadR GET POST -/lms/#SchoolId/#QualificationShorthand/userlist/direct LmsUserlistDirectR POST -/lms/#SchoolId/#QualificationShorthand/result LmsResultR GET POST -/lms/#SchoolId/#QualificationShorthand/result/upload LmsResultUploadR GET POST -/lms/#SchoolId/#QualificationShorthand/result/direct LmsResultDirectR POST -/lms/#SchoolId/#QualificationShorthand/fake LmsFakeR GET POST -- 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/Handler/LMS.hs b/src/Handler/LMS.hs index d75ed1010..8a925bb14 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 $ AdminUserR euid -- TODO create a page with proper rights; this is only for admins! + guardM . lift . lift . fmap (== b) . hasReadAccessTo . urlRoute $ ForProfuleDataR euid -- TODO create a page with proper rights; this is only for admins! return (qusr,user,lusr,pjob) dbtColonnade = cols diff --git a/src/Model/Types/Security.hs b/src/Model/Types/Security.hs index 2d7915795..8a40f084a 100644 --- a/src/Model/Types/Security.hs +++ b/src/Model/Types/Security.hs @@ -115,6 +115,7 @@ data AuthTag -- sortiert nach gewünschter Reihenfolge auf /authpreds, d.h. Prä | AuthToken | AuthDeprecated | AuthDevelopment + | AuthSupervisor | AuthFree deriving (Eq, Ord, Enum, Bounded, Read, Show, Data, Generic, Typeable) deriving anyclass (Universe, Finite, Hashable, NFData) From f36b5ee4d062a2a3c2a5aab2bcbf49beeba2a893 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Mon, 10 Oct 2022 18:09:24 +0200 Subject: [PATCH 03/41] chore(supervisor): add profile pages for supervisors --- .../categories/settings/de-de-formal.msg | 1 + .../uniworx/categories/settings/en-eu.msg | 1 + routes | 16 +++++----- src/Foundation/Authorization.hs | 21 ++++++++++++-- src/Foundation/Navigation.hs | 29 ++++++++++++++----- src/Handler/LMS.hs | 2 +- src/Handler/Profile.hs | 29 +++++++++++++++---- 7 files changed, 76 insertions(+), 23 deletions(-) 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] [] From 84e3097706504eacb3258ade020499447d5d726e Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 11 Oct 2022 17:20:20 +0200 Subject: [PATCH 04/41] fix build. No idea what was wrong though. --- routes | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/routes b/routes index 8f1da5937..15cad2ad9 100644 --- a/routes +++ b/routes @@ -10,7 +10,7 @@ -- Admins always have access to entities within their assigned schools. -- -- Access tags are defined in Model.Types.Security --- +-- -- Access Tags: -- !free -- free for all -- !lecturer -- lecturer for this course (or for any school, if route is not connected to a course) @@ -62,7 +62,7 @@ /admin/tokens AdminTokensR GET POST /admin/crontab AdminCrontabR GET /admin/avs AdminAvsR GET POST -/admin/ldap AdminLdapR GET POST +/admin/ldap AdminLdapR GET POST /print PrintCenterR GET POST !system-printer /print/acknowledge/#Day/#Int/#Int PrintAcknowR GET POST !system-printer @@ -282,10 +282,10 @@ /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/fake LmsFakeR GET POST -- development -- TODO: delete this testing URL +/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 From ddca9f6688820aca00e1e4914868f0add61e9780 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 11 Oct 2022 18:52:33 +0200 Subject: [PATCH 05/41] chore(supervisor): access tag implemented --- .../categories/authorization/de-de-formal.msg | 1 + .../categories/authorization/en-eu.msg | 1 + models/users.model | 10 +++++-- routes | 11 ++++---- src/Foundation/Authorization.hs | 28 ++++++++----------- 5 files changed, 27 insertions(+), 24 deletions(-) diff --git a/messages/uniworx/categories/authorization/de-de-formal.msg b/messages/uniworx/categories/authorization/de-de-formal.msg index 3f9d02ca2..1921bc0f1 100644 --- a/messages/uniworx/categories/authorization/de-de-formal.msg +++ b/messages/uniworx/categories/authorization/de-de-formal.msg @@ -15,6 +15,7 @@ UnauthorizedTokenInvalidAuthorityGroup: Ihr Authorisierungs-Token basiert auf de UnauthorizedTokenInvalidAuthorityValue: Ihr Authorisierungs-Token basiert auf Rechten, deren Spezifikation nicht interpretiert werden konnte. UnauthorizedTokenInvalidImpersonation: Ihr Authorisierungs-Token enthält die Anweisung sich als ein Nutzer:in auszugeben, dies ist jedoch nicht allen Benutzer:innen, auf deren Rechten ihr Authorisierungs-Token basiert, erlaubt. UnauthorizedToken404: Authorisierungs-Tokens können nicht auf Fehlerseiten ausgewertet werden. +UnauthorizedSupervisor: Sie sind kein Ansprechpartner:in für diesen Benuzter:in. UnauthorizedSiteAdmin: Sie sind nicht System-weiter Administrator:in. UnauthorizedSchoolAdmin: Sie sind nicht als Administrator:in für dieses Institut eingetragen. UnauthorizedAdminEscalation: Sie sind nicht Administrator:in für alle Institute, für die dieser Nutzer/diese Nutzerin Administrator:in oder Veranstalter:in ist. diff --git a/messages/uniworx/categories/authorization/en-eu.msg b/messages/uniworx/categories/authorization/en-eu.msg index f5e82dd4c..5b4586cb6 100644 --- a/messages/uniworx/categories/authorization/en-eu.msg +++ b/messages/uniworx/categories/authorization/en-eu.msg @@ -15,6 +15,7 @@ UnauthorizedTokenInvalidAuthorityGroup: Your authorisation-token is based in an UnauthorizedTokenInvalidAuthorityValue: The specification of the rights in which your authorisation-token is based, could not be interpreted. UnauthorizedTokenInvalidImpersonation: Your authorisation-token contains an instruction to impersonate an user. Not all users on whose rights your token is based however are permitted to do so. UnauthorizedToken404: Authorisation-tokens cannot be processed on error pages. +UnauthorizedSupervisor: You are not a supervisor for the requested user. UnauthorizedSiteAdmin: You are no system-wide administrator. UnauthorizedSchoolAdmin: You are no administrator for this department. UnauthorizedAdminEscalation: You aren't an administrator for all departments for which this user is an administrator. diff --git a/models/users.model b/models/users.model index 7bc14297a..be3dd5807 100644 --- a/models/users.model +++ b/models/users.model @@ -76,9 +76,13 @@ UserGroupMember group UserGroupName user UserId primary Checkmark nullable - UniquePrimaryUserGroupMember group primary !force UniqueUserGroupMember group user - deriving Generic - +UserSupervisor + supervisor UserId -- multiple supervisor per trainee possible + user UserId + rerouteNotifications Bool + UniqueUserSupervisor supervisor user + deriving Generic + \ No newline at end of file diff --git a/routes b/routes index 15cad2ad9..490b35d35 100644 --- a/routes +++ b/routes @@ -34,6 +34,7 @@ -- !read -- only if it is read-only access (i.e. GET but not POST) -- !write -- only if it is write access (i.e. POST only, included for completeness) -- +-- !token -- requires bearer token -- !no-escalation -- -- !deprecated -- like free, but logs and gives a warning; entirely disabled in production -- !development -- like free, but only for development builds @@ -92,8 +93,8 @@ /user/lang LangR POST !free /user/storage-key StorageKeyR POST !free -/user/for/#CryptoUUIDUser ForProfileR GET POST !supervisor -/user/profile/for/#CryptoUUIDUser ForProfileDataR GET !supervisor +/for/#CryptoUUIDUser/user ForProfileR GET POST !supervisor +/for/#CryptoUUIDUser/user/profile ForProfileDataR GET !supervisor /exam-office ExamOfficeR !exam-office: @@ -281,11 +282,11 @@ /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/fake LmsFakeR GET POST -- development -- TODO: delete this testing URL +/lms/#SchoolId/#QualificationShorthand/userlist/direct LmsUserlistDirectR POST !token +/lms/#SchoolId/#QualificationShorthand/fake LmsFakeR GET POST !development -- TODO: delete this testing URL /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/result/direct LmsResultDirectR POST !token /api ApiDocsR GET !free /swagger SwaggerR GET !free diff --git a/src/Foundation/Authorization.hs b/src/Foundation/Authorization.hs index fa1fbbe50..4c6189676 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,22 +546,18 @@ 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 +tagAccessPredicate AuthSupervisor = APDB $ \_ _ mAuthId route _ -> case route of + ForProfileR cID -> checkSupervisor (mAuthId, cID) + ForProfileDataR cID -> checkSupervisor (mAuthId, cID) + r -> $unsupportedAuthPredicate AuthSupervisor r + where + checkSupervisor sup@(mAuthId, cID) = $cachedHereBinary sup . 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 - -} + uid <- decrypt cID + isSupervisor <- lift . existsBy $ UniqueUserSupervisor authId uid + guardMExceptT isSupervisor (unauthorizedI MsgUnauthorizedSupervisor) + return Authorized tagAccessPredicate AuthSystemExamOffice = cacheAPSystemFunction SystemExamOffice (Just $ Right diffHour) $ \mAuthId' _ _ examOfficeList -> if | maybe True (`Set.notMember` examOfficeList) mAuthId' -> Right $ if From 184ccbc7a60f8a3baded3f30eabeb6649ffd331b Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Thu, 13 Oct 2022 16:24:26 +0200 Subject: [PATCH 06/41] chore(notifications): send notifications to supervisors, but it wont work --- src/Jobs/Handler/SendNotification.hs | 10 ++++++++-- 1 file changed, 8 insertions(+), 2 deletions(-) diff --git a/src/Jobs/Handler/SendNotification.hs b/src/Jobs/Handler/SendNotification.hs index 4b31fcafa..80574a065 100644 --- a/src/Jobs/Handler/SendNotification.hs +++ b/src/Jobs/Handler/SendNotification.hs @@ -24,5 +24,11 @@ import Jobs.Handler.SendNotification.Qualification dispatchJobSendNotification :: UserId -> Notification -> JobHandler UniWorX -dispatchJobSendNotification jRecipient jNotification = JobHandlerException $ - $(dispatchTH ''Notification) jNotification jRecipient +dispatchJobSendNotification jRecipient jNotification = JobHandlerException $ do + -- TODO: this is a bad idea, since all notifications use jRecipient to generate the message body, + -- thus supervisors would receive all notifications with their own name inside! + superVs <- runDB $ selectList [UserSupervisorUser ==. jRecipient, UserSupervisorRerouteNotifications ==. True] [] + if null superVs + then $(dispatchTH ''Notification) jNotification jRecipient + else forM_ superVs $ \Entity { entityVal = UserSupervisor { userSupervisorSupervisor = svr } } -> + $(dispatchTH ''Notification) jNotification svr From 56af63adc0bb61dd0fa2b5ae0d0e84f6f5ea247e Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Thu, 13 Oct 2022 18:17:38 +0200 Subject: [PATCH 07/41] chore(user): assimilateUser considers qualifications (wip) --- src/Database/Esqueleto/Utils.hs | 6 +++-- src/Handler/Utils/Users.hs | 37 ++++++++++++++++++++++++++-- src/Jobs/Handler/SendNotification.hs | 10 ++++++++ 3 files changed, 49 insertions(+), 4 deletions(-) diff --git a/src/Database/Esqueleto/Utils.hs b/src/Database/Esqueleto/Utils.hs index 228179f9c..e0b93ee5b 100644 --- a/src/Database/Esqueleto/Utils.hs +++ b/src/Database/Esqueleto/Utils.hs @@ -26,7 +26,7 @@ module Database.Esqueleto.Utils , maybe, maybe2, maybeEq, guardMaybe, unsafeCoalesce , bool , max, min - , greatest + , greatest, least , abs , SqlProject(..) , (->.), (#>>.) @@ -36,7 +36,7 @@ module Database.Esqueleto.Utils , selectMaybe , day, diffDays, diffTimes , exprLift - , explicitUnsafeCoerceSqlExprValue + , explicitUnsafeCoerceSqlExprValue , module Database.Esqueleto.Utils.TH ) where @@ -435,6 +435,8 @@ min a b = bool a b $ b E.<. a greatest :: PersistField a => (E.SqlExpr (E.Value a), E.SqlExpr (E.Value a)) -> E.SqlExpr (E.Value a) greatest = E.unsafeSqlFunction "GREATEST" . E.toArgList +least :: PersistField a => (E.SqlExpr (E.Value a), E.SqlExpr (E.Value a)) -> E.SqlExpr (E.Value a) +least = E.unsafeSqlFunction "LEAST" . E.toArgList abs :: (PersistField a, Num a) diff --git a/src/Handler/Utils/Users.hs b/src/Handler/Utils/Users.hs index 5a50fcd79..6a2bd800e 100644 --- a/src/Handler/Utils/Users.hs +++ b/src/Handler/Utils/Users.hs @@ -243,7 +243,7 @@ assimilateUser :: UserId -- ^ @newUserId@ -- ^ Move all relevant properties (submissions, corrections, grades, ...) from @oldUserId@ to @newUserId@ -- -- Fatal errors are thrown, non-fatal warnings are returned -assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do +assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do E.insertSelectWithConflict UniqueCourseFavourite (E.from $ \courseFavourite -> do @@ -779,7 +779,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do E.<&> E.val newUserId E.<&> (systemMessageHidden E.^. SystemMessageHiddenTime) ) - (\current excluded -> [ SystemMessageHiddenTime E.=. E.max (current E.^. SystemMessageHiddenTime) (excluded E.^. SystemMessageHiddenTime) ]) + (\current excluded -> [ SystemMessageHiddenTime E.=. combineWith current excluded E.max SystemMessageHiddenTime]) deleteWhere [ SystemMessageHiddenUser ==. oldUserId ] let getStudyFeatures = selectSource [ StudyFeaturesUser ==. oldUserId ] [] @@ -808,6 +808,29 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do delete oldSFId in runConduit $ getStudyFeatures .| C.mapM_ upsertStudyFeatures + -- lms + E.insertSelectWithConflict + UniqueQualificationUser + (E.from $ \qualificationUser -> do + E.where_ $ qualificationUser E.^. QualificationUserUser E.==. E.val oldUserId + return $ QualificationUser + E.<# E.val newUserId + E.<&> (qualificationUser E.^. QualificationUserQualification) + E.<&> (qualificationUser E.^. QualificationUserValidUntil) + E.<&> (qualificationUser E.^. QualificationUserLastRefresh) + E.<&> (qualificationUser E.^. QualificationUserFirstHeld) + E.<&> (qualificationUser E.^. QualificationUserBlockedDue) + ) + (\current excluded -> + [ QualificationUserValidUntil E.=. combineWith current excluded E.max QualificationUserValidUntil + , QualificationUserLastRefresh E.=. combineWith current excluded E.max QualificationUserLastRefresh + , QualificationUserFirstHeld E.=. combineWith current excluded E.min QualificationUserFirstHeld + , QualificationUserBlockedDue E.=. combineWith current excluded E.max QualificationUserBlockedDue + ] + ) + -- TODO: LmsUser! + deleteWhere [ QualificationUserUser ==. oldUserId ] + userIdents <- E.select . E.from $ \user -> do E.where_ $ user E.^. UserId `E.in_` E.valList [newUserId, oldUserId] return ( user E.^. UserId @@ -827,3 +850,13 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do tellError :: forall a. UserAssimilateExceptionReason -> ReaderT SqlBackend (WriterT (Set UserAssimilateException) Handler) a tellError = throwM . UserAssimilateException oldUserId newUserId + + + +combineWith :: (PersistEntity val, PersistField typ1) => + E.SqlExpr (Entity val) + -> E.SqlExpr (Entity val) + -> (E.SqlExpr (E.Value typ1) -> E.SqlExpr (E.Value typ1) -> E.SqlExpr (E.Value typ2)) + -> EntityField val typ1 + -> E.SqlExpr (E.Value typ2) +combineWith x y f pj = f (x E.^. pj) (y E.^. pj) \ No newline at end of file diff --git a/src/Jobs/Handler/SendNotification.hs b/src/Jobs/Handler/SendNotification.hs index 80574a065..a819c3d4e 100644 --- a/src/Jobs/Handler/SendNotification.hs +++ b/src/Jobs/Handler/SendNotification.hs @@ -22,6 +22,15 @@ import Jobs.Handler.SendNotification.CourseRegistered import Jobs.Handler.SendNotification.SubmissionEdited import Jobs.Handler.SendNotification.Qualification +dispatchJobSendNotification :: UserId -> Notification -> JobHandler UniWorX +dispatchJobSendNotification jRecipient jNotification = JobHandlerException $ + $(dispatchTH ''Notification) jNotification jRecipient + +{- +IDEAS: + 1) change type of dispatchNotificationfunctions to take another argument in addition to + jRecipient jNotificiation + 2) change mailT and sendPrintJob to account for supervisors dispatchJobSendNotification :: UserId -> Notification -> JobHandler UniWorX dispatchJobSendNotification jRecipient jNotification = JobHandlerException $ do @@ -32,3 +41,4 @@ dispatchJobSendNotification jRecipient jNotification = JobHandlerException $ do then $(dispatchTH ''Notification) jNotification jRecipient else forM_ superVs $ \Entity { entityVal = UserSupervisor { userSupervisorSupervisor = svr } } -> $(dispatchTH ''Notification) jNotification svr +-} \ No newline at end of file From e01fd96bb5b5a71e508be1c647b040d2bfe863d3 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 28 Oct 2022 17:59:54 +0200 Subject: [PATCH 08/41] chore(supervisor): reroute most notifications (WIP) --- models/users.model | 2 +- src/Handler/LMS.hs | 6 +++-- src/Handler/Utils/Mail.hs | 11 +++++++- src/Jobs/Handler/SendNotification.hs | 25 +++++++++---------- .../Handler/SendNotification/Allocation.hs | 20 +++++++-------- .../SendNotification/CorrectionsAssigned.hs | 2 +- .../CorrectionsNotDistributed.hs | 2 +- .../SendNotification/CourseRegistered.hs | 4 +-- .../Handler/SendNotification/ExamActive.hs | 12 ++++----- .../Handler/SendNotification/ExamOffice.hs | 14 +++++------ .../Handler/SendNotification/ExamResult.hs | 4 +-- .../Handler/SendNotification/Qualification.hs | 19 ++++++++------ .../Handler/SendNotification/SheetActive.hs | 8 +++--- .../Handler/SendNotification/SheetInactive.hs | 8 +++--- .../SendNotification/SubmissionEdited.hs | 12 ++++----- .../SendNotification/SubmissionRated.hs | 2 +- .../SendNotification/UserAuthModeUpdate.hs | 4 +-- .../SendNotification/UserRightsUpdate.hs | 8 +++--- 18 files changed, 88 insertions(+), 75 deletions(-) diff --git a/models/users.model b/models/users.model index db8618863..fe2560974 100644 --- a/models/users.model +++ b/models/users.model @@ -86,7 +86,7 @@ UserGroupMember UserSupervisor supervisor UserId -- multiple supervisor per trainee possible user UserId - rerouteNotifications Bool + rerouteNotifications Bool -- User can be his own supervisor to receive notifications as well UniqueUserSupervisor supervisor user deriving Generic \ No newline at end of file diff --git a/src/Handler/LMS.hs b/src/Handler/LMS.hs index 5439fd45f..3086f65c7 100644 --- a/src/Handler/LMS.hs +++ b/src/Handler/LMS.hs @@ -321,7 +321,7 @@ lmsTableQuery :: QualificationId -> LmsTableExpr -> E.SqlQuery ( E.SqlExpr (Enti , E.SqlExpr (Entity User) , E.SqlExpr (Maybe (Entity LmsUser)) , E.SqlExpr (Maybe (Entity PrintJob)) - , E.SqlExpr (E.Value (Maybe [Maybe UTCTime])) + , E.SqlExpr (E.Value (Maybe [Maybe UTCTime])) -- Nutzbar zum sortieren und filtern! ) lmsTableQuery qid (qualUser `E.InnerJoin` user `E.LeftOuterJoin` lmsUser `E.LeftOuterJoin` printJob) = do -- E.distinctOn [E.don $ printJob E.?. PrintJobLmsUser] $ do -- types, but destroys the ability to sort interactively, since distinctOn requires sorting; @@ -334,9 +334,11 @@ lmsTableQuery qid (qualUser `E.InnerJoin` user `E.LeftOuterJoin` lmsUser `E.Left E.&&. ((printJob E.?. PrintJobCreated) E.<. E.just (otherpj E.^. PrintJobCreated)) ) E.on $ user E.^. UserId E.=?. lmsUser E.?. LmsUserUser - E.&&. E.val qid E.=?. lmsUser E.?. LmsUserQualification -- NOTE: condition was once erroneously placed in where-clause + E.&&. E.val qid E.=?. lmsUser E.?. LmsUserQualification -- NOTE: condition was once erroneously placed in where-clause, which does not work E.on $ user E.^. UserId E.==. qualUser E.^. QualificationUserUser E.where_ $ E.val qid E.==. qualUser E.^. QualificationUserQualification + -- TODO: decide whether to use subSelect or LeftOuterJoin and delete the other! + -- Letztes Datum anzeigen, wenn mehrere, dann diese in klickbaren Tooltip verstecken! let printAcknowledged = E.subSelectMaybe . E.from $ \pj -> do E.where_ $ E.isJust (pj E.^. PrintJobLmsUser) E.&&. ((lmsUser E.?. LmsUserIdent) E.==. (pj E.^. PrintJobLmsUser)) diff --git a/src/Handler/Utils/Mail.hs b/src/Handler/Utils/Mail.hs index 82ded9c15..f4b1ac754 100644 --- a/src/Handler/Utils/Mail.hs +++ b/src/Handler/Utils/Mail.hs @@ -5,7 +5,7 @@ module Handler.Utils.Mail ( addRecipientsDB , userAddress, userAddressFrom - , userMailT + , userMailT, superMailT , addFileDB , addHtmlMarkdownAlternatives , addHtmlMarkdownAlternatives' @@ -73,6 +73,15 @@ userMailT uid mAct = do _mailTo .= pure (userAddress user) mAct + +superMailT :: ( MonadHandler m + , HandlerSite m ~ UniWorX + , MonadThrow m + , MonadUnliftIO m + ) => Maybe UserId -> UserId -> MailT m a -> m a +superMailT svr uid = userMailT $ fromMaybe uid svr + + addFileDB :: ( MonadMail m , HandlerSite m ~ UniWorX ) => FileReference -> m (Maybe MailObjectId) diff --git a/src/Jobs/Handler/SendNotification.hs b/src/Jobs/Handler/SendNotification.hs index da5e6074f..e77b3c6cc 100644 --- a/src/Jobs/Handler/SendNotification.hs +++ b/src/Jobs/Handler/SendNotification.hs @@ -26,23 +26,22 @@ import Jobs.Handler.SendNotification.CourseRegistered import Jobs.Handler.SendNotification.SubmissionEdited import Jobs.Handler.SendNotification.Qualification -dispatchJobSendNotification :: UserId -> Notification -> JobHandler UniWorX -dispatchJobSendNotification jRecipient jNotification = JobHandlerException $ - $(dispatchTH ''Notification) jNotification jRecipient - {- -IDEAS: - 1) change type of dispatchNotificationfunctions to take another argument in addition to - jRecipient jNotificiation - 2) change mailT and sendPrintJob to account for supervisors + Notfications receive three arguments: + 1) addressee, the person for whom the message truly is + 2) type of notification to be send + 3) maybe supervisor, the person actually receiving the message + + + +-} + +- - TODO: check that we caught all calls to userMailT!!! dispatchJobSendNotification :: UserId -> Notification -> JobHandler UniWorX dispatchJobSendNotification jRecipient jNotification = JobHandlerException $ do - -- TODO: this is a bad idea, since all notifications use jRecipient to generate the message body, - -- thus supervisors would receive all notifications with their own name inside! superVs <- runDB $ selectList [UserSupervisorUser ==. jRecipient, UserSupervisorRerouteNotifications ==. True] [] if null superVs - then $(dispatchTH ''Notification) jNotification jRecipient + then $(dispatchTH ''Notification) jNotification jRecipient Nothing else forM_ superVs $ \Entity { entityVal = UserSupervisor { userSupervisorSupervisor = svr } } -> - $(dispatchTH ''Notification) jNotification svr --} \ No newline at end of file + $(dispatchTH ''Notification) jNotification jRecipient (Just svr) \ No newline at end of file diff --git a/src/Jobs/Handler/SendNotification/Allocation.hs b/src/Jobs/Handler/SendNotification/Allocation.hs index 747d05e4a..96551ec7f 100644 --- a/src/Jobs/Handler/SendNotification/Allocation.hs +++ b/src/Jobs/Handler/SendNotification/Allocation.hs @@ -26,8 +26,8 @@ import qualified Database.Esqueleto.Legacy as E import qualified Database.Esqueleto.Utils as E -dispatchNotificationAllocationStaffRegister :: Set AllocationId -> UserId -> Handler () -dispatchNotificationAllocationStaffRegister (otoList -> nAllocations) jRecipient = userMailT jRecipient $ do +dispatchNotificationAllocationStaffRegister :: Set AllocationId -> UserId -> Maybe UserId -> Handler () +dispatchNotificationAllocationStaffRegister (otoList -> nAllocations) jRecipient jSupervisor = superMailT jSupervisor jRecipient $ do allocs <- fmap (sortOn $ \Allocation{..} -> (allocationSchool, allocationName)) . liftHandler . runDB $ mapM getJust nAllocations replaceMailHeader "Auto-Submitted" $ Just "auto-generated" @@ -42,8 +42,8 @@ dispatchNotificationAllocationStaffRegister (otoList -> nAllocations) jRecipient singleRegisterDeadline = maybe True (flip all (allocs ^.. folded . _allocationStaffRegisterTo) . (==)) $ allocs ^? _head . _allocationStaffRegisterTo addHtmlMarkdownAlternatives $(ihamletFile "templates/mail/allocationStaffRegister.hamlet") -dispatchNotificationAllocationRegister :: Set AllocationId -> UserId -> Handler () -dispatchNotificationAllocationRegister (otoList -> nAllocations) jRecipient = userMailT jRecipient $ do +dispatchNotificationAllocationRegister :: Set AllocationId -> UserId -> Maybe UserId -> Handler () +dispatchNotificationAllocationRegister (otoList -> nAllocations) jRecipient jSupervisor = superMailT jSupervisor jRecipient $ do allocs <- fmap (sortOn $ \Allocation{..} -> (allocationSchool, allocationName)) . liftHandler . runDB $ mapM getJust nAllocations replaceMailHeader "Auto-Submitted" $ Just "auto-generated" @@ -58,7 +58,7 @@ dispatchNotificationAllocationRegister (otoList -> nAllocations) jRecipient = us singleRegisterDeadline = maybe True (flip all (allocs ^.. folded . _allocationRegisterTo) . (==)) $ allocs ^? _head . _allocationRegisterTo addHtmlMarkdownAlternatives $(ihamletFile "templates/mail/allocationRegister.hamlet") -dispatchNotificationAllocationAllocation :: Set AllocationId -> UserId -> Handler () +dispatchNotificationAllocationAllocation :: Set AllocationId -> UserId -> Maybe UserId -> Handler () dispatchNotificationAllocationAllocation (otoList -> nAllocations) jRecipient = do courses <- fmap (nubOrdOn $ views _2 entityKey) . runDB . E.select . E.from $ \(course `E.InnerJoin` allocationCourse `E.InnerJoin` allocation `E.InnerJoin` lecturer) -> do E.on $ lecturer E.^. LecturerCourse E.==. course E.^. CourseId @@ -97,7 +97,7 @@ dispatchNotificationAllocationAllocation (otoList -> nAllocations) jRecipient = addHtmlMarkdownAlternatives $(ihamletFile "templates/mail/allocationAllocation.hamlet") -dispatchNotificationAllocationUnratedApplications :: Set AllocationId -> UserId -> Handler () +dispatchNotificationAllocationUnratedApplications :: Set AllocationId -> UserId -> Maybe UserId -> Handler () dispatchNotificationAllocationUnratedApplications (otoList -> nAllocations) jRecipient = do courses <- fmap (nubOrdOn (views _2 entityKey) . over (traverse . _3) (fromIntegral . E.unValue)) . runDB . E.select . E.from $ \(course `E.InnerJoin` allocationCourse `E.InnerJoin` allocation `E.InnerJoin` lecturer) -> do E.on $ lecturer E.^. LecturerCourse E.==. course E.^. CourseId @@ -142,8 +142,8 @@ dispatchNotificationAllocationUnratedApplications (otoList -> nAllocations) jRec addHtmlMarkdownAlternatives $(ihamletFile "templates/mail/allocationUnratedApplications.hamlet") -dispatchNotificationAllocationResults :: AllocationId -> UserId -> Handler () -dispatchNotificationAllocationResults nAllocation jRecipient = userMailT jRecipient $ do +dispatchNotificationAllocationResults :: AllocationId -> UserId -> Maybe UserId -> Handler () +dispatchNotificationAllocationResults nAllocation jRecipient jSupervisor = superMailT jSupervisor jRecipient $ do (Allocation{..}, lecturerResults, warnSubstituteCourses, participantResults) <- liftHandler . runDB $ do allocation <- getJust nAllocation @@ -194,8 +194,8 @@ dispatchNotificationAllocationResults nAllocation jRecipient = userMailT jRecipi where studentFaqItems' = [FAQAllocationNoPlaces] -dispatchNotificationAllocationNewCourse :: AllocationId -> CourseId -> UserId -> Handler () -dispatchNotificationAllocationNewCourse nAllocation nCourse jRecipient = userMailT jRecipient $ do +dispatchNotificationAllocationNewCourse :: AllocationId -> CourseId -> UserId -> Maybe UserId -> Handler () +dispatchNotificationAllocationNewCourse nAllocation nCourse jRecipient jSupervisor = superMailT jSupervisor jRecipient $ do (Allocation{..}, Course{..}, hasApplied) <- liftHandler . runDB $ (,,) <$> getJust nAllocation <*> getJust nCourse diff --git a/src/Jobs/Handler/SendNotification/CorrectionsAssigned.hs b/src/Jobs/Handler/SendNotification/CorrectionsAssigned.hs index 125310edf..148f33d7a 100644 --- a/src/Jobs/Handler/SendNotification/CorrectionsAssigned.hs +++ b/src/Jobs/Handler/SendNotification/CorrectionsAssigned.hs @@ -16,7 +16,7 @@ import Handler.Utils.Mail import Text.Hamlet import qualified Data.CaseInsensitive as CI -dispatchNotificationCorrectionsAssigned :: UserId -> SheetId -> UserId -> Handler () +dispatchNotificationCorrectionsAssigned :: UserId -> SheetId -> UserId -> Maybe UserId -> Handler () dispatchNotificationCorrectionsAssigned nUser nSheet jRecipient = do (Course{..}, Sheet{..}, nbrSubs) <- runDB $ do sheet <- getJust nSheet diff --git a/src/Jobs/Handler/SendNotification/CorrectionsNotDistributed.hs b/src/Jobs/Handler/SendNotification/CorrectionsNotDistributed.hs index 74ee13c04..e3302ce8d 100644 --- a/src/Jobs/Handler/SendNotification/CorrectionsNotDistributed.hs +++ b/src/Jobs/Handler/SendNotification/CorrectionsNotDistributed.hs @@ -13,7 +13,7 @@ import Handler.Utils.Mail import Text.Hamlet import qualified Data.CaseInsensitive as CI -dispatchNotificationCorrectionsNotDistributed :: SheetId -> UserId -> Handler () +dispatchNotificationCorrectionsNotDistributed :: SheetId -> UserId -> Maybe UserId -> Handler () dispatchNotificationCorrectionsNotDistributed nSheet jRecipient = do (Course{..}, Sheet{..}, nbrSubs) <- runDB $ do sheet <- getJust nSheet diff --git a/src/Jobs/Handler/SendNotification/CourseRegistered.hs b/src/Jobs/Handler/SendNotification/CourseRegistered.hs index bb519e978..0472fe279 100644 --- a/src/Jobs/Handler/SendNotification/CourseRegistered.hs +++ b/src/Jobs/Handler/SendNotification/CourseRegistered.hs @@ -16,8 +16,8 @@ import Jobs.Handler.SendNotification.Utils import Text.Hamlet import qualified Data.CaseInsensitive as CI -dispatchNotificationCourseRegistered :: UserId -> CourseId -> UserId -> Handler () -dispatchNotificationCourseRegistered nUser nCourse jRecipient = userMailT jRecipient $ do +dispatchNotificationCourseRegistered :: UserId -> CourseId -> UserId -> Maybe UserId -> Handler () +dispatchNotificationCourseRegistered nUser nCourse jRecipient jSupervisor = superMailT jSupervisor jRecipient $ do (User{..}, Course{..}) <- liftHandler . runDB $ (,) <$> getJust nUser <*> getJust nCourse let isSelf = nUser == jRecipient diff --git a/src/Jobs/Handler/SendNotification/ExamActive.hs b/src/Jobs/Handler/SendNotification/ExamActive.hs index 18161e7e4..a1b80b5d1 100644 --- a/src/Jobs/Handler/SendNotification/ExamActive.hs +++ b/src/Jobs/Handler/SendNotification/ExamActive.hs @@ -18,8 +18,8 @@ import Jobs.Handler.SendNotification.Utils import Text.Hamlet import qualified Data.CaseInsensitive as CI -dispatchNotificationExamRegistrationActive :: ExamId -> UserId -> Handler () -dispatchNotificationExamRegistrationActive nExam jRecipient = userMailT jRecipient $ do +dispatchNotificationExamRegistrationActive :: ExamId -> UserId -> Maybe UserId -> Handler () +dispatchNotificationExamRegistrationActive nExam jRecipient jSupervisor = superMailT jSupervisor jRecipient $ do (Course{..}, Exam{..}) <- liftHandler . runDB $ do exam <- getJust nExam course <- belongsToJust examCourse exam @@ -38,8 +38,8 @@ dispatchNotificationExamRegistrationActive nExam jRecipient = userMailT jRecipie addHtmlMarkdownAlternatives ($(ihamletFile "templates/mail/examRegistrationActive.hamlet") :: HtmlUrlI18n (SomeMessage UniWorX) (Route UniWorX)) -dispatchNotificationExamRegistrationSoonInactive :: ExamId -> UserId -> Handler () -dispatchNotificationExamRegistrationSoonInactive nExam jRecipient = userMailT jRecipient $ do +dispatchNotificationExamRegistrationSoonInactive :: ExamId -> UserId -> Maybe UserId -> Handler () +dispatchNotificationExamRegistrationSoonInactive nExam jRecipient jSupervisor = superMailT jSupervisor jRecipient $ do (Course{..}, Exam{..}) <- liftHandler . runDB $ do exam <- getJust nExam course <- belongsToJust examCourse exam @@ -58,8 +58,8 @@ dispatchNotificationExamRegistrationSoonInactive nExam jRecipient = userMailT jR addHtmlMarkdownAlternatives ($(ihamletFile "templates/mail/examRegistrationSoonInactive.hamlet") :: HtmlUrlI18n (SomeMessage UniWorX) (Route UniWorX)) -dispatchNotificationExamDeregistrationSoonInactive :: ExamId -> UserId -> Handler () -dispatchNotificationExamDeregistrationSoonInactive nExam jRecipient = userMailT jRecipient $ do +dispatchNotificationExamDeregistrationSoonInactive :: ExamId -> UserId -> Maybe UserId -> Handler () +dispatchNotificationExamDeregistrationSoonInactive nExam jRecipient jSupervisor = superMailT jSupervisor jRecipient $ do (Course{..}, Exam{..}) <- liftHandler . runDB $ do exam <- getJust nExam course <- belongsToJust examCourse exam diff --git a/src/Jobs/Handler/SendNotification/ExamOffice.hs b/src/Jobs/Handler/SendNotification/ExamOffice.hs index 65b1f4b3e..aafa6950c 100644 --- a/src/Jobs/Handler/SendNotification/ExamOffice.hs +++ b/src/Jobs/Handler/SendNotification/ExamOffice.hs @@ -21,8 +21,8 @@ import qualified Data.CaseInsensitive as CI import qualified Data.Set as Set -dispatchNotificationExamOfficeExamResults :: ExamId -> UserId -> Handler () -dispatchNotificationExamOfficeExamResults nExam jRecipient = userMailT jRecipient $ do +dispatchNotificationExamOfficeExamResults :: ExamId -> UserId -> Maybe UserId -> Handler () +dispatchNotificationExamOfficeExamResults nExam jRecipient jSupervisor = superMailT jSupervisor jRecipient $ do (Course{..}, Exam{..}) <- liftHandler . runDB $ do exam <- getJust nExam course <- belongsToJust examCourse exam @@ -41,12 +41,12 @@ dispatchNotificationExamOfficeExamResults nExam jRecipient = userMailT jRecipien addHtmlMarkdownAlternatives ($(ihamletFile "templates/mail/examOffice/examResults.hamlet") :: HtmlUrlI18n (SomeMessage UniWorX) (Route UniWorX)) -dispatchNotificationExamOfficeExamResultsChanged :: Set ExamResultId -> UserId -> Handler () -dispatchNotificationExamOfficeExamResultsChanged nExamResults jRecipient = do +dispatchNotificationExamOfficeExamResultsChanged :: Set ExamResultId -> UserId -> Maybe UserId -> Handler () +dispatchNotificationExamOfficeExamResultsChanged nExamResults jRecipient jSupervisor = do entitiesExamResults <- runDB $ selectList [ ExamResultId <-. Set.toList nExamResults ] [] let exams = Set.fromList $ map (examResultExam . entityVal) entitiesExamResults - forM_ exams $ \nExam -> userMailT jRecipient $ do + forM_ exams $ \nExam -> superMailT jSupervisor jRecipient $ do (Course{..}, Exam{..}) <- liftHandler . runDB $ do exam <- getJust nExam course <- belongsToJust examCourse exam @@ -66,8 +66,8 @@ dispatchNotificationExamOfficeExamResultsChanged nExamResults jRecipient = do addHtmlMarkdownAlternatives ($(ihamletFile "templates/mail/examOffice/examResultsChanged.hamlet") :: HtmlUrlI18n (SomeMessage UniWorX) (Route UniWorX)) -dispatchNotificationExamOfficeExternalExamResults :: ExternalExamId -> UserId -> Handler () -dispatchNotificationExamOfficeExternalExamResults nExternalExam jRecipient = userMailT jRecipient $ do +dispatchNotificationExamOfficeExternalExamResults :: ExternalExamId -> UserId -> Maybe UserId -> Handler () +dispatchNotificationExamOfficeExternalExamResults nExternalExam jRecipient jSupervisor = superMailT jSupervisor jRecipient $ do ExternalExam{..} <- liftHandler . runDB $ getJust nExternalExam replaceMailHeader "Auto-Submitted" $ Just "auto-generated" setSubjectI $ MsgMailSubjectExamOfficeExternalExamResults externalExamCourseName externalExamExamName diff --git a/src/Jobs/Handler/SendNotification/ExamResult.hs b/src/Jobs/Handler/SendNotification/ExamResult.hs index 7d598bf36..539ff089f 100644 --- a/src/Jobs/Handler/SendNotification/ExamResult.hs +++ b/src/Jobs/Handler/SendNotification/ExamResult.hs @@ -16,8 +16,8 @@ import Jobs.Handler.SendNotification.Utils import Text.Hamlet import qualified Data.CaseInsensitive as CI -dispatchNotificationExamResult :: ExamId -> UserId -> Handler () -dispatchNotificationExamResult nExam jRecipient = userMailT jRecipient $ do +dispatchNotificationExamResult :: ExamId -> UserId -> Maybe UserId -> Handler () +dispatchNotificationExamResult nExam jRecipient jSupervisor = superMailT jSupervisor jRecipient $ do (Course{..}, Exam{..}) <- liftHandler . runDB $ do exam <- getJust nExam course <- belongsToJust examCourse exam diff --git a/src/Jobs/Handler/SendNotification/Qualification.hs b/src/Jobs/Handler/SendNotification/Qualification.hs index 9b16abc79..45bc4d855 100644 --- a/src/Jobs/Handler/SendNotification/Qualification.hs +++ b/src/Jobs/Handler/SendNotification/Qualification.hs @@ -26,8 +26,8 @@ import qualified Data.CaseInsensitive as CI import Text.Hamlet -dispatchNotificationQualificationExpiry :: QualificationId -> Day -> UserId -> Handler () -dispatchNotificationQualificationExpiry nQualification dExpiry jRecipient = userMailT jRecipient $ do +dispatchNotificationQualificationExpiry :: QualificationId -> Day -> UserId -> Maybe UserId -> Handler () +dispatchNotificationQualificationExpiry nQualification dExpiry jRecipient jSupervisor = superMailT jSupervisor jRecipient $ do (recipient@User{..}, Qualification{..}) <- liftHandler . runDB $ (,) <$> getJust jRecipient <*> getJust nQualification @@ -44,11 +44,14 @@ dispatchNotificationQualificationExpiry nQualification dExpiry jRecipient = user editNotifications <- mkEditNotifications jRecipient - addHtmlMarkdownAlternatives $(ihamletFile "templates/mail/qualificationExpiry.hamlet") + -- if supervisor: + let inner = $(ihamletFile "templates/mail/qualificationExpiry.hamlet") + --addHtmlMarkdownAlternatives $(ihamletFile "templates/mail/supervisor.hamlet") -- uses ^{inner} + addHtmlMarkdownAlternatives inner -dispatchNotificationQualificationExpired :: QualificationId -> Day -> UserId -> Handler () -dispatchNotificationQualificationExpired nQualification dExpired jRecipient = userMailT jRecipient $ do +dispatchNotificationQualificationExpired :: QualificationId -> Day -> UserId -> Maybe UserId -> Handler () +dispatchNotificationQualificationExpired nQualification dExpired jRecipient jSupervisor = superMailT jSupervisor jRecipient $ do (recipient@User{..}, Qualification{..}) <- liftHandler . runDB $ (,) <$> getJust jRecipient <*> getJust nQualification @@ -69,8 +72,8 @@ dispatchNotificationQualificationExpired nQualification dExpired jRecipient = us -- NOTE: qualificationRenewal expects that LmsUser already exists for recipient -dispatchNotificationQualificationRenewal :: QualificationId -> UserId -> Handler () -dispatchNotificationQualificationRenewal nQualification jRecipient = do +dispatchNotificationQualificationRenewal :: QualificationId -> UserId -> Maybe UserId -> Handler () +dispatchNotificationQualificationRenewal nQualification jRecipient jSupervisor = do (recipient@User{..}, Qualification{..}, Entity _ QualificationUser{..}, Entity luid LmsUser{..}) <- runDB $ (,,,) <$> getJust jRecipient <*> getJust nQualification @@ -111,7 +114,7 @@ dispatchNotificationQualificationRenewal nQualification jRecipient = do $logErrorS "LMS" msg return False | otherwise = do - userMailT jRecipient $ do + superMailT jSupervisor jRecipient $ do replaceMailHeader "Auto-Submitted" $ Just "auto-generated" setSubjectI $ MsgMailSubjectQualificationRenewal qname whenIsJust attachment $ \afile -> diff --git a/src/Jobs/Handler/SendNotification/SheetActive.hs b/src/Jobs/Handler/SendNotification/SheetActive.hs index 7948fb988..2b2c69abf 100644 --- a/src/Jobs/Handler/SendNotification/SheetActive.hs +++ b/src/Jobs/Handler/SendNotification/SheetActive.hs @@ -18,8 +18,8 @@ import Jobs.Handler.SendNotification.Utils import Text.Hamlet import qualified Data.CaseInsensitive as CI -dispatchNotificationSheetActive, dispatchNotificationSheetHint, dispatchNotificationSheetSolution :: SheetId -> UserId -> Handler () -dispatchNotificationSheetActive nSheet jRecipient = userMailT jRecipient $ do +dispatchNotificationSheetActive, dispatchNotificationSheetHint, dispatchNotificationSheetSolution :: SheetId -> UserId -> Maybe UserId -> Handler () +dispatchNotificationSheetActive nSheet jRecipient jSupervisor = superMailT jSupervisor jRecipient $ do (Course{..}, Sheet{..}) <- liftHandler . runDB $ do sheet <- getJust nSheet course <- belongsToJust sheetCourse sheet @@ -37,7 +37,7 @@ dispatchNotificationSheetActive nSheet jRecipient = userMailT jRecipient $ do editNotifications <- mkEditNotifications jRecipient addHtmlMarkdownAlternatives ($(ihamletFile "templates/mail/sheetActive.hamlet") :: HtmlUrlI18n (SomeMessage UniWorX) (Route UniWorX)) -dispatchNotificationSheetHint nSheet jRecipient = userMailT jRecipient $ do +dispatchNotificationSheetHint nSheet jRecipient jSupervisor = superMailT jSupervisor jRecipient $ do (Course{..}, Sheet{..}) <- liftHandler . runDB $ do sheet <- getJust nSheet course <- belongsToJust sheetCourse sheet @@ -55,7 +55,7 @@ dispatchNotificationSheetHint nSheet jRecipient = userMailT jRecipient $ do editNotifications <- mkEditNotifications jRecipient addHtmlMarkdownAlternatives ($(ihamletFile "templates/mail/sheetHint.hamlet") :: HtmlUrlI18n (SomeMessage UniWorX) (Route UniWorX)) -dispatchNotificationSheetSolution nSheet jRecipient = userMailT jRecipient $ do +dispatchNotificationSheetSolution nSheet jRecipient jSupervisor = superMailT jSupervisor jRecipient $ do (Course{..}, Sheet{..}) <- liftHandler . runDB $ do sheet <- getJust nSheet course <- belongsToJust sheetCourse sheet diff --git a/src/Jobs/Handler/SendNotification/SheetInactive.hs b/src/Jobs/Handler/SendNotification/SheetInactive.hs index 6e26ad7c3..8db7f8833 100644 --- a/src/Jobs/Handler/SendNotification/SheetInactive.hs +++ b/src/Jobs/Handler/SendNotification/SheetInactive.hs @@ -19,8 +19,8 @@ import qualified Data.CaseInsensitive as CI import qualified Database.Esqueleto.Legacy as E -dispatchNotificationSheetSoonInactive :: SheetId -> UserId -> Handler () -dispatchNotificationSheetSoonInactive nSheet jRecipient = userMailT jRecipient $ do +dispatchNotificationSheetSoonInactive :: SheetId -> UserId -> Maybe UserId -> Handler () +dispatchNotificationSheetSoonInactive nSheet jRecipient jSupervisor = superMailT jSupervisor jRecipient $ do (Course{..}, Sheet{..}) <- liftHandler . runDB $ do sheet <- getJust nSheet course <- belongsToJust sheetCourse sheet @@ -39,8 +39,8 @@ dispatchNotificationSheetSoonInactive nSheet jRecipient = userMailT jRecipient $ addHtmlMarkdownAlternatives ($(ihamletFile "templates/mail/sheetSoonInactive.hamlet") :: HtmlUrlI18n (SomeMessage UniWorX) (Route UniWorX)) -dispatchNotificationSheetInactive :: SheetId -> UserId -> Handler () -dispatchNotificationSheetInactive nSheet jRecipient = userMailT jRecipient $ do +dispatchNotificationSheetInactive :: SheetId -> UserId -> Maybe UserId -> Handler () +dispatchNotificationSheetInactive nSheet jRecipient jSupervisor = superMailT jSupervisor jRecipient $ do (Course{..}, Sheet{..}, nrSubs, nrSubmitters, nrPseudonyms, nrParticipants) <- liftHandler . runDB $ do sheet <- getJust nSheet course <- belongsToJust sheetCourse sheet diff --git a/src/Jobs/Handler/SendNotification/SubmissionEdited.hs b/src/Jobs/Handler/SendNotification/SubmissionEdited.hs index 94679e01a..c2b0b2183 100644 --- a/src/Jobs/Handler/SendNotification/SubmissionEdited.hs +++ b/src/Jobs/Handler/SendNotification/SubmissionEdited.hs @@ -22,8 +22,8 @@ import qualified Database.Esqueleto.Legacy as E import qualified Data.Text as Text -dispatchNotificationSubmissionEdited :: UserId -> SubmissionId -> UserId -> Handler () -dispatchNotificationSubmissionEdited nInitiator nSubmission jRecipient = userMailT jRecipient $ do +dispatchNotificationSubmissionEdited :: UserId -> SubmissionId -> UserId -> Maybe UserId -> Handler () +dispatchNotificationSubmissionEdited nInitiator nSubmission jRecipient jSupervisor = superMailT jSupervisor jRecipient $ do (Course{..}, Sheet{..}, Submission{}, initiator, coSubmittors) <- liftHandler . runDB $ do submission <- getJust nSubmission sheet <- belongsToJust submissionSheet submission @@ -57,8 +57,8 @@ dispatchNotificationSubmissionEdited nInitiator nSubmission jRecipient = userMai addHtmlMarkdownAlternatives $(ihamletFile "templates/mail/submissionEdited.hamlet") -dispatchNotificationSubmissionUserCreated :: UserId -> SubmissionId -> UserId -> Handler () -dispatchNotificationSubmissionUserCreated nUser nSubmission jRecipient = userMailT jRecipient $ do +dispatchNotificationSubmissionUserCreated :: UserId -> SubmissionId -> UserId -> Maybe UserId -> Handler () +dispatchNotificationSubmissionUserCreated nUser nSubmission jRecipient jSupervisor = superMailT jSupervisor jRecipient $ do (User{..}, Course{..}, Sheet{..}, Submission{}, coSubmittors) <- liftHandler . runDB $ do submission <- getJust nSubmission sheet <- belongsToJust submissionSheet submission @@ -97,8 +97,8 @@ dispatchNotificationSubmissionUserCreated nUser nSubmission jRecipient = userMai addHtmlMarkdownAlternatives $(ihamletFile "templates/mail/submissionUserCreated.hamlet") -dispatchNotificationSubmissionUserDeleted :: UserId -> SheetId -> SubmissionId -> UserId -> Handler () -dispatchNotificationSubmissionUserDeleted nUser nSheet nSubmission jRecipient = userMailT jRecipient $ do +dispatchNotificationSubmissionUserDeleted :: UserId -> SheetId -> SubmissionId -> UserId -> Maybe UserId -> Handler () +dispatchNotificationSubmissionUserDeleted nUser nSheet nSubmission jRecipient jSupervisor = superMailT jSupervisor jRecipient $ do (User{..}, Course{..}, Sheet{..}, mSubmission, coSubmittors) <- liftHandler . runDB $ do submission <- get nSubmission diff --git a/src/Jobs/Handler/SendNotification/SubmissionRated.hs b/src/Jobs/Handler/SendNotification/SubmissionRated.hs index efbb0a5fc..23f5c2758 100644 --- a/src/Jobs/Handler/SendNotification/SubmissionRated.hs +++ b/src/Jobs/Handler/SendNotification/SubmissionRated.hs @@ -17,7 +17,7 @@ import Text.Hamlet import qualified Data.CaseInsensitive as CI -dispatchNotificationSubmissionRated :: SubmissionId -> UserId -> Handler () +dispatchNotificationSubmissionRated :: SubmissionId -> UserId -> Maybe UserId -> Handler () dispatchNotificationSubmissionRated nSubmission jRecipient = maybeT_ $ do (Course{..}, Sheet{..}, Submission{..}, corrector, sheetTypeDesc, hasAccess, csid) <- lift . runDB $ do submission@Submission{submissionRatingBy} <- getJust nSubmission diff --git a/src/Jobs/Handler/SendNotification/UserAuthModeUpdate.hs b/src/Jobs/Handler/SendNotification/UserAuthModeUpdate.hs index 5296dd84e..ffb12c8d4 100644 --- a/src/Jobs/Handler/SendNotification/UserAuthModeUpdate.hs +++ b/src/Jobs/Handler/SendNotification/UserAuthModeUpdate.hs @@ -19,8 +19,8 @@ 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 +dispatchNotificationUserAuthModeUpdate :: UserId -> AuthenticationMode -> UserId -> Maybe UserId -> Handler () +dispatchNotificationUserAuthModeUpdate nUser _nOriginalAuthMode jRecipient jSupervisor = superMailT jSupervisor jRecipient $ do User{..} <- liftHandler . runDB $ getJust nUser replaceMailHeader "Auto-Submitted" $ Just "auto-generated" setSubjectI MsgMailSubjectUserAuthModeUpdate diff --git a/src/Jobs/Handler/SendNotification/UserRightsUpdate.hs b/src/Jobs/Handler/SendNotification/UserRightsUpdate.hs index ab1033eee..7af06499a 100644 --- a/src/Jobs/Handler/SendNotification/UserRightsUpdate.hs +++ b/src/Jobs/Handler/SendNotification/UserRightsUpdate.hs @@ -20,8 +20,8 @@ import qualified Data.Set as Set import Text.Hamlet -- import qualified Data.CaseInsensitive as CI -dispatchNotificationUserRightsUpdate :: UserId -> Set (SchoolFunction, SchoolShorthand) -> UserId -> Handler () -dispatchNotificationUserRightsUpdate nUser _originalRights jRecipient = userMailT jRecipient $ do +dispatchNotificationUserRightsUpdate :: UserId -> Set (SchoolFunction, SchoolShorthand) -> UserId -> Maybe UserId -> Handler () +dispatchNotificationUserRightsUpdate nUser _originalRights jRecipient jSupervisor = superMailT jSupervisor jRecipient $ do (User{..}, functions) <- liftHandler . runDB $ do user <- getJust nUser functions <- Map.fromListWith Set.union . map (\(Entity _ UserFunction{..}) -> (userFunctionFunction, Set.singleton userFunctionSchool)) <$> selectList [UserFunctionUser ==. nUser] [] @@ -33,8 +33,8 @@ dispatchNotificationUserRightsUpdate nUser _originalRights jRecipient = userMai addHtmlMarkdownAlternatives ($(ihamletFile "templates/mail/userRightsUpdate.hamlet") :: HtmlUrlI18n (SomeMessage UniWorX) (Route UniWorX)) -dispatchNotificationUserSystemFunctionsUpdate :: UserId -> Set SystemFunction -> UserId -> Handler () -dispatchNotificationUserSystemFunctionsUpdate nUser _originalSystemFunctions jRecipient = userMailT jRecipient $ do +dispatchNotificationUserSystemFunctionsUpdate :: UserId -> Set SystemFunction -> UserId -> Maybe UserId -> Handler () +dispatchNotificationUserSystemFunctionsUpdate nUser _originalSystemFunctions jRecipient jSupervisor = superMailT jSupervisor jRecipient $ do (User{..}, functions) <- liftHandler . runDB $ do user <- getJust nUser functions <- map (userSystemFunctionFunction . entityVal) <$> selectList [UserSystemFunctionUser ==. nUser] [] From 85894c08051ad2ead7505d3be5eb33a5f871f2d3 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Mon, 31 Oct 2022 09:45:55 +0100 Subject: [PATCH 09/41] chore(mail): revert supervisor rerouting at notification level --- src/Jobs/Handler/SendNotification.hs | 25 ++++++++++--------- .../Handler/SendNotification/Allocation.hs | 20 +++++++-------- .../SendNotification/CorrectionsAssigned.hs | 2 +- .../CorrectionsNotDistributed.hs | 2 +- .../SendNotification/CourseRegistered.hs | 4 +-- .../Handler/SendNotification/ExamActive.hs | 12 ++++----- .../Handler/SendNotification/ExamOffice.hs | 14 +++++------ .../Handler/SendNotification/ExamResult.hs | 4 +-- .../Handler/SendNotification/Qualification.hs | 19 ++++++-------- .../Handler/SendNotification/SheetActive.hs | 8 +++--- .../Handler/SendNotification/SheetInactive.hs | 8 +++--- .../SendNotification/SubmissionEdited.hs | 12 ++++----- .../SendNotification/SubmissionRated.hs | 2 +- .../SendNotification/UserAuthModeUpdate.hs | 4 +-- .../SendNotification/UserRightsUpdate.hs | 8 +++--- 15 files changed, 71 insertions(+), 73 deletions(-) diff --git a/src/Jobs/Handler/SendNotification.hs b/src/Jobs/Handler/SendNotification.hs index e77b3c6cc..da5e6074f 100644 --- a/src/Jobs/Handler/SendNotification.hs +++ b/src/Jobs/Handler/SendNotification.hs @@ -26,22 +26,23 @@ import Jobs.Handler.SendNotification.CourseRegistered import Jobs.Handler.SendNotification.SubmissionEdited import Jobs.Handler.SendNotification.Qualification +dispatchJobSendNotification :: UserId -> Notification -> JobHandler UniWorX +dispatchJobSendNotification jRecipient jNotification = JobHandlerException $ + $(dispatchTH ''Notification) jNotification jRecipient + {- - Notfications receive three arguments: - 1) addressee, the person for whom the message truly is - 2) type of notification to be send - 3) maybe supervisor, the person actually receiving the message - - - --} - -- - TODO: check that we caught all calls to userMailT!!! +IDEAS: + 1) change type of dispatchNotificationfunctions to take another argument in addition to + jRecipient jNotificiation + 2) change mailT and sendPrintJob to account for supervisors dispatchJobSendNotification :: UserId -> Notification -> JobHandler UniWorX dispatchJobSendNotification jRecipient jNotification = JobHandlerException $ do + -- TODO: this is a bad idea, since all notifications use jRecipient to generate the message body, + -- thus supervisors would receive all notifications with their own name inside! superVs <- runDB $ selectList [UserSupervisorUser ==. jRecipient, UserSupervisorRerouteNotifications ==. True] [] if null superVs - then $(dispatchTH ''Notification) jNotification jRecipient Nothing + then $(dispatchTH ''Notification) jNotification jRecipient else forM_ superVs $ \Entity { entityVal = UserSupervisor { userSupervisorSupervisor = svr } } -> - $(dispatchTH ''Notification) jNotification jRecipient (Just svr) \ No newline at end of file + $(dispatchTH ''Notification) jNotification svr +-} \ No newline at end of file diff --git a/src/Jobs/Handler/SendNotification/Allocation.hs b/src/Jobs/Handler/SendNotification/Allocation.hs index 96551ec7f..747d05e4a 100644 --- a/src/Jobs/Handler/SendNotification/Allocation.hs +++ b/src/Jobs/Handler/SendNotification/Allocation.hs @@ -26,8 +26,8 @@ import qualified Database.Esqueleto.Legacy as E import qualified Database.Esqueleto.Utils as E -dispatchNotificationAllocationStaffRegister :: Set AllocationId -> UserId -> Maybe UserId -> Handler () -dispatchNotificationAllocationStaffRegister (otoList -> nAllocations) jRecipient jSupervisor = superMailT jSupervisor jRecipient $ do +dispatchNotificationAllocationStaffRegister :: Set AllocationId -> UserId -> Handler () +dispatchNotificationAllocationStaffRegister (otoList -> nAllocations) jRecipient = userMailT jRecipient $ do allocs <- fmap (sortOn $ \Allocation{..} -> (allocationSchool, allocationName)) . liftHandler . runDB $ mapM getJust nAllocations replaceMailHeader "Auto-Submitted" $ Just "auto-generated" @@ -42,8 +42,8 @@ dispatchNotificationAllocationStaffRegister (otoList -> nAllocations) jRecipient singleRegisterDeadline = maybe True (flip all (allocs ^.. folded . _allocationStaffRegisterTo) . (==)) $ allocs ^? _head . _allocationStaffRegisterTo addHtmlMarkdownAlternatives $(ihamletFile "templates/mail/allocationStaffRegister.hamlet") -dispatchNotificationAllocationRegister :: Set AllocationId -> UserId -> Maybe UserId -> Handler () -dispatchNotificationAllocationRegister (otoList -> nAllocations) jRecipient jSupervisor = superMailT jSupervisor jRecipient $ do +dispatchNotificationAllocationRegister :: Set AllocationId -> UserId -> Handler () +dispatchNotificationAllocationRegister (otoList -> nAllocations) jRecipient = userMailT jRecipient $ do allocs <- fmap (sortOn $ \Allocation{..} -> (allocationSchool, allocationName)) . liftHandler . runDB $ mapM getJust nAllocations replaceMailHeader "Auto-Submitted" $ Just "auto-generated" @@ -58,7 +58,7 @@ dispatchNotificationAllocationRegister (otoList -> nAllocations) jRecipient jSup singleRegisterDeadline = maybe True (flip all (allocs ^.. folded . _allocationRegisterTo) . (==)) $ allocs ^? _head . _allocationRegisterTo addHtmlMarkdownAlternatives $(ihamletFile "templates/mail/allocationRegister.hamlet") -dispatchNotificationAllocationAllocation :: Set AllocationId -> UserId -> Maybe UserId -> Handler () +dispatchNotificationAllocationAllocation :: Set AllocationId -> UserId -> Handler () dispatchNotificationAllocationAllocation (otoList -> nAllocations) jRecipient = do courses <- fmap (nubOrdOn $ views _2 entityKey) . runDB . E.select . E.from $ \(course `E.InnerJoin` allocationCourse `E.InnerJoin` allocation `E.InnerJoin` lecturer) -> do E.on $ lecturer E.^. LecturerCourse E.==. course E.^. CourseId @@ -97,7 +97,7 @@ dispatchNotificationAllocationAllocation (otoList -> nAllocations) jRecipient = addHtmlMarkdownAlternatives $(ihamletFile "templates/mail/allocationAllocation.hamlet") -dispatchNotificationAllocationUnratedApplications :: Set AllocationId -> UserId -> Maybe UserId -> Handler () +dispatchNotificationAllocationUnratedApplications :: Set AllocationId -> UserId -> Handler () dispatchNotificationAllocationUnratedApplications (otoList -> nAllocations) jRecipient = do courses <- fmap (nubOrdOn (views _2 entityKey) . over (traverse . _3) (fromIntegral . E.unValue)) . runDB . E.select . E.from $ \(course `E.InnerJoin` allocationCourse `E.InnerJoin` allocation `E.InnerJoin` lecturer) -> do E.on $ lecturer E.^. LecturerCourse E.==. course E.^. CourseId @@ -142,8 +142,8 @@ dispatchNotificationAllocationUnratedApplications (otoList -> nAllocations) jRec addHtmlMarkdownAlternatives $(ihamletFile "templates/mail/allocationUnratedApplications.hamlet") -dispatchNotificationAllocationResults :: AllocationId -> UserId -> Maybe UserId -> Handler () -dispatchNotificationAllocationResults nAllocation jRecipient jSupervisor = superMailT jSupervisor jRecipient $ do +dispatchNotificationAllocationResults :: AllocationId -> UserId -> Handler () +dispatchNotificationAllocationResults nAllocation jRecipient = userMailT jRecipient $ do (Allocation{..}, lecturerResults, warnSubstituteCourses, participantResults) <- liftHandler . runDB $ do allocation <- getJust nAllocation @@ -194,8 +194,8 @@ dispatchNotificationAllocationResults nAllocation jRecipient jSupervisor = super where studentFaqItems' = [FAQAllocationNoPlaces] -dispatchNotificationAllocationNewCourse :: AllocationId -> CourseId -> UserId -> Maybe UserId -> Handler () -dispatchNotificationAllocationNewCourse nAllocation nCourse jRecipient jSupervisor = superMailT jSupervisor jRecipient $ do +dispatchNotificationAllocationNewCourse :: AllocationId -> CourseId -> UserId -> Handler () +dispatchNotificationAllocationNewCourse nAllocation nCourse jRecipient = userMailT jRecipient $ do (Allocation{..}, Course{..}, hasApplied) <- liftHandler . runDB $ (,,) <$> getJust nAllocation <*> getJust nCourse diff --git a/src/Jobs/Handler/SendNotification/CorrectionsAssigned.hs b/src/Jobs/Handler/SendNotification/CorrectionsAssigned.hs index 148f33d7a..125310edf 100644 --- a/src/Jobs/Handler/SendNotification/CorrectionsAssigned.hs +++ b/src/Jobs/Handler/SendNotification/CorrectionsAssigned.hs @@ -16,7 +16,7 @@ import Handler.Utils.Mail import Text.Hamlet import qualified Data.CaseInsensitive as CI -dispatchNotificationCorrectionsAssigned :: UserId -> SheetId -> UserId -> Maybe UserId -> Handler () +dispatchNotificationCorrectionsAssigned :: UserId -> SheetId -> UserId -> Handler () dispatchNotificationCorrectionsAssigned nUser nSheet jRecipient = do (Course{..}, Sheet{..}, nbrSubs) <- runDB $ do sheet <- getJust nSheet diff --git a/src/Jobs/Handler/SendNotification/CorrectionsNotDistributed.hs b/src/Jobs/Handler/SendNotification/CorrectionsNotDistributed.hs index e3302ce8d..74ee13c04 100644 --- a/src/Jobs/Handler/SendNotification/CorrectionsNotDistributed.hs +++ b/src/Jobs/Handler/SendNotification/CorrectionsNotDistributed.hs @@ -13,7 +13,7 @@ import Handler.Utils.Mail import Text.Hamlet import qualified Data.CaseInsensitive as CI -dispatchNotificationCorrectionsNotDistributed :: SheetId -> UserId -> Maybe UserId -> Handler () +dispatchNotificationCorrectionsNotDistributed :: SheetId -> UserId -> Handler () dispatchNotificationCorrectionsNotDistributed nSheet jRecipient = do (Course{..}, Sheet{..}, nbrSubs) <- runDB $ do sheet <- getJust nSheet diff --git a/src/Jobs/Handler/SendNotification/CourseRegistered.hs b/src/Jobs/Handler/SendNotification/CourseRegistered.hs index 0472fe279..bb519e978 100644 --- a/src/Jobs/Handler/SendNotification/CourseRegistered.hs +++ b/src/Jobs/Handler/SendNotification/CourseRegistered.hs @@ -16,8 +16,8 @@ import Jobs.Handler.SendNotification.Utils import Text.Hamlet import qualified Data.CaseInsensitive as CI -dispatchNotificationCourseRegistered :: UserId -> CourseId -> UserId -> Maybe UserId -> Handler () -dispatchNotificationCourseRegistered nUser nCourse jRecipient jSupervisor = superMailT jSupervisor jRecipient $ do +dispatchNotificationCourseRegistered :: UserId -> CourseId -> UserId -> Handler () +dispatchNotificationCourseRegistered nUser nCourse jRecipient = userMailT jRecipient $ do (User{..}, Course{..}) <- liftHandler . runDB $ (,) <$> getJust nUser <*> getJust nCourse let isSelf = nUser == jRecipient diff --git a/src/Jobs/Handler/SendNotification/ExamActive.hs b/src/Jobs/Handler/SendNotification/ExamActive.hs index a1b80b5d1..18161e7e4 100644 --- a/src/Jobs/Handler/SendNotification/ExamActive.hs +++ b/src/Jobs/Handler/SendNotification/ExamActive.hs @@ -18,8 +18,8 @@ import Jobs.Handler.SendNotification.Utils import Text.Hamlet import qualified Data.CaseInsensitive as CI -dispatchNotificationExamRegistrationActive :: ExamId -> UserId -> Maybe UserId -> Handler () -dispatchNotificationExamRegistrationActive nExam jRecipient jSupervisor = superMailT jSupervisor jRecipient $ do +dispatchNotificationExamRegistrationActive :: ExamId -> UserId -> Handler () +dispatchNotificationExamRegistrationActive nExam jRecipient = userMailT jRecipient $ do (Course{..}, Exam{..}) <- liftHandler . runDB $ do exam <- getJust nExam course <- belongsToJust examCourse exam @@ -38,8 +38,8 @@ dispatchNotificationExamRegistrationActive nExam jRecipient jSupervisor = superM addHtmlMarkdownAlternatives ($(ihamletFile "templates/mail/examRegistrationActive.hamlet") :: HtmlUrlI18n (SomeMessage UniWorX) (Route UniWorX)) -dispatchNotificationExamRegistrationSoonInactive :: ExamId -> UserId -> Maybe UserId -> Handler () -dispatchNotificationExamRegistrationSoonInactive nExam jRecipient jSupervisor = superMailT jSupervisor jRecipient $ do +dispatchNotificationExamRegistrationSoonInactive :: ExamId -> UserId -> Handler () +dispatchNotificationExamRegistrationSoonInactive nExam jRecipient = userMailT jRecipient $ do (Course{..}, Exam{..}) <- liftHandler . runDB $ do exam <- getJust nExam course <- belongsToJust examCourse exam @@ -58,8 +58,8 @@ dispatchNotificationExamRegistrationSoonInactive nExam jRecipient jSupervisor = addHtmlMarkdownAlternatives ($(ihamletFile "templates/mail/examRegistrationSoonInactive.hamlet") :: HtmlUrlI18n (SomeMessage UniWorX) (Route UniWorX)) -dispatchNotificationExamDeregistrationSoonInactive :: ExamId -> UserId -> Maybe UserId -> Handler () -dispatchNotificationExamDeregistrationSoonInactive nExam jRecipient jSupervisor = superMailT jSupervisor jRecipient $ do +dispatchNotificationExamDeregistrationSoonInactive :: ExamId -> UserId -> Handler () +dispatchNotificationExamDeregistrationSoonInactive nExam jRecipient = userMailT jRecipient $ do (Course{..}, Exam{..}) <- liftHandler . runDB $ do exam <- getJust nExam course <- belongsToJust examCourse exam diff --git a/src/Jobs/Handler/SendNotification/ExamOffice.hs b/src/Jobs/Handler/SendNotification/ExamOffice.hs index aafa6950c..65b1f4b3e 100644 --- a/src/Jobs/Handler/SendNotification/ExamOffice.hs +++ b/src/Jobs/Handler/SendNotification/ExamOffice.hs @@ -21,8 +21,8 @@ import qualified Data.CaseInsensitive as CI import qualified Data.Set as Set -dispatchNotificationExamOfficeExamResults :: ExamId -> UserId -> Maybe UserId -> Handler () -dispatchNotificationExamOfficeExamResults nExam jRecipient jSupervisor = superMailT jSupervisor jRecipient $ do +dispatchNotificationExamOfficeExamResults :: ExamId -> UserId -> Handler () +dispatchNotificationExamOfficeExamResults nExam jRecipient = userMailT jRecipient $ do (Course{..}, Exam{..}) <- liftHandler . runDB $ do exam <- getJust nExam course <- belongsToJust examCourse exam @@ -41,12 +41,12 @@ dispatchNotificationExamOfficeExamResults nExam jRecipient jSupervisor = superMa addHtmlMarkdownAlternatives ($(ihamletFile "templates/mail/examOffice/examResults.hamlet") :: HtmlUrlI18n (SomeMessage UniWorX) (Route UniWorX)) -dispatchNotificationExamOfficeExamResultsChanged :: Set ExamResultId -> UserId -> Maybe UserId -> Handler () -dispatchNotificationExamOfficeExamResultsChanged nExamResults jRecipient jSupervisor = do +dispatchNotificationExamOfficeExamResultsChanged :: Set ExamResultId -> UserId -> Handler () +dispatchNotificationExamOfficeExamResultsChanged nExamResults jRecipient = do entitiesExamResults <- runDB $ selectList [ ExamResultId <-. Set.toList nExamResults ] [] let exams = Set.fromList $ map (examResultExam . entityVal) entitiesExamResults - forM_ exams $ \nExam -> superMailT jSupervisor jRecipient $ do + forM_ exams $ \nExam -> userMailT jRecipient $ do (Course{..}, Exam{..}) <- liftHandler . runDB $ do exam <- getJust nExam course <- belongsToJust examCourse exam @@ -66,8 +66,8 @@ dispatchNotificationExamOfficeExamResultsChanged nExamResults jRecipient jSuperv addHtmlMarkdownAlternatives ($(ihamletFile "templates/mail/examOffice/examResultsChanged.hamlet") :: HtmlUrlI18n (SomeMessage UniWorX) (Route UniWorX)) -dispatchNotificationExamOfficeExternalExamResults :: ExternalExamId -> UserId -> Maybe UserId -> Handler () -dispatchNotificationExamOfficeExternalExamResults nExternalExam jRecipient jSupervisor = superMailT jSupervisor jRecipient $ do +dispatchNotificationExamOfficeExternalExamResults :: ExternalExamId -> UserId -> Handler () +dispatchNotificationExamOfficeExternalExamResults nExternalExam jRecipient = userMailT jRecipient $ do ExternalExam{..} <- liftHandler . runDB $ getJust nExternalExam replaceMailHeader "Auto-Submitted" $ Just "auto-generated" setSubjectI $ MsgMailSubjectExamOfficeExternalExamResults externalExamCourseName externalExamExamName diff --git a/src/Jobs/Handler/SendNotification/ExamResult.hs b/src/Jobs/Handler/SendNotification/ExamResult.hs index 539ff089f..7d598bf36 100644 --- a/src/Jobs/Handler/SendNotification/ExamResult.hs +++ b/src/Jobs/Handler/SendNotification/ExamResult.hs @@ -16,8 +16,8 @@ import Jobs.Handler.SendNotification.Utils import Text.Hamlet import qualified Data.CaseInsensitive as CI -dispatchNotificationExamResult :: ExamId -> UserId -> Maybe UserId -> Handler () -dispatchNotificationExamResult nExam jRecipient jSupervisor = superMailT jSupervisor jRecipient $ do +dispatchNotificationExamResult :: ExamId -> UserId -> Handler () +dispatchNotificationExamResult nExam jRecipient = userMailT jRecipient $ do (Course{..}, Exam{..}) <- liftHandler . runDB $ do exam <- getJust nExam course <- belongsToJust examCourse exam diff --git a/src/Jobs/Handler/SendNotification/Qualification.hs b/src/Jobs/Handler/SendNotification/Qualification.hs index 45bc4d855..9b16abc79 100644 --- a/src/Jobs/Handler/SendNotification/Qualification.hs +++ b/src/Jobs/Handler/SendNotification/Qualification.hs @@ -26,8 +26,8 @@ import qualified Data.CaseInsensitive as CI import Text.Hamlet -dispatchNotificationQualificationExpiry :: QualificationId -> Day -> UserId -> Maybe UserId -> Handler () -dispatchNotificationQualificationExpiry nQualification dExpiry jRecipient jSupervisor = superMailT jSupervisor jRecipient $ do +dispatchNotificationQualificationExpiry :: QualificationId -> Day -> UserId -> Handler () +dispatchNotificationQualificationExpiry nQualification dExpiry jRecipient = userMailT jRecipient $ do (recipient@User{..}, Qualification{..}) <- liftHandler . runDB $ (,) <$> getJust jRecipient <*> getJust nQualification @@ -44,14 +44,11 @@ dispatchNotificationQualificationExpiry nQualification dExpiry jRecipient jSuper editNotifications <- mkEditNotifications jRecipient - -- if supervisor: - let inner = $(ihamletFile "templates/mail/qualificationExpiry.hamlet") - --addHtmlMarkdownAlternatives $(ihamletFile "templates/mail/supervisor.hamlet") -- uses ^{inner} - addHtmlMarkdownAlternatives inner + addHtmlMarkdownAlternatives $(ihamletFile "templates/mail/qualificationExpiry.hamlet") -dispatchNotificationQualificationExpired :: QualificationId -> Day -> UserId -> Maybe UserId -> Handler () -dispatchNotificationQualificationExpired nQualification dExpired jRecipient jSupervisor = superMailT jSupervisor jRecipient $ do +dispatchNotificationQualificationExpired :: QualificationId -> Day -> UserId -> Handler () +dispatchNotificationQualificationExpired nQualification dExpired jRecipient = userMailT jRecipient $ do (recipient@User{..}, Qualification{..}) <- liftHandler . runDB $ (,) <$> getJust jRecipient <*> getJust nQualification @@ -72,8 +69,8 @@ dispatchNotificationQualificationExpired nQualification dExpired jRecipient jSup -- NOTE: qualificationRenewal expects that LmsUser already exists for recipient -dispatchNotificationQualificationRenewal :: QualificationId -> UserId -> Maybe UserId -> Handler () -dispatchNotificationQualificationRenewal nQualification jRecipient jSupervisor = do +dispatchNotificationQualificationRenewal :: QualificationId -> UserId -> Handler () +dispatchNotificationQualificationRenewal nQualification jRecipient = do (recipient@User{..}, Qualification{..}, Entity _ QualificationUser{..}, Entity luid LmsUser{..}) <- runDB $ (,,,) <$> getJust jRecipient <*> getJust nQualification @@ -114,7 +111,7 @@ dispatchNotificationQualificationRenewal nQualification jRecipient jSupervisor = $logErrorS "LMS" msg return False | otherwise = do - superMailT jSupervisor jRecipient $ do + userMailT jRecipient $ do replaceMailHeader "Auto-Submitted" $ Just "auto-generated" setSubjectI $ MsgMailSubjectQualificationRenewal qname whenIsJust attachment $ \afile -> diff --git a/src/Jobs/Handler/SendNotification/SheetActive.hs b/src/Jobs/Handler/SendNotification/SheetActive.hs index 2b2c69abf..7948fb988 100644 --- a/src/Jobs/Handler/SendNotification/SheetActive.hs +++ b/src/Jobs/Handler/SendNotification/SheetActive.hs @@ -18,8 +18,8 @@ import Jobs.Handler.SendNotification.Utils import Text.Hamlet import qualified Data.CaseInsensitive as CI -dispatchNotificationSheetActive, dispatchNotificationSheetHint, dispatchNotificationSheetSolution :: SheetId -> UserId -> Maybe UserId -> Handler () -dispatchNotificationSheetActive nSheet jRecipient jSupervisor = superMailT jSupervisor jRecipient $ do +dispatchNotificationSheetActive, dispatchNotificationSheetHint, dispatchNotificationSheetSolution :: SheetId -> UserId -> Handler () +dispatchNotificationSheetActive nSheet jRecipient = userMailT jRecipient $ do (Course{..}, Sheet{..}) <- liftHandler . runDB $ do sheet <- getJust nSheet course <- belongsToJust sheetCourse sheet @@ -37,7 +37,7 @@ dispatchNotificationSheetActive nSheet jRecipient jSupervisor = superMailT jSupe editNotifications <- mkEditNotifications jRecipient addHtmlMarkdownAlternatives ($(ihamletFile "templates/mail/sheetActive.hamlet") :: HtmlUrlI18n (SomeMessage UniWorX) (Route UniWorX)) -dispatchNotificationSheetHint nSheet jRecipient jSupervisor = superMailT jSupervisor jRecipient $ do +dispatchNotificationSheetHint nSheet jRecipient = userMailT jRecipient $ do (Course{..}, Sheet{..}) <- liftHandler . runDB $ do sheet <- getJust nSheet course <- belongsToJust sheetCourse sheet @@ -55,7 +55,7 @@ dispatchNotificationSheetHint nSheet jRecipient jSupervisor = superMailT jSuperv editNotifications <- mkEditNotifications jRecipient addHtmlMarkdownAlternatives ($(ihamletFile "templates/mail/sheetHint.hamlet") :: HtmlUrlI18n (SomeMessage UniWorX) (Route UniWorX)) -dispatchNotificationSheetSolution nSheet jRecipient jSupervisor = superMailT jSupervisor jRecipient $ do +dispatchNotificationSheetSolution nSheet jRecipient = userMailT jRecipient $ do (Course{..}, Sheet{..}) <- liftHandler . runDB $ do sheet <- getJust nSheet course <- belongsToJust sheetCourse sheet diff --git a/src/Jobs/Handler/SendNotification/SheetInactive.hs b/src/Jobs/Handler/SendNotification/SheetInactive.hs index 8db7f8833..6e26ad7c3 100644 --- a/src/Jobs/Handler/SendNotification/SheetInactive.hs +++ b/src/Jobs/Handler/SendNotification/SheetInactive.hs @@ -19,8 +19,8 @@ import qualified Data.CaseInsensitive as CI import qualified Database.Esqueleto.Legacy as E -dispatchNotificationSheetSoonInactive :: SheetId -> UserId -> Maybe UserId -> Handler () -dispatchNotificationSheetSoonInactive nSheet jRecipient jSupervisor = superMailT jSupervisor jRecipient $ do +dispatchNotificationSheetSoonInactive :: SheetId -> UserId -> Handler () +dispatchNotificationSheetSoonInactive nSheet jRecipient = userMailT jRecipient $ do (Course{..}, Sheet{..}) <- liftHandler . runDB $ do sheet <- getJust nSheet course <- belongsToJust sheetCourse sheet @@ -39,8 +39,8 @@ dispatchNotificationSheetSoonInactive nSheet jRecipient jSupervisor = superMailT addHtmlMarkdownAlternatives ($(ihamletFile "templates/mail/sheetSoonInactive.hamlet") :: HtmlUrlI18n (SomeMessage UniWorX) (Route UniWorX)) -dispatchNotificationSheetInactive :: SheetId -> UserId -> Maybe UserId -> Handler () -dispatchNotificationSheetInactive nSheet jRecipient jSupervisor = superMailT jSupervisor jRecipient $ do +dispatchNotificationSheetInactive :: SheetId -> UserId -> Handler () +dispatchNotificationSheetInactive nSheet jRecipient = userMailT jRecipient $ do (Course{..}, Sheet{..}, nrSubs, nrSubmitters, nrPseudonyms, nrParticipants) <- liftHandler . runDB $ do sheet <- getJust nSheet course <- belongsToJust sheetCourse sheet diff --git a/src/Jobs/Handler/SendNotification/SubmissionEdited.hs b/src/Jobs/Handler/SendNotification/SubmissionEdited.hs index c2b0b2183..94679e01a 100644 --- a/src/Jobs/Handler/SendNotification/SubmissionEdited.hs +++ b/src/Jobs/Handler/SendNotification/SubmissionEdited.hs @@ -22,8 +22,8 @@ import qualified Database.Esqueleto.Legacy as E import qualified Data.Text as Text -dispatchNotificationSubmissionEdited :: UserId -> SubmissionId -> UserId -> Maybe UserId -> Handler () -dispatchNotificationSubmissionEdited nInitiator nSubmission jRecipient jSupervisor = superMailT jSupervisor jRecipient $ do +dispatchNotificationSubmissionEdited :: UserId -> SubmissionId -> UserId -> Handler () +dispatchNotificationSubmissionEdited nInitiator nSubmission jRecipient = userMailT jRecipient $ do (Course{..}, Sheet{..}, Submission{}, initiator, coSubmittors) <- liftHandler . runDB $ do submission <- getJust nSubmission sheet <- belongsToJust submissionSheet submission @@ -57,8 +57,8 @@ dispatchNotificationSubmissionEdited nInitiator nSubmission jRecipient jSupervis addHtmlMarkdownAlternatives $(ihamletFile "templates/mail/submissionEdited.hamlet") -dispatchNotificationSubmissionUserCreated :: UserId -> SubmissionId -> UserId -> Maybe UserId -> Handler () -dispatchNotificationSubmissionUserCreated nUser nSubmission jRecipient jSupervisor = superMailT jSupervisor jRecipient $ do +dispatchNotificationSubmissionUserCreated :: UserId -> SubmissionId -> UserId -> Handler () +dispatchNotificationSubmissionUserCreated nUser nSubmission jRecipient = userMailT jRecipient $ do (User{..}, Course{..}, Sheet{..}, Submission{}, coSubmittors) <- liftHandler . runDB $ do submission <- getJust nSubmission sheet <- belongsToJust submissionSheet submission @@ -97,8 +97,8 @@ dispatchNotificationSubmissionUserCreated nUser nSubmission jRecipient jSupervis addHtmlMarkdownAlternatives $(ihamletFile "templates/mail/submissionUserCreated.hamlet") -dispatchNotificationSubmissionUserDeleted :: UserId -> SheetId -> SubmissionId -> UserId -> Maybe UserId -> Handler () -dispatchNotificationSubmissionUserDeleted nUser nSheet nSubmission jRecipient jSupervisor = superMailT jSupervisor jRecipient $ do +dispatchNotificationSubmissionUserDeleted :: UserId -> SheetId -> SubmissionId -> UserId -> Handler () +dispatchNotificationSubmissionUserDeleted nUser nSheet nSubmission jRecipient = userMailT jRecipient $ do (User{..}, Course{..}, Sheet{..}, mSubmission, coSubmittors) <- liftHandler . runDB $ do submission <- get nSubmission diff --git a/src/Jobs/Handler/SendNotification/SubmissionRated.hs b/src/Jobs/Handler/SendNotification/SubmissionRated.hs index 23f5c2758..efbb0a5fc 100644 --- a/src/Jobs/Handler/SendNotification/SubmissionRated.hs +++ b/src/Jobs/Handler/SendNotification/SubmissionRated.hs @@ -17,7 +17,7 @@ import Text.Hamlet import qualified Data.CaseInsensitive as CI -dispatchNotificationSubmissionRated :: SubmissionId -> UserId -> Maybe UserId -> Handler () +dispatchNotificationSubmissionRated :: SubmissionId -> UserId -> Handler () dispatchNotificationSubmissionRated nSubmission jRecipient = maybeT_ $ do (Course{..}, Sheet{..}, Submission{..}, corrector, sheetTypeDesc, hasAccess, csid) <- lift . runDB $ do submission@Submission{submissionRatingBy} <- getJust nSubmission diff --git a/src/Jobs/Handler/SendNotification/UserAuthModeUpdate.hs b/src/Jobs/Handler/SendNotification/UserAuthModeUpdate.hs index ffb12c8d4..5296dd84e 100644 --- a/src/Jobs/Handler/SendNotification/UserAuthModeUpdate.hs +++ b/src/Jobs/Handler/SendNotification/UserAuthModeUpdate.hs @@ -19,8 +19,8 @@ import Jobs.Handler.SendNotification.Utils import Text.Hamlet -- import qualified Data.CaseInsensitive as CI -dispatchNotificationUserAuthModeUpdate :: UserId -> AuthenticationMode -> UserId -> Maybe UserId -> Handler () -dispatchNotificationUserAuthModeUpdate nUser _nOriginalAuthMode jRecipient jSupervisor = superMailT jSupervisor jRecipient $ do +dispatchNotificationUserAuthModeUpdate :: UserId -> AuthenticationMode -> UserId -> Handler () +dispatchNotificationUserAuthModeUpdate nUser _nOriginalAuthMode jRecipient = userMailT jRecipient $ do User{..} <- liftHandler . runDB $ getJust nUser replaceMailHeader "Auto-Submitted" $ Just "auto-generated" setSubjectI MsgMailSubjectUserAuthModeUpdate diff --git a/src/Jobs/Handler/SendNotification/UserRightsUpdate.hs b/src/Jobs/Handler/SendNotification/UserRightsUpdate.hs index 7af06499a..ab1033eee 100644 --- a/src/Jobs/Handler/SendNotification/UserRightsUpdate.hs +++ b/src/Jobs/Handler/SendNotification/UserRightsUpdate.hs @@ -20,8 +20,8 @@ import qualified Data.Set as Set import Text.Hamlet -- import qualified Data.CaseInsensitive as CI -dispatchNotificationUserRightsUpdate :: UserId -> Set (SchoolFunction, SchoolShorthand) -> UserId -> Maybe UserId -> Handler () -dispatchNotificationUserRightsUpdate nUser _originalRights jRecipient jSupervisor = superMailT jSupervisor jRecipient $ do +dispatchNotificationUserRightsUpdate :: UserId -> Set (SchoolFunction, SchoolShorthand) -> UserId -> Handler () +dispatchNotificationUserRightsUpdate nUser _originalRights jRecipient = userMailT jRecipient $ do (User{..}, functions) <- liftHandler . runDB $ do user <- getJust nUser functions <- Map.fromListWith Set.union . map (\(Entity _ UserFunction{..}) -> (userFunctionFunction, Set.singleton userFunctionSchool)) <$> selectList [UserFunctionUser ==. nUser] [] @@ -33,8 +33,8 @@ dispatchNotificationUserRightsUpdate nUser _originalRights jRecipient jSupervis addHtmlMarkdownAlternatives ($(ihamletFile "templates/mail/userRightsUpdate.hamlet") :: HtmlUrlI18n (SomeMessage UniWorX) (Route UniWorX)) -dispatchNotificationUserSystemFunctionsUpdate :: UserId -> Set SystemFunction -> UserId -> Maybe UserId -> Handler () -dispatchNotificationUserSystemFunctionsUpdate nUser _originalSystemFunctions jRecipient jSupervisor = superMailT jSupervisor jRecipient $ do +dispatchNotificationUserSystemFunctionsUpdate :: UserId -> Set SystemFunction -> UserId -> Handler () +dispatchNotificationUserSystemFunctionsUpdate nUser _originalSystemFunctions jRecipient = userMailT jRecipient $ do (User{..}, functions) <- liftHandler . runDB $ do user <- getJust nUser functions <- map (userSystemFunctionFunction . entityVal) <$> selectList [UserSystemFunctionUser ==. nUser] [] From ee1469c9740239930f3fce971c24942b69074207 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Mon, 31 Oct 2022 13:21:37 +0100 Subject: [PATCH 10/41] chore(email): userMailT respects supervisors --- .../categories/authorization/de-de-formal.msg | 2 +- src/Handler/LMS.hs | 5 +- src/Handler/Utils/Mail.hs | 46 +++++++++++++++---- 3 files changed, 40 insertions(+), 13 deletions(-) diff --git a/messages/uniworx/categories/authorization/de-de-formal.msg b/messages/uniworx/categories/authorization/de-de-formal.msg index 4728f2384..15d5204e6 100644 --- a/messages/uniworx/categories/authorization/de-de-formal.msg +++ b/messages/uniworx/categories/authorization/de-de-formal.msg @@ -19,7 +19,7 @@ UnauthorizedTokenInvalidAuthorityGroup: Ihr Authorisierungs-Token basiert auf de UnauthorizedTokenInvalidAuthorityValue: Ihr Authorisierungs-Token basiert auf Rechten, deren Spezifikation nicht interpretiert werden konnte. UnauthorizedTokenInvalidImpersonation: Ihr Authorisierungs-Token enthält die Anweisung sich als ein Nutzer:in auszugeben, dies ist jedoch nicht allen Benutzer:innen, auf deren Rechten ihr Authorisierungs-Token basiert, erlaubt. UnauthorizedToken404: Authorisierungs-Tokens können nicht auf Fehlerseiten ausgewertet werden. -UnauthorizedSupervisor: Sie sind kein Ansprechpartner:in für diesen Benuzter:in. +UnauthorizedSupervisor: Sie sind kein Ansprechpartner:in für diesen Benutzer:in. UnauthorizedSiteAdmin: Sie sind nicht System-weiter Administrator:in. UnauthorizedSchoolAdmin: Sie sind nicht als Administrator:in für dieses Institut eingetragen. UnauthorizedAdminEscalation: Sie sind nicht Administrator:in für alle Institute, für die dieser Nutzer/diese Nutzerin Administrator:in oder Veranstalter:in ist. diff --git a/src/Handler/LMS.hs b/src/Handler/LMS.hs index 3086f65c7..f8b08ac15 100644 --- a/src/Handler/LMS.hs +++ b/src/Handler/LMS.hs @@ -383,10 +383,11 @@ mkLmsTable (Entity qid quali) acts restrict cols psValidator = do user <- view $ _dbtProjRow . resultUser lusr <- preview $ _dbtProjRow . resultLmsUser pjob <- preview $ _dbtProjRow . resultPrintJob + pjac <- preview $ _dbtProjRow . resultPrintAck forMM_ (view $ _dbtProjFilter . _ltProjFilterMayAccess) $ \b -> do euid <- encrypt $ user ^. _entityKey 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) + return (qusr,user,lusr,pjob,pjac) dbtColonnade = cols dbtSorting = mconcat @@ -464,7 +465,7 @@ mkLmsTable (Entity qid quali) acts restrict cols psValidator = do <*> preview (resultLmsUser . _entityVal . _lmsUserStarted) <*> preview (resultLmsUser . _entityVal . _lmsUserDatePin) <*> (join . preview (resultLmsUser . _entityVal . _lmsUserReceived)) - <*> (join . preview (resultLmsUser . _entityVal . _lmsUserNotified)) + <*> (join . preview (resultLmsUser . _entityVal . _lmsUserNotified)) -- TODO: only exports last email date / print job sending date, not print acknowledge <*> (join . preview (resultLmsUser . _entityVal . _lmsUserEnded)) dbtCsvDecode = Nothing dbtExtraReps = [] diff --git a/src/Handler/Utils/Mail.hs b/src/Handler/Utils/Mail.hs index f4b1ac754..576fbc495 100644 --- a/src/Handler/Utils/Mail.hs +++ b/src/Handler/Utils/Mail.hs @@ -5,7 +5,7 @@ module Handler.Utils.Mail ( addRecipientsDB , userAddress, userAddressFrom - , userMailT, superMailT + , userMailT , addFileDB , addHtmlMarkdownAlternatives , addHtmlMarkdownAlternatives' @@ -47,12 +47,46 @@ userAddress :: User -> Address -- Uses `userEmail` userAddress User{userEmail, userDisplayName} = Address (Just userDisplayName) $ CI.original userEmail + userMailT :: ( MonadHandler m , HandlerSite m ~ UniWorX , MonadThrow m , MonadUnliftIO m - ) => UserId -> MailT m a -> m a + ) => UserId -> MailT m () -> m () userMailT uid mAct = do + superVs <- liftHandler . runDB $ selectList [UserSupervisorUser ==. uid, UserSupervisorRerouteNotifications ==. True] [] + let receivers = if null superVs + then [uid] + else userSupervisorSupervisor . entityVal <$> superVs + -- underling <- liftHandler . runDB $ getJust uid + forM_ receivers $ \svr -> do + supervisor@User + { userLanguages + , userDateTimeFormat + , userDateFormat + , userTimeFormat + , userCsvOptions + } <- liftHandler . runDB $ getJust svr + let ctx = MailContext + { mcLanguages = fromMaybe def userLanguages + , mcDateTimeFormat = \case + SelFormatDateTime -> userDateTimeFormat + SelFormatDate -> userDateFormat + SelFormatTime -> userTimeFormat + , mcCsvOptions = userCsvOptions + } + mailT ctx $ do + _mailTo .= pure (userAddress supervisor) + -- unless (uid == svr) $ addHtmlMarkdownAlternatives $(ihamletFile "templates/mail/supervisorPrefix.hamlet") -- TODO + mAct + + +_userMailTdirect :: ( MonadHandler m + , HandlerSite m ~ UniWorX + , MonadThrow m + , MonadUnliftIO m + ) => UserId -> MailT m a -> m a +_userMailTdirect uid mAct = do user@User { userLanguages , userDateTimeFormat @@ -74,14 +108,6 @@ userMailT uid mAct = do mAct -superMailT :: ( MonadHandler m - , HandlerSite m ~ UniWorX - , MonadThrow m - , MonadUnliftIO m - ) => Maybe UserId -> UserId -> MailT m a -> m a -superMailT svr uid = userMailT $ fromMaybe uid svr - - addFileDB :: ( MonadMail m , HandlerSite m ~ UniWorX ) => FileReference -> m (Maybe MailObjectId) From 2c10a07a15836e1042938aeafb7247576346ec37 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Mon, 31 Oct 2022 18:06:16 +0100 Subject: [PATCH 11/41] chore(qualifications): fix build for filter by supervisor --- src/Handler/LMS.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Handler/LMS.hs b/src/Handler/LMS.hs index f8b08ac15..d5818ce6b 100644 --- a/src/Handler/LMS.hs +++ b/src/Handler/LMS.hs @@ -387,7 +387,7 @@ mkLmsTable (Entity qid quali) acts restrict cols psValidator = do forMM_ (view $ _dbtProjFilter . _ltProjFilterMayAccess) $ \b -> do euid <- encrypt $ user ^. _entityKey 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,pjac) + return (qusr,user,lusr,pjob,E.Value pjac) dbtColonnade = cols dbtSorting = mconcat From a75c7520b55794392001922bd46bcf1e0d4a0638 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Thu, 3 Nov 2022 15:46:50 +0100 Subject: [PATCH 12/41] chore(mail): modify subject for supervisor --- .../send/send_notifications/en-eu.msg | 2 +- src/Handler/Utils/Mail.hs | 9 ++++++++- src/Jobs/Handler/SendTestEmail.hs | 19 +++++++++++++++++++ src/Mail.hs | 11 ++++++++--- 4 files changed, 36 insertions(+), 5 deletions(-) diff --git a/messages/uniworx/categories/send/send_notifications/en-eu.msg b/messages/uniworx/categories/send/send_notifications/en-eu.msg index 3a3d18ddf..d6af818f2 100644 --- a/messages/uniworx/categories/send/send_notifications/en-eu.msg +++ b/messages/uniworx/categories/send/send_notifications/en-eu.msg @@ -135,7 +135,7 @@ UserAuthModeLDAPChangedToPWHash: You can now log in using your FRADrive-internal AuthPWHashTip: You now need to use the login form labeled "FRADrive login". Please ensure that you have already set a password when you try to log in. PasswordResetEmailIncoming: For security reasons you will receive a link to the page on which you can set and later change your password in a separate email. MailFradrive: FRADrive -MailBodyFradrive: is the apron driving licence management app of Fraport AG. +MailBodyFradrive: is the apron driver's licence management app of Fraport AG. #userRightsUpdate.hs + templates MailSubjectUserRightsUpdate name: Permissions for #{name} changed diff --git a/src/Handler/Utils/Mail.hs b/src/Handler/Utils/Mail.hs index 576fbc495..217e916ba 100644 --- a/src/Handler/Utils/Mail.hs +++ b/src/Handler/Utils/Mail.hs @@ -54,6 +54,7 @@ userMailT :: ( MonadHandler m , MonadUnliftIO m ) => UserId -> MailT m () -> m () userMailT uid mAct = do + -- now <- liftIO getCurrentTime superVs <- liftHandler . runDB $ selectList [UserSupervisorUser ==. uid, UserSupervisorRerouteNotifications ==. True] [] let receivers = if null superVs then [uid] @@ -75,10 +76,16 @@ userMailT uid mAct = do SelFormatTime -> userTimeFormat , mcCsvOptions = userCsvOptions } + --bsExplainSupervisor = $(ihamletFile "templates/mail/supervisorPrefix.hamlet") -- TODO + --explanationSupervisor = File { fileTitle = "SupervisorInfo.txt" + -- , fileModified = no + -- , fileContent = Just $ yield bsExplainSupervisor + -- } mailT ctx $ do _mailTo .= pure (userAddress supervisor) - -- unless (uid == svr) $ addHtmlMarkdownAlternatives $(ihamletFile "templates/mail/supervisorPrefix.hamlet") -- TODO mAct + mapSubject ("[SUPERVISOR]"<>) -- changing subject is easy + --addPart explanationSupervisor -- adding an attachment is also easy _userMailTdirect :: ( MonadHandler m diff --git a/src/Jobs/Handler/SendTestEmail.hs b/src/Jobs/Handler/SendTestEmail.hs index c6aa205f4..2b4fe3e32 100644 --- a/src/Jobs/Handler/SendTestEmail.hs +++ b/src/Jobs/Handler/SendTestEmail.hs @@ -14,6 +14,13 @@ import Handler.Utils.DateTime dispatchJobSendTestEmail :: Email -> MailContext -> JobHandler UniWorX dispatchJobSendTestEmail jEmail jMailContext = JobHandlerException . mailT jMailContext $ do _mailTo .= [Address Nothing jEmail] + -- TODO: remove me after the test! + addHtmlMarkdownAlternatives $ \(MsgRenderer _mr) -> [shamlet| +

+ Testheader +

+ Dieser Abschnitt ist ein Test, ob mehrfache Mailparts ankommen. + |] replaceMailHeader "Auto-Submitted" $ Just "auto-generated" setSubjectI MsgMailTestSubject now <- liftIO getCurrentTime @@ -21,6 +28,18 @@ dispatchJobSendTestEmail jEmail jMailContext = JobHandlerException . mailT jMail nD <- formatTimeMail SelFormatDate now nT <- formatTimeMail SelFormatTime now addHtmlMarkdownAlternatives $ \(MsgRenderer mr) -> [shamlet| +

+ #{mr MsgMailTestContent} + +

+ #{mr MsgMailTestDateTime} +