diff --git a/frontend/src/app.sass b/frontend/src/app.sass index c82d1bb8e..a5195c783 100644 --- a/frontend/src/app.sass +++ b/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 diff --git a/messages/uniworx/de-de-formal.msg b/messages/uniworx/de-de-formal.msg index 14e103f49..37e635897 100644 --- a/messages/uniworx/de-de-formal.msg +++ b/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} diff --git a/messages/uniworx/en-eu.msg b/messages/uniworx/en-eu.msg index fa8496197..d581d1730 100644 --- a/messages/uniworx/en-eu.msg +++ b/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} diff --git a/models/allocations.model b/models/allocations.model index f063a50ea..a8263979b 100644 --- a/models/allocations.model +++ b/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 diff --git a/src/Handler/Allocation/Accept.hs b/src/Handler/Allocation/Accept.hs index d6b1c47d3..865f356f0 100644 --- a/src/Handler/Allocation/Accept.hs +++ b/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 diff --git a/src/Handler/Allocation/AddUser.hs b/src/Handler/Allocation/AddUser.hs index 1eb83e59d..689919c45 100644 --- a/src/Handler/Allocation/AddUser.hs +++ b/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
- $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
_{MsgAllocationPriority} @@ -129,6 +132,15 @@ allocationApplicationsForm aId courses FieldSettings{..} fvRequired = formToAFor ^{fvWidget prioView} #{courseName} +
+

+ $maybe deadline <- allocationCourseAcceptSubstitutes + _{MsgCourseAllocationCourseAcceptsSubstitutesUntil}: # + ^{formatTimeW SelFormatDateTime deadline} + $nothing + _{MsgCourseAllocationCourseAcceptsSubstitutesNever} + $if allocationCourseAcceptSubstitutes >= Just now + \ ^{iconOK} $if hasApplicationTemplate || is _Just courseApplicationsInstructions

_{MsgCourseApplicationInstructionsApplication} diff --git a/src/Handler/Allocation/Compute.hs b/src/Handler/Allocation/Compute.hs index d18b68b31..d1d5a18ef 100644 --- a/src/Handler/Allocation/Compute.hs +++ b/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 $ - optionalActionA selectCourses (fslI MsgAllocationRestrictCourses & setTooltip MsgAllocationRestrictCoursesTip) (Just False) +restrictCourses aId = hoistAForm liftHandler $ multiActionA restrictOpts (fslI MsgAllocationRestrictCourses & setTooltip MsgAllocationRestrictCoursesTip) (Just AllocationCourseRestrictionNone) 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 diff --git a/src/Handler/Allocation/Show.hs b/src/Handler/Allocation/Show.hs index 0b44f9346..f58b1be58 100644 --- a/src/Handler/Allocation/Show.hs +++ b/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 diff --git a/src/Handler/Allocation/Users.hs b/src/Handler/Allocation/Users.hs index 43ea49e9f..2a1d69932 100644 --- a/src/Handler/Allocation/Users.hs +++ b/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) diff --git a/src/Handler/Course/Edit.hs b/src/Handler/Course/Edit.hs index ab1548823..7a4fa97eb 100644 --- a/src/Handler/Course/Edit.hs +++ b/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 - , allocationCourseCourse = cid - , allocationCourseMinCapacity = acfMinCapacity + { allocationCourseAllocation = acfAllocation + , allocationCourseCourse = cid + , allocationCourseMinCapacity = acfMinCapacity + , allocationCourseAcceptSubstitutes = acfAcceptSubstitutes } - [ AllocationCourseAllocation =. acfAllocation - , AllocationCourseCourse =. cid - , AllocationCourseMinCapacity =. acfMinCapacity + [ AllocationCourseAllocation =. acfAllocation + , AllocationCourseCourse =. cid + , AllocationCourseMinCapacity =. acfMinCapacity + , AllocationCourseAcceptSubstitutes =. acfAcceptSubstitutes ] when (Just acfAllocation /= fmap entityKey prevAllocation) $ diff --git a/src/Handler/Utils/Allocation.hs b/src/Handler/Utils/Allocation.hs index cefdf7c1a..9e9045291 100644 --- a/src/Handler/Utils/Allocation.hs +++ b/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 diff --git a/src/Jobs/Handler/SendNotification/Allocation.hs b/src/Jobs/Handler/SendNotification/Allocation.hs index 24c517239..1b6ee8585 100644 --- a/src/Jobs/Handler/SendNotification/Allocation.hs +++ b/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.where_ $ allocationCourse E.^. AllocationCourseCourse E.==. course E.^. CourseId - E.&&. allocationCourse E.^. AllocationCourseAllocation E.==. E.val nAllocation - ) + 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) - let lecturerResults = flip map lecturerResults' $ \(Entity _ Course{..}, E.Value allocCount, E.Value partCount) -> SomeMessage $ if + return (course, allocationCourse, allocatedCount, participantCount) + 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 diff --git a/templates/allocation/accept.hamlet b/templates/allocation/accept.hamlet index fad573c3e..7a34947d5 100644 --- a/templates/allocation/accept.hamlet +++ b/templates/allocation/accept.hamlet @@ -47,6 +47,9 @@ $newline never _{MsgSchool} _{MsgCourse} + $if eligibleCourses /= allocCourses + + _{MsgAllocationCourseEligible} _{MsgCourseCapacity} @@ -72,6 +75,9 @@ $newline never
#{courseName} + $if eligibleCourses /= allocCourses + + #{hasTickmark $ Set.member cid eligibleCourses}
$maybe capN <- courseCapacity diff --git a/templates/allocation/show.hamlet b/templates/allocation/show.hamlet index b99a98218..9f49e5a3c 100644 --- a/templates/allocation/show.hamlet +++ b/templates/allocation/show.hamlet @@ -53,6 +53,15 @@ $newline never ^{iconTooltip (i18n MsgAllocationRegisterByStaffFromTip) Nothing True}
^{formatTimeRangeW SelFormatDateTime fromT allocationRegisterByStaffTo} + $if isAdmin +
+ _{MsgAllocationNextSubstitutesDeadline} # + ^{iconInvisible} +
+ $maybe deadline <- nextSubstitutesDeadline + ^{formatTimeW SelFormatDateTime deadline} + $nothing + _{MsgAllocationNextSubstitutesDeadlineNever} $maybe fromT <- allocationRegisterByCourse
_{MsgAllocationRegisterByCourseFrom} diff --git a/templates/allocation/show/course.hamlet b/templates/allocation/show/course.hamlet index b5314cb99..322b5ea6d 100644 --- a/templates/allocation/show/course.hamlet +++ b/templates/allocation/show/course.hamlet @@ -14,6 +14,16 @@ $if is _Just muid #{courseName} $if not courseVisible && mayEdit \ #{iconInvisible} +$if isAdmin +
+

