fix(exams): cleanup exam interface
BREAKING CHANGE: examStart and examPublishOccurrenceAssignments now optional
This commit is contained in:
Gregor Kleen
parent
a075b1648e
commit
05e7b52f08
@ -1069,9 +1069,9 @@ ExamRegisterFrom: Anmeldung ab
|
||||
ExamRegisterFromTip: Zeitpunkt ab dem sich Kursteilnehmer selbständig zur Klausur anmelden können; ohne Datum ist keine Anmeldung möglich
|
||||
ExamRegisterTo: Anmeldung bis
|
||||
ExamDeregisterUntil: Abmeldung bis
|
||||
ExamPublishOccurrenceAssignments: Terminzuteilung den Teilnehmern mitteilen um
|
||||
ExamPublishOccurrenceAssignmentsTip: Ab diesem Zeitpunkt Teilnehmer einsehen zu welchen Teilprüfungen (Räumen) sie angemeldet sind
|
||||
ExamPublishOccurrenceAssignmentsParticipant: Terminzuteilung einsehbar ab
|
||||
ExamPublishOccurrenceAssignments: Termin- bzw. Raumzuteilung den Teilnehmern mitteilen um
|
||||
ExamPublishOccurrenceAssignmentsTip: Ab diesem Zeitpunkt Teilnehmer einsehen zu welcher Teilprüfung bzw. welchen Raum sie angemeldet sind
|
||||
ExamPublishOccurrenceAssignmentsParticipant: Termin- bzw. Raumzuteilung einsehbar ab
|
||||
ExamFinished: Bewertung abgeschlossen ab
|
||||
ExamFinishedParticipant: Bewertung vorrausichtlich abgeschlossen
|
||||
ExamFinishedTip: Zeitpunkt zu dem Klausurergebnisse den Teilnehmern gemeldet werden
|
||||
@ -1082,7 +1082,7 @@ ExamShowGradesTip: Soll den Teilnehmern ihre genaue Note angezeigt werden, oder
|
||||
ExamPublicStatistics: Statistik veröffentlichen
|
||||
ExamPublicStatisticsTip: Soll die statistische Auswertung auch den Teilnehmer angezeigt werden, sobald diese ihre Noten einsehen können?
|
||||
ExamGradingRule: Notenberechnung
|
||||
ExamGradingManual': Manuell
|
||||
ExamGradingManual': Keine automatische Berechnung
|
||||
ExamGradingKey': Nach Schlüssel
|
||||
ExamGradingKey: Notenschlüssel
|
||||
ExamGradingKeyTip: Die Grenzen beziehen sich auf die effektive Maximalpunktzahl, nachdem etwaige Bonuspunkte aus dem Übungsbetrieb angerechnet und die Ergebnise der Teilaufgaben mit ihrem Gewicht multipliziert wurden
|
||||
@ -1092,7 +1092,7 @@ PointsMustBeMonotonic: Punktegrenzen müssen aufsteigend sein
|
||||
GradingFrom: Ab
|
||||
ExamNew: Neue Klausur
|
||||
ExamBonusRule: Klausurbonus aus Übungsbetrieb
|
||||
ExamNoBonus': Kein Bonus
|
||||
ExamNoBonus': Kein automatischer Bonus
|
||||
ExamBonusPoints': Umrechnung von Übungspunkten
|
||||
|
||||
ExamEditHeading examn@ExamName: #{examn} bearbeiten
|
||||
@ -1101,8 +1101,8 @@ ExamBonusMaxPoints: Maximal erreichbare Klausur-Bonuspunkte
|
||||
ExamBonusMaxPointsNonPositive: Maximaler Klausurbonus muss positiv und größer null sein
|
||||
ExamBonusOnlyPassed: Bonus nur nach Bestehen anrechnen
|
||||
|
||||
ExamOccurrenceRule: Automatische Terminzuteilung
|
||||
ExamOccurrenceRuleParticipant: Terminzuteilung
|
||||
ExamOccurrenceRule: Automatische Termin- bzw. Raumzuteilung
|
||||
ExamOccurrenceRuleParticipant: Termin- bzw. Raumzuteilung
|
||||
ExamRoomManual': Keine automatische Zuteilung
|
||||
ExamRoomSurname': Nach Nachname
|
||||
ExamRoomMatriculation': Nach Matrikelnummer
|
||||
@ -1121,7 +1121,7 @@ ExamTimeTip: Nur zur Information der Studierenden, die tatsächliche Zeitangabe
|
||||
ExamRoomRegistered: Zugeteilt
|
||||
|
||||
ExamFormTimes: Zeiten
|
||||
ExamFormOccurrences: Prüfungstermine
|
||||
ExamFormOccurrences: Prüfungstermine/Räume
|
||||
ExamFormAutomaticFunctions: Automatische Funktionen
|
||||
ExamFormCorrection: Korrektur
|
||||
ExamFormParts: Teile
|
||||
@ -1159,7 +1159,7 @@ ExamRegistration: Anmeldung
|
||||
|
||||
ExamRegisterToMustBeAfterRegisterFrom: "Anmeldung ab" muss vor "Anmeldung bis" liegen
|
||||
ExamDeregisterUntilMustBeAfterRegisterFrom: "Abmeldung bis" muss nach "Anmeldung bis" liegen
|
||||
ExamStartMustBeAfterPublishOccurrenceAssignments: Start muss nach Veröffentlichung der Terminzuordnung liegen
|
||||
ExamStartMustBeAfterPublishOccurrenceAssignments: Start muss nach Veröffentlichung der Termin- bzw. Raumzuordnung liegen
|
||||
ExamEndMustBeAfterStart: Beginn der Klausur muss vor ihrem Ende liegen
|
||||
ExamFinishedMustBeAfterEnd: "Bewertung abgeschlossen ab" muss nach Ende liegen
|
||||
ExamFinishedMustBeAfterStart: "Bewertung abgeschlossen ab" muss nach Start liegen
|
||||
@ -1167,6 +1167,11 @@ ExamClosedMustBeAfterFinished: "Noten stehen fest ab" muss nach "Bewertung abges
|
||||
ExamClosedMustBeAfterStart: "Noten stehen fest ab" muss nach Start liegen
|
||||
ExamClosedMustBeAfterEnd: "Noten stehen fest ab" muss nach Ende liegen
|
||||
|
||||
ExamOccurrenceEndMustBeAfterStart eoRoom@Text eoRange@Text: Beginn des Termins #{eoRoom} #{eoRange} muss vor seinem Ende liegen
|
||||
ExamOccurrenceStartMustBeAfterExamStart eoRoom@Text eoRange@Text: Beginn des Termins #{eoRoom} #{eoRange} muss nach Beginn der Klausur liegen
|
||||
ExamOccurrenceEndMustBeBeforeExamEnd eoRoom@Text eoRange@Text: Ende des Termins #{eoRoom} #{eoRange} muss vor Ende der Klausur liegen
|
||||
ExamOccurrenceDuplicate eoRoom@Text eoRange@Text: Raum #{eoRoom}, Termin #{eoRange} kommt mehrfach mit der selben Beschreibung vor
|
||||
|
||||
VersionHistory: Versionsgeschichte
|
||||
KnownBugs: Bekannte Bugs
|
||||
|
||||
|
||||
@ -8,8 +8,8 @@ Exam
|
||||
registerFrom UTCTime Maybe
|
||||
registerTo UTCTime Maybe
|
||||
deregisterUntil UTCTime Maybe
|
||||
publishOccurrenceAssignments UTCTime
|
||||
start UTCTime
|
||||
publishOccurrenceAssignments UTCTime Maybe
|
||||
start UTCTime Maybe
|
||||
end UTCTime Maybe
|
||||
finished UTCTime Maybe -- Grades shown to students, `ExamCorrector`s locked out
|
||||
closed UTCTime Maybe -- Prüfungsamt hat Einsicht (notification)
|
||||
|
||||
@ -678,7 +678,7 @@ tagAccessPredicate AuthTime = APDB $ \mAuthId route _ -> case route of
|
||||
|
||||
case subRoute of
|
||||
EShowR -> guard visible
|
||||
EUsersR -> guard $ examStart <= cTime
|
||||
EUsersR -> guard $ NTop examStart <= NTop (Just cTime)
|
||||
&& NTop (Just cTime) <= NTop examFinished
|
||||
ERegisterR
|
||||
| not registered -> guard $ visible
|
||||
|
||||
@ -425,15 +425,7 @@ getCShowR tid ssh csh = do
|
||||
[ sortable (Just "name") (i18nCell MsgExamName) $ \DBRow{ dbrOutput = Entity _ Exam{..} } -> indicatorCell <> anchorCell (CExamR tid ssh csh examName EShowR) (toWidget examName)
|
||||
, sortable (Just "register-from") (i18nCell MsgExamRegisterFrom) $ \DBRow { dbrOutput = Entity _ Exam{..} } -> maybe mempty dateTimeCell examRegisterFrom
|
||||
, sortable (Just "register-to") (i18nCell MsgExamRegisterTo) $ \DBRow { dbrOutput = Entity _ Exam{..} } -> maybe mempty dateTimeCell examRegisterTo
|
||||
, sortable (Just "time") (i18nCell MsgExamTime) $ \DBRow{ dbrOutput = Entity _ Exam{..} } -> cell $ do
|
||||
startT <- formatTime SelFormatDateTime examStart
|
||||
endT <- traverse (\examEnd' -> formatTime (bool SelFormatDateTime SelFormatTime $ ((==) `on` utctDay) examStart examEnd') examEnd') examEnd
|
||||
[whamlet|
|
||||
$newline never
|
||||
#{startT}
|
||||
$maybe endT' <- endT
|
||||
\ – #{endT'}
|
||||
|]
|
||||
, sortable (Just "time") (i18nCell MsgExamTime) $ \DBRow{ dbrOutput = Entity _ Exam{..} } -> maybe mempty (cell . flip (formatTimeRangeW SelFormatDateTime) examEnd) examStart
|
||||
, sortable Nothing mempty $ \DBRow{ dbrOutput = Entity eId Exam{..} } -> sqlCell $ do
|
||||
mayRegister <- (== Authorized) <$> evalAccessDB (CExamR tid ssh csh examName ERegisterR) True
|
||||
isRegistered <- case mbAid of
|
||||
|
||||
@ -56,15 +56,7 @@ getCExamListR tid ssh csh = do
|
||||
, (<$ guard mayCreate) . sortable (Just "visible") (i18nCell MsgExamVisibleFrom) $ \DBRow { dbrOutput = Entity _ Exam{..} } -> maybe mempty (dateTimeCellVisible now) examVisibleFrom
|
||||
, Just . sortable (Just "register-from") (i18nCell MsgExamRegisterFrom) $ \DBRow { dbrOutput = Entity _ Exam{..} } -> maybe mempty dateTimeCell examRegisterFrom
|
||||
, Just . sortable (Just "register-to") (i18nCell MsgExamRegisterTo) $ \DBRow { dbrOutput = Entity _ Exam{..} } -> maybe mempty dateTimeCell examRegisterTo
|
||||
, Just . sortable (Just "time") (i18nCell MsgExamTime) $ \DBRow{ dbrOutput = Entity _ Exam{..} } -> cell $ do
|
||||
startT <- formatTime SelFormatDateTime examStart
|
||||
endT <- traverse (\examEnd' -> formatTime (bool SelFormatDateTime SelFormatTime $ ((==) `on` utctDay) examStart examEnd') examEnd') examEnd
|
||||
[whamlet|
|
||||
$newline never
|
||||
#{startT}
|
||||
$maybe endT' <- endT
|
||||
\ – #{endT'}
|
||||
|]
|
||||
, Just . sortable (Just "time") (i18nCell MsgExamTime) $ \DBRow{ dbrOutput = Entity _ Exam{..} } -> maybe mempty (cell . flip (formatTimeRangeW SelFormatDateTime) examEnd) examStart
|
||||
]
|
||||
dbtSorting = Map.fromList
|
||||
[ ("name", SortColumn $ \exam -> exam E.^. ExamName )
|
||||
@ -154,13 +146,13 @@ postECInviteR = invitationR examCorrectorInvitationConfig
|
||||
data ExamForm = ExamForm
|
||||
{ efName :: ExamName
|
||||
, efDescription :: Maybe Html
|
||||
, efStart :: UTCTime
|
||||
, efStart :: Maybe UTCTime
|
||||
, efEnd :: Maybe UTCTime
|
||||
, efVisibleFrom :: Maybe UTCTime
|
||||
, efRegisterFrom :: Maybe UTCTime
|
||||
, efRegisterTo :: Maybe UTCTime
|
||||
, efDeregisterUntil :: Maybe UTCTime
|
||||
, efPublishOccurrenceAssignments :: UTCTime
|
||||
, efPublishOccurrenceAssignments :: Maybe UTCTime
|
||||
, efFinished :: Maybe UTCTime
|
||||
, efClosed :: Maybe UTCTime
|
||||
, efOccurrences :: Set ExamOccurrenceForm
|
||||
@ -189,6 +181,8 @@ data ExamPartForm = ExamPartForm
|
||||
, epfWeight :: Rational
|
||||
} deriving (Read, Show, Eq, Ord, Generic, Typeable)
|
||||
|
||||
makeLenses_ ''ExamForm
|
||||
|
||||
deriveJSON defaultOptions
|
||||
{ fieldLabelModifier = camelToPathPiece' 1
|
||||
} ''ExamPartForm
|
||||
@ -206,13 +200,13 @@ examForm template html = do
|
||||
<$> areq ciField (fslpI MsgExamName (mr MsgExamName) & setTooltip MsgExamNameTip) (efName <$> template)
|
||||
<*> (assertM (not . null . renderHtml) <$> aopt htmlField (fslpI MsgExamDescription "Html") (efDescription <$> template))
|
||||
<* aformSection MsgExamFormTimes
|
||||
<*> areq utcTimeField (fslpI MsgExamStart (mr MsgDate) & setTooltip MsgExamTimeTip) (efStart <$> template)
|
||||
<*> aopt utcTimeField (fslpI MsgExamStart (mr MsgDate) & setTooltip MsgExamTimeTip) (efStart <$> template)
|
||||
<*> aopt utcTimeField (fslpI MsgExamEnd (mr MsgDate) & setTooltip MsgExamTimeTip) (efEnd <$> template)
|
||||
<*> aopt utcTimeField (fslpI MsgExamVisibleFrom (mr MsgDate) & setTooltip MsgExamVisibleFromTip) (efVisibleFrom <$> template)
|
||||
<*> aopt utcTimeField (fslpI MsgExamRegisterFrom (mr MsgDate) & setTooltip MsgExamRegisterFromTip) (efRegisterFrom <$> template)
|
||||
<*> aopt utcTimeField (fslpI MsgExamRegisterTo (mr MsgDate)) (efRegisterTo <$> template)
|
||||
<*> aopt utcTimeField (fslpI MsgExamDeregisterUntil (mr MsgDate)) (efDeregisterUntil <$> template)
|
||||
<*> areq utcTimeField (fslpI MsgExamPublishOccurrenceAssignments (mr MsgDate) & setTooltip MsgExamPublishOccurrenceAssignments) (efPublishOccurrenceAssignments <$> template)
|
||||
<*> aopt utcTimeField (fslpI MsgExamPublishOccurrenceAssignments (mr MsgDate) & setTooltip MsgExamPublishOccurrenceAssignmentsTip) (efPublishOccurrenceAssignments <$> template)
|
||||
<*> aopt utcTimeField (fslpI MsgExamFinished (mr MsgDate) & setTooltip MsgExamFinishedTip) (efFinished <$> template)
|
||||
<*> aopt utcTimeField (fslpI MsgExamClosed (mr MsgDate) & setTooltip MsgExamClosedTip) (efClosed <$> template)
|
||||
<* aformSection MsgExamFormOccurrences
|
||||
@ -221,7 +215,7 @@ examForm template html = do
|
||||
<*> (fromMaybe False <$> aopt checkBoxField (fslI MsgExamShowGrades & setTooltip MsgExamShowGradesTip) (Just . efShowGrades <$> template))
|
||||
<*> (fromMaybe False <$> aopt checkBoxField (fslI MsgExamPublicStatistics & setTooltip MsgExamPublicStatisticsTip) (Just . efPublicStatistics <$> template))
|
||||
<*> examGradingRuleForm (efGradingRule <$> template)
|
||||
<*> bonusRuleForm (efBonusRule <$> template)
|
||||
<*> examBonusRuleForm (efBonusRule <$> template)
|
||||
<*> examOccurrenceRuleForm (efOccurrenceRule <$> template)
|
||||
<* aformSection MsgExamFormCorrection
|
||||
<*> examCorrectorsForm (efCorrectors <$> template)
|
||||
@ -272,7 +266,7 @@ examCorrectorsForm mPrev = wFormToAForm $ do
|
||||
miLayout' :: MassInputLayout ListLength (Either UserEmail UserId) ()
|
||||
miLayout' lLength _ cellWdgts delButtons addWdgts = $(widgetFile "widgets/massinput/examCorrectors/layout")
|
||||
|
||||
fmap Set.fromList <$> massInputAccumW miAdd' miCell' miButtonAction' miLayout' ("correctors" :: Text) (fslI MsgExamCorrectors & setTooltip MsgMassInputTip) True (Set.toList <$> mPrev)
|
||||
fmap Set.fromList <$> massInputAccumW miAdd' miCell' miButtonAction' miLayout' ("correctors" :: Text) (fslI MsgExamCorrectors & setTooltip MsgMassInputTip) False (Set.toList <$> mPrev)
|
||||
|
||||
examOccurrenceForm :: Maybe (Set ExamOccurrenceForm) -> AForm Handler (Set ExamOccurrenceForm)
|
||||
examOccurrenceForm prev = wFormToAForm $ do
|
||||
@ -281,7 +275,7 @@ examOccurrenceForm prev = wFormToAForm $ do
|
||||
miButtonAction' :: forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX)
|
||||
miButtonAction' frag = Just . SomeRoute $ currentRoute :#: frag
|
||||
|
||||
fmap (fmap Set.fromList) . massInputAccumEditW miAdd' miCell' miButtonAction' miLayout' miIdent' (fslI MsgExamOccurrences & setTooltip MsgMassInputTip) True $ Set.toList <$> prev
|
||||
fmap (fmap Set.fromList) . massInputAccumEditW miAdd' miCell' miButtonAction' miLayout' miIdent' (fslI MsgExamOccurrences & setTooltip MsgMassInputTip) False $ Set.toList <$> prev
|
||||
where
|
||||
examOccurrenceForm' nudge mPrev csrf = do
|
||||
(eofIdRes, eofIdView) <- mopt hiddenField ("" & addName (nudge "id")) (Just $ eofId =<< mPrev)
|
||||
@ -321,7 +315,7 @@ examPartsForm prev = wFormToAForm $ do
|
||||
miButtonAction' :: forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX)
|
||||
miButtonAction' frag = Just . SomeRoute $ currentRoute :#: frag
|
||||
|
||||
fmap (fmap Set.fromList) . massInputAccumEditW miAdd' miCell' miButtonAction' miLayout' miIdent' (fslI MsgExamParts & setTooltip MsgMassInputTip) True $ Set.toList <$> prev
|
||||
fmap (fmap Set.fromList) . massInputAccumEditW miAdd' miCell' miButtonAction' miLayout' miIdent' (fslI MsgExamParts & setTooltip MsgMassInputTip) False $ Set.toList <$> prev
|
||||
where
|
||||
examPartForm' nudge mPrev csrf = do
|
||||
(epfIdRes, epfIdView) <- mopt hiddenField ("" & addName (nudge "id")) (Just $ epfId =<< mPrev)
|
||||
@ -436,8 +430,8 @@ examTemplate cid = runMaybeT $ do
|
||||
, efRegisterFrom = dateOffset <$> examRegisterFrom oldExam
|
||||
, efRegisterTo = dateOffset <$> examRegisterTo oldExam
|
||||
, efDeregisterUntil = dateOffset <$> examDeregisterUntil oldExam
|
||||
, efPublishOccurrenceAssignments = dateOffset $ examPublishOccurrenceAssignments oldExam
|
||||
, efStart = dateOffset $ examStart oldExam
|
||||
, efPublishOccurrenceAssignments = dateOffset <$> examPublishOccurrenceAssignments oldExam
|
||||
, efStart = dateOffset <$> examStart oldExam
|
||||
, efEnd = dateOffset <$> examEnd oldExam
|
||||
, efFinished = dateOffset <$> examFinished oldExam
|
||||
, efClosed = dateOffset <$> examClosed oldExam
|
||||
@ -456,14 +450,31 @@ validateExam = do
|
||||
|
||||
guardValidation MsgExamRegisterToMustBeAfterRegisterFrom $ NTop efRegisterTo >= NTop efRegisterFrom
|
||||
guardValidation MsgExamDeregisterUntilMustBeAfterRegisterFrom $ NTop efDeregisterUntil >= NTop efRegisterFrom
|
||||
guardValidation MsgExamStartMustBeAfterPublishOccurrenceAssignments $ efStart >= efPublishOccurrenceAssignments
|
||||
guardValidation MsgExamEndMustBeAfterStart $ NTop efEnd >= NTop (Just efStart)
|
||||
guardValidation MsgExamStartMustBeAfterPublishOccurrenceAssignments . fromMaybe True $ (>=) <$> efStart <*> efPublishOccurrenceAssignments
|
||||
guardValidation MsgExamEndMustBeAfterStart $ NTop efEnd >= NTop efStart
|
||||
guardValidation MsgExamFinishedMustBeAfterEnd . fromMaybe True $ (>=) <$> efFinished <*> efEnd
|
||||
guardValidation MsgExamFinishedMustBeAfterStart $ NTop efFinished >= NTop (Just efStart)
|
||||
guardValidation MsgExamFinishedMustBeAfterStart $ NTop efFinished >= NTop efStart
|
||||
guardValidation MsgExamClosedMustBeAfterFinished . fromMaybe True $ (>=) <$> efClosed <*> efFinished
|
||||
guardValidation MsgExamClosedMustBeAfterStart $ NTop efClosed >= NTop (Just efStart)
|
||||
guardValidation MsgExamClosedMustBeAfterStart $ NTop efClosed >= NTop efStart
|
||||
guardValidation MsgExamClosedMustBeAfterEnd . fromMaybe True $ (>=) <$> efClosed <*> efEnd
|
||||
|
||||
forM_ efOccurrences $ \ExamOccurrenceForm{..} -> do
|
||||
eofRange' <- formatTimeRange SelFormatDateTime eofStart eofEnd
|
||||
|
||||
guardValidation (MsgExamOccurrenceEndMustBeAfterStart eofRoom eofRange') $ NTop eofEnd >= NTop (Just eofStart)
|
||||
guardValidation (MsgExamOccurrenceStartMustBeAfterExamStart eofRoom eofRange') $ NTop (Just eofStart) >= NTop efStart
|
||||
guardValidation (MsgExamOccurrenceEndMustBeBeforeExamEnd eofRoom eofRange') $ 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)
|
||||
|
||||
guardValidation (MsgExamOccurrenceDuplicate (eofRoom a) eofRange') $ any (\f -> f a b)
|
||||
[ (/=) `on` eofRoom
|
||||
, (/=) `on` eofStart
|
||||
, (/=) `on` eofEnd
|
||||
, (/=) `on` fmap renderHtml . eofDescription
|
||||
]
|
||||
|
||||
|
||||
getCExamNewR, postCExamNewR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
|
||||
getCExamNewR = postCExamNewR
|
||||
@ -669,7 +680,7 @@ getEShowR tid ssh csh examn = do
|
||||
let gradingVisible = NTop (Just cTime) >= NTop examFinished
|
||||
gradingShown <- or2M (return gradingVisible) . hasReadAccessTo $ CExamR tid ssh csh examn EEditR
|
||||
|
||||
let occurrenceAssignmentsVisible = cTime >= examPublishOccurrenceAssignments
|
||||
let occurrenceAssignmentsVisible = NTop (Just cTime) >= NTop examPublishOccurrenceAssignments
|
||||
occurrenceAssignmentsShown <- or2M (return occurrenceAssignmentsVisible) . hasReadAccessTo $ CExamR tid ssh csh examn EEditR
|
||||
|
||||
parts <- selectList [ ExamPartExam ==. eId ] [ Asc ExamPartName ]
|
||||
@ -703,7 +714,7 @@ getEShowR tid ssh csh examn = do
|
||||
|
||||
return (exam, parts, examVisible, (gradingVisible, gradingShown), (occurrenceAssignmentsVisible, occurrenceAssignmentsShown), results, result, occurrences, (registered, mayRegister))
|
||||
|
||||
let examTimes = all (\(Entity _ ExamOccurrence{..}, _) -> examOccurrenceStart == examStart && examOccurrenceEnd == examEnd) occurrences
|
||||
let examTimes = all (\(Entity _ ExamOccurrence{..}, _) -> Just examOccurrenceStart == examStart && examOccurrenceEnd == examEnd) occurrences
|
||||
registerWidget
|
||||
| Just isRegistered <- registered
|
||||
, mayRegister = Just $ do
|
||||
|
||||
@ -231,15 +231,7 @@ homeUpcomingExams uid = do
|
||||
indicatorCell <> anchorCell (CExamR courseTerm courseSchool courseShorthand examName EShowR) (toWidget 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{..} } -> cell $ do
|
||||
startT <- formatTime SelFormatDateTime examStart
|
||||
endT <- traverse (\examEnd' -> formatTime (bool SelFormatDateTime SelFormatTime $ ((==) `on` utctDay) examStart examEnd') examEnd') examEnd
|
||||
[whamlet|
|
||||
$newline never
|
||||
#{startT}
|
||||
$maybe endT' <- endT
|
||||
\ – #{endT'}
|
||||
|]
|
||||
, sortable (Just "time") (i18nCell MsgExamTime) $ \DBRow{ dbrOutput = view lensExam -> Entity _ Exam{..} } -> maybe mempty (cell . flip (formatTimeRangeW SelFormatDateTime) examEnd) examStart
|
||||
{- 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
|
||||
|
||||
@ -3,10 +3,11 @@ module Handler.Utils.DateTime
|
||||
, localTimeToUTC, TZ.LocalToUTCResult(..)
|
||||
, toMidnight, beforeMidnight, toMidday, toMorning
|
||||
, formatDiffDays
|
||||
, formatTime, formatTime', formatTimeW
|
||||
, formatTime'
|
||||
, formatTime, formatTimeW, formatTimeMail
|
||||
, formatTimeRange, formatTimeRangeW, formatTimeRangeMail
|
||||
, getTimeLocale, getDateTimeFormat
|
||||
, validDateTimeFormats, dateTimeFormatOptions
|
||||
, formatTimeMail
|
||||
, addOneWeek, addWeeks
|
||||
, weeksToAdd
|
||||
, setYear
|
||||
@ -236,3 +237,44 @@ ceilingMinuteBy margin roundto utct = addUTCTime bonus utct
|
||||
newMin = roundToNearestMultiple roundto $ oldMin + margin
|
||||
newTime = oldTime { todMin = newMin, todSec = 0 } -- might be invalid, but correctly treated by `timeOfDayToTime`
|
||||
bonus = realToFrac $ timeOfDayToTime newTime - timeOfDayToTime oldTime
|
||||
|
||||
|
||||
formatTimeRange' :: ( HasLocalTime t, HasLocalTime t'
|
||||
, Monad m
|
||||
)
|
||||
=> (forall t2. HasLocalTime t2 => SelDateTimeFormat -> t2 -> m Text) -- ^ @formatTime@
|
||||
-> SelDateTimeFormat
|
||||
-> t -- ^ Start
|
||||
-> Maybe t' -- ^ End
|
||||
-> m Text
|
||||
formatTimeRange' cont proj startT endT = do
|
||||
startT' <- cont proj startT
|
||||
let
|
||||
endProj = (/\ proj) $ if
|
||||
| Just endT' <- endT
|
||||
, ((==) `on` localDay) (toLocalTime startT) (toLocalTime endT')
|
||||
-> SelFormatTime
|
||||
| otherwise
|
||||
-> SelFormatDateTime
|
||||
endT' <- for endT $ cont endProj
|
||||
|
||||
return $ case endT' of
|
||||
Nothing -> startT'
|
||||
Just endT'' -> [st|#{startT'} – #{endT''}|]
|
||||
|
||||
|
||||
formatTimeRange :: ( HasLocalTime t, HasLocalTime t'
|
||||
, MonadHandler m
|
||||
, HandlerSite m ~ UniWorX
|
||||
)
|
||||
=> SelDateTimeFormat
|
||||
-> t -- ^ Start
|
||||
-> Maybe t' -- ^ End
|
||||
-> m Text
|
||||
formatTimeRange = formatTimeRange' formatTime
|
||||
|
||||
formatTimeRangeW :: (HasLocalTime t, HasLocalTime t') => SelDateTimeFormat -> t -> Maybe t' -> Widget
|
||||
formatTimeRangeW s t t' = toWidget =<< formatTimeRange s t t'
|
||||
|
||||
formatTimeRangeMail :: (MonadMail m, HasLocalTime t, HasLocalTime t') => SelDateTimeFormat -> t -> Maybe t' -> m Text
|
||||
formatTimeRangeMail = formatTimeRange' formatTimeMail
|
||||
|
||||
@ -463,8 +463,8 @@ classifyBonusRule = \case
|
||||
ExamNoBonus -> ExamNoBonus'
|
||||
ExamBonusPoints{} -> ExamBonusPoints'
|
||||
|
||||
bonusRuleForm :: Maybe ExamBonusRule -> AForm Handler ExamBonusRule
|
||||
bonusRuleForm prev = multiActionA actions (fslI MsgExamBonusRule) $ classifyBonusRule <$> prev
|
||||
examBonusRuleForm :: Maybe ExamBonusRule -> AForm Handler ExamBonusRule
|
||||
examBonusRuleForm prev = multiActionA actions (fslI MsgExamBonusRule) $ classifyBonusRule <$> prev
|
||||
where
|
||||
actions :: Map ExamBonusRule' (AForm Handler ExamBonusRule)
|
||||
actions = Map.fromList
|
||||
|
||||
@ -21,8 +21,6 @@ import Utils.Lens
|
||||
import Handler.Utils.Form.MassInput.Liveliness
|
||||
import Handler.Utils.Form.MassInput.TH
|
||||
|
||||
import Algebra.Lattice hiding (join)
|
||||
|
||||
import Text.Blaze (Markup)
|
||||
|
||||
import qualified Data.Text as Text
|
||||
|
||||
@ -77,6 +77,8 @@ import Data.Aeson.Types as Import (FromJSON(..), ToJSON(..), FromJSONKey(..), To
|
||||
import Data.Constraint as Import (Dict(..))
|
||||
import Data.Void as Import (Void)
|
||||
|
||||
import Algebra.Lattice as Import hiding (meet, join)
|
||||
|
||||
import Language.Haskell.TH.Instances as Import ()
|
||||
import Data.List.NonEmpty.Instances as Import ()
|
||||
import Data.NonNull.Instances as Import ()
|
||||
|
||||
@ -34,6 +34,9 @@ import Data.Aeson.TH
|
||||
import Utils.PathPiece
|
||||
|
||||
import Data.Time.Format.Instances ()
|
||||
|
||||
import Algebra.Lattice
|
||||
import Algebra.Lattice.Ordered
|
||||
|
||||
|
||||
-- $(timeLocaleMap _) :: [Lang] -> TimeLocale
|
||||
@ -78,7 +81,7 @@ newtype DateTimeFormat = DateTimeFormat { unDateTimeFormat :: String }
|
||||
|
||||
instance Hashable DateTimeFormat
|
||||
|
||||
data SelDateTimeFormat = SelFormatDateTime | SelFormatDate | SelFormatTime
|
||||
data SelDateTimeFormat = SelFormatDate | SelFormatTime | SelFormatDateTime
|
||||
deriving (Eq, Ord, Read, Show, Enum, Bounded, Data, Generic, Typeable)
|
||||
|
||||
instance Universe SelDateTimeFormat
|
||||
@ -98,3 +101,19 @@ instance {-# OVERLAPPING #-} Default (SelDateTimeFormat -> DateTimeFormat) where
|
||||
def SelFormatDateTime = "%c"
|
||||
def SelFormatDate = "%F"
|
||||
def SelFormatTime = "%T"
|
||||
|
||||
instance JoinSemiLattice SelDateTimeFormat where
|
||||
a \/ b = getOrdered $ ((\/) `on` Ordered) a b
|
||||
|
||||
instance MeetSemiLattice SelDateTimeFormat where
|
||||
a /\ b = getOrdered $ ((/\) `on` Ordered) a b
|
||||
|
||||
instance Lattice SelDateTimeFormat
|
||||
|
||||
instance BoundedJoinSemiLattice SelDateTimeFormat where
|
||||
bottom = SelFormatTime
|
||||
|
||||
instance BoundedMeetSemiLattice SelDateTimeFormat where
|
||||
top = SelFormatDateTime
|
||||
|
||||
instance BoundedLattice SelDateTimeFormat
|
||||
|
||||
@ -1,4 +1,5 @@
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
{-# OPTIONS_GHC -fno-warn-deprecations #-}
|
||||
|
||||
module Utils.Form where
|
||||
@ -832,9 +833,18 @@ deriving newtype instance Monad m => Applicative (FormValidator r m)
|
||||
deriving newtype instance Monad m => Monad (FormValidator r m)
|
||||
deriving newtype instance Monad m => MonadState r (FormValidator r m)
|
||||
deriving newtype instance MonadFix m => MonadFix (FormValidator r m)
|
||||
deriving newtype instance MonadResource m => MonadResource (FormValidator r m)
|
||||
deriving newtype instance MonadThrow m => MonadThrow (FormValidator r m)
|
||||
deriving newtype instance MonadIO m => MonadIO (FormValidator r m)
|
||||
instance MonadBase b m => MonadBase b (FormValidator r m) where
|
||||
liftBase = lift . liftBase
|
||||
instance MonadTrans (FormValidator r) where
|
||||
lift = FormValidator . lift
|
||||
|
||||
instance MonadHandler m => MonadHandler (FormValidator r m) where
|
||||
type HandlerSite (FormValidator r m) = HandlerSite m
|
||||
liftHandlerT = lift . liftHandlerT
|
||||
|
||||
validateForm :: MonadHandler m
|
||||
=> FormValidator a m ()
|
||||
-> (Markup -> MForm m (FormResult a, xml))
|
||||
|
||||
@ -44,14 +44,14 @@ $maybe desc <- examDescription
|
||||
$maybe deregUntil <- examDeregisterUntil
|
||||
<dt .deflist__dt>_{MsgExamDeregisterUntil}
|
||||
<dd .deflist__dd>^{formatTimeW SelFormatDateTime deregUntil}
|
||||
<dt .deflist__dt>_{MsgExamPublishOccurrenceAssignmentsParticipant}
|
||||
<dd .deflist__dd>^{formatTimeW SelFormatDateTime examPublishOccurrenceAssignments}
|
||||
$maybe publishAssignments <- examPublishOccurrenceAssignments
|
||||
<dt .deflist__dt>_{MsgExamPublishOccurrenceAssignmentsParticipant}
|
||||
<dd .deflist__dd>^{formatTimeW SelFormatDateTime publishAssignments}
|
||||
$if examTimes
|
||||
<dt .deflist__dt>_{MsgExamTime}
|
||||
<dd .deflist__dd>
|
||||
^{formatTimeW SelFormatDateTime examStart}
|
||||
$maybe end <- examEnd
|
||||
\ – ^{formatTimeW (bool SelFormatDateTime SelFormatTime ((on (==) utctDay) examStart end)) end}
|
||||
$maybe start <- examStart
|
||||
^{formatTimeRangeW SelFormatDateTime start examEnd}
|
||||
$maybe finished <- examFinished
|
||||
<dt .deflist__dt>_{MsgExamFinishedParticipant}
|
||||
<dd .deflist__dd>^{formatTimeW SelFormatDateTime finished}
|
||||
@ -108,9 +108,7 @@ $if not (null occurrences)
|
||||
<td .table__td>#{examOccurrenceRoom}
|
||||
$if not examTimes
|
||||
<td .table__td>
|
||||
^{formatTimeW SelFormatDateTime examOccurrenceStart}
|
||||
$maybe end <- examOccurrenceEnd
|
||||
\ – ^{formatTimeW (bool SelFormatDateTime SelFormatTime ((on (==) utctDay) examStart end)) end}
|
||||
^{formatTimeRangeW SelFormatDateTime examOccurrenceStart examOccurrenceEnd}
|
||||
<td .table__td>
|
||||
$maybe desc <- examOccurrenceDescription
|
||||
#{desc}
|
||||
|
||||
Loading…
Reference in New Issue
Block a user