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

Merge branch 'master' of gitlab.cip.ifi.lmu.de:jost/UniWorX

Browse Source
This commit is contained in:
Gregor Kleen 2019-08-06 18:15:46 +02:00
commit bba1686eab
8 changed files with 93 additions and 33 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

18
CHANGELOG.md
View File

@ -2,6 +2,24 @@
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)
### 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)

2
package-lock.json generated
View File

@ -1,6 +1,6 @@
{
"name": "uni2work",
"version": "4.11.0",
"version": "4.12.1",
"lockfileVersion": 1,
"requires": true,
"dependencies": {

2
package.json
View File

@ -1,6 +1,6 @@
{
"name": "uni2work",
"version": "4.11.0",
"version": "4.12.1",
"description": "",
"keywords": [],
"author": "",

2
package.yaml
View File

@ -1,5 +1,5 @@
name: uniworx
version: 4.11.0
version: 4.12.1
dependencies:
# Due to a bug in GHC 8.0.1, we block its usage

12
src/Foundation.hs
View File

@ -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

14
src/Handler/Exam/Form.hs
View File

@ -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
@ -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
guardValidation (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)

58
src/Handler/Home.hs
View File

@ -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))

18
src/Utils/Form.hs
View File

@ -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,16 @@ guardValidationM :: ( MonadHandler m
=> msg -> m Bool -> FormValidator r m ()
guardValidationM = (. lift) . (=<<) . guardValidation
-- | 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 ()
warn_Validation msg isValid = unless isValid $ addMessageI Warning msg
-----------------------
-- Form Manipulation --
-----------------------