feat(allocations): allocation-course-accept-substitutes

frontend/src/app.sass

@@ -782,7 +782,7 @@ section
 .allocation-course
   display: grid
   grid-template-columns: minmax(105px, 1fr) 9fr
-  grid-template-areas: 'name        name       ' '.           registered ' 'prio-label  prio       ' 'instr-label instr      ' 'form-label  form       '
+  grid-template-areas: 'name name' '. admin-info' '. registered' 'prio-label prio' 'instr-label instr' 'form-label form'
   grid-gap: 5px 7px
   margin: 12px 0
   padding: 0 10px 12px 7px
@@ -833,10 +833,14 @@ section
     text-align: right
     padding-top: 6px
 
+  .allocation-course__admin-info
+    @extend .explanation
+    grid-area: admin-info
+
 @media (max-width: 426px)
   .allocation-course
     grid-template-columns: 1fr
-    grid-template-areas: 'name       ' 'registered ' 'prio-label ' 'prio       ' 'instr-label' 'instr      ' 'form-label ' 'form       '
+    grid-template-areas: 'name' 'admin-info' 'registered' 'prio-label' 'prio' 'instr-label' 'instr' 'form-label' 'form'
 
   .allocation-course__application-label
     padding-top: 0

messages/uniworx/de-de-formal.msg

@@ -204,6 +204,8 @@ CourseAllocationOption term@Text name@Text: #{name} (#{term})
 CourseAllocationMinCapacity: Minimale Teilnehmeranzahl
 CourseAllocationMinCapacityTip: Wenn der Veranstaltung bei der Zentralanmeldung weniger als diese Anzahl von Teilnehmern zugeteilt würden, werden diese stattdessen auf andere Kurse umverteilt
 CourseAllocationMinCapacityMustBeNonNegative: Minimale Teilnehmeranzahl darf nicht negativ sein
+CourseAllocationCourseAcceptsSubstitutesUntil: Akzeptiert Nachrücker bis
+CourseAllocationCourseAcceptsSubstitutesNever: Akzeptiert keine Nachrücker
 CourseApplicationInstructions: Anweisungen zur Bewerbung/Anmeldung
 CourseApplicationInstructionsTip: Wird den Studierenden angezeigt, wenn diese sich für Ihre Veranstaltung bewerben bzw. bei dieser anmelden
 CourseApplicationTemplate: Bewerbungsvorlagen
@@ -2263,6 +2265,8 @@ AllocationNotificationNewCourseSuccessForceOff: Sie werden nicht benachrichtigt,
 AllocationNotificationNewCourseCurrentlyOff: Aktuell würden Sie keine Benachrichtigung erhalten.
 AllocationNotificationNewCourseCurrentlyOn: Aktuell würden Sie benachrichtigt werden.
 AllocationNotificationLoginFirst: Um Ihre Benachrichtigungseinstellungen zu ändern, loggen Sie sich bitte zunächst ein.
+AllocationNextSubstitutesDeadline: Nächster Kurs akzeptiert Nachrücker bis
+AllocationNextSubstitutesDeadlineNever: Keine Kurse akzeptieren mehr Nachrücker
 
 AllocationSchoolShort: Institut
 Allocation: Zentralanmeldung
@@ -2502,6 +2506,8 @@ 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.
+CourseAcceptSubstitutesUntil: Nachrücker akzeptieren bis
+CourseAcceptSubstitutesUntilTip: Bis zu welchem Zeitpunkt sollen durch die Zentralanmeldung Nachrücker diesem Kurs zugewiesen werden? Wird kein Datum angegeben werden nach der Initialen Verteilung nie Nachrücker zugewiesen. Diese Frist sollte nicht willkürlich früh bzw. nicht gesetzt werden, um für die Studierenden keine unnötige Beschränkung darzustellen. Geeignet ist z.B. bei einem Seminar wenige Stunden vor dem ersten Treffen zum Verteilen der Themen.
 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
@@ -2513,6 +2519,7 @@ AllocationResultsLecturer: Im Rahmen der oben genannten Zentralanmeldung wurden
 AllocationResultLecturer csh@CourseShorthand count@Int64 count2@Int64: #{count} Teilnehmer (von insgesamt #{count2}) für #{csh}
 AllocationResultLecturerAll csh@CourseShorthand count@Int64: #{count} Teilnehmer für #{csh}
 AllocationResultLecturerNone csh@CourseShorthand: Keine Teilnehmer für #{csh}
+AllocationResultsLecturerSubstituteCoursesWarning: Bitte konfigurieren Sie so bald wie möglich einen Zeitrahmen in dem Sie bereit sind etwaige Nachrücker in den folgenden Kursen zu akzeptieren:
 AllocationResultsStudent: Sie haben Plätze erhalten in:
 AllocationNoResultsStudent: Sie haben leider keine Plätze erhalten.
 AllocationResultStudent csh@CourseShorthand: Sie haben einen Platz in #{csh} erhalten.
@@ -2752,6 +2759,9 @@ AllocationUsersMissingPrioritiesTip: Es muss sichergestellt sein, dass keine Tei
 AllocationUsersMissingPrioritiesOk: Es wurde sichergestellt, dass es für jeden der genannten Benutzer einen zulässigen Grund gibt, warum dieser nicht an der Zentralanmeldung teilnehmen sollte.
 AllocationRestrictCourses: Kurse einschränken
 AllocationRestrictCoursesTip: Sollen nur Plätze für eine Teilmenge von Kursen zugewiesen werden? So können u.A. Nachrücker verteilt werden. Diese Funktionalität sollte nur verwendet werden, wenn manche Kurse aus zulässigen Gründen ausgeschlossen werden müssen; z.B. weil ein Seminar bereits ein Treffen zur Organisation hatte und nun keine weiteren Teilnehmer mehr akzeptieren kann.
