From ced6ef287451cc59ef32f5454fc23e5cbf0f70eb Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Thu, 16 Apr 2020 17:19:16 +0200 Subject: [PATCH] feat(course-user): major improvements See #126 --- .dir-locals.el | 5 + frontend/src/utils/alerts/alerts.js | 2 +- messages/uniworx/de-de-formal.msg | 13 + src/Handler/Corrections.hs | 37 ++- src/Handler/Course/Show.hs | 8 +- src/Handler/Course/User.hs | 309 +++++++++++++++++++++++ src/Handler/Utils/Table/Pagination.hs | 19 +- src/Utils/Form.hs | 29 ++- src/Utils/Lens.hs | 1 + templates/corrections.hamlet | 1 + templates/course/user/corrections.hamlet | 5 + templates/course/user/exams.hamlet | 4 + templates/course/user/note.hamlet | 1 + templates/course/user/profile.hamlet | 95 +++---- templates/course/user/tutorials.hamlet | 4 + 15 files changed, 457 insertions(+), 76 deletions(-) create mode 100644 .dir-locals.el create mode 100644 templates/course/user/corrections.hamlet create mode 100644 templates/course/user/exams.hamlet create mode 100644 templates/course/user/tutorials.hamlet diff --git a/.dir-locals.el b/.dir-locals.el new file mode 100644 index 000000000..484dee737 --- /dev/null +++ b/.dir-locals.el @@ -0,0 +1,5 @@ +;;; Directory Local Variables +;;; For more information see (info "(emacs) Directory Variables") + +((nil + (indent-tabs-mode))) diff --git a/frontend/src/utils/alerts/alerts.js b/frontend/src/utils/alerts/alerts.js index 6c4a41a40..dcecc915b 100644 --- a/frontend/src/utils/alerts/alerts.js +++ b/frontend/src/utils/alerts/alerts.js @@ -155,7 +155,7 @@ export class Alerts { alertCloser.classList.add(ALERT_CLOSER_CLASS); const alertIcon = document.createElement('div'); - alertIcon.classList.add(ALERT_ICON_CLASS, 'fas', 'fa-fw', 'fa-' + icon); + alertIcon.classList.add(ALERT_ICON_CLASS, 'fas', 'fa-' + icon); const alertContent = document.createElement('div'); alertContent.classList.add(ALERT_CONTENT_CLASS); diff --git a/messages/uniworx/de-de-formal.msg b/messages/uniworx/de-de-formal.msg index 3225592d5..b41073150 100644 --- a/messages/uniworx/de-de-formal.msg +++ b/messages/uniworx/de-de-formal.msg @@ -166,6 +166,9 @@ CourseUserTutorial: Angemeldetes Tutorium CourseUserTutorials: Angemeldete Tutorien CourseUserExam: Angemeldete Prüfung CourseUserExams: Angemeldete Prüfungen +CourseSingleUserExams: Prüfungen +CourseSingleUserTutorials: Tutorien +CourseUserCorrections: Abgaben CourseUserNote: Notiz CourseUserNoteTooltip: Nur für Verwalter dieses Kurses einsehbar CourseUserNoteSaved: Notizänderungen gespeichert @@ -533,6 +536,9 @@ CloseAlert: Schliessen Name: Name MatrikelNr: Matrikelnummer +Surname: Nachname(n) +FirstName: Vorname(n) +Title: Titel LdapSynced: LDAP-Synchronisiert LdapSyncedBefore: Letzte LDAP-Synchronisation vor NoMatrikelKnown: Keine Matrikelnummer @@ -1710,6 +1716,7 @@ ExamRegistered: Zur Prüfung angemeldet ExamNotRegistered: Nicht zur Prüfung angemeldet ExamRegistration: Prüfungsanmeldung ExamLoginToRegister: Um sich zum Kurs anzumelden müssen Sie zunächst in Uni2work anmelden +ExamRegistrationTime: Angemeldet seit ExamRegisterToMustBeAfterRegisterFrom: "Anmeldung ab" muss vor "Anmeldung bis" liegen ExamDeregisterUntilMustBeAfterRegisterFrom: "Abmeldung bis" muss nach "Anmeldung bis" liegen @@ -1749,6 +1756,12 @@ ExamUsersResultsReset count@Int64: Prüfungsergebnis für #{show count} Teilnehm ExamUsersPartResultsSet count@Int64: Teilprüfungsergebnis für #{show count} Teilnehmer angepasst ExamUsersBonusSet count@Int64: Bonuspunkte für #{show count} Teilnehmer angepasst ExamUsersResultSet count@Int64: Prüfungsergebnis für #{show count} Teilnehmer angepasst +CourseUserTutorialsDeregistered count@Int64: Teilnehmer von #{show count} #{pluralDE count "Tutorium" "Tutorien"} abgemeldet +CourseUserNoTutorialsDeregistered: Teilnehmer ist zu keinem der gewählten Tutorien angemeldet +CourseUserExamsDeregistered count@Int64: Teilnehmer von #{show count} #{pluralDE count "Prüfung" "Prüfungen"} abgemeldet +CourseUserNoExamsDeregistered: Teilnehmer ist zu keiner der gewählten Prüfungen angemeldet +CourseUserExamsResultSet count@Int64: Ergebnis zu #{show count} #{pluralDE count "Prüfung" "Prüfungen"} erfolgreich angepasst +CourseUserExamResultDoesNotMatchMode examn@ExamName: Gewähtes Ergebnis passt nicht zu Bewertungsmodus von Prüfung „#{examn}“. ExamUserSynchronised: Synchronisiert ExamUserSyncOfficeName: Name diff --git a/src/Handler/Corrections.hs b/src/Handler/Corrections.hs index 2a161af78..db79ad6c4 100644 --- a/src/Handler/Corrections.hs +++ b/src/Handler/Corrections.hs @@ -8,6 +8,11 @@ module Handler.Corrections , getCorrectionsGradeR, postCorrectionsGradeR , getCAssignR, postCAssignR , getSAssignR, postSAssignR + , correctionsR' + , ratedBy, courseIs, sheetIs, userIs + , colTerm, colSchool, colCourse, colSheet, colCorrector, colSubmissionLink, colSelect, colSubmittors, colSMatrikel, colRating, colAssigned, colRated, colPseudonyms, colRatedField, colPointsField, colMaxPointsField, colCommentField, colLastEdit + , makeCorrectionsTable + , ActionCorrections(..), downloadAction, deleteAction, assignAction, autoAssignAction ) where import Import hiding (link) @@ -94,6 +99,12 @@ courseIs cid (( course `E.InnerJoin` _sheet `E.InnerJoin` _submission) `E.LeftO sheetIs :: Key Sheet -> CorrectionTableWhere sheetIs shid ((_course `E.InnerJoin` sheet `E.InnerJoin` _submission) `E.LeftOuterJoin` _corrector) = sheet E.^. SheetId E.==. E.val shid +userIs :: Key User -> CorrectionTableWhere +userIs uid ((_course `E.InnerJoin` _sheet `E.InnerJoin` submission) `E.LeftOuterJoin` _corrector) = E.exists . E.from $ \submissionUser -> + E.where_ $ submissionUser E.^. SubmissionUserSubmission E.==. submission E.^. SubmissionId + E.&&. submissionUser E.^. SubmissionUserUser E.==. E.val uid + + -- Columns colTerm :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a) @@ -417,6 +428,14 @@ data ActionCorrectionsData = CorrDownloadData correctionsR :: _ -> _ -> _ -> _ -> Map ActionCorrections (AForm (HandlerFor UniWorX) ActionCorrectionsData) -> Handler TypedContent correctionsR whereClause displayColumns dbtFilterUI psValidator actions = do + (table, statistics) <- correctionsR' whereClause displayColumns dbtFilterUI psValidator actions + + fmap toTypedContent . defaultLayout $ do + setTitleI MsgCourseCorrectionsTitle + $(widgetFile "corrections") + +correctionsR' :: _ -> _ -> _ -> _ -> Map ActionCorrections (AForm (HandlerFor UniWorX) ActionCorrectionsData) -> Handler (Widget, SheetTypeSummary) +correctionsR' whereClause displayColumns dbtFilterUI psValidator actions = do currentRoute <- fromMaybe (error "correctionsR called from 404-handler") <$> getCurrentRoute -- This should never be called from a 404 handler postDeleteR $ \drRecords -> (submissionDeleteRoute drRecords) @@ -450,14 +469,12 @@ correctionsR whereClause displayColumns dbtFilterUI psValidator actions = do & mapped._1 %~ fromMaybe (error "By consctruction the form should always return an action") . getLast auditAllSubEdit = mapM_ $ \sId -> getJust sId >>= \sub -> audit $ TransactionSubmissionEdit sId $ sub ^. _submissionSheet - case actionRes of - FormFailure errs -> mapM_ (addMessage Warning . toHtml) errs - FormMissing -> return () - FormSuccess (CorrDownloadData, subs) -> do + formResult actionRes $ \case + (CorrDownloadData, subs) -> do ids <- Set.fromList <$> forM (Set.toList subs) decrypt -- Set is not traversable addHeader "Content-Disposition" [st|attachment; filename="corrections.zip"|] sendResponse =<< submissionMultiArchive ids - FormSuccess (CorrSetCorrectorData (Just uid), subs') -> do + (CorrSetCorrectorData (Just uid), subs') -> do subs <- mapM decrypt $ Set.toList subs' now <- liftIO getCurrentTime runDB $ do @@ -490,7 +507,7 @@ correctionsR whereClause displayColumns dbtFilterUI psValidator actions = do return (E.countRows :: E.SqlExpr (E.Value Int64)) when (selfCorrectors > 0) $ addMessageI Warning $ MsgSelfCorrectors selfCorrectors redirect currentRoute - FormSuccess (CorrSetCorrectorData Nothing, subs') -> do -- delete corrections + (CorrSetCorrectorData Nothing, subs') -> do -- delete corrections subs <- mapM decrypt $ Set.toList subs' runDB $ do num <- updateWhereCount [SubmissionId <-. subs] @@ -503,7 +520,7 @@ correctionsR whereClause displayColumns dbtFilterUI psValidator actions = do addMessageI Success $ MsgRemovedCorrections num auditAllSubEdit subs redirect currentRoute - FormSuccess (CorrAutoSetCorrectorData shid, subs') -> do + (CorrAutoSetCorrectorData shid, subs') -> do subs <- mapM decrypt $ Set.toList subs' let assignExceptions :: AssignSubmissionException -> Handler () @@ -540,16 +557,14 @@ correctionsR whereClause displayColumns dbtFilterUI psValidator actions = do unassigned' <- forM (Set.toList stillUnassigned) $ \sid -> encrypt sid :: DB CryptoFileNameSubmission addMessage Warning =<< withUrlRenderer ($(ihamletFile "templates/messages/submissionsNotAssignedAuto.hamlet") mr) redirect currentRoute - FormSuccess (CorrDeleteData, subs) -> do + (CorrDeleteData, subs) -> do subs' <- Set.fromList <$> forM (Set.toList subs) decrypt -- Set is not traversable getDeleteR (submissionDeleteRoute subs') { drAbort = SomeRoute currentRoute , drSuccess = SomeRoute currentRoute } - fmap toTypedContent . defaultLayout $ do - setTitleI MsgCourseCorrectionsTitle - $(widgetFile "corrections") + return (table, statistics) where authorizedToAssign :: SubmissionId -> DB Bool diff --git a/src/Handler/Course/Show.hs b/src/Handler/Course/Show.hs index e419b3cce..48666e9f6 100644 --- a/src/Handler/Course/Show.hs +++ b/src/Handler/Course/Show.hs @@ -127,7 +127,7 @@ getCShowR tid ssh csh = do dbtColonnade = dbColonnade $ mconcat [ sortable (Just "type") (i18nCell MsgTutorialType) $ \DBRow{ dbrOutput = Entity _ Tutorial{..} } -> textCell $ CI.original tutorialType , sortable (Just "name") (i18nCell MsgTutorialName) $ \DBRow{ dbrOutput = Entity _ Tutorial{..} } -> indicatorCell <> anchorCell (CTutorialR tid ssh csh tutorialName TUsersR) [whamlet|#{tutorialName}|] - , sortable Nothing (i18nCell MsgTutorialTutors) $ \DBRow{ dbrOutput = Entity tutid _ } -> sqlCell $ do + , sortable (Just "tutors") (i18nCell MsgTutorialTutors) $ \DBRow{ dbrOutput = Entity tutid _ } -> sqlCell $ do tutTutors <- fmap (map $(unValueN 3)) . E.select . E.from $ \(tutor `E.InnerJoin` user) -> do E.on $ tutor E.^. TutorUser E.==. user E.^. UserId E.where_ $ tutor E.^. TutorTutorial E.==. E.val tutid @@ -176,6 +176,12 @@ getCShowR tid ssh csh = do , ("register-from", SortColumn $ \tutorial -> tutorial E.^. TutorialRegisterFrom ) , ("register-to", SortColumn $ \tutorial -> tutorial E.^. TutorialRegisterTo ) , ("deregister-until", SortColumn $ \tutorial -> tutorial E.^. TutorialDeregisterUntil ) + , ( "tutors" + , SortColumn $ \tutorial -> E.subSelectMaybe . E.from $ \(tutor `E.InnerJoin` user) -> do + E.on $ tutor E.^. TutorUser E.==. user E.^. UserId + E.where_ $ tutorial E.^. TutorialId E.==. tutor E.^. TutorTutorial + return . E.min_ $ user E.^. UserSurname + ) ] dbtFilter = Map.empty dbtFilterUI = const mempty diff --git a/src/Handler/Course/User.hs b/src/Handler/Course/User.hs index 240c80cec..f3b401c8c 100644 --- a/src/Handler/Course/User.hs +++ b/src/Handler/Course/User.hs @@ -6,9 +6,13 @@ import Import import Utils.Form import Handler.Utils +import Handler.Utils.SheetType import Database.Esqueleto.Utils.TH import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Utils as E + +import Database.Persist.Sql (deleteWhereCount) import Text.Blaze.Html.Renderer.Text (renderHtml) @@ -16,6 +20,31 @@ import Handler.Course.Register import Jobs.Queue +import Handler.Corrections + +import qualified Data.Map as Map +import qualified Data.Text as Text +import qualified Data.CaseInsensitive as CI + + +data ExamAction = ExamDeregister + | ExamSetResult + deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable) + deriving anyclass (Universe, Finite) +nullaryPathPiece ''ExamAction $ camelToPathPiece' 1 +embedRenderMessage ''UniWorX ''ExamAction $ Text.replace "Exam" "ExamUser" + +data ExamActionData = ExamDeregisterData + | ExamSetResultData (Maybe ExamResultPassedGrade) + +data TutorialAction = TutorialDeregister + deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable) + deriving anyclass (Universe, Finite) +nullaryPathPiece ''TutorialAction $ camelToPathPiece' 1 +embedRenderMessage ''UniWorX ''TutorialAction $ Text.replace "Tutorial" "TutorialUser" + +data TutorialActionData = TutorialDeregisterData + getCUserR, postCUserR :: TermId -> SchoolId -> CourseShorthand -> CryptoUUIDUser -> Handler Html getCUserR = postCUserR @@ -33,6 +62,9 @@ postCUserR tid ssh csh uCId = do sections <- mapM (runMaybeT . ($ user) . ($ course)) [ courseUserProfileSection , courseUserNoteSection + , courseUserExamsSection + , courseUserTutorialsSection + , courseUserSubmissionsSection ] -- generate output @@ -208,3 +240,280 @@ courseUserNoteSection (Entity cid _) (Entity uid _) = do redirect $ currentRoute :#: noteFrag -- reload page after post return $(widgetFile "course/user/note") + + +courseUserSubmissionsSection :: Entity Course -> Entity User -> MaybeT Handler Widget +courseUserSubmissionsSection (Entity cid _) (Entity uid _) = do + let whereClause = (E.&&.) <$> courseIs cid <*> userIs uid + colonnade = mconcat -- should match getSSubsR for consistent UX + [ colSelect + , colSheet + , colSMatrikel + , colSubmittors + , colSubmissionLink + , colLastEdit + , colRating + , colRated + , colCorrector + , colAssigned + ] -- Continue here + filterUI = Just $ \mPrev -> mconcat + [ prismAForm (singletonFilter "user-name-email") mPrev $ aopt textField (fslI MsgCourseMembers) + , prismAForm (singletonFilter "user-matriclenumber") mPrev $ aopt textField (fslI MsgMatrikelNr) + -- "pseudonym" TODO DB only stores Word24 + , Map.singleton "sheet-search" . maybeToList <$> aopt textField (fslI MsgSheet) (Just <$> listToMaybe =<< ((Map.lookup "sheet-search" =<< mPrev) <|> (Map.lookup "sheet" =<< mPrev))) + , prismAForm (singletonFilter "corrector-name-email") mPrev $ aopt textField (fslI MsgCorrector) + , prismAForm (singletonFilter "isassigned" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgHasCorrector) + , prismAForm (singletonFilter "israted" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgRatingTime) + , prismAForm (singletonFilter "submission") mPrev $ aopt (lift `hoistField` textField) (fslI MsgSubmission) + ] + psValidator = def & defaultPagesize PagesizeAll -- Assisstant always want to see them all at once anyway + (cWdgt, statistics) <- lift . correctionsR' whereClause colonnade filterUI psValidator $ Map.fromList + [ downloadAction + , assignAction (Left cid) + , deleteAction + ] + + guard $ statistics /= mempty + + return $(widgetFile "course/user/corrections") + + +courseUserExamsSection :: Entity Course -> Entity User -> MaybeT Handler Widget +courseUserExamsSection (Entity cid Course{..}) (Entity uid _) = do + uCID <- encrypt uid + + let + examDBTable = DBTable{..} + where + dbtSQLQuery exam = do + E.where_ $ exam E.^. ExamCourse E.==. E.val cid + E.where_ $ E.or + [ E.exists . E.from $ \examRegistration -> + E.where_ $ examRegistration E.^. ExamRegistrationUser E.==. E.val uid + E.&&. examRegistration E.^. ExamRegistrationExam E.==. exam E.^. ExamId + , E.exists . E.from $ \(examPart `E.InnerJoin` examPartResult) -> do + E.on $ examPart E.^. ExamPartId E.==. examPartResult E.^. ExamPartResultExamPart + E.where_ $ examPartResult E.^. ExamPartResultUser E.==. E.val uid + E.&&. examPart E.^. ExamPartExam E.==. exam E.^. ExamId + , E.exists . E.from $ \examBonus -> + E.where_ $ examBonus E.^. ExamBonusUser E.==. E.val uid + E.&&. examBonus E.^. ExamBonusExam E.==. exam E.^. ExamId + , E.exists . E.from $ \examResult -> + E.where_ $ examResult E.^. ExamResultUser E.==. E.val uid + E.&&. examResult E.^. ExamResultExam E.==. exam E.^. ExamId + ] + return exam + dbtRowKey = (E.^. ExamId) + dbtProj = traverse $ \exam@(Entity eId _) -> do + registration <- getBy $ UniqueExamRegistration eId uid + occurrence <- runMaybeT $ do + Entity _ ExamRegistration{..} <- hoistMaybe registration + occId <- hoistMaybe examRegistrationOccurrence + MaybeT $ getEntity occId + bonus <- getBy $ UniqueExamBonus eId uid + result <- getBy $ UniqueExamResult eId uid + + return ( exam + , occurrence + , bonus + , result + , registration + ) + dbtColonnade = mconcat + [ dbSelect (_2 . applying _2) _1 $ return . view (_dbrOutput . _1 . _entityKey) + , sortable (Just "name") (i18nCell MsgExamName) $ tellCell (Any True, mempty) . anchorCell' (\(view $ _dbrOutput . _1 . _entityVal -> Exam{..}) -> CExamR courseTerm courseSchool courseShorthand examName EShowR) (view $ _dbrOutput . _1 . _entityVal . _examName) + , sortable (Just "occurrence") (i18nCell MsgExamOccurrence) $ maybe mempty (cell . toWidget) . preview (_dbrOutput . _2 . _Just . _entityVal . _examOccurrenceName) + , sortable (Just "registration-time") (i18nCell MsgExamRegistrationTime) $ maybe mempty (cell . formatTimeW SelFormatDateTime) . preview (_dbrOutput . _5 . _Just . _entityVal . _examRegistrationTime) + , sortable (Just "bonus") (i18nCell MsgExamBonusAchieved) $ maybe mempty i18nCell . preview (_dbrOutput . _3 . _Just . _entityVal . _examBonusBonus) + , sortable (Just "result") (i18nCell MsgExamResult) $ maybe mempty i18nCell . preview (_dbrOutput . _4 . _Just . _entityVal . _examResultResult) + ] + dbtSorting = mconcat + [ singletonMap "name" . SortColumn $ \exam -> exam E.^. ExamName + , singletonMap "occurrence" . SortColumn $ \exam -> E.subSelectMaybe . E.from $ \(examOccurrence `E.InnerJoin` examRegistration) -> do + E.on $ examRegistration E.^. ExamRegistrationOccurrence E.==. E.just (examOccurrence E.^. ExamOccurrenceId) + E.where_ $ examRegistration E.^. ExamRegistrationExam E.==. exam E.^. ExamId + E.&&. examRegistration E.^. ExamRegistrationUser E.==. E.val uid + return . E.just $ examOccurrence E.^. ExamOccurrenceName + , singletonMap "registration-time" . SortColumn $ \exam -> E.subSelectMaybe . E.from $ \examRegistration -> do + E.where_ $ examRegistration E.^. ExamRegistrationExam E.==. exam E.^. ExamId + E.&&. examRegistration E.^. ExamRegistrationUser E.==. E.val uid + return . E.just $ examRegistration E.^. ExamRegistrationTime + , singletonMap "bonus" . SortColumn $ \exam -> E.subSelectMaybe . E.from $ \examBonus -> do + E.where_ $ examBonus E.^. ExamBonusExam E.==. exam E.^. ExamId + E.&&. examBonus E.^. ExamBonusUser E.==. E.val uid + return . E.just $ examBonus E.^. ExamBonusBonus + , singletonMap "result" . SortColumn $ \exam -> E.subSelectMaybe . E.from $ \examResult -> do + E.where_ $ examResult E.^. ExamResultExam E.==. exam E.^. ExamId + E.&&. examResult E.^. ExamResultUser E.==. E.val uid + return . E.just $ examResult E.^. ExamResultResult + ] + dbtFilter = mempty + dbtFilterUI _mPrev = mempty + dbtStyle = def + dbtParams = DBParamsForm + { dbParamsFormMethod = POST + , dbParamsFormAction = Just . SomeRoute . CourseR courseTerm courseSchool courseShorthand $ CUserR uCID + , dbParamsFormAttrs = [] + , dbParamsFormSubmit = FormSubmit + , dbParamsFormAdditional = \csrf -> do + let + actionMap :: Map ExamAction (AForm Handler ExamActionData) + actionMap = mconcat + [ singletonMap ExamDeregister $ + pure ExamDeregisterData + , singletonMap ExamSetResult $ + ExamSetResultData <$> aopt (examResultModeField (Just $ SomeMessage MsgExamResultNone) ExamGradingMixed) (fslI MsgExamResult) Nothing + ] + + (res, formWgt) <- multiActionM actionMap (fslI MsgAction) Nothing csrf + let formRes = (, mempty) . First . Just <$> res + return (formRes, formWgt) + , dbParamsFormEvaluate = liftHandler . runFormPost + , dbParamsFormResult = _2 + , dbParamsFormIdent = def + } + dbtIdent :: Text + dbtIdent = "course-user-exams" + dbtCsvEncode = noCsvEncode + dbtCsvDecode = Nothing + examDBTableValidator = def & defaultSorting [SortAscBy "registration-time"] + postprocess :: FormResult (First ExamActionData, DBFormResult ExamId (Bool, _) _) -> FormResult (ExamActionData, Map ExamId _) + postprocess inp = do + (First (Just act), regMap) <- inp + let regMap' = Map.mapMaybe (uncurry guardOn) $ getDBFormResult (False,) regMap + return (act, regMap') + ((Any hasExams, actRes), examTable) <- lift . runDB $ over (_1 . _2) postprocess <$> dbTable examDBTableValidator examDBTable + + lift . formResult actRes $ \case + (ExamDeregisterData, Map.keys -> selectedExams) -> do + nrDel <- runDB $ deleteWhereCount + [ ExamRegistrationUser ==. uid + , ExamRegistrationExam <-. selectedExams + ] + if | nrDel > 0 -> addMessageI Success $ MsgCourseUserExamsDeregistered nrDel + | otherwise -> addMessageI Info MsgCourseUserNoExamsDeregistered + redirect . CourseR courseTerm courseSchool courseShorthand $ CUserR uCID + (ExamSetResultData mRes, selectedExams) -> do + now <- liftIO getCurrentTime + Sum nrUpdated <- runDB . flip ifoldMapM selectedExams $ \eId (view $ _dbrOutput . _1 . _entityVal -> Exam{..}) -> if + | hasExamGradingGrades examGradingMode || isn't (_Just . _ExamAttended . _Right) mRes + , hasExamGradingPass examGradingMode || isn't (_Just . _ExamAttended . _Left ) mRes + -> do + oldResult <- getBy $ UniqueExamResult eId uid + case mRes of + Just res + | maybe True ((/= res) . examResultResult . entityVal) oldResult -> do + void $ upsert + ExamResult + { examResultExam = eId + , examResultUser = uid + , examResultResult = res + , examResultLastChanged = now + } + [ ExamResultResult =. res, ExamResultLastChanged =. now ] + audit $ TransactionExamResultEdit eId uid + return $ Sum 1 + Nothing + | is _Just oldResult -> do + deleteBy $ UniqueExamResult eId uid + audit $ TransactionExamResultDeleted eId uid + return $ Sum 1 + _other -> return mempty + | otherwise -> mempty <$ addMessageI Error (MsgCourseUserExamResultDoesNotMatchMode examName) + when (nrUpdated > 0) . addMessageI Success $ MsgCourseUserExamsResultSet nrUpdated + redirect . CourseR courseTerm courseSchool courseShorthand $ CUserR uCID + + guard hasExams + + return $(widgetFile "course/user/exams") + + +courseUserTutorialsSection :: Entity Course -> Entity User -> MaybeT Handler Widget +courseUserTutorialsSection (Entity cid Course{..}) (Entity uid _) = do + uCID <- encrypt uid + + let + tutorialDBTable = DBTable{..} + where + dbtSQLQuery (tutorial `E.InnerJoin` tutorialParticipant) = do + E.on $ tutorial E.^. TutorialId E.==. tutorialParticipant E.^. TutorialParticipantTutorial + E.where_ $ tutorial E.^. TutorialCourse E.==. E.val cid + E.&&. tutorialParticipant E.^. TutorialParticipantUser E.==. E.val uid + return (tutorial, tutorialParticipant) + dbtRowKey (_ `E.InnerJoin` tutorialParticipant) = tutorialParticipant E.^. TutorialParticipantId + dbtProj = traverse $ \(tutorial, tutorialParticipant) -> do + tutors <- E.select . E.from $ \(tutor `E.InnerJoin` user) -> do + E.on $ tutor E.^. TutorUser E.==. user E.^. UserId + E.where_ $ tutor E.^. TutorTutorial E.==. E.val (tutorial ^. _entityKey) + return user + return (tutorial, tutorialParticipant, tutors) + dbtColonnade = mconcat + [ dbSelect (_2 . applying _2) _1 $ return . view (_dbrOutput . _2 . _entityKey) + , sortable (Just "type") (i18nCell MsgTutorialType) $ textCell . CI.original . view (_dbrOutput . _1 . _entityVal . _tutorialType) + , sortable (Just "name") (i18nCell MsgTutorialName) $ tellCell (Any True, mempty) . anchorCell' (\(view $ _dbrOutput . _1 . _entityVal . _tutorialName -> tutn) -> CTutorialR courseTerm courseSchool courseShorthand tutn TUsersR) (view $ _dbrOutput . _1 . _entityVal . _tutorialName) + , sortable (Just "tutors") (i18nCell MsgTutorialTutors) $ \(view $ _dbrOutput . _3 -> tutors) -> cell + [whamlet| + $newline never +