From 93e718f32366b4f4b6cd083473f15b192aeb642f Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 6 Aug 2019 17:05:05 +0200 Subject: [PATCH 1/6] 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)) From 2eb062beb2f9d32935f24420b217a778d97fa13d Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 6 Aug 2019 17:13:59 +0200 Subject: [PATCH 2/6] chore(release): 4.12.0 --- CHANGELOG.md | 9 +++++++++ package-lock.json | 2 +- package.json | 2 +- package.yaml | 2 +- 4 files changed, 12 insertions(+), 3 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 0453ae009..743bc955f 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,15 @@ All notable changes to this project will be documented in this file. See [standard-version](https://github.com/conventional-changelog/standard-version) for commit guidelines. +## [4.12.0](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v4.11.0...v4.12.0) (2019-08-06) + + +### Features + +* **exams:** improve immediate exam table on home page ([93e718f](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/93e718f)) + + + ## [4.11.0](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v4.10.0...v4.11.0) (2019-08-06) diff --git a/package-lock.json b/package-lock.json index e7b59044e..de67ce757 100644 --- a/package-lock.json +++ b/package-lock.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "4.11.0", + "version": "4.12.0", "lockfileVersion": 1, "requires": true, "dependencies": { diff --git a/package.json b/package.json index 6b16974f7..3f140f0f3 100644 --- a/package.json +++ b/package.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "4.11.0", + "version": "4.12.0", "description": "", "keywords": [], "author": "", diff --git a/package.yaml b/package.yaml index 12f20a1a2..9a0a9e2be 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: uniworx -version: 4.11.0 +version: 4.12.0 dependencies: # Due to a bug in GHC 8.0.1, we block its usage From 3d63b355eb15daf858b554afe41932b117b00dd7 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 6 Aug 2019 17:19:00 +0200 Subject: [PATCH 3/6] fix(exams): allow occurrences after exam end --- src/Handler/Exam/Form.hs | 12 ++++++------ src/Utils/Form.hs | 17 +++++++++++++---- 2 files changed, 19 insertions(+), 10 deletions(-) diff --git a/src/Handler/Exam/Form.hs b/src/Handler/Exam/Form.hs index 905adc4fe..5948bf744 100644 --- a/src/Handler/Exam/Form.hs +++ b/src/Handler/Exam/Form.hs @@ -11,18 +11,18 @@ import Import import Utils.Lens hiding (parts) import Handler.Exam.CorrectorInvite - + import Handler.Utils import Handler.Utils.Invitations - + import Data.Map ((!)) import qualified Data.Set as Set - + import qualified Database.Esqueleto as E - + import qualified Control.Monad.State.Class as State import Text.Blaze.Html.Renderer.String (renderHtml) - + data ExamForm = ExamForm { efName :: ExamName @@ -346,7 +346,7 @@ validateExam = do forM_ efOccurrences $ \ExamOccurrenceForm{..} -> do guardValidation (MsgExamOccurrenceEndMustBeAfterStart eofName) $ NTop eofEnd >= NTop (Just eofStart) guardValidation (MsgExamOccurrenceStartMustBeAfterExamStart eofName) $ NTop (Just eofStart) >= NTop efStart - guardValidation (MsgExamOccurrenceEndMustBeBeforeExamEnd eofName) $ NTop eofEnd <= NTop efEnd + warnValidation (MsgExamOccurrenceEndMustBeBeforeExamEnd eofName) $ NTop eofEnd <= NTop efEnd forM_ [ (a, b) | a <- Set.toAscList efOccurrences, b <- Set.toAscList efOccurrences, b > a ] $ \(a, b) -> do eofRange' <- formatTimeRange SelFormatDateTime (eofStart a) (eofEnd a) diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index b98c9fd2c..b789bccba 100644 --- a/src/Utils/Form.hs +++ b/src/Utils/Form.hs @@ -4,7 +4,7 @@ module Utils.Form where -import ClassyPrelude.Yesod hiding (addMessage, cons, Proxy(..), identifyForm) +import ClassyPrelude.Yesod hiding (addMessage, addMessageI, cons, Proxy(..), identifyForm) import Yesod.Core.Instances () import Settings @@ -632,7 +632,7 @@ selectField' :: ( Eq a selectField' optMsg mkOpts = Field{..} where fieldEnctype = UrlEncoded - + fieldParse [] _ = return $ Right Nothing fieldParse (s:_) _ | s == "" = return $ Right Nothing @@ -646,7 +646,7 @@ selectField' optMsg mkOpts = Field{..} rendered = case val of Left _ -> "" Right a -> maybe "" optionExternalValue . listToMaybe $ filter ((== a) . optionInternalValue) olOptions - + isSel Nothing = not $ rendered `elem` map optionExternalValue olOptions isSel (Just opt) = rendered == optionExternalValue opt [whamlet| @@ -936,7 +936,7 @@ guardValidation :: ( MonadHandler m => msg -- ^ Message describing violation -> Bool -- ^ @False@ iff constraint is violated -> FormValidator r m () -guardValidation msg isValid = when (not isValid) $ tellValidationError msg +guardValidation msg isValid = unless isValid $ tellValidationError msg guardValidationM :: ( MonadHandler m , RenderMessage (HandlerSite m) msg @@ -944,6 +944,15 @@ guardValidationM :: ( MonadHandler m => msg -> m Bool -> FormValidator r m () guardValidationM = (. lift) . (=<<) . guardValidation + +warnValidation :: ( MonadHandler m + , RenderMessage (HandlerSite m) msg + ) + => msg -- ^ Message describing violation + -> Bool -- ^ @False@ iff constraint is violated + -> FormValidator r m () +warnValidation msg isValid = unless isValid $ addMessageI Warning msg + ----------------------- -- Form Manipulation -- ----------------------- From 42c3987ee93a6051a54fe89d6da7126b69c39828 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 6 Aug 2019 17:23:45 +0200 Subject: [PATCH 4/6] chore(release): 4.12.1 --- CHANGELOG.md | 9 +++++++++ package-lock.json | 2 +- package.json | 2 +- package.yaml | 2 +- 4 files changed, 12 insertions(+), 3 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 743bc955f..20d6b9b50 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,15 @@ All notable changes to this project will be documented in this file. See [standard-version](https://github.com/conventional-changelog/standard-version) for commit guidelines. +### [4.12.1](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v4.12.0...v4.12.1) (2019-08-06) + + +### Bug Fixes + +* **exams:** allow occurrences after exam end ([3d63b35](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/3d63b35)) + + + ## [4.12.0](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v4.11.0...v4.12.0) (2019-08-06) diff --git a/package-lock.json b/package-lock.json index de67ce757..74d4772c2 100644 --- a/package-lock.json +++ b/package-lock.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "4.12.0", + "version": "4.12.1", "lockfileVersion": 1, "requires": true, "dependencies": { diff --git a/package.json b/package.json index 3f140f0f3..293029ab4 100644 --- a/package.json +++ b/package.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "4.12.0", + "version": "4.12.1", "description": "", "keywords": [], "author": "", diff --git a/package.yaml b/package.yaml index 9a0a9e2be..cec8e434e 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: uniworx -version: 4.12.0 +version: 4.12.1 dependencies: # Due to a bug in GHC 8.0.1, we block its usage From b75aed5dda8c5ab87291526c93868a4bc42f5cc8 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 6 Aug 2019 17:28:22 +0200 Subject: [PATCH 5/6] refactor(forms): form validation minor refactor --- src/Handler/Exam/Form.hs | 4 ++-- src/Utils/Form.hs | 7 ++++--- 2 files changed, 6 insertions(+), 5 deletions(-) diff --git a/src/Handler/Exam/Form.hs b/src/Handler/Exam/Form.hs index 5948bf744..1020c6f28 100644 --- a/src/Handler/Exam/Form.hs +++ b/src/Handler/Exam/Form.hs @@ -344,9 +344,9 @@ validateExam = do guardValidation MsgExamClosedMustBeAfterEnd . fromMaybe True $ (>=) <$> efClosed <*> efEnd forM_ efOccurrences $ \ExamOccurrenceForm{..} -> do - guardValidation (MsgExamOccurrenceEndMustBeAfterStart eofName) $ NTop eofEnd >= NTop (Just eofStart) + guardValidation (MsgExamOccurrenceEndMustBeAfterStart eofName) $ NTop eofEnd >= NTop (Just eofStart) guardValidation (MsgExamOccurrenceStartMustBeAfterExamStart eofName) $ NTop (Just eofStart) >= NTop efStart - warnValidation (MsgExamOccurrenceEndMustBeBeforeExamEnd eofName) $ NTop eofEnd <= NTop efEnd + warn_Validation (MsgExamOccurrenceEndMustBeBeforeExamEnd eofName) $ NTop eofEnd <= NTop efEnd forM_ [ (a, b) | a <- Set.toAscList efOccurrences, b <- Set.toAscList efOccurrences, b > a ] $ \(a, b) -> do eofRange' <- formatTimeRange SelFormatDateTime (eofStart a) (eofEnd a) diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index b789bccba..c54ed44b3 100644 --- a/src/Utils/Form.hs +++ b/src/Utils/Form.hs @@ -944,14 +944,15 @@ guardValidationM :: ( MonadHandler m => msg -> m Bool -> FormValidator r m () guardValidationM = (. lift) . (=<<) . guardValidation - -warnValidation :: ( MonadHandler m +-- | like `guardValidation`, but issues a warning instead +warn_Validation :: ( MonadHandler m , RenderMessage (HandlerSite m) msg ) => msg -- ^ Message describing violation -> Bool -- ^ @False@ iff constraint is violated -> FormValidator r m () -warnValidation msg isValid = unless isValid $ addMessageI Warning msg +warn_Validation msg isValid = unless isValid $ addMessageI Warning msg + ----------------------- -- Form Manipulation -- From 22083685961ca0503cce168c97bba73beaec2ea7 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 6 Aug 2019 18:00:27 +0200 Subject: [PATCH 6/6] feat(homepage): add prime action new course to homepage --- src/Foundation.hs | 12 ++++++++++-- 1 file changed, 10 insertions(+), 2 deletions(-) diff --git a/src/Foundation.hs b/src/Foundation.hs index c6f4da349..8070aa3d0 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -834,7 +834,7 @@ tagAccessPredicate AuthAllocationTime = APDB $ \mAuthId route _ -> case route of || NTop allocationRegisterByStaffFrom >= NTop (Just now) -> unauthorizedI MsgUnauthorizedAllocatedCourseDelete _other -> return Authorized - + r -> $unsupportedAuthPredicate AuthAllocationTime r where mbAllocation tid ssh csh = $cachedHereBinary (tid, ssh, csh) . runMaybeT $ do @@ -1805,6 +1805,14 @@ pageActions (HomeR) = , menuItemModal = False , menuItemAccessCallback' = return True } + , MenuItem + { menuItemType = PageActionPrime + , menuItemLabel = MsgMenuCourseNew + , menuItemIcon = Just "book" + , menuItemRoute = SomeRoute CourseNewR + , menuItemModal = False + , menuItemAccessCallback' = return True + } , MenuItem { menuItemType = PageActionPrime , menuItemLabel = MsgAdminHeading @@ -2968,7 +2976,7 @@ instance YesodAuth UniWorX where acceptExisting | otherwise = return res - + excHandlers = [ C.Handler $ \case CampusUserNoResult -> do