From 4b525ea8246706d191fce109d4a9d1f5cc4c22d1 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Tue, 17 Nov 2020 12:43:24 +0100 Subject: [PATCH] feat(exams): optionally close on finish Fixes #652 --- messages/uniworx/de-de-formal.msg | 9 +++- messages/uniworx/en-eu.msg | 7 +++ models/schools.model | 1 + src/Database/Esqueleto/Utils.hs | 16 ++++++- src/Foundation/I18n.hs | 9 ++++ src/Handler/Exam/Edit.hs | 3 +- src/Handler/Exam/Form.hs | 7 +-- src/Handler/Exam/New.hs | 3 +- src/Handler/Exam/Show.hs | 2 +- src/Handler/ExamOffice/Exam.hs | 48 ++++++++++++------- src/Handler/ExamOffice/Exams.hs | 46 ++++++++++++------ src/Handler/School.hs | 5 ++ src/Jobs/Crontab.hs | 18 +++++-- src/Model/Types/Exam.hs | 21 ++++++++ .../widgets/exam-close-on-finished.hamlet | 6 +++ templates/widgets/exam-close.hamlet | 11 +++-- test/Database/Fill.hs | 6 ++- 17 files changed, 168 insertions(+), 50 deletions(-) create mode 100644 templates/widgets/exam-close-on-finished.hamlet diff --git a/messages/uniworx/de-de-formal.msg b/messages/uniworx/de-de-formal.msg index 6f54a2e5e..d86ee64dd 100644 --- a/messages/uniworx/de-de-formal.msg +++ b/messages/uniworx/de-de-formal.msg @@ -1795,6 +1795,7 @@ ExamFinished: Ergebnisse sichtbar ab ExamFinishedOffice: Noten bekannt gegeben ExamFinishedParticipant: Bewertung voraussichtlich abgeschlossen ExamFinishedTip: Zeitpunkt zu dem Prüfungergebnisse den Teilnehmern gemeldet werden; ohne Datum werden die Prüfungsergebnisse zunächst nie gemeldet +ExamFinishedTipCloseOnFinished: Zeitpunkt zu dem Prüfungergebnisse den Teilnehmern und den Prüfungsverwaltungen gemeldet werden; ohne Datum werden die Prüfungsergebnisse zunächst nie gemeldet ExamClosed: Noten gemeldet ExamClosedTip: Prüfungsbeauftraget, die im System Noten einsehen, werden zu diesem Zeitpunkt benachrichtigt und danach bei Änderungen informiert ExamGradingMode: Bewertungsmodus @@ -2457,6 +2458,7 @@ BtnCloseExam: Prüfung abschließen ExamCloseTip: Wenn eine Prüfung abgeschlossen wird, werden Prüfungsbeauftragte, die im System Noten einsehen, benachrichtigt und danach bei Änderungen informiert. ExamCloseReminder: Bitte schließen Sie die Prüfung frühstmöglich, sobald die Prüfungsleistungen sich voraussichtlich nicht mehr ändern werden. Z.B. direkt nach der Klausureinsicht. ExamDidClose: Prüfung erfolgreich abgeschlossen +ExamCloseTipOnFinished: Die Prüfung wird automatisch abgeschlossen, also Prüfungsbeauftragte, die im System Note einsehen, benachrichtigt und danach bei Änderungen informiert, sobald die Noten für die Prüfungsteilnehmer veröffentlicht werden. ExamClosedSince time@Text: Prüfung abgeschlossen seit #{time} @@ -2927,4 +2929,9 @@ InvalidCredentialsADAccountDisabled: Benutzereintrag gesperrt InvalidCredentialsADTooManyContextIds: Benutzereintrag trägt zu viele Sicherheitskennzeichen InvalidCredentialsADAccountExpired: Benutzereintrag abgelaufen InvalidCredentialsADPasswordMustChange: Passwort muss geändert werden -InvalidCredentialsADAccountLockedOut: Benutzereintrag wurde durch Eindringlingserkennung gesperrt \ No newline at end of file +InvalidCredentialsADAccountLockedOut: Benutzereintrag wurde durch Eindringlingserkennung gesperrt + +ExamCloseModeSeparate: Separat +ExamCloseModeOnFinished: Mit Veröffentlichung +ExamCloseModeOnFinishedHidden: Mit Veröffentlichung (versteckt) +ExamCloseMode: Prüfungs-Abschluss \ No newline at end of file diff --git a/messages/uniworx/en-eu.msg b/messages/uniworx/en-eu.msg index a9c9159a5..f0f4df032 100644 --- a/messages/uniworx/en-eu.msg +++ b/messages/uniworx/en-eu.msg @@ -1794,6 +1794,7 @@ ExamFinished: Results visible from ExamFinishedOffice: Exam achievements published ExamFinishedParticipant: Marking expected to be finished ExamFinishedTip: At this participants are informed of their exam achievements. If left empty participants are never informed of their exam achievements. +ExamFinishedTipCloseOnFinished: At this time participants and exam offices are informed of the exam achievements. If left empty participants and exam offices are never informed of the exam achievements. ExamClosed: Exam achievements registered ExamClosedTip: At this time exam offices, which pull exam achievements from Uni2work, are informed. Changes to exam achievements trigger further notifications ExamGradingMode: Grading mode @@ -2457,6 +2458,7 @@ BtnCloseExam: Close exam ExamCloseTip: When an exam is closed all relevant exam offices, which pull exam achievements from Uni2work, are informed and kept up to date with changes. ExamCloseReminder: Please close the exam as soon as possible, when exam achievements are no longer expected to change e.g. after inspection of the exam has concluced. ExamDidClose: Successfully closed exam +ExamCloseTipOnFinished: The exam will be closed automatically as soon as exam participants are informed of their exam achievements. That means exam offices will be able notified once and after that each time a grade changes. ExamClosedSince time: Exam closed since #{time} @@ -2929,3 +2931,8 @@ InvalidCredentialsADTooManyContextIds: Account carries to many security identifi InvalidCredentialsADAccountExpired: Account expired InvalidCredentialsADPasswordMustChange: Password needs to be changed InvalidCredentialsADAccountLockedOut: Account disabled by intruder detection + +ExamCloseModeSeparate: Seperately +ExamCloseModeOnFinished: With publication of achievements +ExamCloseModeOnFinishedHidden: With publication of achievements (hidden) +ExamCloseMode: Exam closure diff --git a/models/schools.model b/models/schools.model index 950b1c624..af9e54889 100644 --- a/models/schools.model +++ b/models/schools.model @@ -7,6 +7,7 @@ School json examMinimumRegisterDuration NominalDiffTime Maybe examRequireModeForRegistration Bool default=false examDiscouragedModes ExamModeDNF + examCloseMode ExamCloseMode default='separate' UniqueSchool name UniqueSchoolShorthand shorthand -- required for Normalisation of CI Text Primary shorthand -- newtype Key School = SchoolKey { unSchoolKey :: SchoolShorthand } diff --git a/src/Database/Esqueleto/Utils.hs b/src/Database/Esqueleto/Utils.hs index 396f497f6..81ec606cf 100644 --- a/src/Database/Esqueleto/Utils.hs +++ b/src/Database/Esqueleto/Utils.hs @@ -20,7 +20,7 @@ module Database.Esqueleto.Utils , selectExists, selectNotExists , SqlHashable , sha256 - , maybe, maybeEq, unsafeCoalesce + , maybe, maybe2, maybeEq, unsafeCoalesce , bool , max, min , abs @@ -302,6 +302,20 @@ maybe onNothing onJust val = E.case_ ] (E.else_ onNothing) +maybe2 :: (PersistField a, PersistField b, PersistField c) + => E.SqlExpr (E.Value c) + -> (E.SqlExpr (E.Value a) -> E.SqlExpr (E.Value b) -> E.SqlExpr (E.Value c)) + -> E.SqlExpr (E.Value (Maybe a)) + -> E.SqlExpr (E.Value (Maybe b)) + -> E.SqlExpr (E.Value c) +maybe2 onNothing onJust val1 val2 = E.case_ + [ E.when_ + (isJust val1 E.&&. isJust val2) + E.then_ + (onJust (E.veryUnsafeCoerceSqlExprValue val1) (E.veryUnsafeCoerceSqlExprValue val2)) + ] + (E.else_ onNothing) + infix 4 `maybeEq` maybeEq :: PersistField a diff --git a/src/Foundation/I18n.hs b/src/Foundation/I18n.hs index ac5e31cb0..78578b9ed 100644 --- a/src/Foundation/I18n.hs +++ b/src/Foundation/I18n.hs @@ -322,6 +322,15 @@ instance RenderMessage UniWorX CourseParticipantState where mr :: RenderMessage UniWorX msg => msg -> Text mr = renderMessage foundation ls +instance RenderMessage UniWorX ExamCloseMode where + renderMessage foundation ls = \case + ExamCloseSeparate -> mr MsgExamCloseModeSeparate + ExamCloseOnFinished False -> mr MsgExamCloseModeOnFinished + ExamCloseOnFinished True -> mr MsgExamCloseModeOnFinishedHidden + where + mr :: RenderMessage UniWorX msg => msg -> Text + mr = renderMessage foundation ls + -- ToMessage instances for converting raw numbers to Text (no internationalization) instance ToMessage Int where diff --git a/src/Handler/Exam/Edit.hs b/src/Handler/Exam/Edit.hs index 7cc3ef518..8a6e43a91 100644 --- a/src/Handler/Exam/Edit.hs +++ b/src/Handler/Exam/Edit.hs @@ -20,10 +20,11 @@ getEEditR = postEEditR postEEditR tid ssh csh examn = do (template, (editExamAct, (editExamWidget, editExamEnctype))) <- runDBJobs $ do (cid, exam@(Entity eId oldExam)) <- fetchCourseIdExam tid ssh csh examn + course <- getEntity404 cid template <- examFormTemplate exam - ((editExamResult, editExamWidget), editExamEnctype) <- runFormPost . validateForm (validateExam cid $ Just exam) . examForm $ Just template + ((editExamResult, editExamWidget), editExamEnctype) <- runFormPost . validateForm (validateExam cid $ Just exam) . examForm course $ Just template editExamAct <- formResultMaybe editExamResult $ \ExamForm{..} -> do insertRes <- myReplaceUnique eId Exam diff --git a/src/Handler/Exam/Form.hs b/src/Handler/Exam/Form.hs index cc8d0c273..5b909d779 100644 --- a/src/Handler/Exam/Form.hs +++ b/src/Handler/Exam/Form.hs @@ -103,9 +103,10 @@ deriveJSON defaultOptions examForm :: ( MonadHandler m , HandlerSite m ~ UniWorX ) - => Maybe ExamForm -> (Html -> MForm m (FormResult ExamForm, Widget)) -examForm template csrf = hoist liftHandler $ do + => Entity Course -> Maybe ExamForm -> (Html -> MForm m (FormResult ExamForm, Widget)) +examForm (Entity _ Course{..}) template csrf = hoist liftHandler $ do MsgRenderer mr <- getMsgRenderer + School{..} <- liftHandler . runDBRead $ getJust courseSchool flip (renderAForm FormStandard) csrf $ ExamForm <$> areq ciField (fslpI MsgExamName (mr MsgExamName) & setTooltip MsgExamNameTip) (efName <$> template) @@ -118,7 +119,7 @@ examForm template csrf = hoist liftHandler $ do <*> aopt utcTimeField (fslpI MsgExamRegisterTo (mr MsgDate)) (efRegisterTo <$> template) <*> aopt utcTimeField (fslpI MsgExamDeregisterUntil (mr MsgDate)) (efDeregisterUntil <$> template) <*> aopt utcTimeField (fslpI MsgExamPublishOccurrenceAssignments (mr MsgDate) & setTooltip MsgExamPublishOccurrenceAssignmentsTip) (efPublishOccurrenceAssignments <$> template) - <*> aopt utcTimeField (fslpI MsgExamFinished (mr MsgDate) & setTooltip MsgExamFinishedTip) (efFinished <$> template) + <*> aopt utcTimeField (fslpI MsgExamFinished (mr MsgDate) & setTooltip (bool MsgExamFinishedTip MsgExamFinishedTipCloseOnFinished $ is _ExamCloseOnFinished' schoolExamCloseMode)) (efFinished <$> template) <* aformSection MsgExamFormOccurrences <*> examOccurrenceForm (efOccurrences <$> template) <* aformSection MsgExamFormAutomaticFunctions diff --git a/src/Handler/Exam/New.hs b/src/Handler/Exam/New.hs index 43b7b287e..f4f313fef 100644 --- a/src/Handler/Exam/New.hs +++ b/src/Handler/Exam/New.hs @@ -21,9 +21,10 @@ getCExamNewR = postCExamNewR postCExamNewR tid ssh csh = do (newExamAct, (newExamWidget, newExamEnctype)) <- runDBJobs $ do cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh + course <- getEntity404 cid template <- examTemplate cid - ((newExamResult, newExamWidget), newExamEnctype) <- runFormPost . validateForm (validateExam cid Nothing) $ examForm template + ((newExamResult, newExamWidget), newExamEnctype) <- runFormPost . validateForm (validateExam cid Nothing) $ examForm course template newExamAct <- formResultMaybe newExamResult $ \ExamForm{..} -> do now <- liftIO getCurrentTime diff --git a/src/Handler/Exam/Show.hs b/src/Handler/Exam/Show.hs index 00584ff83..65439d72d 100644 --- a/src/Handler/Exam/Show.hs +++ b/src/Handler/Exam/Show.hs @@ -94,7 +94,7 @@ getEShowR tid ssh csh examn = do let occurrenceNamesShown = lecturerInfoShown partNumbersShown = lecturerInfoShown - examClosedShown = lecturerInfoShown + examClosedShown = lecturerInfoShown && isn't _ExamCloseOnFinished' schoolExamCloseMode showCloseWidget = lecturerInfoShown showAutoOccurrenceCalculateWidget = lecturerInfoShown showRegisteredCount = lecturerInfoShown diff --git a/src/Handler/ExamOffice/Exam.hs b/src/Handler/ExamOffice/Exam.hs index 4364079c7..c41684727 100644 --- a/src/Handler/ExamOffice/Exam.hs +++ b/src/Handler/ExamOffice/Exam.hs @@ -39,30 +39,44 @@ instance Button UniWorX ButtonCloseExam where examCloseWidget :: SomeRoute UniWorX -> ExamId -> Handler Widget examCloseWidget dest eId = do - Exam{..} <- runDB $ get404 eId + (Exam{..}, School{..}) <- runDB $ do + exam@Exam{..} <- get404 eId + Course{..} <- get404 examCourse + school <- get404 courseSchool + return (exam, school) - ((closeRes, closeView), closeEnc) <- runFormPost $ identifyForm BtnCloseExam buttonForm + let closeTime = case (examClosed, examFinished) of + (mClose, Just finish) + | isn't _ExamCloseSeparate schoolExamCloseMode -> Just $ maybe id min mClose finish + (Just close, _) + | is _ExamCloseSeparate schoolExamCloseMode -> Just close + _other -> Nothing - formResult closeRes $ \case - BtnCloseExam -> do - now <- liftIO getCurrentTime + examClosedStr <- for closeTime $ formatTime SelFormatDateTime - unless (is _Nothing examClosed) $ - invalidArgs ["Exam is already closed"] + if | is _ExamCloseOnFinished' schoolExamCloseMode + -> return $(widgetFile "widgets/exam-close-on-finished") + | otherwise -> do + ((closeRes, closeView'), closeEnc) <- runFormPost $ identifyForm BtnCloseExam buttonForm - runDB $ update eId [ ExamClosed =. Just now ] - addMessageI Success MsgExamDidClose - redirect dest + formResult closeRes $ \case + BtnCloseExam -> do + now <- liftIO getCurrentTime - let closeView' = wrapForm closeView def - { formSubmit = FormNoSubmit - , formAction = Just dest - , formEncoding = closeEnc - } + unless (is _Nothing examClosed) $ + invalidArgs ["Exam is already closed"] - examClosed' <- for examClosed $ formatTime SelFormatDateTime + runDB $ update eId [ ExamClosed =. Just now ] + addMessageI Success MsgExamDidClose + redirect dest - return $(widgetFile "widgets/exam-close") + let closeView = wrapForm closeView' def + { formSubmit = FormNoSubmit + , formAction = Just dest + , formEncoding = closeEnc + } + + return $(widgetFile "widgets/exam-close") type ExamUserTableExpr = ( E.SqlExpr (Entity ExamResult) diff --git a/src/Handler/ExamOffice/Exams.hs b/src/Handler/ExamOffice/Exams.hs index c2f4f1c75..7aa94a7f8 100644 --- a/src/Handler/ExamOffice/Exams.hs +++ b/src/Handler/ExamOffice/Exams.hs @@ -18,18 +18,22 @@ import qualified Colonnade type ExamsTableExpr = ( E.SqlExpr (Maybe (Entity Exam)) `E.InnerJoin` E.SqlExpr (Maybe (Entity Course)) + `E.InnerJoin` E.SqlExpr (Maybe (Entity School)) ) `E.FullOuterJoin` E.SqlExpr (Maybe (Entity ExternalExam)) -type ExamsTableData = DBRow ( Either (Entity ExternalExam) (Entity Exam, Entity Course) +type ExamsTableData = DBRow ( Either (Entity ExternalExam) (Entity Exam, Entity Course, Entity School) , Natural, Natural ) queryExam :: Getter ExamsTableExpr (E.SqlExpr (Maybe (Entity Exam))) -queryExam = to $ $(E.sqlIJproj 2 1) . $(E.sqlFOJproj 2 1) +queryExam = to $ $(E.sqlIJproj 3 1) . $(E.sqlFOJproj 2 1) queryCourse :: Getter ExamsTableExpr (E.SqlExpr (Maybe (Entity Course))) -queryCourse = to $ $(E.sqlIJproj 2 2) . $(E.sqlFOJproj 2 1) +queryCourse = to $ $(E.sqlIJproj 3 2) . $(E.sqlFOJproj 2 1) + +querySchool :: Getter ExamsTableExpr (E.SqlExpr (Maybe (Entity School))) +querySchool = to $ $(E.sqlIJproj 3 3) . $(E.sqlFOJproj 2 1) queryExternalExam :: Getter ExamsTableExpr (E.SqlExpr (Maybe (Entity ExternalExam))) queryExternalExam = to $(E.sqlFOJproj 2 2) @@ -66,6 +70,7 @@ queryIsSynced :: UTCTime -> E.SqlExpr (E.Value UserId) -> Getter ExamsTableExpr queryIsSynced now office = to . runReader $ do exam' <- view queryExam externalExam' <- view queryExternalExam + school' <- view querySchool let examSynchronised examId = E.not_ . E.exists . E.from $ \examResult -> do E.where_ $ examResult E.^. ExamResultExam E.==. examId @@ -75,8 +80,11 @@ queryIsSynced now office = to . runReader $ do E.where_ $ externalExamResult E.^. ExternalExamResultExam E.==. externalExamId E.where_ $ ExternalExam.examOfficeExternalExamResultAuth office externalExamResult E.where_ . E.not_ $ ExternalExam.resultIsSynced office externalExamResult - open examClosed' = E.maybe E.true (E.>. E.val now) examClosed' - return $ E.maybe E.false examSynchronised (exam' E.?. ExamId) E.||. E.maybe E.false open (exam' E.?. ExamClosed) E.||. E.maybe E.false externalExamSynchronised (externalExam' E.?. ExternalExamId) + open examClosed' examFinished' + = E.bool (E.maybe E.true (E.>. E.val now) $ E.min examClosed' examFinished') + (E.maybe E.true (E.>. E.val now) examClosed') + (E.maybe E.false (E.==. E.val ExamCloseSeparate) (school' E.?. SchoolExamCloseMode)) + return $ E.maybe E.false examSynchronised (exam' E.?. ExamId) E.||. E.maybe2 E.false open (exam' E.?. ExamClosed) (exam' E.?. ExamFinished) E.||. E.maybe E.false externalExamSynchronised (externalExam' E.?. ExternalExamId) resultExam :: Traversal' ExamsTableData (Entity Exam) @@ -85,6 +93,9 @@ resultExam = _dbrOutput . _1 . _Right . _1 resultCourse :: Traversal' ExamsTableData (Entity Course) resultCourse = _dbrOutput . _1 . _Right . _2 +resultSchool :: Traversal' ExamsTableData (Entity School) +resultSchool = _dbrOutput . _1 . _Right . _3 + resultExternalExam :: Traversal' ExamsTableData (Entity ExternalExam) resultExternalExam = _dbrOutput . _1 . _Left @@ -126,6 +137,7 @@ getEOExamsR = do dbtSQLQuery = runReaderT $ do exam <- view queryExam course <- view queryCourse + school <- view querySchool externalExam <- view queryExternalExam synchronised <- view querySynchronised' @@ -133,35 +145,41 @@ getEOExamsR = do lift $ do E.on E.false + E.on $ school E.?. SchoolId E.==. course E.?. CourseSchool E.on $ exam E.?. ExamCourse E.==. course E.?. CourseId E.where_ $ results E.>. E.val 0 E.where_ $ (E.not_ (E.isNothing $ exam E.?. ExamId) E.&&. E.not_ (E.isNothing $ course E.?. CourseId) E.&&. E.isNothing (externalExam E.?. ExternalExamId)) E.||. ( E.isNothing (exam E.?. ExamId) E.&&. E.isNothing (course E.?. CourseId) E.&&. E.not_ (E.isNothing $ externalExam E.?. ExternalExamId)) - return (exam, course, externalExam, synchronised, results) + return (exam, course, school, externalExam, synchronised, results) dbtRowKey = views ($(multifocusG 2) queryExam queryExternalExam) (bimap (E.?. ExamId) (E.?. ExternalExamId)) dbtProj :: DBRow _ -> DB ExamsTableData dbtProj = runReaderT $ (asks . set _dbrOutput) <=< magnify _dbrOutput $ do exam <- view _1 course <- view _2 - externalExam <- view _3 + school <- view _3 + externalExam <- view _4 - case (exam, course, externalExam) of - (Just exam', Just course', Nothing) -> - (Right (exam', course'),,) <$> view (_4 . _Value) <*> view (_5 . _Value) - (Nothing, Nothing, Just externalExam') -> - (Left externalExam',,) <$> view (_4 . _Value) <*> view (_5 . _Value) + case (exam, course, school, externalExam) of + (Just exam', Just course', Just school', Nothing) -> + (Right (exam', course', school'),,) <$> view (_5 . _Value) <*> view (_6 . _Value) + (Nothing, Nothing, Nothing, Just externalExam') -> + (Left externalExam',,) <$> view (_5 . _Value) <*> view (_6 . _Value) _other -> return $ error "Got exam & externalExam in same result" colSynced = Colonnade.singleton (fromSortable . Sortable (Just "synced") $ i18nCell MsgExamSynchronised) $ \x -> flip runReader x $ do mExam <- preview resultExam + mSchool <- preview resultSchool if - | Just (Entity _ Exam{examClosed}) <- mExam - , NTop examClosed > NTop (Just now) + | Just (Entity _ Exam{examClosed, examFinished}) <- mExam + , Just (Entity _ School{schoolExamCloseMode}) <- mSchool + , bool ((min `on` NTop) examClosed examFinished > NTop (Just now)) + (NTop examClosed > NTop (Just now)) + $ is _ExamCloseSeparate schoolExamCloseMode -> return . cell $ toWidget iconNew | otherwise -> do diff --git a/src/Handler/School.hs b/src/Handler/School.hs index 2ba5695e4..184191c3f 100644 --- a/src/Handler/School.hs +++ b/src/Handler/School.hs @@ -66,6 +66,7 @@ data SchoolForm = SchoolForm , sfExamMinimumRegisterDuration :: Maybe NominalDiffTime , sfExamRequireModeForRegistration :: Bool , sfExamDiscouragedModes :: ExamModeDNF + , sfExamCloseMode :: ExamCloseMode } mkSchoolForm :: Maybe SchoolId -> Maybe SchoolForm -> Form SchoolForm @@ -77,6 +78,7 @@ mkSchoolForm mSsh template = renderAForm FormStandard $ SchoolForm <*> aopt daysField (fslI MsgSchoolExamMinimumRegisterDuration & setTooltip MsgSchoolExamMinimumRegisterDurationTip) (sfExamMinimumRegisterDuration <$> template) <*> apopt checkBoxField (fslI MsgSchoolExamRequireModeForRegistration & setTooltip MsgSchoolExamRequireModeForRegistration) (sfExamRequireModeForRegistration <$> template) <*> areq pathPieceField (fslI MsgSchoolExamDiscouragedModes) (sfExamDiscouragedModes <$> template <|> pure (ExamModeDNF predDNFFalse)) + <*> apopt (selectField optionsFinite) (fslI MsgExamCloseMode) (sfExamCloseMode <$> template <|> pure ExamCloseSeparate) where ldapOrgs :: HandlerFor UniWorX (OptionList (CI Text)) ldapOrgs = fmap (mkOptionList . map (\t -> Option (CI.original t) t (CI.original t)) . Set.toAscList) . runDB $ @@ -94,6 +96,7 @@ schoolToForm ssh = do , sfExamMinimumRegisterDuration = schoolExamMinimumRegisterDuration , sfExamRequireModeForRegistration = schoolExamRequireModeForRegistration , sfExamDiscouragedModes = schoolExamDiscouragedModes + , sfExamCloseMode = schoolExamCloseMode } @@ -112,6 +115,7 @@ postSchoolEditR ssh = do , SchoolExamMinimumRegisterDuration =. sfExamMinimumRegisterDuration , SchoolExamRequireModeForRegistration =. sfExamRequireModeForRegistration , SchoolExamDiscouragedModes =. sfExamDiscouragedModes + , SchoolExamCloseMode =. sfExamCloseMode ] forM_ sfOrgUnits $ \schoolLdapOrgUnit -> void $ upsert SchoolLdap @@ -153,6 +157,7 @@ postSchoolNewR = do , schoolExamMinimumRegisterDuration = sfExamMinimumRegisterDuration , schoolExamRequireModeForRegistration = sfExamRequireModeForRegistration , schoolExamDiscouragedModes = sfExamDiscouragedModes + , schoolExamCloseMode = sfExamCloseMode } when didInsert $ do insert_ UserFunction diff --git a/src/Jobs/Crontab.hs b/src/Jobs/Crontab.hs index 91949d85a..19411a3af 100644 --- a/src/Jobs/Crontab.hs +++ b/src/Jobs/Crontab.hs @@ -306,7 +306,11 @@ determineCrontab = execWriterT $ do let - examJobs (Entity nExam Exam{..}) = do + examSelect = E.selectSource . E.from $ \(exam `E.InnerJoin` course `E.InnerJoin` school) -> do + E.on $ school E.^. SchoolId E.==. course E.^. CourseSchool + E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse + return (exam, course, school) + examJobs (Entity nExam Exam{..}, _, Entity _ School{..}) = do newestResult <- lift . E.select . E.from $ \examResult -> do E.where_ $ examResult E.^. ExamResultExam E.==. E.val nExam return . E.max_ $ examResult E.^. ExamResultLastChanged @@ -352,7 +356,14 @@ determineCrontab = execWriterT $ do , cronNotAfter = Right . CronTimestamp $ utcToLocalTimeTZ appTZ deregisterUntil } - case examClosed of + let closeTime = case (examClosed, examFinished) of + (mClose, Just finish) + | isn't _ExamCloseSeparate schoolExamCloseMode -> Just $ maybe id min mClose finish + (Just close, _) + | is _ExamCloseSeparate schoolExamCloseMode -> Just close + _other -> Nothing + + case closeTime of Just close -> do changedResults <- lift . E.select . E.from $ \examResult -> do E.where_ $ examResult E.^. ExamResultExam E.==. E.val nExam @@ -381,8 +392,7 @@ determineCrontab = execWriterT $ do , cronNotAfter = Left appNotificationExpiration } Nothing -> return () - - runConduit $ transPipe lift (selectSource [] []) .| C.mapM_ examJobs + in runConduit $ transPipe lift examSelect .| C.mapM_ examJobs let diff --git a/src/Model/Types/Exam.hs b/src/Model/Types/Exam.hs index 98835feb3..44cd909dc 100644 --- a/src/Model/Types/Exam.hs +++ b/src/Model/Types/Exam.hs @@ -38,6 +38,7 @@ module Model.Types.Exam , ExamRequiredEquipment(..), ExamRequiredEquipmentPreset(..) , ExamMode(..) , ExamModePredicate(..), ExamModeDNF(..) + , ExamCloseMode(..), _ExamCloseSeparate, _ExamCloseOnFinished, _ExamCloseOnFinished', _ExamCloseOnFinishedHidden, _examCloseOnFinishedHidden ) where import Import.NoModel @@ -558,3 +559,23 @@ newtype ExamModeDNF = ExamModeDNF { examModeDNF :: PredDNF ExamModePredicate } deriving newtype (Semigroup, Monoid, ToJSON, FromJSON, PathPiece) derivePersistFieldJSON ''ExamModeDNF + + +data ExamCloseMode + = ExamCloseSeparate + | ExamCloseOnFinished { examCloseOnFinishedHidden :: Bool } + deriving (Eq, Ord, Read, Show, Generic, Typeable) + deriving anyclass (Binary) +deriveFinite ''ExamCloseMode +finitePathPiece ''ExamCloseMode ["separate", "on-finished", "on-finished-hidden"] +derivePersistFieldPathPiece ''ExamCloseMode +pathPieceJSON ''ExamCloseMode +pathPieceJSONKey ''ExamCloseMode +pathPieceHttpApiData ''ExamCloseMode + +makeLenses_ ''ExamCloseMode +makePrisms ''ExamCloseMode + +_ExamCloseOnFinished', _ExamCloseOnFinishedHidden :: Prism' ExamCloseMode () +_ExamCloseOnFinished' = _ExamCloseOnFinished . only False +_ExamCloseOnFinishedHidden = _ExamCloseOnFinished . only True diff --git a/templates/widgets/exam-close-on-finished.hamlet b/templates/widgets/exam-close-on-finished.hamlet new file mode 100644 index 000000000..d2b760e5b --- /dev/null +++ b/templates/widgets/exam-close-on-finished.hamlet @@ -0,0 +1,6 @@ +$newline never +

