fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

feat(exams): improve immediate exam table on home page

Browse Source
This commit is contained in:
Steffen Jost 2019-08-06 17:05:05 +02:00
parent e3aacbbc10
commit 93e718f323
1 changed files with 41 additions and 17 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

58
src/Handler/Home.hs
View File

@ -196,24 +196,39 @@ homeUpcomingExams uid = do
examDBTable = DBTable{..} examDBTable = DBTable{..}
where where
-- for ease of refactoring: -- for ease of refactoring:
queryCourse = $(sqlIJproj 2 1) queryCourse = $(sqlIJproj 2 1) . $(sqlLOJproj 3 1)
queryExam = $(sqlIJproj 2 2) queryExam = $(sqlIJproj 2 2) . $(sqlLOJproj 3 1)
lensCourse = _1 lensCourse = _1
lensExam = _2 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.on $ course E.^. CourseId E.==. exam E.^. ExamCourse
E.where_ $ E.exists $ E.from $ \participant -> E.where_ $ E.exists $ E.from $ \participant ->
E.where_ $ participant E.^. CourseParticipantUser E.==. E.val uid E.where_ $ participant E.^. CourseParticipantUser E.==. E.val uid
E.&&. participant E.^. CourseParticipantCourse E.==. course E.^. CourseId E.&&. participant E.^. CourseParticipantCourse E.==. course E.^. CourseId
let regFromJustFortnight = let regToWithinFortnight = exam E.^. ExamRegisterTo E.<=. E.just (E.val fortnight)
E.isJust (exam E.^. ExamRegisterFrom) E.&&. exam E.^. ExamRegisterTo E.>=. E.just (E.val now)
E.&&. exam E.^. ExamRegisterFrom E.<=. E.just (E.val fortnight) E.&&. E.isNothing (register E.?. ExamRegistrationId)
regToJustNow = startExamFortnight = exam E.^. ExamStart E.<=. E.just (E.val fortnight)
E.isJust (exam E.^. ExamEnd) E.&&. exam E.^. ExamStart E.>=. E.just (E.val now)
E.&&. exam E.^. ExamEnd E.>=. E.just (E.val now) E.&&. E.isJust (register E.?. ExamRegistrationId)
E.where_ $ regFromJustFortnight E.&&. regToJustNow startOccurFortnight = occurrence E.?. ExamOccurrenceStart E.<=. E.just (E.val fortnight)
return (course, exam) 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) dbtRowKey = queryExam >>> (E.^. ExamId)
dbtProj r@DBRow{ dbrOutput } = do dbtProj r@DBRow{ dbrOutput } = do
let Entity _ Exam{..} = view lensExam dbrOutput let Entity _ Exam{..} = view lensExam dbrOutput
@ -234,7 +249,12 @@ homeUpcomingExams uid = do
indicatorCell <> anchorCell (CExamR courseTerm courseSchool courseShorthand examName EShowR) examName 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-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 "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. {- 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. 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 , sortable Nothing mempty $ \DBRow{ dbrOutput } -> sqlCell $ do
@ -254,14 +274,18 @@ homeUpcomingExams uid = do
| otherwise -> return mempty | otherwise -> return mempty
-} -}
, sortable (Just "registered") (i18nCell MsgExamRegistration ) $ \DBRow{ dbrOutput } -> sqlCell $ do , 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 Entity _ Course{..} = view lensCourse dbrOutput
mayRegister <- (== Authorized) <$> evalAccessDB (CExamR courseTerm courseSchool courseShorthand examName ERegisterR) True mayRegister <- (== Authorized) <$> evalAccessDB (CExamR courseTerm courseSchool courseShorthand examName ERegisterR) True
isRegistered <- existsBy $ UniqueExamRegistration eId uid let isRegistered = has lensRegister dbrOutput
let label = bool MsgExamNotRegistered MsgExamRegistered isRegistered label = bool MsgExamNotRegistered MsgExamRegistered isRegistered
examUrl = CExamR courseTerm courseSchool courseShorthand examName EShowR examUrl = CExamR courseTerm courseSchool courseShorthand examName EShowR
if | mayRegister -> return $ simpleLinkI (SomeMessage label) examUrl if | mayRegister -> return $ simpleLinkI (SomeMessage label) examUrl
| otherwise -> return [whamlet|_{label}|] | 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 dbtSorting = Map.fromList
[ ("demo-both", SortColumn $ queryCourse &&& queryExam >>> (\(_course,exam)-> exam E.^. ExamName)) [ ("demo-both", SortColumn $ queryCourse &&& queryExam >>> (\(_course,exam)-> exam E.^. ExamName))