From 93e718f32366b4f4b6cd083473f15b192aeb642f Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 6 Aug 2019 17:05:05 +0200 Subject: [PATCH] feat(exams): improve immediate exam table on home page --- src/Handler/Home.hs | 58 ++++++++++++++++++++++++++++++++------------- 1 file changed, 41 insertions(+), 17 deletions(-) diff --git a/src/Handler/Home.hs b/src/Handler/Home.hs index 87d36f53a..1c07cfc6b 100644 --- a/src/Handler/Home.hs +++ b/src/Handler/Home.hs @@ -196,24 +196,39 @@ homeUpcomingExams uid = do examDBTable = DBTable{..} where -- for ease of refactoring: - queryCourse = $(sqlIJproj 2 1) - queryExam = $(sqlIJproj 2 2) - lensCourse = _1 - lensExam = _2 + queryCourse = $(sqlIJproj 2 1) . $(sqlLOJproj 3 1) + queryExam = $(sqlIJproj 2 2) . $(sqlLOJproj 3 1) + lensCourse = _1 + lensExam = _2 + lensRegister = _3 . _Just + lensOccurrence = _4 . _Just - dbtSQLQuery (course `E.InnerJoin` exam) = do + dbtSQLQuery ((course `E.InnerJoin` exam) `E.LeftOuterJoin` register `E.LeftOuterJoin` occurrence) = do + E.on $ register E.?. ExamRegistrationOccurrence E.==. E.just (occurrence E.?. ExamOccurrenceId) + E.on $ register E.?. ExamRegistrationExam E.==. E.just (exam E.^. ExamId) + E.&&. register E.?. ExamRegistrationUser E.==. E.just (E.val uid) E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse E.where_ $ E.exists $ E.from $ \participant -> E.where_ $ participant E.^. CourseParticipantUser E.==. E.val uid E.&&. participant E.^. CourseParticipantCourse E.==. course E.^. CourseId - let regFromJustFortnight = - E.isJust (exam E.^. ExamRegisterFrom) - E.&&. exam E.^. ExamRegisterFrom E.<=. E.just (E.val fortnight) - regToJustNow = - E.isJust (exam E.^. ExamEnd) - E.&&. exam E.^. ExamEnd E.>=. E.just (E.val now) - E.where_ $ regFromJustFortnight E.&&. regToJustNow - return (course, exam) + let regToWithinFortnight = exam E.^. ExamRegisterTo E.<=. E.just (E.val fortnight) + E.&&. exam E.^. ExamRegisterTo E.>=. E.just (E.val now) + E.&&. E.isNothing (register E.?. ExamRegistrationId) + startExamFortnight = exam E.^. ExamStart E.<=. E.just (E.val fortnight) + E.&&. exam E.^. ExamStart E.>=. E.just (E.val now) + E.&&. E.isJust (register E.?. ExamRegistrationId) + startOccurFortnight = occurrence E.?. ExamOccurrenceStart E.<=. E.just (E.val fortnight) + E.&&. occurrence E.?. ExamOccurrenceStart E.>=. E.just (E.val now) + E.&&. E.isJust (register E.?. ExamRegistrationId) + earliestOccurrence = E.sub_select $ E.from $ \occ -> do + E.where_ $ occ E.^. ExamOccurrenceExam E.==. exam E.^. ExamId + E.&&. occ E.^. ExamOccurrenceStart E.>=. E.val now + return $ E.min_ $ occ E.^. ExamOccurrenceStart + startEarliest = E.isNothing (occurrence E.?. ExamOccurrenceId) + E.&&. earliestOccurrence E.<=. E.just (E.val fortnight) + -- E.&&. earliestOccurrence E.>=. E.just (E.val now) + E.where_ $ regToWithinFortnight E.||. startExamFortnight E.||. startOccurFortnight E.||. startEarliest + return (course, exam, register, occurrence) dbtRowKey = queryExam >>> (E.^. ExamId) dbtProj r@DBRow{ dbrOutput } = do let Entity _ Exam{..} = view lensExam dbrOutput @@ -234,7 +249,12 @@ homeUpcomingExams uid = do indicatorCell <> anchorCell (CExamR courseTerm courseSchool courseShorthand examName EShowR) examName , sortable (Just "register-from") (i18nCell MsgExamRegisterFrom) $ \DBRow { dbrOutput = view lensExam -> Entity _ Exam{..} } -> maybe mempty dateTimeCell examRegisterFrom , sortable (Just "register-to") (i18nCell MsgExamRegisterTo) $ \DBRow { dbrOutput = view lensExam -> Entity _ Exam{..} } -> maybe mempty dateTimeCell examRegisterTo - , sortable (Just "time") (i18nCell MsgExamTime) $ \DBRow{ dbrOutput = view lensExam -> Entity _ Exam{..} } -> maybe mempty (cell . flip (formatTimeRangeW SelFormatDateTime) examEnd) examStart + , sortable (Just "time") (i18nCell MsgExamTime) $ \DBRow{ dbrOutput } -> + if | Just (Entity _ ExamOccurrence{..}) <- preview lensOccurrence dbrOutput + -> cell $ formatTimeRangeW SelFormatDateTime examOccurrenceStart examOccurrenceEnd + | Entity _ Exam{..} <- view lensExam dbrOutput + , Just start <- examStart -> cell $ formatTimeRangeW SelFormatDateTime start examEnd + | otherwise -> mempty {- NOTE: We do not want thoughtless exam registrations, since many people click "register" and don't show up, causing logistic problems. Hence we force them here to click twice. Maybe add a captcha where users have to distinguish pictures showing pink elephants and course lecturers. , sortable Nothing mempty $ \DBRow{ dbrOutput } -> sqlCell $ do @@ -254,14 +274,18 @@ homeUpcomingExams uid = do | otherwise -> return mempty -} , sortable (Just "registered") (i18nCell MsgExamRegistration ) $ \DBRow{ dbrOutput } -> sqlCell $ do - let Entity eId Exam{..} = view lensExam dbrOutput + let Entity _ Exam{..} = view lensExam dbrOutput Entity _ Course{..} = view lensCourse dbrOutput mayRegister <- (== Authorized) <$> evalAccessDB (CExamR courseTerm courseSchool courseShorthand examName ERegisterR) True - isRegistered <- existsBy $ UniqueExamRegistration eId uid - let label = bool MsgExamNotRegistered MsgExamRegistered isRegistered + let isRegistered = has lensRegister dbrOutput + label = bool MsgExamNotRegistered MsgExamRegistered isRegistered examUrl = CExamR courseTerm courseSchool courseShorthand examName EShowR if | mayRegister -> return $ simpleLinkI (SomeMessage label) examUrl | otherwise -> return [whamlet|_{label}|] + , sortable (toNothingS "occurrence") (i18nCell MsgExamOccurrence) $ \DBRow{ dbrOutput } -> + if | Just (Entity _ ExamOccurrence{..}) <- preview lensOccurrence dbrOutput + -> textCell examOccurrenceRoom + | otherwise -> mempty ] dbtSorting = Map.fromList [ ("demo-both", SortColumn $ queryCourse &&& queryExam >>> (\(_course,exam)-> exam E.^. ExamName))