+AllocationCourseRestrictionNone: Nicht einschränken
+AllocationCourseRestrictionSubstitutes: Kurse, die aktuell Nachrücker azkeptieren
+AllocationCourseRestrictionCustom: Benutzerdefiniert
 AllocationRestrictCoursesSelection: Kurse
 AllocationRestrictCoursesSelectionTip: Teilnehmer werden nur auf die Kurse verteilt, die hier angegeben werden.
 AllocationUsersMissingPrioritiesNotOk: Zentralvergabe kann nicht erfolgen, solange nicht allen Teilnehmern, die nicht explizit von der Vergabe ausgeschlossen wurden („Teilnehmer ohne zentrale Dringlichkeit”), eine zentrale Dringlichkeit zugewiesen wurde! 
@@ -2769,6 +2779,7 @@ AllocationOfferedPlaces: Angebotene Plätze
 AllocationUserNewMatches: Neue Zuteilungen
 AllocationUsersCount: Teilnehmer
 AllocationCoursesCount: Kurse
+AllocationCourseEligible: Berücksichtigt
 
 CourseOption tid@TermId ssh@SchoolId coursen@CourseName: #{tid} - #{ssh} - #{coursen}
 

messages/uniworx/en-eu.msg

@@ -204,6 +204,8 @@ CourseAllocationOption term name: #{name} (#{term})
 CourseAllocationMinCapacity: Minimum number of participants
 CourseAllocationMinCapacityTip: If fewer students than this number were to be assigned to this course, then these students would instead be assigned to other courses
 CourseAllocationMinCapacityMustBeNonNegative: Minimum number of participants must not be negative
+CourseAllocationCourseAcceptsSubstitutesUntil: Accepts substitutes until
+CourseAllocationCourseAcceptsSubstitutesNever: Does not accept substitutes
 CourseApplicationInstructions: Instructions for application
 CourseApplicationInstructionsTip: Will be shown to students if they decide to apply for this course
 CourseApplicationTemplate: Application template
@@ -2262,6 +2264,8 @@ AllocationNotificationNewCourseSuccessForceOff: You will not be notified if a ne
 AllocationNotificationNewCourseCurrentlyOff: Currently you would not receive a notification.
 AllocationNotificationNewCourseCurrentlyOn: Currently you would be notified.
 AllocationNotificationLoginFirst: To change your notification settings, please log in first.
+AllocationNextSubstitutesDeadline: Next course accepts substitutes until
+AllocationNextSubstitutesDeadlineNever: No course currently accepts substitutes
 
 AllocationSchoolShort: Department
 Allocation: Central allocation
@@ -2502,6 +2506,8 @@ CourseDeregistrationAllocationReason: Reason
 CourseDeregistrationAllocationReasonTip: The specified reason will be permanently stored and might be the only information available during conflict resolution
 CourseDeregistrationAllocationNoShow: Record as “no show”
 CourseDeregistrationAllocationNoShowTip: Should, for all exams associated with this course, “no show” be recorded as the exam achievement automatically? This would be done once immediately (if no other achievement exists for the given exam) and automatically whenever a new exam is created.
+CourseAcceptSubstitutesUntil: Accept substitute registrations until
+CourseAcceptSubstitutesUntilTip: Until which time should substitute registrations through the central allocation be accepted to fill free places in the course? If left empty no substitute registrations will be made. This deadline should not arbitrarily be set early or ommitted so as to not be an unneccesarily restrictive for students. For a seminar a valid choice might be a few hours before the first meeting in which topics will be assigned.
 CourseDeregisterNoShow: Record “no show” when deregistering
 CourseDeregisterNoShowTip: Should “no show” be recorded as the exam achievement for all exams associated with this course automatically whenever a course participant deregisters themselves? This would be done once upon deregistration (if no other achievement exists for the given exam) and automatically whenever a new exam is created.
 CourseDeregistrationAllocationShouldLog: Self imposed
@@ -2513,6 +2519,7 @@ AllocationResultsLecturer: In the course of the central allocations placements h
 AllocationResultLecturer csh count count2: #{count} #{pluralEN count "participant" "participants"} (of #{count2}) for #{csh}
 AllocationResultLecturerAll csh count: #{count} #{pluralEN count "participant" "participants"} for #{csh}
 AllocationResultLecturerNone csh: No participants for #{csh}
+AllocationResultsLecturerSubstituteCoursesWarning: Please configure a deadline up to which you are able to accept substitute registrations for the following courses as soon as possible:
 AllocationResultsStudent: You have been placed in:
 AllocationNoResultsStudent: Unfortunately you were not placed in any courses.
 AllocationResultStudent csh: You were placed in #{csh}.
@@ -2752,6 +2759,9 @@ AllocationUsersMissingPrioritiesTip: Care must be taken, that no participant is
 AllocationUsersMissingPrioritiesOk: It was ensured, that all participants mentioned above, are excluded from the allocation on valid grounds.
 AllocationRestrictCourses: Restrict courses
 AllocationRestrictCoursesTip: Should places be assigned only in a subset of courses? This functionality can be used to make alternate placements in the case that some participants withdraw from their assigned courses. This functionality should only be used to exclude courses on valid grounds. E.g. if a seminar already had a planning meeting and is thus unable to accept new participants.
