feat(course-participants): course-deregister-no-show

Fixes #499

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
+CourseParticipantStateIsActiveFilter: Ansicht
+CourseUserReRegister: Wieder anmelden
+CourseParticipantActive: Teilnehmer
+CourseParticipantInactive: Abgemeldet
+CourseParticipantNoShow: Nicht erschienen
+CourseUserState: Zustand

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

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

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 Course -> Entity AllocationCourse -> AllocationCourseForm
-allocationCourseToForm (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

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
-
+            let recordNoShow eId = do
-        deregisterParticipant uid cid
+                  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

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

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
+        acts = mconcat $ catMaybes
-          [ singletonMap CourseUserSendMail $ pure CourseUserSendMailData
+          [ pure . singletonMap CourseUserSendMail $ pure CourseUserSendMailData
-          , singletonMap CourseUserRegisterTutorial $ CourseUserRegisterTutorialData <$>
+          , pure . singletonMap CourseUserRegisterTutorial $ CourseUserRegisterTutorialData
-            apopt (selectField' Nothing . fmap (fmap entityKey) $ optionsPersistCryptoId [TutorialCourse ==. cid] [Asc TutorialName] tutorialName)
+              <$> apopt (selectField' Nothing . fmap (fmap entityKey) $ optionsPersistCryptoId [TutorialCourse ==. cid] [Asc TutorialName] tutorialName)
-                  (fslI MsgCourseTutorial)
+                        (fslI MsgCourseTutorial)
-                  Nothing
+                        Nothing
-          , singletonMap CourseUserRegisterExam $ CourseUserRegisterExamData <$>
+          , pure . singletonMap CourseUserRegisterExam $ CourseUserRegisterExamData <$>
-            multiActionAOpts examOccActs examActs (fslI MsgCourseExam) Nothing
+              multiActionAOpts examOccActs examActs (fslI MsgCourseExam) Nothing
-          , singletonMap CourseUserSetSubmissionGroup $ CourseUserSetSubmissionGroupData . assertM (not . Text.null . CI.original) <$>
+          , pure . singletonMap CourseUserSetSubmissionGroup $ CourseUserSetSubmissionGroupData . assertM (not . Text.null . CI.original)
-            aopt (textField & cfStrip & cfCI & addDatalist submissionGroupOpts) (fslI MsgSubmissionGroup & setTooltip MsgSubmissionGroupEmptyIsUnsetTip) Nothing
+              <$> aopt (textField & cfStrip & cfCI & addDatalist submissionGroupOpts) (fslI MsgSubmissionGroup & setTooltip MsgSubmissionGroupEmptyIsUnsetTip) Nothing
-          , if
+          , guardOn mayRegister . singletonMap CourseUserDeregister $ courseUserDeregisterForm cid
-              | mayRegister
+          , guardOn mayRegister . singletonMap CourseUserReRegister $ pure CourseUserReRegisterData
-                -> singletonMap CourseUserDeregister $ courseUserDeregisterForm cid
-              | otherwise
-                -> mempty
           ]
     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
+          case deregisterSelfImposed of
-            Just reason
+            Just (reason, noShow)
-              | is _Just courseParticipantAllocated ->
+              | is _Just courseParticipantAllocated -> lift $ do
-                  lift . insert_ $ AllocationDeregister uid (Just cid) now (Just reason)
+                  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

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

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