diff --git a/messages/uniworx/de-de-formal.msg b/messages/uniworx/de-de-formal.msg index d4c0d6d6d..81bbd36ff 100644 --- a/messages/uniworx/de-de-formal.msg +++ b/messages/uniworx/de-de-formal.msg @@ -404,6 +404,7 @@ UnauthorizedAdminEscalation: Sie sind nicht Administrator für alle Institute, f UnauthorizedExamOffice: Sie sind nicht mit Prüfungsverwaltung beauftragt. UnauthorizedExamExamOffice: Es existieren keine Prüfungsergebnisse für Nutzer, für die Sie mit der Prüfungsverwaltung beauftragt sind. UnauthorizedExternalExamExamOffice: Es existieren keine Prüfungsergebnisse für Nutzer, für die Sie mit der Prüfungsverwaltung beauftragt sind. +UnauthorizedEvaluation: Sie sind nicht mit der Kursumfragenverwaltung beauftragt. UnauthorizedSchoolLecturer: Sie sind nicht als Veranstalter für dieses Institut eingetragen. UnauthorizedLecturer: Sie sind nicht als Veranstalter für diese Veranstaltung eingetragen. UnauthorizedAllocationLecturer: Sie sind nicht als Veranstalter für eine Veranstaltung dieser Zentralanmeldung eingetragen. @@ -1203,6 +1204,7 @@ MenuExternalExamUsers: Teilnehmer MenuExternalExamEdit: Bearbeiten MenuExternalExamNew: Neue externe Prüfung MenuExternalExamList: Externe Prüfungen +MenuParticipantsList: Kursteilnehmerlisten BreadcrumbSubmissionFile: Datei BreadcrumbSubmissionUserInvite: Einladung zur Abgabe @@ -1263,6 +1265,8 @@ BreadcrumbExternalExamEdit: Editieren BreadcrumbExternalExamUsers: Teilnehmer BreadcrumbExternalExamGrades: Prüfungsleistungen BreadcrumbExternalExamStaffInvite: Einladung zum Prüfer +BreadcrumbParticipantsList: Kursteilnehmerlisten +BreadcrumbParticipants: Kursteilnehmerliste ExternalExamEdit coursen@CourseName examn@ExamName: Bearbeiten: #{coursen}, #{examn} ExternalExamGrades coursen@CourseName examn@ExamName: Prüfungsleistungen: #{coursen}, #{examn} @@ -1276,6 +1280,7 @@ AuthPredsActiveChanged: Authorisierungseinstellungen für aktuelle Sitzung gespe AuthTagFree: Seite ist universell zugänglich AuthTagAdmin: Nutzer ist Administrator AuthTagExamOffice: Nutzer ist mit Prüfungsverwaltung beauftragt +AuthTagEvaluation: Nutzer ist mit Kursumfragenverwaltung beauftragt AuthTagToken: Nutzer präsentiert Authorisierungs-Token AuthTagNoEscalation: Nutzer-Rechte werden nicht auf fremde Institute ausgeweitet AuthTagDeprecated: Seite ist nicht überholt @@ -1720,6 +1725,7 @@ CourseUserCsvName tid@TermId ssh@SchoolId csh@CourseShorthand: #{foldCase (termT ExamUserCsvName tid@TermId ssh@SchoolId csh@CourseShorthand examn@ExamName: #{foldCase (termToText (unTermKey tid))}-#{foldedCase (unSchoolKey ssh)}-#{foldedCase csh}-#{foldedCase examn}-teilnehmer ExternalExamUserCsvName tid@TermId ssh@SchoolId coursen@CourseName examn@ExamName: #{foldCase (termToText (unTermKey tid))}-#{foldedCase (unSchoolKey ssh)}-#{foldedCase coursen}-#{foldedCase examn}-teilnehmer CourseApplicationsTableCsvName tid@TermId ssh@SchoolId csh@CourseShorthand: #{foldCase (termToText (unTermKey tid))}-#{foldedCase (unSchoolKey ssh)}-#{foldedCase csh}-bewerbungen +ParticipantsCsvName tid@TermId ssh@SchoolId: #{foldCase (termToText (unTermKey tid))}-#{foldedCase (unSchoolKey ssh)}-kursteilnehmer CsvColumnsExplanationsLabel: Spalten- & Zellenformat CsvColumnsExplanationsTip: Bedeutung und Format der in der CSV-Datei enthaltenen Spalten diff --git a/messages/uniworx/en-eu.msg b/messages/uniworx/en-eu.msg index 807fc4330..cfac175fd 100644 --- a/messages/uniworx/en-eu.msg +++ b/messages/uniworx/en-eu.msg @@ -400,6 +400,7 @@ 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. UnauthorizedExamOffice: You are not part of an exam office. +UnauthorizedEvaluation: You are not charged with course evaluation. UnauthorizedExamExamOffice: You are not part of the appropriate exam office for any of the participants of this exam. UnauthorizedExternalExamExamOffice: You are not part of the appropriate exam office for any of the participants of this exam. UnauthorizedSchoolLecturer: You are no lecturer for this department. @@ -1202,6 +1203,7 @@ MenuExternalExamUsers: Participants MenuExternalExamEdit: Edit MenuExternalExamNew: New external exam MenuExternalExamList: External exams +MenuParticipantsList: Lists of course participants BreadcrumbSubmissionFile: File BreadcrumbSubmissionUserInvite: Invitation to participate in a submission @@ -1262,6 +1264,8 @@ BreadcrumbExternalExamEdit: Edit BreadcrumbExternalExamUsers: Participants BreadcrumbExternalExamGrades: Exam results BreadcrumbExternalExamStaffInvite: Invitation +BreadcrumbParticipantsList: Lists of course participants +BreadcrumbParticipants: Course participants ExternalExamEdit coursen examn: Edit: #{coursen}, #{examn} ExternalExamGrades coursen examn: Exam achievements: #{coursen}, #{examn} @@ -1275,6 +1279,7 @@ AuthPredsActiveChanged: Authorisation settings saved for the current session AuthTagFree: Page is freely accessable AuthTagAdmin: User is administrator AuthTagExamOffice: User is part of an exam office +AuthTagEvaluation: User is charged with course evaluation AuthTagToken: User is presenting an authorisation-token AuthTagNoEscalation: User permissions are not being expanded to other departments AuthTagDeprecated: Page is not deprecated @@ -1718,6 +1723,7 @@ CourseUserCsvName tid ssh csh: #{foldCase (termToText (unTermKey tid))}-#{folded ExamUserCsvName tid ssh csh examn: #{foldCase (termToText (unTermKey tid))}-#{foldedCase (unSchoolKey ssh)}-#{foldedCase csh}-#{foldedCase examn}-participants ExternalExamUserCsvName tid@TermId ssh@SchoolId coursen@CourseName examn@ExamName: #{foldCase (termToText (unTermKey tid))}-#{foldedCase (unSchoolKey ssh)}-#{foldedCase coursen}-#{foldedCase examn}-participants CourseApplicationsTableCsvName tid ssh csh: #{foldCase (termToText (unTermKey tid))}-#{foldedCase (unSchoolKey ssh)}-#{foldedCase csh}-applications +ParticipantsCsvName tid ssh: #{foldCase (termToText (unTermKey tid))}-#{foldedCase (unSchoolKey ssh)}-participants CsvColumnsExplanationsLabel: Column & cell format CsvColumnsExplanationsTip: Meaning and format of the columns contained in imported and exported CSV files diff --git a/routes b/routes index e2f0bbb74..8bf60981c 100644 --- a/routes +++ b/routes @@ -108,6 +108,9 @@ /register ARegisterR POST !time /course/#CryptoUUIDCourse/apply AApplyR POST !timeANDallocation-registered +/participants ParticipantsListR GET !evaluation +/participants/#TermId/#SchoolId ParticipantsR GET !evaluation + -- For Pattern Synonyms see Foundation /course/ CourseListR GET !free diff --git a/src/Application.hs b/src/Application.hs index cc7d70d4d..e84ad6bb8 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -123,6 +123,7 @@ import Handler.Allocation import Handler.ExamOffice import Handler.Metrics import Handler.ExternalExam +import Handler.Participants -- This line actually creates our YesodDispatch instance. It is the second half diff --git a/src/Foundation.hs b/src/Foundation.hs index 96ed2e3fc..a4d40b60e 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -388,8 +388,19 @@ tagAccessPredicate AuthExamOffice = APDB $ \mAuthId route _ -> case route of return Authorized _other -> $cachedHereBinary mAuthId . exceptT return return $ do authId <- maybeExceptT AuthenticationRequired $ return mAuthId - adrights <- lift $ selectFirst [UserFunctionUser ==. authId, UserFunctionFunction ==. SchoolExamOffice] [] - guardMExceptT (isJust adrights) (unauthorizedI MsgUnauthorizedExamOffice) + isExamOffice <- lift $ exists [UserFunctionUser ==. authId, UserFunctionFunction ==. SchoolExamOffice] + guardMExceptT isExamOffice (unauthorizedI MsgUnauthorizedExamOffice) + return Authorized +tagAccessPredicate AuthEvaluation = APDB $ \mAuthId route _ -> case route of + ParticipantsR tid ssh -> $cachedHereBinary (mAuthId, tid, ssh) . exceptT return return $ do + authId <- maybeExceptT AuthenticationRequired $ return mAuthId + isEvaluation <- lift . existsBy $ UniqueUserFunction authId ssh SchoolEvaluation + guardMExceptT isEvaluation $ unauthorizedI MsgUnauthorizedEvaluation + return Authorized + _other -> $cachedHereBinary mAuthId . exceptT return return $ do + authId <- maybeExceptT AuthenticationRequired $ return mAuthId + isEvaluation <- lift $ exists [UserFunctionUser ==. authId, UserFunctionFunction ==. SchoolEvaluation] + guardMExceptT isEvaluation $ unauthorizedI MsgUnauthorizedEvaluation return Authorized tagAccessPredicate AuthToken = APDB $ \mAuthId route isWrite -> exceptT return return $ lift . validateToken mAuthId route isWrite =<< askTokenUnsafe @@ -1838,6 +1849,9 @@ instance YesodBreadcrumbs UniWorX where MaybeT $ get cid return (CI.original courseName, Just $ AllocationR tid ssh ash AShowR) + breadcrumb ParticipantsListR = i18nCrumb MsgBreadcrumbParticipantsList $ Just CourseListR + breadcrumb (ParticipantsR _ _) = i18nCrumb MsgBreadcrumbParticipants $ Just ParticipantsListR + breadcrumb CourseListR = i18nCrumb MsgMenuCourseList Nothing breadcrumb CourseNewR = i18nCrumb MsgMenuCourseNew $ Just CourseListR breadcrumb (CourseR tid ssh csh CShowR) = maybeT (i18nCrumb MsgBreadcrumbCourse . Just $ TermSchoolCourseListR tid ssh) $ do @@ -2411,6 +2425,14 @@ pageActions TermShowR = , menuItemModal = False , menuItemAccessCallback' = return True } + , MenuItem + { menuItemType = PageActionPrime + , menuItemLabel = MsgMenuParticipantsList + , menuItemIcon = Nothing + , menuItemRoute = SomeRoute ParticipantsListR + , menuItemModal = False + , menuItemAccessCallback' = return True + } ] pageActions (TermCourseListR tid) = [ MenuItem @@ -2467,6 +2489,14 @@ pageActions (CourseListR) = , menuItemModal = False , menuItemAccessCallback' = return True } + , MenuItem + { menuItemType = PageActionPrime + , menuItemLabel = MsgMenuParticipantsList + , menuItemIcon = Nothing + , menuItemRoute = SomeRoute ParticipantsListR + , menuItemModal = False + , menuItemAccessCallback' = return True + } ] pageActions (CourseNewR) = [ MenuItem @@ -3184,6 +3214,16 @@ pageActions (EExamR tid ssh coursen examn EEUsersR) = , menuItemAccessCallback' = return True } ] +pageActions ParticipantsListR = + [ MenuItem + { menuItemType = PageActionPrime + , menuItemLabel = MsgCsvOptions + , menuItemIcon = Nothing + , menuItemRoute = SomeRoute CsvOptionsR + , menuItemModal = True + , menuItemAccessCallback' = return True + } + ] pageActions _ = [] diff --git a/src/Handler/Participants.hs b/src/Handler/Participants.hs new file mode 100644 index 000000000..428da5491 --- /dev/null +++ b/src/Handler/Participants.hs @@ -0,0 +1,79 @@ +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} +module Handler.Participants + ( getParticipantsListR + , getParticipantsR + ) where + +import Import + +import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Utils as E + +import qualified Data.Set as Set + +import Handler.Utils.Csv +import Handler.Utils.ContentDisposition + +import qualified Data.Csv as Csv + +import qualified Data.Conduit.List as C + + +data ParticipantEntry = ParticipantEntry + { peCourse :: CourseName + , peEmail :: UserEmail + } deriving (Eq, Ord, Read, Show, Generic, Typeable) + +instance ToNamedRecord ParticipantEntry where + toNamedRecord ParticipantEntry{..} = Csv.namedRecord + [ "course" Csv..= peCourse + , "email" Csv..= peEmail + ] + +instance DefaultOrdered ParticipantEntry where + headerOrder _ = Csv.header ["course", "email"] + + +getParticipantsListR :: Handler Html +getParticipantsListR = do + schoolTerms'' <- runDB . E.select . E.from $ \(school `E.InnerJoin` term) -> do + E.on E.true + + E.where_ . E.exists . E.from $ \(course `E.InnerJoin` participant) -> do + E.on $ course E.^. CourseId E.==. participant E.^. CourseParticipantCourse + E.where_ $ course E.^. CourseTerm E.==. term E.^. TermId + E.&&. course E.^. CourseSchool E.==. school E.^. SchoolId + + return (school E.^. SchoolId, term E.^. TermId) + + schoolTerms' <- flip filterM schoolTerms'' $ \(E.Value ssh, E.Value tid) -> + hasReadAccessTo $ ParticipantsR tid ssh + + let schoolTerms :: Set (SchoolId, TermId) + schoolTerms = setOf (folded . $(multifocusG 2) (_1 . _Value) (_2 . _Value)) schoolTerms' + + siteLayoutMsg MsgMenuParticipantsList $ do + setTitleI MsgMenuParticipantsList + + let schools :: Set SchoolId + schools = Set.map (view _1) schoolTerms + terms :: Set TermId + terms = Set.map (view _2) schoolTerms + $(widgetFile "participants-list") + +getParticipantsR :: TermId -> SchoolId -> Handler TypedContent +getParticipantsR tid ssh = do + csvName <- timestampCsv <*> fmap (flip (addExtension `on` unpack) extensionCsv) (getMessageRender <*> pure (MsgParticipantsCsvName tid ssh)) + setContentDisposition' $ Just csvName + respondDefaultOrderedCsvDB $ E.selectSource partQuery .| C.map toParticipantEntry + where + partQuery = E.from $ \(course `E.InnerJoin` participant `E.InnerJoin` user) -> do + E.on $ user E.^. UserId E.==. participant E.^. CourseParticipantUser + E.on $ course E.^. CourseId E.==. participant E.^. CourseParticipantCourse + + E.where_ $ course E.^. CourseTerm E.==. E.val tid + E.&&. course E.^. CourseSchool E.==. E.val ssh + + return (course E.^. CourseName, user E.^. UserEmail) + + toParticipantEntry (E.Value peCourse, E.Value peEmail) = ParticipantEntry{..} diff --git a/src/Model/Types/Security.hs b/src/Model/Types/Security.hs index 95f11c217..65bf1259f 100644 --- a/src/Model/Types/Security.hs +++ b/src/Model/Types/Security.hs @@ -50,6 +50,7 @@ data AuthTag -- sortiert nach gewünschter Reihenfolge auf /authpreds, d.h. Prä | AuthTutor | AuthTutorControl | AuthExamOffice + | AuthEvaluation | AuthAllocationRegistered | AuthCourseRegistered | AuthTutorialRegistered diff --git a/src/Utils/Lens.hs b/src/Utils/Lens.hs index 72012f265..1e5042171 100644 --- a/src/Utils/Lens.hs +++ b/src/Utils/Lens.hs @@ -49,6 +49,9 @@ _nullable = prism' toNullable fromNullable _SchoolId :: Iso' SchoolId SchoolShorthand _SchoolId = iso unSchoolKey SchoolKey +_TermId :: Iso' TermId TermIdentifier +_TermId = iso unTermKey TermKey + _StudyTermsId :: Iso' StudyTermsId StudyTermsKey _StudyTermsId = iso unStudyTermsKey StudyTermsKey' diff --git a/templates/i18n/changelog/de-de-formal.hamlet b/templates/i18n/changelog/de-de-formal.hamlet index ad97f3dae..3da252aaa 100644 --- a/templates/i18n/changelog/de-de-formal.hamlet +++ b/templates/i18n/changelog/de-de-formal.hamlet @@ -1,5 +1,16 @@ $newline never
+
+ ^{formatGregorianW 2020 01 17} +
+