+AllocationCourseRestrictionNone: Don't restrict
+AllocationCourseRestrictionSubstitutes: Courses which currently allow substitute registrations
+AllocationCourseRestrictionCustom: Custom
 AllocationRestrictCoursesSelection: Courses
 AllocationRestrictCoursesSelectionTip: Participants will only be assigned to courses listed here.
 AllocationUsersMissingPrioritiesNotOk: Central allocation cannot occur until all participants, that were not excluded explicitly (“Participants without central priority”), have been assigned a central priority!
@@ -2769,6 +2779,7 @@ AllocationOfferedPlaces: Offered places
 AllocationUserNewMatches: New allocations
 AllocationUsersCount: Participants
 AllocationCoursesCount: Courses
+AllocationCourseEligible: Considered
 
 CourseOption tid ssh coursen: #{tid} - #{ssh} - #{coursen}
 

models/allocations.model

@@ -36,6 +36,7 @@ AllocationCourse
     allocation          AllocationId
     course              CourseId
     minCapacity         Int          -- if the course would get assigned fewer than this many applicants, restart the assignment process without the course
+    acceptSubstitutes   UTCTime Maybe
     UniqueAllocationCourse course
 
 AllocationUser

src/Handler/Allocation/Accept.hs

@@ -11,6 +11,7 @@ import Handler.Utils.Allocation
 
 import Data.Map ((!?))
 import qualified Data.Map as Map
+import qualified Data.Set as Set
 
 import qualified Database.Esqueleto as E
 import qualified Control.Monad.State.Class as State
@@ -25,12 +26,13 @@ newtype SessionDataAllocationResults = SessionDataAllocationResults
                                            )
                                            ( UTCTime
                                            , AllocationFingerprint
+                                           , Set CourseId
                                            , Set (UserId, CourseId)
                                            , Seq MatchingLogRun
                                            )
   } deriving (Eq, Ord, Read, Show, Generic, Typeable)
     deriving newtype (ToJSON, FromJSON)
-    deriving (Monoid, Semigroup) via Dual (Map (TermId, SchoolId, AllocationShorthand) (UTCTime, AllocationFingerprint, Set (UserId, CourseId), Seq MatchingLogRun))
+    deriving (Monoid, Semigroup) via Dual (Map (TermId, SchoolId, AllocationShorthand) (UTCTime, AllocationFingerprint, Set CourseId, Set (UserId, CourseId), Seq MatchingLogRun))
 
 makeWrapped ''SessionDataAllocationResults
 
@@ -47,11 +49,11 @@ instance Button UniWorX AllocationAcceptButton where
   btnClasses BtnAllocationAccept = [BCIsButton, BCPrimary]
 
 
-allocationAcceptForm :: AllocationId -> DB (Maybe (Form (UTCTime, AllocationFingerprint, Set (UserId, CourseId), Seq MatchingLogRun)))
+allocationAcceptForm :: AllocationId -> DB (Maybe (Form (UTCTime, AllocationFingerprint, Set CourseId, Set (UserId, CourseId), Seq MatchingLogRun)))
 allocationAcceptForm aId = runMaybeT $ do
   Allocation{..} <- MaybeT $ get aId
   SessionDataAllocationResults allocMap <- MaybeT $ lookupSessionJson SessionAllocationResults
-  allocRes@(allocTime, allocFp, allocMatching, _ :|> MatchingLogRun{..}) <- hoistMaybe $ allocMap !? (allocationTerm, allocationSchool, allocationShorthand)
+  allocRes@(allocTime, allocFp, eligibleCourses, allocMatching, _ :|> MatchingLogRun{..}) <- hoistMaybe $ allocMap !? (allocationTerm, allocationSchool, allocationShorthand)
 
   allocationUsers <- fmap (map $ bimap E.unValue E.unValue) . lift . E.select . E.from $ \allocationUser -> do
     E.where_ $ allocationUser E.^. AllocationUserAllocation E.==. E.val aId
@@ -85,6 +87,7 @@ allocationAcceptForm aId = runMaybeT $ do
                E.&&. courseParticipant E.^. CourseParticipantState E.==. E.val CourseParticipantActive
     return (allocationCourse, course, participants)
   let allocationCapacity = sumOf (folded . _2 . _entityVal . _courseCapacity . _Just) allocationCourses
+      allocCourses = setOf (folded . _1 . _entityVal . _allocationCourseCourse) allocationCourses
 
   let courseAllocations = ofoldr (\(_uid, cid) -> Map.insertWith (+) cid 1) Map.empty allocMatching
   allocationCourses' <- hoistMaybe $
@@ -137,9 +140,9 @@ postAAcceptR tid ssh ash = do
 
     formRes@((acceptRes, _), _) <- liftHandler $ runFormPost acceptForm
 