+ $maybe deadline <- allocationCourseAcceptSubstitutes + _{MsgCourseAllocationCourseAcceptsSubstitutesUntil}: # + ^{formatTimeW SelFormatDateTime deadline} + $nothing + _{MsgCourseAllocationCourseAcceptsSubstitutesNever} + $if allocationCourseAcceptSubstitutes >= Just now + \ ^{iconOK} $if hasApplicationTemplate || is _Just courseApplicationsInstructions

_{MsgCourseApplicationInstructionsApplication} diff --git a/templates/course.hamlet b/templates/course.hamlet index db30a590b..197869f18 100644 --- a/templates/course.hamlet +++ b/templates/course.hamlet @@ -136,6 +136,7 @@ $# $if NTop (Just 0) < NTop (courseCapacity course)

$maybe visFrom <- courseVisibleFrom ^{formatTimeRangeW SelFormatDateTime visFrom courseVisibleTo} +
$if NTop (Just now) < NTop courseVisibleFrom $if hasAllocationRegistrationOpen _{MsgCourseInvisibleOverridenByAllocation} diff --git a/templates/i18n/changelog/allocation-course-accept-substitutes.de-de-formal.hamlet b/templates/i18n/changelog/allocation-course-accept-substitutes.de-de-formal.hamlet new file mode 100644 index 000000000..dc1db6461 --- /dev/null +++ b/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 diff --git a/templates/i18n/changelog/allocation-course-accept-substitutes.en-eu.hamlet b/templates/i18n/changelog/allocation-course-accept-substitutes.en-eu.hamlet new file mode 100644 index 000000000..d7e5ad889 --- /dev/null +++ b/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 diff --git a/templates/mail/allocationResults.hamlet b/templates/mail/allocationResults.hamlet index bf2bddf89..8b9039215 100644 --- a/templates/mail/allocationResults.hamlet +++ b/templates/mail/allocationResults.hamlet @@ -16,6 +16,15 @@ $newline never

_{SomeMessage MsgAllocationResultsTip} + $if not (null warnSubstituteCourses) +

+ _{SomeMessage MsgAllocationResultsLecturerSubstituteCoursesWarning} +