feat: course-participant-lists

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

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

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

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

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 _ = []
 
 

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{..}

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

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'
 

templates/i18n/changelog/de-de-formal.hamlet

@@ -1,5 +1,16 @@
 $newline never
 <dl .deflist>
+  <dt .deflist__dt>
+    ^{formatGregorianW 2020 01 17}
+  <dd .deflist__dd>
+    <ul>
+      <li>
+        Eintragung von Ergebnissen für extern (nicht in Uni2work #
+        verwaltete) Klausuren zur Übermittlung an Prüfungsbeauftragte
+      <li>
+        Export von Listen von Kursteilnehmern zur Durchführung von #
+        Kursumfragen
+
   <dt .deflist__dt>
     ^{formatGregorianW 2019 12 05}
   <dd .deflist__dd>

templates/i18n/changelog/en-eu.hamlet

@@ -1,5 +1,15 @@
 $newline never
 <dl .deflist>
+  <dt .deflist__dt>
+    ^{formatGregorianW 2020 01 17}
+  <dd .deflist__dd>
+    <ul>
+      <li>
+        Support for uploading results of external exams (not managed #
+        within Uni2work).
+      <li>
+        Export of lists of course participants
+
   <dt .deflist__dt>
     ^{formatGregorianW 2019 12 05}
   <dd .deflist__dd>

templates/participants-list.hamlet

@@ -0,0 +1,17 @@
+$newline never
+<div .scrolltable .scrolltable--bordered>
+  <table .table .table--striped .table--hover>
+    <thead>
+      <tr .table__row .table__row--head>
+        <th .table__th>_{MsgTerm}
+        $forall school <- schools
+          <th .table__th>#{unSchoolKey school}
+    <tbody>
+      $forall term <- terms
+        <tr .table__row>
+          <th .table__th>_{ShortTermIdentifier (unTermKey term)}
+          $forall school <- schools
+            <td .table__td>
+              $if Set.member (school, term) schoolTerms
+                <a href=@{ParticipantsR term school}>
+                  #{iconFileCSV}