+ _{MsgExamCloseTipOnFinished} +$maybe closed <- examClosedStr +

+ _{MsgExamClosedSince closed} diff --git a/templates/widgets/exam-close.hamlet b/templates/widgets/exam-close.hamlet index 6a768b533..47f64ea35 100644 --- a/templates/widgets/exam-close.hamlet +++ b/templates/widgets/exam-close.hamlet @@ -1,9 +1,10 @@ $newline never -$maybe closed <- examClosed' - _{MsgExamClosedSince closed} +$maybe closed <- examClosedStr +

+ _{MsgExamClosedSince closed} $nothing -

+

_{MsgExamCloseTip} -

+

_{MsgExamCloseReminder} - ^{closeView'} + ^{closeView} diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs index 29cdb615b..ec51b7952 100644 --- a/test/Database/Fill.hs +++ b/test/Database/Fill.hs @@ -368,8 +368,8 @@ fillDb = do , termLectureEnd , termActive = term >= currentTerm } - ifi <- insert' $ School "Institut für Informatik" "IfI" (Just $ 14 * nominalDay) (Just $ 10 * nominalDay) True (ExamModeDNF predDNFFalse) - mi <- insert' $ School "Institut für Mathematik" "MI" Nothing Nothing False (ExamModeDNF predDNFFalse) + ifi <- insert' $ School "Institut für Informatik" "IfI" (Just $ 14 * nominalDay) (Just $ 10 * nominalDay) True (ExamModeDNF predDNFFalse) (ExamCloseOnFinished True) + mi <- insert' $ School "Institut für Mathematik" "MI" Nothing Nothing False (ExamModeDNF predDNFFalse) (ExamCloseOnFinished False) void . insert' $ UserFunction gkleen ifi SchoolAdmin void . insert' $ UserFunction gkleen mi SchoolAdmin void . insert' $ UserFunction fhamann ifi SchoolAdmin @@ -382,6 +382,8 @@ fillDb = do void . insert' $ UserFunction jost ifi SchoolLecturer void . insert' $ UserFunction svaupel ifi SchoolLecturer void . insert' $ UserFunction gkleen ifi SchoolAllocation + void . insert' $ UserFunction gkleen ifi SchoolExamOffice + void . insert' $ UserFunction gkleen mi SchoolExamOffice for_ [gkleen, fhamann, jost, maxMuster, svaupel] $ \uid -> void . insert' $ UserSchool uid ifi False for_ [gkleen, tinaTester] $ \uid ->