diff --git a/messages/uniworx/de-de-formal.msg b/messages/uniworx/de-de-formal.msg index 6e52c454f..d0e96638e 100644 --- a/messages/uniworx/de-de-formal.msg +++ b/messages/uniworx/de-de-formal.msg @@ -1790,6 +1790,7 @@ CourseUserExamResultDoesNotMatchMode examn@ExamName: Gewähtes Ergebnis passt ni CourseUserSetSubmissionGroup: Feste Abgabegruppe setzen/entfernen CourseUsersSubmissionGroupSetNew count@Int64: #{show count} Benutzer der festen Abgabegruppe zugeordnet CourseUsersSubmissionGroupUnset count@Int64: #{show count} Benutzer aus ihren jeweiligen festen Abgabegruppen entfernt +CourseUsersStateSet count@Int64: Zustand von #{show count} #{pluralDE count "Benutzer" "Benutzern"} angepasst SubmissionGroup: Feste Abgabegruppe NoSubmissionGroup: Keine feste Abgabegruppe @@ -2253,8 +2254,13 @@ CourseNewsDeleteQuestion: Wollen Sie die unten aufgeführte Nachricht wirklich l CourseNewsDeleted: Kursnachricht erfolgreich gelöscht CourseDeregistrationAllocationLog: Ihr Platz in diesem Kurs stammt aus einer Zentralanmeldung. Wenn Sie sich vom Kurs abmelden wird dieser Umstand permanent im System gespeichert und kann Sie u.U. bei zukünftigen Zentralanmeldungen benachteiligen. Wenn Sie gute Gründe vorzuweisen haben, warum Ihre Abmeldung nicht selbstverschuldet ist, kontaktieren Sie bitte einen Kursverwalter. Diese haben die Möglichkeit Sie ohne permanente Eintragung im System abzumelden. +CourseDeregistrationNoShow: Wenn Sie sich vom Kurs abmelden, wird für alle Prüfungen des Kurses „nicht erschienen“ gemeldet. Wenn Sie gute Gründe vorzuweisen haben, warum Ihre Abmeldung nicht selbstverschuldet ist, kontaktieren Sie bitte einen Kursverwalter. Diese haben die Möglichkeit Sie ohne permanente Eintragung im System abzumelden. CourseDeregistrationAllocationReason: Grund CourseDeregistrationAllocationReasonTip: Der angegebene Grund wird permanent im System hinterlegt und ist i.A. einziger Anhaltspunkt zur Schlichtung etwaiger Konflikte +CourseDeregistrationAllocationNoShow: „Nicht erschienen“ eintragen +CourseDeregistrationAllocationNoShowTip: Soll für alle Prüfungen dieses Kurses „nicht erschienen“ als Prüfungsleistung eingetragen werden? Dies geschieht einmalig bei der Abmeldung (sofern nicht bereits eine Prüfungsleistung existiert) und automatisch beim Anlegen von neuen Prüfungen. +CourseDeregisterNoShow: „Nicht erschienen“ bei Abmeldung +CourseDeregisterNoShowTip: Soll, wenn sich Teilnehmer selbstständig abmelden, für alle Prüfungen dieses Kurses „nicht erschienen“ als Prüfungsleistung eingetragen werden? Dies geschieht einmalig bei der Abmeldung (sofern nicht bereits eine Prüfungsleistung existiert) und automatisch beim Anlegen von neuen Prüfungen. CourseDeregistrationAllocationShouldLog: Selbstverschuldet CourseDeregistrationAllocationShouldLogTip: Falls der Platz des Studierenden, der abgemeldet wird, aus einer Zentralanmeldung stammt, ist vorgesehen einen permanenten Eintrag im System zu speichern, der den Studierenden u.U. bei zukünftigen Zentralanmeldungen benachteiligt. Als Kursverwalter haben Sie die Möglichkeit dies zu unterbinden, wenn der Studierende gute Gründe vorweisen kann, warum seine Abmeldung nicht selbstverschuldet ist. @@ -2516,4 +2522,9 @@ MultiActionUnknownAction: In einem von einem Eingabefeld abhängigen Formular wu CourseParticipantStateIsActive: Aktive Teilnehmer CourseParticipantStateIsInactive: Ehemalige Teilnehmer -CourseParticipantStateIsActiveFilter: Ansicht \ No newline at end of file +CourseParticipantStateIsActiveFilter: Ansicht +CourseUserReRegister: Wieder anmelden +CourseParticipantActive: Teilnehmer +CourseParticipantInactive: Abgemeldet +CourseParticipantNoShow: Nicht erschienen +CourseUserState: Zustand \ No newline at end of file diff --git a/models/courses.model b/models/courses.model index cb9839b81..21bd6132b 100644 --- a/models/courses.model +++ b/models/courses.model @@ -15,6 +15,7 @@ Course -- Information about a single course; contained info is always visible registerFrom UTCTime Maybe -- enrolement allowed from a given day onwwards or prohibited registerTo UTCTime Maybe -- enrolement may be prohibited from a given date onwards deregisterUntil UTCTime Maybe -- unenrolement may be prohibited from a given date onwards + deregisterNoShow Bool default=false registerSecret Text Maybe -- enrolement maybe protected by a simple common passphrase materialFree Bool -- False: only enrolled users may see course materials not stored in this table applicationsRequired Bool default=false diff --git a/src/Foundation/I18n.hs b/src/Foundation/I18n.hs index b1ab71296..2b505386c 100644 --- a/src/Foundation/I18n.hs +++ b/src/Foundation/I18n.hs @@ -277,6 +277,15 @@ instance RenderMessage UniWorX (Either ExamPassed ExamGrade) where mr :: RenderMessage UniWorX msg => msg -> Text mr = renderMessage foundation ls +instance RenderMessage UniWorX CourseParticipantState where + renderMessage foundation ls = \case + CourseParticipantActive -> mr MsgCourseParticipantActive + CourseParticipantInactive False -> mr MsgCourseParticipantInactive + CourseParticipantInactive True -> mr MsgCourseParticipantNoShow + 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/Course/Edit.hs b/src/Handler/Course/Edit.hs index 8707c568b..1e83e4393 100644 --- a/src/Handler/Course/Edit.hs +++ b/src/Handler/Course/Edit.hs @@ -55,10 +55,11 @@ data CourseForm = CourseForm data AllocationCourseForm = AllocationCourseForm { acfAllocation :: AllocationId , acfMinCapacity :: Int + , acfDeregisterNoShow :: Bool } courseToForm :: Entity Course -> [Lecturer] -> Map UserEmail (InvitationDBData Lecturer) -> Maybe (Entity AllocationCourse) -> CourseForm -courseToForm (Entity cid Course{..}) lecs lecInvites alloc = CourseForm +courseToForm cEnt@(Entity cid Course{..}) lecs lecInvites alloc = CourseForm { cfCourseId = Just cid , cfName = courseName , cfDesc = courseDescription @@ -69,7 +70,7 @@ courseToForm (Entity cid Course{..}) lecs lecInvites alloc = CourseForm , cfCapacity = courseCapacity , cfSecret = courseRegisterSecret , cfMatFree = courseMaterialFree - , cfAllocation = allocationCourseToForm <$> alloc + , cfAllocation = allocationCourseToForm cEnt <$> alloc , cfAppRequired = courseApplicationsRequired , cfAppInstructions = courseApplicationsInstructions , cfAppInstructionFiles @@ -89,10 +90,11 @@ courseToForm (Entity cid Course{..}) lecs lecInvites alloc = CourseForm return $ courseAppInstructionFile E.^. CourseAppInstructionFileFile -allocationCourseToForm :: Entity AllocationCourse -> AllocationCourseForm -allocationCourseToForm (Entity _ AllocationCourse{..}) = AllocationCourseForm +allocationCourseToForm :: Entity Course -> Entity AllocationCourse -> AllocationCourseForm +allocationCourseToForm (Entity _ Course{..}) (Entity _ AllocationCourse{..}) = AllocationCourseForm { acfAllocation = allocationCourseAllocation , acfMinCapacity = allocationCourseMinCapacity + , acfDeregisterNoShow = courseDeregisterNoShow } makeCourseForm :: (forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX)) -> Maybe CourseForm -> Form CourseForm @@ -251,6 +253,7 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse . validateFormDB in AllocationCourseForm <$> ainp (selectField' Nothing $ return allocationOptions) (fslI MsgCourseAllocation) (fmap acfAllocation $ template >>= cfAllocation) <*> ainp (natFieldI MsgCourseAllocationMinCapacityMustBeNonNegative) (fslI MsgCourseAllocationMinCapacity & setTooltip MsgCourseAllocationMinCapacityTip) (fmap acfMinCapacity $ template >>= cfAllocation) + <*> apopt checkBoxField (fslI MsgCourseDeregisterNoShow & setTooltip MsgCourseDeregisterNoShowTip) ((<|> Just True) . fmap acfDeregisterNoShow $ template >>= cfAllocation) optionalActionW' (bool mforcedJust mpopt mayChange) allocationForm' (fslI MsgCourseAllocationParticipate & setTooltip MsgCourseAllocationParticipateTip) (is _Just . cfAllocation <$> template) @@ -459,6 +462,7 @@ courseEditHandler miButtonAction mbCourseForm = do , courseRegisterFrom = cfRegFrom , courseRegisterTo = cfRegTo , courseDeregisterUntil = cfDeRegUntil + , courseDeregisterNoShow = maybe False acfDeregisterNoShow cfAllocation } whenIsJust insertOkay $ \cid -> do let (invites, adds) = partitionEithers $ cfLecturers res @@ -506,6 +510,7 @@ courseEditHandler miButtonAction mbCourseForm = do , courseRegisterFrom = cfRegFrom , courseRegisterTo = cfRegTo , courseDeregisterUntil = cfDeRegUntil + , courseDeregisterNoShow = maybe False acfDeregisterNoShow cfAllocation } case updOkay of (Just _) -> addMessageI Warning (MsgCourseEditDupShort tid ssh csh) $> False diff --git a/src/Handler/Course/Register.hs b/src/Handler/Course/Register.hs index a3f342926..506453d8e 100644 --- a/src/Handler/Course/Register.hs +++ b/src/Handler/Course/Register.hs @@ -142,6 +142,8 @@ courseRegisterForm (Entity cid Course{..}) = liftHandler $ do -> aFormToWForm $ fileUploadForm False (fslI . mkFs) courseApplicationsFiles when (is _Just $ registration >>= courseParticipantAllocated . entityVal) $ + wformMessage =<< messageIconI Warning IconExamRegisterFalse MsgCourseDeregistrationNoShow + when (is _Just (registration >>= courseParticipantAllocated . entityVal) && courseDeregisterNoShow) $ wformMessage =<< messageIconI Warning IconEnrolFalse MsgCourseDeregistrationAllocationLog return $ CourseRegisterForm @@ -216,11 +218,23 @@ postCRegisterR tid ssh csh = do BtnCourseDeregister -> runDB $ do part <- fmap (assertM . has $ _entityVal . _courseParticipantState . _CourseParticipantActive) . getBy $ UniqueParticipant uid cid forM_ part $ \(Entity _partId CourseParticipant{..}) -> do + deregisterParticipant uid cid + when (is _Just courseParticipantAllocated) $ do + updateBy (UniqueParticipant uid cid) [ CourseParticipantState =. CourseParticipantInactive courseDeregisterNoShow ] + now <- liftIO getCurrentTime insert_ $ AllocationDeregister courseParticipantUser (Just courseParticipantCourse) now Nothing - - deregisterParticipant uid cid + let recordNoShow eId = do + didRecord <- is _Just <$> insertUnique ExamResult + { examResultExam = eId + , examResultUser = uid + , examResultResult = ExamNoShow + , examResultLastChanged = now + } + when didRecord $ + audit $ TransactionExamResultEdit eId uid + when courseDeregisterNoShow . runConduit $ selectKeys [ ExamCourse ==. cid ] [] .| C.mapM_ recordNoShow addMessageIconI Info IconEnrolFalse MsgCourseDeregisterOk BtnCourseApply -> runDB $ do diff --git a/src/Handler/Course/User.hs b/src/Handler/Course/User.hs index f5568c5ca..ba223ceaa 100644 --- a/src/Handler/Course/User.hs +++ b/src/Handler/Course/User.hs @@ -26,6 +26,8 @@ import qualified Data.Map as Map import qualified Data.Text as Text import qualified Data.CaseInsensitive as CI +import qualified Data.Conduit.Combinators as C + data ExamAction = ExamDeregister | ExamSetResult @@ -129,7 +131,10 @@ courseUserProfileSection (Entity cid Course{..}) (Entity uid User{ userShowSex = if | is _Just $ courseParticipantAllocated . entityVal =<< mRegistration -> renderWForm FormStandard $ fmap (regButton, ) <$ (wformMessage =<< messageIconI Warning IconEnrolFalse MsgCourseDeregistrationAllocationShouldLogTip) - <*> optionalActionW (areq (textField & cfStrip & guardField (not . null)) (fslI MsgCourseDeregistrationAllocationReason & setTooltip MsgCourseDeregistrationAllocationReasonTip) Nothing) (fslI MsgCourseDeregistrationAllocationShouldLog) (Just True) + <*> optionalActionW ((,) + <$> areq (textField & cfStrip & guardField (not . null)) (fslI MsgCourseDeregistrationAllocationReason & setTooltip MsgCourseDeregistrationAllocationReasonTip) Nothing + <*> apopt checkBoxField (fslI MsgCourseDeregistrationAllocationNoShow & setTooltip MsgCourseDeregistrationAllocationNoShowTip) Nothing + ) (fslI MsgCourseDeregistrationAllocationShouldLog) (Just True) | otherwise -> \csrf -> pure (FormSuccess (regButton, Nothing), toWidget csrf) @@ -153,9 +158,21 @@ courseUserProfileSection (Entity cid Course{..}) (Entity uid User{ userShowSex = lift . runDB $ do deregisterParticipant courseParticipantUser courseParticipantCourse - whenIsJust mbReason $ \reason -> do + whenIsJust mbReason $ \(reason, noShow) -> do + updateBy (UniqueParticipant uid cid) [ CourseParticipantState =. CourseParticipantInactive noShow ] + now <- liftIO getCurrentTime insert_ $ AllocationDeregister courseParticipantUser (Just cid) now (Just reason) + let recordNoShow eId = do + didRecord <- is _Just <$> insertUnique ExamResult + { examResultExam = eId + , examResultUser = uid + , examResultResult = ExamNoShow + , examResultLastChanged = now + } + when didRecord $ + audit $ TransactionExamResultEdit eId uid + when noShow . runConduit $ selectKeys [ ExamCourse ==. cid ] [] .| C.mapM_ recordNoShow addMessageIconI Info IconEnrolFalse MsgCourseDeregisterOk redirect $ CourseR courseTerm courseSchool courseShorthand CUsersR | otherwise diff --git a/src/Handler/Course/Users.hs b/src/Handler/Course/Users.hs index 01d2baf02..b50644b09 100644 --- a/src/Handler/Course/Users.hs +++ b/src/Handler/Course/Users.hs @@ -30,6 +30,8 @@ import qualified Data.Conduit.List as C import qualified Data.CaseInsensitive as CI +import Database.Persist.Sql (updateWhereCount) + type UserTableExpr = ( E.SqlExpr (Entity User) `E.InnerJoin` E.SqlExpr (Entity CourseParticipant) @@ -283,6 +285,7 @@ data CourseUserAction = CourseUserSendMail | CourseUserRegisterTutorial | CourseUserRegisterExam | CourseUserSetSubmissionGroup + | CourseUserReRegister deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable) instance Universe CourseUserAction @@ -292,7 +295,7 @@ embedRenderMessage ''UniWorX ''CourseUserAction id data CourseUserActionData = CourseUserSendMailData | CourseUserDeregisterData - { deregisterReason :: Maybe Text + { deregisterSelfImposed :: Maybe (Text, Bool {- no-show -}) } | CourseUserRegisterTutorialData { registerTutorial :: TutorialId @@ -303,6 +306,7 @@ data CourseUserActionData = CourseUserSendMailData | CourseUserSetSubmissionGroupData { setSubmissionGroup :: Maybe SubmissionGroupName } + | CourseUserReRegisterData deriving (Eq, Ord, Read, Show, Generic, Typeable) @@ -372,6 +376,7 @@ makeCourseUserTable cid acts restrict colChoices psValidator csvColumns = do return . E.min_ $ exam E.^. ExamName ) , single $ ("submission-group", SortColumn $ querySubmissionGroup >>> (E.?. SubmissionGroupName)) + , single $ ("state", SortColumn $ queryParticipant >>> (E.^. CourseParticipantState)) ] where single = uncurry Map.singleton dbtFilter = mconcat @@ -513,7 +518,10 @@ courseUserDeregisterForm cid = wFormToAForm $ do E.&&. participant E.^. CourseParticipantState E.==. E.val CourseParticipantActive if | allocated -> do wformMessage =<< messageIconI Warning IconEnrolFalse MsgCourseDeregistrationAllocationShouldLogTip - fmap CourseUserDeregisterData <$> optionalActionW (apreq (textField & cfStrip & guardField (not . null)) (fslI MsgCourseDeregistrationAllocationReason & setTooltip MsgCourseDeregistrationAllocationReasonTip) Nothing) (fslI MsgCourseDeregistrationAllocationShouldLog) (Just True) + let selfImposedForm = (,) + <$> apreq (textField & cfStrip & guardField (not . null)) (fslI MsgCourseDeregistrationAllocationReason & setTooltip MsgCourseDeregistrationAllocationReasonTip) Nothing + <*> apopt checkBoxField (fslI MsgCourseDeregistrationAllocationNoShow & setTooltip MsgCourseDeregistrationAllocationNoShowTip) Nothing + fmap CourseUserDeregisterData <$> optionalActionW selfImposedForm (fslI MsgCourseDeregistrationAllocationShouldLog) (Just True) | otherwise -> pure . pure $ CourseUserDeregisterData Nothing getCUsersR, postCUsersR :: TermId -> SchoolId -> CourseShorthand -> Handler Html @@ -547,6 +555,7 @@ postCUsersR tid ssh csh = do , guardOn hasTutorials $ colUserTutorials tid ssh csh , guardOn hasExams $ colUserExams tid ssh csh , pure $ sortable (Just "registration") (i18nCell MsgRegisteredSince) (maybe mempty dateCell . preview (_Just . _userTableRegistration) . assertM' (has $ _userTableParticipant . _entityVal . _courseParticipantState . _CourseParticipantActive)) + , pure $ sortable (Just "state") (i18nCell MsgCourseUserState) (i18nCell . view (_userTableParticipant . _entityVal . _courseParticipantState)) , pure $ colUserComment tid ssh csh ] psValidator = def & defaultSortingByName @@ -578,21 +587,18 @@ postCUsersR tid ssh csh = do optionDisplay = CI.original $ examName entityVal return Option{..} submissionGroupOpts = optionsPersist [SubmissionGroupCourse ==. cid] [Asc SubmissionGroupName] submissionGroupName <&> fmap (submissionGroupName . entityVal) - acts = mconcat - [ singletonMap CourseUserSendMail $ pure CourseUserSendMailData - , singletonMap CourseUserRegisterTutorial $ CourseUserRegisterTutorialData <$> - apopt (selectField' Nothing . fmap (fmap entityKey) $ optionsPersistCryptoId [TutorialCourse ==. cid] [Asc TutorialName] tutorialName) - (fslI MsgCourseTutorial) - Nothing - , singletonMap CourseUserRegisterExam $ CourseUserRegisterExamData <$> - multiActionAOpts examOccActs examActs (fslI MsgCourseExam) Nothing - , singletonMap CourseUserSetSubmissionGroup $ CourseUserSetSubmissionGroupData . assertM (not . Text.null . CI.original) <$> - aopt (textField & cfStrip & cfCI & addDatalist submissionGroupOpts) (fslI MsgSubmissionGroup & setTooltip MsgSubmissionGroupEmptyIsUnsetTip) Nothing - , if - | mayRegister - -> singletonMap CourseUserDeregister $ courseUserDeregisterForm cid - | otherwise - -> mempty + acts = mconcat $ catMaybes + [ pure . singletonMap CourseUserSendMail $ pure CourseUserSendMailData + , pure . singletonMap CourseUserRegisterTutorial $ CourseUserRegisterTutorialData + <$> apopt (selectField' Nothing . fmap (fmap entityKey) $ optionsPersistCryptoId [TutorialCourse ==. cid] [Asc TutorialName] tutorialName) + (fslI MsgCourseTutorial) + Nothing + , pure . singletonMap CourseUserRegisterExam $ CourseUserRegisterExamData <$> + multiActionAOpts examOccActs examActs (fslI MsgCourseExam) Nothing + , pure . singletonMap CourseUserSetSubmissionGroup $ CourseUserSetSubmissionGroupData . assertM (not . Text.null . CI.original) + <$> aopt (textField & cfStrip & cfCI & addDatalist submissionGroupOpts) (fslI MsgSubmissionGroup & setTooltip MsgSubmissionGroupEmptyIsUnsetTip) Nothing + , guardOn mayRegister . singletonMap CourseUserDeregister $ courseUserDeregisterForm cid + , guardOn mayRegister . singletonMap CourseUserReRegister $ pure CourseUserReRegisterData ] numParticipants <- count [CourseParticipantCourse ==. cid, CourseParticipantState ==. CourseParticipantActive] table <- makeCourseUserTable cid acts (const E.true) colChoices psValidator (Just $ const True) @@ -606,10 +612,21 @@ postCUsersR tid ssh csh = do now <- liftIO getCurrentTime Entity _ CourseParticipant{..} <- MaybeT . fmap (assertM . has $ _entityVal . _courseParticipantState . _CourseParticipantActive) . getBy $ UniqueParticipant uid cid lift $ deregisterParticipant courseParticipantUser courseParticipantCourse - case deregisterReason of - Just reason - | is _Just courseParticipantAllocated -> - lift . insert_ $ AllocationDeregister uid (Just cid) now (Just reason) + case deregisterSelfImposed of + Just (reason, noShow) + | is _Just courseParticipantAllocated -> lift $ do + insert_ $ AllocationDeregister uid (Just cid) now (Just reason) + updateBy (UniqueParticipant uid cid) [ CourseParticipantState =. CourseParticipantInactive noShow ] + let recordNoShow eId = do + didRecord <- is _Just <$> insertUnique ExamResult + { examResultExam = eId + , examResultUser = uid + , examResultResult = ExamNoShow + , examResultLastChanged = now + } + when didRecord $ + audit $ TransactionExamResultEdit eId uid + when noShow . runConduit $ selectKeys [ ExamCourse ==. cid ] [] .| C.mapM_ recordNoShow _other -> return () return 1 addMessageI Success $ MsgCourseUsersDeregistered nrDel @@ -646,6 +663,24 @@ postCUsersR tid ssh csh = do Just _ -> addMessageI Success $ MsgCourseUsersSubmissionGroupSetNew nrSet redirect $ CourseR tid ssh csh CUsersR + (CourseUserReRegisterData, selectedUsers) -> do + now <- liftIO getCurrentTime + Sum nrSet <- runDB . flip foldMapM selectedUsers $ \uid -> maybeT (return mempty) $ do + didUpdate <- lift $ updateWhereCount + [ CourseParticipantUser ==. uid + , CourseParticipantCourse ==. cid + , CourseParticipantState !=. CourseParticipantActive + ] + [ CourseParticipantState =. CourseParticipantActive + , CourseParticipantRegistration =. now + , CourseParticipantAllocated =. Nothing + ] + guard $ didUpdate > 0 + lift $ deleteWhere [ AllocationDeregisterCourse ==. Just cid, AllocationDeregisterUser ==. uid ] + lift . audit $ TransactionCourseParticipantEdit cid uid + return $ Sum didUpdate + addMessageI Success $ MsgCourseUsersStateSet nrSet + redirect $ CourseR tid ssh csh CUsersR let headingLong = [whamlet|_{MsgMenuCourseMembers} #{courseName course} #{tid}|] headingShort = prependCourseTitle tid ssh csh MsgCourseMembers diff --git a/src/Handler/Exam/New.hs b/src/Handler/Exam/New.hs index ee30db715..5c9e2d2c3 100644 --- a/src/Handler/Exam/New.hs +++ b/src/Handler/Exam/New.hs @@ -12,6 +12,8 @@ import Handler.Utils import Handler.Utils.Invitations import Jobs.Queue + +import qualified Data.Conduit.Combinators as C getCExamNewR, postCExamNewR :: TermId -> SchoolId -> CourseShorthand -> Handler Html @@ -26,6 +28,8 @@ postCExamNewR tid ssh csh = do formResult newExamResult $ \ExamForm{..} -> do insertRes <- runDBJobs $ do + now <- liftIO getCurrentTime + insertRes <- insertUnique Exam { examName = efName , examCourse = cid @@ -75,6 +79,18 @@ postCExamNewR tid ssh csh = do , examCorrectorUser <- adds ] sinkInvitationsF examCorrectorInvitationConfig $ map (, examid, (InvDBDataExamCorrector, InvTokenDataExamCorrector)) invites + + let recordNoShow (Entity _ CourseParticipant{..}) = do + didRecord <- is _Just <$> insertUnique ExamResult + { examResultExam = examid + , examResultUser = courseParticipantUser + , examResultResult = ExamNoShow + , examResultLastChanged = now + } + when didRecord $ + audit $ TransactionExamResultEdit examid courseParticipantUser + runConduit $ selectSource [ CourseParticipantCourse ==. cid, CourseParticipantState ==. CourseParticipantInactive True ] [] .| C.mapM_ recordNoShow + return insertRes case insertRes of Nothing -> addMessageI Error $ MsgExamNameTaken efName diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs index f6d0f6ed7..1bdefbe09 100644 --- a/test/Database/Fill.hs +++ b/test/Database/Fill.hs @@ -552,11 +552,12 @@ fillDb = do , courseApplicationsText = False , courseApplicationsFiles = NoUpload , courseApplicationsRatingsVisible = False + , courseDeregisterNoShow = True } insert_ $ CourseEdit jost now ffp void . insert $ DegreeCourse ffp sdBsc sdInf void . insert $ DegreeCourse ffp sdMst sdInf - void . insert $ Lecturer jost ffp CourseLecturer + -- void . insert $ Lecturer jost ffp CourseLecturer void . insert $ Lecturer gkleen ffp CourseAssistant adhoc <- insert Sheet { sheetCourse = ffp @@ -614,9 +615,6 @@ fillDb = do ,(maxMuster , Just sfMMs) ,(tinaTester, Just sfTTc) ] - void . insertMany $ map (\(u,sf) -> CourseParticipant ffp u now sf Nothing $ CourseParticipantInactive False) - [(svaupel, Nothing) - ] examFFP <- insert' $ Exam { examCourse = ffp @@ -663,6 +661,7 @@ fillDb = do , courseApplicationsText = False , courseApplicationsFiles = NoUpload , courseApplicationsRatingsVisible = False + , courseDeregisterNoShow = False } insert_ $ CourseEdit fhamann now eip void . insert' $ DegreeCourse eip sdBsc sdInf @@ -686,6 +685,7 @@ fillDb = do , courseApplicationsText = False , courseApplicationsFiles = NoUpload , courseApplicationsRatingsVisible = False + , courseDeregisterNoShow = False } insert_ $ CourseEdit fhamann now ixd void . insert' $ DegreeCourse ixd sdBsc sdInf @@ -709,6 +709,7 @@ fillDb = do , courseApplicationsText = False , courseApplicationsFiles = NoUpload , courseApplicationsRatingsVisible = False + , courseDeregisterNoShow = False } insert_ $ CourseEdit fhamann now ux3 void . insert' $ DegreeCourse ux3 sdBsc sdInf @@ -732,6 +733,7 @@ fillDb = do , courseApplicationsText = False , courseApplicationsFiles = NoUpload , courseApplicationsRatingsVisible = False + , courseDeregisterNoShow = False } insert_ $ CourseEdit jost now pmo void . insert $ DegreeCourse pmo sdBsc sdInf @@ -899,6 +901,7 @@ fillDb = do , courseApplicationsText = False , courseApplicationsFiles = NoUpload , courseApplicationsRatingsVisible = False + , courseDeregisterNoShow = False } insert_ $ CourseEdit gkleen now dbs void . insert' $ DegreeCourse dbs sdBsc sdInf @@ -997,6 +1000,11 @@ fillDb = do insert_ $ AllocationCourse funAlloc pmo 100 insert_ $ AllocationCourse funAlloc ffp 2 + void . insertMany $ map (\(u, pState) -> CourseParticipant ffp u now Nothing (Just funAlloc) pState) + [ (svaupel, CourseParticipantInactive False) + , (jost, CourseParticipantActive) + ] + void $ insertFile "H10-2.hs" -- unreferenced -- -- betriebssysteme @@ -1018,6 +1026,7 @@ fillDb = do , courseApplicationsText = False , courseApplicationsFiles = NoUpload , courseApplicationsRatingsVisible = False + , courseDeregisterNoShow = False } insert_ $ CourseEdit gkleen now bs void . insert' $ Lecturer gkleen bs CourseLecturer @@ -1086,6 +1095,7 @@ fillDb = do , courseApplicationsText = False , courseApplicationsFiles = NoUpload , courseApplicationsRatingsVisible = False + , courseDeregisterNoShow = False } insert_ $ CourseEdit gkleen now cid -- void . insert' $ Lecturer gkleen cid CourseLecturer @@ -1140,6 +1150,7 @@ fillDb = do , courseApplicationsText = False , courseApplicationsFiles = NoUpload , courseApplicationsRatingsVisible = False + , courseDeregisterNoShow = False } insert_ $ CourseEdit gkleen now cid insert_ $ AllocationCourse bigAlloc cid minCap