feat(exams): add extremely rudimentary registration table

messages/uniworx/de.msg

@@ -864,6 +864,7 @@ MenuTutorialComm: Mitteilung an Teilnehmer
 MenuExamList: Klausuren
 MenuExamNew: Neue Klausur anlegen
 MenuExamEdit: Bearbeiten
+MenuExamUsers: Teilnehmer
 
 AuthPredsInfo: Um eigene Veranstaltungen aus Sicht der Teilnehmer anzusehen, können Veranstalter und Korrektoren hier die Prüfung ihrer erweiterten Berechtigungen temporär deaktivieren. Abgewählte Prädikate schlagen immer fehl. Abgewählte Prädikate werden also nicht geprüft um Zugriffe zu gewähren, welche andernfalls nicht erlaubt wären. Diese Einstellungen gelten nur temporär bis Ihre Sitzung abgelaufen ist, d.h. bis ihr Browser-Cookie abgelaufen ist. Durch Abwahl von Prädikaten kann man sich höchstens temporär aussperren.
 AuthPredsActive: Aktive Authorisierungsprädikate
@@ -1164,4 +1165,6 @@ ExamClosedMustBeAfterStart: "Noten stehen fest ab" muss nach Start liegen
 ExamClosedMustBeAfterEnd: "Noten stehen fest ab" muss nach Ende liegen
 
 VersionHistory: Versionsgeschichte
-KnownBugs: Bekannte Bugs
+KnownBugs: Bekannte Bugs
+
+ExamUsersHeading: Klausurteilnehmer

src/Foundation.hs

@@ -1509,6 +1509,7 @@ instance YesodBreadcrumbs UniWorX where
 
   breadcrumb (CExamR tid ssh csh examn EShowR) = return (CI.original examn, Just $ CourseR tid ssh csh CExamListR)
   breadcrumb (CExamR tid ssh csh examn EEditR) = return ("Bearbeiten", Just $ CExamR tid ssh csh examn EShowR)
+  breadcrumb (CExamR tid ssh csh examn EUsersR) = return ("Teilnehmer", Just $ CExamR tid ssh csh examn EShowR)
 
   breadcrumb (CTutorialR tid ssh csh tutn TUsersR)   = return (CI.original tutn, Just $ CourseR tid ssh csh CTutorialListR)
   breadcrumb (CTutorialR tid ssh csh tutn TEditR)    = return ("Bearbeiten", Just $ CTutorialR tid ssh csh tutn TUsersR)
@@ -2192,6 +2193,14 @@ pageActions (CExamR tid ssh csh examn EShowR) =
       , menuItemModal = False
       , menuItemAccessCallback' = return True
       }
+  , MenuItem
+      { menuItemType  = PageActionPrime
+      , menuItemLabel = MsgMenuExamUsers
+      , menuItemIcon  = Nothing
+      , menuItemRoute = SomeRoute $ CExamR tid ssh csh examn EUsersR
+      , menuItemModal = False
+      , menuItemAccessCallback' = return True
+      }
   ]
 pageActions (CSheetR tid ssh csh shn SShowR) =
   [ MenuItem

src/Handler/Exam.hs

@@ -7,6 +7,7 @@ import Import
 import Handler.Utils
 import Handler.Utils.Exam
 import Handler.Utils.Invitations
+import Handler.Utils.Table.Columns
 import Handler.Utils.Table.Cells
 import Jobs.Queue
 
@@ -14,6 +15,7 @@ import Utils.Lens hiding (parts)
 
 import qualified Database.Esqueleto as E
 import qualified Database.Esqueleto.Utils as E
+import Database.Esqueleto.Utils.TH
 
 import Data.Map ((!), (!?))
 import qualified Data.Map as Map
@@ -731,9 +733,68 @@ getEShowR tid ssh csh examn = do
       examBonusW bonusRule = $(widgetFile "widgets/bonusRule")
     $(widgetFile "exam-show")
 
+type ExamUserTableExpr = (E.SqlExpr (Entity ExamRegistration) `E.InnerJoin` E.SqlExpr (Entity User)) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity ExamOccurrence))
+type ExamUserTableData = DBRow (Entity ExamRegistration, Entity User, Maybe (Entity ExamOccurrence))
+
+instance HasEntity ExamUserTableData User where
+  hasEntity = _dbrOutput . _2
+
+instance HasUser ExamUserTableData where
+  hasUser = _dbrOutput . _2 . _entityVal
+
+_userTableOccurrence :: Lens' ExamUserTableData (Maybe (Entity ExamOccurrence))
+_userTableOccurrence = _dbrOutput . _3
+
+queryUser :: ExamUserTableExpr -> E.SqlExpr (Entity User)
+queryUser = $(sqlIJproj 2 2) . $(sqlLOJproj 2 1)
+  
+queryExamRegistration :: ExamUserTableExpr -> E.SqlExpr (Entity ExamRegistration)
+queryExamRegistration = $(sqlIJproj 2 1) . $(sqlLOJproj 2 1)
+
 getEUsersR, postEUsersR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html
 getEUsersR = postEUsersR
-postEUsersR = error "postEUsersR"
+postEUsersR tid ssh csh examn = do
+  eid <- runDB $ fetchExamId tid ssh csh examn
+  
+  let
+    examUsersDBTable = DBTable{..}
+      where
+        dbtSQLQuery ((examRegistration `E.InnerJoin` user) `E.LeftOuterJoin` occurrence) = do
+          E.on $ occurrence E.?. ExamOccurrenceExam E.==. E.just (E.val eid)
+           E.&&. occurrence E.?. ExamOccurrenceId   E.==. examRegistration E.^. ExamRegistrationOccurrence
+          E.on $ examRegistration E.^. ExamRegistrationUser E.==. user E.^. UserId
+          E.where_ $ examRegistration E.^. ExamRegistrationExam E.==. E.val eid
+          return (examRegistration, user, occurrence)
+        dbtRowKey = queryExamRegistration >>> (E.^. ExamRegistrationId)
+        dbtProj = return
+        dbtColonnade = dbColonnade $ mconcat
+          [ colUserNameLink (CourseR tid ssh csh . CUserR)
+          , colUserMatriclenr
+          -- , colUserDegreeShort
+          -- , colUserField
+          -- , colUserSemester
+          , sortable (Just "room") (i18nCell MsgExamRoom) (maybe mempty (cell . toWgt . examOccurrenceRoom . entityVal) . view _userTableOccurrence)
+          ] 
+        dbtSorting = Map.fromList
+          [ sortUserNameLink    queryUser
+          , sortUserSurname     queryUser
+          , sortUserDisplayName queryUser
+          , sortUserMatriclenr  queryUser
+          ]
+        dbtFilter = Map.empty
+        dbtFilterUI = const mempty
+        dbtStyle = def
+        dbtParams = def
+        dbtIdent :: Text
+        dbtIdent = "exam-users"
+
+    examUsersDBTableValidator = def
+  ((), examUsersTable) <- runDB $ dbTable examUsersDBTableValidator examUsersDBTable
+
+  siteLayoutMsg (prependCourseTitle tid ssh csh MsgExamUsersHeading) $ do
+    setTitleI $ prependCourseTitle tid ssh csh MsgExamUsersHeading
+    $(widgetFile "exam-users")
+
 
 getEAddUserR, postEAddUserR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html
 getEAddUserR = postEAddUserR

templates/exam-users.hamlet

@@ -0,0 +1,2 @@
+$newline never
+^{examUsersTable}