-    didStore <- formResultMaybe acceptRes $ \(now, allocFp, allocMatchings, allocLog) -> do
+    didStore <- formResultMaybe acceptRes $ \(now, allocFp, _, allocMatchings, allocLog) -> do
       modifySessionJson SessionAllocationResults . fmap (assertM $ not . views _Wrapped onull) . over (mapped . _Wrapped :: Setter' (Maybe SessionDataAllocationResults) _) $
-        Map.filterWithKey (\(tid', ssh', ash') (_, allocFp', _, _) ->
+        Map.filterWithKey (\(tid', ssh', ash') (_, allocFp', _, _, _) ->
                              or [ tid' /= tid
                                 , ssh' /= ssh
                                 , ash' /= ash

src/Handler/Allocation/AddUser.hs

@@ -33,6 +33,7 @@ postAAddUserR tid ssh ash = do
       return ( course
              , E.exists . E.from $ \courseAppInstructionFile ->
                  E.where_ $ courseAppInstructionFile E.^. CourseAppInstructionFileCourse E.==. course E.^. CourseId
+             , allocationCourse
              )
 
     MsgRenderer mr <- getMsgRenderer
@@ -40,7 +41,7 @@ postAAddUserR tid ssh ash = do
       <$> areq (checkMap (first $ const MsgAllocationAddUserUserNotFound) Right $ userField False Nothing) (fslpI MsgAllocationAddUserUser (mr MsgAllocationAddUserUserPlaceholder)) Nothing
       <*> areq (posIntFieldI MsgAllocationAddUserTotalCoursesLessThanOne) (fslI MsgAllocationAddUserTotalCourses) (Just 1)
       <*> optionalActionA (allocationPriorityForm (fslI MsgAllocationAddUserPriority) Nothing) (fslI MsgAllocationAddUserSetPriority) (Just True)
-      <*> allocationApplicationsForm aId (Map.fromList [ (cId, (course, hasTemplate)) | (Entity cId course, E.Value hasTemplate) <- allocCourses ]) (fslI MsgAllocationAddUserApplications) False
+      <*> allocationApplicationsForm aId (Map.fromList [ (cId, (course, allocationCourse, hasTemplate)) | (Entity cId course, E.Value hasTemplate, Entity _ allocationCourse) <- allocCourses ]) (fslI MsgAllocationAddUserApplications) False
 
     addUserAct <- formResultMaybe addUserRes $ \AllocationAddUserForm{..} -> Just <$> do
       now <- liftIO getCurrentTime
@@ -103,16 +104,18 @@ postAAddUserR tid ssh ash = do
       }
 
 allocationApplicationsForm :: AllocationId
-                           -> Map CourseId (Course, Bool)
+                           -> Map CourseId (Course, AllocationCourse, Bool)
                            -> FieldSettings UniWorX
                            -> Bool
                            -> AForm Handler (Map CourseId ApplicationForm)
 allocationApplicationsForm aId courses FieldSettings{..} fvRequired = formToAForm $ do
+  now <- liftIO getCurrentTime
+  
   let afmApplicant = True
       afmApplicantEdit = True
       afmLecturer = True
 
-  appsRes' <- iforM courses $ \cId (course, hasApplicationTemplate) -> over _2 (course, hasApplicationTemplate, ) <$> applicationForm (Just aId) cId Nothing ApplicationFormMode{..} Nothing
+  appsRes' <- iforM courses $ \cId (course, allocCourse, hasApplicationTemplate) -> over _2 (course, allocCourse, hasApplicationTemplate, ) <$> applicationForm (Just aId) cId Nothing ApplicationFormMode{..} Nothing
   let appsRes = sequenceA $ view _1 <$> appsRes'
       appsViews = view _2 <$> appsRes'
   
@@ -120,7 +123,7 @@ allocationApplicationsForm aId courses FieldSettings{..} fvRequired = formToAFor
         [whamlet|
           $newline never
           <div .allocation__courses>
-            $forall (Course{courseTerm, courseSchool, courseShorthand, courseName, courseApplicationsInstructions}, hasApplicationTemplate, ApplicationFormView{afvPriority, afvForm}) <- Map.elems appsViews
+            $forall (Course{courseTerm, courseSchool, courseShorthand, courseName, courseApplicationsInstructions}, AllocationCourse{allocationCourseAcceptSubstitutes}, hasApplicationTemplate, ApplicationFormView{afvPriority, afvForm}) <- Map.elems appsViews
               <div .allocation-course>
                 <div .allocation-course__priority-label .allocation__label>
                   _{MsgAllocationPriority}
@@ -129,6 +132,15 @@ allocationApplicationsForm aId courses FieldSettings{..} fvRequired = formToAFor
                     ^{fvWidget prioView}
                 <a .allocation-course__name href=@{CourseR courseTerm courseSchool courseShorthand CShowR} target="_blank">
                   #{courseName}
+                <div .allocation-course__admin-info>
+                  <p>
+                    $maybe deadline <- allocationCourseAcceptSubstitutes
+                      _{MsgCourseAllocationCourseAcceptsSubstitutesUntil}: #
+                      ^{formatTimeW SelFormatDateTime deadline}
+                    $nothing
+                      _{MsgCourseAllocationCourseAcceptsSubstitutesNever}
+                    $if allocationCourseAcceptSubstitutes >= Just now
+                      \ ^{iconOK}
                 $if hasApplicationTemplate || is _Just courseApplicationsInstructions
                   <div .allocation-course__instructions-label .allocation__label>
                     _{MsgCourseApplicationInstructionsApplication}

src/Handler/Allocation/Compute.hs

@@ -13,6 +13,7 @@ import qualified Data.Set as Set
 import qualified Data.Map as Map
 
 import qualified Database.Esqueleto as E
+import qualified Database.Esqueleto.Utils as E
 
 import qualified Control.Monad.State.Class as State
 
@@ -70,10 +71,28 @@ missingPriorities aId = wFormToAForm $ do
       -> fmap (bool Set.empty $ Map.keysSet usersWithoutPrio) <$> wpreq missingPriosField (fslI MsgAllocationUsersMissingPriorities & setTooltip MsgAllocationUsersMissingPrioritiesTip) (Just False)
 
 
+data AllocationCourseRestrictionMode
+  = AllocationCourseRestrictionNone
+  | AllocationCourseRestrictionSubstitutes
+  | AllocationCourseRestrictionCustom
+  deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
+  deriving anyclass (Universe, Finite)
+nullaryPathPiece ''AllocationCourseRestrictionMode $ camelToPathPiece' 3
+embedRenderMessage ''UniWorX ''AllocationCourseRestrictionMode id
+  
 restrictCourses :: (MonadHandler m, HandlerSite m ~ UniWorX) => AllocationId -> AForm m (Maybe (Set CourseId))
-restrictCourses aId = hoistAForm liftHandler $
+restrictCourses aId = hoistAForm liftHandler $ multiActionA restrictOpts (fslI MsgAllocationRestrictCourses & setTooltip MsgAllocationRestrictCoursesTip) (Just AllocationCourseRestrictionNone)
-  optionalActionA selectCourses (fslI MsgAllocationRestrictCourses & setTooltip MsgAllocationRestrictCoursesTip) (Just False)
   where
+    restrictOpts = mapF $ \case
+      AllocationCourseRestrictionNone -> pure Nothing
+      AllocationCourseRestrictionSubstitutes -> wFormToAForm $ do
+        now <- liftIO getCurrentTime
+        allocCourses <- fmap (setOf $ folded . _Value) . liftHandler . runDB . E.select . E.from $ \allocationCourse -> do
+          E.where_ $ allocationCourse E.^. AllocationCourseAllocation E.==. E.val aId
+          E.where_ . E.maybe E.false (E.>=. E.val now) $ allocationCourse E.^. AllocationCourseAcceptSubstitutes
+          return $ allocationCourse E.^. AllocationCourseCourse
+        return . pure $ Just allocCourses
+      AllocationCourseRestrictionCustom -> Just <$> selectCourses
     selectCourses = courseSelectForm query coursePred miButtonAction' miIdent' fSettings fRequired mPrev
       where
         query = E.from $ \(course `E.InnerJoin` allocationCourse) -> do
@@ -115,9 +134,9 @@ postAComputeR tid ssh ash = do
 
     formResult computeFormRes $ \AllocationComputeForm{..} -> do
       now <- liftIO getCurrentTime
-      (allocFp, allocMatching, allocLog) <- computeAllocation aEnt acfRestrictCourses
+      (allocFp, eligibleCourses, allocMatching, allocLog) <- computeAllocation aEnt acfRestrictCourses
       tellSessionJson SessionAllocationResults . SessionDataAllocationResults $
-        Map.singleton (tid, ssh, ash) (now, allocFp, allocMatching, allocLog)
+        Map.singleton (tid, ssh, ash) (now, allocFp, eligibleCourses, allocMatching, allocLog)
       addMessageI Success MsgAllocationComputed
       redirect $ AllocationR tid ssh ash AUsersR -- Redirect aborts transaction for safety
 

src/Handler/Allocation/Show.hs

@@ -49,18 +49,20 @@ postAShowR tid ssh ash = do
   ata  <- getSessionActiveAuthTags
 
   let
-    resultCourse :: Simple Field1 a (Entity Course) => Lens' a (Entity Course)
+    resultCourse :: _ => Lens' a (Entity Course)
     resultCourse = _1
-    resultCourseApplication :: Simple Field2 a (Maybe (Entity CourseApplication)) => Traversal' a (Entity CourseApplication)
+    resultCourseApplication :: _ => Traversal' a (Entity CourseApplication)
     resultCourseApplication = _2 . _Just
-    resultHasTemplate :: Simple Field3 a (E.Value Bool) => Lens' a Bool
+    resultHasTemplate :: _ => Lens' a Bool
     resultHasTemplate = _3 . _Value
-    resultIsRegistered :: Simple Field4 a (E.Value Bool) => Lens' a Bool
+    resultIsRegistered :: _ => Lens' a Bool
     resultIsRegistered = _4 . _Value
-    resultCourseVisible :: Simple Field5 a (E.Value Bool) => Lens' a Bool
+    resultCourseVisible :: _ => Lens' a Bool
     resultCourseVisible = _5 . _Value
+    resultAllocationCourse :: _ => Lens' a AllocationCourse
+    resultAllocationCourse = _6 . _entityVal
 
-  (Entity aId Allocation{..}, School{..}, isAnyLecturer, courses, registration, wouldNotifyNewCourse) <- runDB $ do
+  (Entity aId Allocation{..}, School{..}, isAnyLecturer, isAdmin, courses, registration, wouldNotifyNewCourse) <- runDB $ do
     alloc@(Entity aId Allocation{allocationSchool}) <- getBy404 $ TermSchoolAllocationShort tid ssh ash
     school <- getJust allocationSchool
 
@@ -79,15 +81,24 @@ postAShowR tid ssh ash = do
       E.orderBy [E.asc $ course E.^. CourseName]
       let hasTemplate = E.exists . E.from $ \courseAppInstructionFile ->
             E.where_ $ courseAppInstructionFile E.^. CourseAppInstructionFileCourse E.==. course E.^. CourseId
-      return (course, courseApplication, hasTemplate, E.not_ . E.isNothing $ registration E.?. CourseParticipantId, courseIsVisible now course (Just (E.val aId)))
+      return ( course
+             , courseApplication
+             , hasTemplate
+             , E.not_ . E.isNothing $ registration E.?. CourseParticipantId
+             , courseIsVisible now course . Just $ E.val aId
+             , allocationCourse
+             )
 
     registration <- fmap join . for muid $ getBy . UniqueAllocationUser aId
 
     isAnyLecturer <- hasWriteAccessTo CourseNewR
+    isAdmin <- hasReadAccessTo $ AllocationR tid ssh ash AUsersR
 
     wouldNotifyNewCourse <- fmap (maybe False E.unValue . join) . for muid $ E.selectMaybe . pure . allocationNotifyNewCourses (E.val aId) . E.val
 
-    return (alloc, school, isAnyLecturer, nubOn (view $ resultCourse . _entityKey) courses, registration, wouldNotifyNewCourse)
+    return (alloc, school, isAnyLecturer, isAdmin, nubOn (view $ resultCourse . _entityKey) courses, registration, wouldNotifyNewCourse)
+
+  let nextSubstitutesDeadline = minimumOf (folded . resultAllocationCourse . _allocationCourseAcceptSubstitutes . _Just . filtered (>= now)) courses
 
   MsgRenderer mr <- getMsgRenderer
   let title = MsgAllocationTitle (mr . ShortTermIdentifier $ unTermKey allocationTerm) (unSchoolKey allocationSchool) allocationName
@@ -146,6 +157,7 @@ postAShowR tid ssh ash = do
               mApp                   = cEntry ^? resultCourseApplication
               isRegistered           = cEntry ^. resultIsRegistered
               courseVisible          = cEntry ^. resultCourseVisible
+              AllocationCourse{..}   = cEntry ^. resultAllocationCourse
           cID <- encrypt cid :: WidgetFor UniWorX CryptoUUIDCourse
           mayApply <- hasWriteAccessTo . AllocationR tid ssh ash $ AApplyR cID
           mayEdit <- hasWriteAccessTo $ CourseR tid ssh courseShorthand CEditR

src/Handler/Allocation/Users.hs

@@ -162,7 +162,7 @@ postAUsersR tid ssh ash = do
     resultsDone <- is _Just <$> allocationStarted aId
     allocMatching <- runMaybeT $ do
       SessionDataAllocationResults allocMap <- MaybeT $ lookupSessionJson SessionAllocationResults
-      allocMatching <- fmap (view _3) . hoistMaybe $ allocMap !? (tid, ssh, ash)
+      allocMatching <- fmap (view _4) . hoistMaybe $ allocMap !? (tid, ssh, ash)
       return $ Map.fromListWith (<>) [ (uid, opoint cid) | (uid, cid) <- Set.toList allocMatching ] :: _ (Map UserId (NonNull (Set CourseId)))
 
     csvName <- getMessageRender <*> pure (MsgAllocationUsersCsvName tid ssh ash)

src/Handler/Course/Edit.hs

@@ -57,6 +57,7 @@ data CourseForm = CourseForm
 data AllocationCourseForm = AllocationCourseForm
   { acfAllocation                :: AllocationId
   , acfMinCapacity               :: Int
+  , acfAcceptSubstitutes         :: Maybe UTCTime
   , acfDeregisterNoShow          :: Bool
   }
 
@@ -98,6 +99,7 @@ allocationCourseToForm :: Entity Course -> Entity AllocationCourse -> Allocation
 allocationCourseToForm (Entity _ Course{..}) (Entity _ AllocationCourse{..}) = AllocationCourseForm
   { acfAllocation = allocationCourseAllocation
   , acfMinCapacity = allocationCourseMinCapacity
+  , acfAcceptSubstitutes = allocationCourseAcceptSubstitutes
   , acfDeregisterNoShow = courseDeregisterNoShow
   }
 
@@ -265,6 +267,7 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse . validateFormDB
                  in AllocationCourseForm
                     <$> ainp allocField (fslI MsgCourseAllocation) (fmap acfAllocation $ template >>= cfAllocation)
                     <*> ainp (natFieldI MsgCourseAllocationMinCapacityMustBeNonNegative) (fslI MsgCourseAllocationMinCapacity & setTooltip MsgCourseAllocationMinCapacityTip) (fmap acfMinCapacity $ template >>= cfAllocation)
+                    <*> aopt utcTimeField (fslI MsgCourseAcceptSubstitutesUntil & setTooltip MsgCourseAcceptSubstitutesUntilTip) (fmap acfAcceptSubstitutes $ 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)
@@ -592,13 +595,15 @@ upsertAllocationCourse cid cfAllocation = do
     case cfAllocation of
       Just AllocationCourseForm{..} -> do
         void $ upsert AllocationCourse
-          { allocationCourseAllocation  =  acfAllocation
+          { allocationCourseAllocation        =  acfAllocation
-          , allocationCourseCourse      =  cid
+          , allocationCourseCourse            =  cid
-          , allocationCourseMinCapacity =  acfMinCapacity
+          , allocationCourseMinCapacity       =  acfMinCapacity
+          , allocationCourseAcceptSubstitutes =  acfAcceptSubstitutes
           }
-          [ AllocationCourseAllocation  =. acfAllocation
+          [ AllocationCourseAllocation        =. acfAllocation
-          , AllocationCourseCourse      =. cid
+          , AllocationCourseCourse            =. cid
-          , AllocationCourseMinCapacity =. acfMinCapacity
+          , AllocationCourseMinCapacity       =. acfMinCapacity
+          , AllocationCourseAcceptSubstitutes =. acfAcceptSubstitutes
           ]
 
         when (Just acfAllocation /= fmap entityKey prevAllocation) $

src/Handler/Utils/Allocation.hs

@@ -107,6 +107,7 @@ sinkAllocationPriorities allocId = fmap getSum . C.foldMapM . ifoldMapM $ \matr
 computeAllocation :: Entity Allocation
                   -> Maybe (Set CourseId) -- ^ Optionally restrict allocation to only consider the given courses
                   -> DB ( AllocationFingerprint
+                        , Set CourseId
                         , Set (UserId, CourseId)
                         , Seq MatchingLogRun
                         )
@@ -162,6 +163,7 @@ computeAllocation (Entity allocId Allocation{allocationMatchingSeed}) cRestr = d
            , allocationCourse E.^. AllocationCourseMinCapacity E.-. participants
            )
   let capacities = Map.filter (maybe True (> 0)) . Map.fromList $ (view (_1 . _entityVal . _allocationCourseCourse) &&& view (_2 . _Value)) <$> courses'
+      eligibleCourses = setOf (folded . _1 . _entityVal . _allocationCourseCourse) courses'
 
   applications' <- selectList [ CourseApplicationAllocation ==. Just allocId ] []
   excludedMatchings <- flip execStateT mempty . forM_ applications' $ \(Entity _ CourseApplication{..}) -> do
@@ -254,7 +256,7 @@ computeAllocation (Entity allocId Allocation{allocationMatchingSeed}) cRestr = d
         | not $ null belowMin -> allocationLoop $ cs <> Set.fromList belowMin
         | otherwise           -> return allocs
 
-  return . (\(ms, mLog) -> (fingerprint, ms, mLog)) $!! runWriter (allocationLoop Set.empty)
+  return . (\(ms, mLog) -> (fingerprint, eligibleCourses, ms, mLog)) $!! runWriter (allocationLoop Set.empty)
 
 
 doAllocation :: AllocationId

src/Jobs/Handler/SendNotification/Allocation.hs

@@ -138,16 +138,14 @@ dispatchNotificationAllocationUnratedApplications (otoList -> nAllocations) jRec
 
 dispatchNotificationAllocationResults :: AllocationId -> UserId -> Handler ()
 dispatchNotificationAllocationResults nAllocation jRecipient = userMailT jRecipient $ do
-  (Allocation{..}, lecturerResults, participantResults) <- liftHandler . runDB $ do
+  (Allocation{..}, lecturerResults, warnSubstituteCourses, participantResults) <- liftHandler . runDB $ do
     allocation <- getJust nAllocation
 
-    lecturerResults' <- E.select . E.from $ \(lecturer `E.InnerJoin` course) -> do
+    lecturerResults' <- E.select . E.from $ \(lecturer `E.InnerJoin` course `E.InnerJoin` allocationCourse) -> do
+      E.on $ allocationCourse E.^. AllocationCourseCourse E.==. course E.^. CourseId
       E.on $ lecturer E.^. LecturerCourse E.==. course E.^. CourseId
       E.where_ $ lecturer E.^. LecturerUser E.==. E.val jRecipient
-           E.&&. E.exists (E.from $ \allocationCourse ->
+           E.&&. allocationCourse E.^. AllocationCourseAllocation E.==. E.val nAllocation
-                              E.where_ $ allocationCourse E.^. AllocationCourseCourse E.==. course E.^. CourseId
-                                   E.&&. allocationCourse E.^. AllocationCourseAllocation E.==. E.val nAllocation
-                          )
       let allocatedCount :: E.SqlExpr (E.Value Int64)
           allocatedCount = E.subSelectCount . E.from $ \participant ->
             E.where_ $ participant E.^. CourseParticipantCourse E.==. lecturer E.^. LecturerCourse
@@ -157,11 +155,12 @@ dispatchNotificationAllocationResults nAllocation jRecipient = userMailT jRecipi
           participantCount = E.subSelectCount . E.from $ \participant ->
             E.where_ $ participant E.^. CourseParticipantCourse E.==. lecturer E.^. LecturerCourse
                  E.&&. participant E.^. CourseParticipantState E.==. E.val CourseParticipantActive
-      return (course, allocatedCount, participantCount)
+      return (course, allocationCourse, allocatedCount, participantCount)
-    let lecturerResults = flip map lecturerResults' $ \(Entity _ Course{..}, E.Value allocCount, E.Value partCount) -> SomeMessage $ if
+    let lecturerResults = flip map lecturerResults' $ \(Entity _ Course{..}, _, E.Value allocCount, E.Value partCount) -> SomeMessage $ if
           | allocCount == partCount -> MsgAllocationResultLecturerAll courseShorthand allocCount
           | allocCount == 0 -> MsgAllocationResultLecturerNone courseShorthand
           | otherwise -> MsgAllocationResultLecturer courseShorthand allocCount partCount
+        warnSubstituteCourses = flip mapMaybe lecturerResults' $ \(Entity _ course, Entity _ AllocationCourse{..}, _, _) -> guardOn (isn't _Just allocationCourseAcceptSubstitutes) course
 
     doParticipantResults <- E.selectExists . E.from $ \application ->
       E.where_ $ application E.^. CourseApplicationAllocation E.==. E.just (E.val nAllocation)
@@ -177,7 +176,7 @@ dispatchNotificationAllocationResults nAllocation jRecipient = userMailT jRecipi
              | otherwise            -> Nothing
           cs -> Just $ map (courseShorthand . entityVal) cs
 
-    return (allocation, lecturerResults, participantResults)
+    return (allocation, lecturerResults, warnSubstituteCourses, participantResults)
 
   replaceMailHeader "Auto-Submitted" $ Just "auto-generated"
   setSubjectI $ MsgMailSubjectAllocationResults allocationName

templates/allocation/accept.hamlet

@@ -47,6 +47,9 @@ $newline never
             _{MsgSchool}
         <th .table__th>
           _{MsgCourse}
+        $if eligibleCourses /= allocCourses
+          <th .table__th>
+            _{MsgAllocationCourseEligible}
         <th .table__th>
           _{MsgCourseCapacity}
         <th .table__th>
@@ -72,6 +75,9 @@ $newline never
             <div .table__td-content>
               <a href=@{CourseR courseTerm courseSchool courseShorthand CShowR}>
                 #{courseName}
+          $if eligibleCourses /= allocCourses
+            <td .table__td>
+              #{hasTickmark $ Set.member cid eligibleCourses}
           <td .table__td>
             <div .table__td-content>
               $maybe capN <- courseCapacity

templates/allocation/show.hamlet

@@ -53,6 +53,15 @@ $newline never
           ^{iconTooltip (i18n MsgAllocationRegisterByStaffFromTip) Nothing True}
       <dd .deflist__dd>
         ^{formatTimeRangeW SelFormatDateTime fromT allocationRegisterByStaffTo}
+    $if isAdmin
+      <dt .deflist__dt>
+        _{MsgAllocationNextSubstitutesDeadline} #
+        ^{iconInvisible}
+      <dd .deflist__dd>
+        $maybe deadline <- nextSubstitutesDeadline
+          ^{formatTimeW SelFormatDateTime deadline}
+        $nothing
+          _{MsgAllocationNextSubstitutesDeadlineNever}
     $maybe fromT <- allocationRegisterByCourse
       <dt .deflist__dt>
         _{MsgAllocationRegisterByCourseFrom}

templates/allocation/show/course.hamlet

@@ -14,6 +14,16 @@ $if is _Just muid
   #{courseName}
   $if not courseVisible && mayEdit
     \ #{iconInvisible}
+$if isAdmin
+  <div .allocation-course__admin-info>
+    <p>
+      $maybe deadline <- allocationCourseAcceptSubstitutes
+        _{MsgCourseAllocationCourseAcceptsSubstitutesUntil}: #
+        ^{formatTimeW SelFormatDateTime deadline}
+      $nothing
+        _{MsgCourseAllocationCourseAcceptsSubstitutesNever}
+      $if allocationCourseAcceptSubstitutes >= Just now
+        \ ^{iconOK}
 $if hasApplicationTemplate || is _Just courseApplicationsInstructions
   <div .allocation-course__instructions-label .allocation__label>
     _{MsgCourseApplicationInstructionsApplication}

templates/course.hamlet

@@ -136,6 +136,7 @@ $#    $if NTop (Just 0) < NTop (courseCapacity course)
       <p>
         $maybe visFrom <- courseVisibleFrom
           ^{formatTimeRangeW SelFormatDateTime visFrom courseVisibleTo}
+          <br />
         $if NTop (Just now) < NTop courseVisibleFrom
           $if hasAllocationRegistrationOpen
             _{MsgCourseInvisibleOverridenByAllocation}

templates/i18n/changelog/allocation-course-accept-substitutes.de-de-formal.hamlet

@@ -0,0 +1,2 @@
+$newline never
+Kurse, die an Zentralanmeldungen teilnehmen, können nun angeben bis zu welcher Frist sie Nachrücker akzeptieren können

templates/i18n/changelog/allocation-course-accept-substitutes.en-eu.hamlet

@@ -0,0 +1,2 @@
+$newline never
+Courses which participate in a central allocation may now specify a deadline up to which they are able to accept substitute registrations

templates/mail/allocationResults.hamlet

@@ -16,6 +16,15 @@ $newline never
     <p>
       _{SomeMessage MsgAllocationResultsTip}
 
+    $if not (null warnSubstituteCourses)
+      <p>
+        _{SomeMessage MsgAllocationResultsLecturerSubstituteCoursesWarning}
+      <ul>
+        $forall Course{courseTerm, courseSchool, courseShorthand, courseName} <- warnSubstituteCourses
+          <li>
+            <a href=@{CourseR courseTerm courseSchool courseShorthand CEditR}>
+              #{courseName}
+
     $if not (null lecturerResults)
       <p>
         _{SomeMessage MsgAllocationResultsLecturer}

test/Database/Fill.hs

@@ -1056,8 +1056,8 @@ fillDb = do
     , allocationOverrideDeregister = Just $ termTime True Summer 1 False Monday toMidnight
     , allocationMatchingSeed = aSeedFunc
     }
-  insert_ $ AllocationCourse funAlloc pmo 100
+  insert_ $ AllocationCourse funAlloc pmo 100 Nothing
-  insert_ $ AllocationCourse funAlloc ffp 2
+  insert_ . AllocationCourse funAlloc ffp 2 . Just $ 2300 `addUTCTime` now
 
   void . insertMany $ map (\(u, pState) -> CourseParticipant ffp u now (Just funAlloc) pState)
     [ (svaupel, CourseParticipantInactive False)
@@ -1196,6 +1196,8 @@ fillDb = do
     cap <- getRandomR (10,50)
 
     minCap <- round . (* fromIntegral cap) <$> getRandomR (0, 0.5 :: Double)
+
+    substitutesUntil <- (`addUTCTime` now) . fromInteger <$> getRandomR (900,2300)
     
     cid <- insert' Course
       { courseName = CI.mk [st|Zentralanmeldungskurs #{n} (#{csh})|]
@@ -1220,7 +1222,7 @@ fillDb = do
       , courseDeregisterNoShow = False
       }
     insert_ $ CourseEdit gkleen now cid
-    insert_ $ AllocationCourse bigAlloc cid minCap
+    insert_ . AllocationCourse bigAlloc cid minCap $ Just substitutesUntil
     -- void . insert' $ Lecturer gkleen cid CourseLecturer
     return cid