From 31e6b72c463e7f638a2cc2ff6f19b67f2d49db73 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 3 Jul 2019 11:56:44 +0200 Subject: [PATCH] feat(exams): add extremely rudimentary registration table --- messages/uniworx/de.msg | 5 ++- src/Foundation.hs | 9 ++++++ src/Handler/Exam.hs | 63 ++++++++++++++++++++++++++++++++++++- templates/exam-users.hamlet | 2 ++ 4 files changed, 77 insertions(+), 2 deletions(-) create mode 100644 templates/exam-users.hamlet diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 6ae69522d..dadac1c30 100644 --- a/messages/uniworx/de.msg +++ b/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 \ No newline at end of file +KnownBugs: Bekannte Bugs + +ExamUsersHeading: Klausurteilnehmer \ No newline at end of file diff --git a/src/Foundation.hs b/src/Foundation.hs index ba5336f14..8a9896dcd 100644 --- a/src/Foundation.hs +++ b/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 diff --git a/src/Handler/Exam.hs b/src/Handler/Exam.hs index f8fb8722e..0cd76224a 100644 --- a/src/Handler/Exam.hs +++ b/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 diff --git a/templates/exam-users.hamlet b/templates/exam-users.hamlet new file mode 100644 index 000000000..dea20c2a7 --- /dev/null +++ b/templates/exam-users.hamlet @@ -0,0 +1,2 @@ +$newline never +^{examUsersTable}