feat(allocations): allocation-course-accept-substitutes
This commit is contained in:
Gregor Kleen
parent
7cb2d9d3b3
commit
8abcd65edf
@ -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
|
||||
|
||||
@ -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}
|
||||
|
||||
|
||||
@ -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}
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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}
|
||||
|
||||
@ -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
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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)
|
||||
|
||||
@ -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) $
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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}
|
||||
|
||||
@ -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}
|
||||
|
||||
@ -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}
|
||||
|
||||
@ -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
|
||||
@ -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
|
||||
@ -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}
|
||||
|
||||
@ -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 ffp 2
|
||||
insert_ $ AllocationCourse funAlloc pmo 100 Nothing
|
||||
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
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user