diff --git a/frontend/src/app.sass b/frontend/src/app.sass index 75601816f..e30529b8b 100644 --- a/frontend/src/app.sass +++ b/frontend/src/app.sass @@ -355,21 +355,11 @@ input[type="button"].btn-info:not(.btn-link):hover, .table__td background-color: rgba(0, 0, 0, 0.03) - &.table--vertical - .table__row:not(.no-stripe):not(.table__row--sum):nth-child(even) - .table__th - background-color: rgba(0, 0, 0, 0.03) - .table--hover .table__row:not(.no-hover):not(.table__row--sum):not(.table__row--head):not(.table__row--foot):hover .table__td background-color: rgba(0, 0, 0, 0.07) - &.table--vertical - .table__row:not(.no-hover):not(.table__row--sum):not(.table__row--head):not(.table__row--foot):hover - .table__th - background-color: rgba(0, 0, 0, 0.07) - .table__row--sum td.table__td::before content: 'Σ' font-weight: bold @@ -431,10 +421,8 @@ input[type="button"].btn-info:not(.btn-link):hover, width: max-content .table__th - background-color: var(--color-dark) position: relative font-size: 16px - color: white line-height: 1.4 padding-top: 10px padding-bottom: 10px @@ -442,6 +430,10 @@ input[type="button"].btn-info:not(.btn-link):hover, text-align: left vertical-align: middle + &:not(.table__th--bright) + background-color: var(--color-dark) + color: white + a color: white text-decoration: none @@ -1460,6 +1452,67 @@ a.breadcrumbs__home &--success border-left-color: var(--color-success) + +.active-allocations__wrapper + display: flex + margin: -7px + flex-wrap: wrap + +.active-allocations__allocation + margin: 7px + display: grid + grid-template-columns: auto min-content + grid-template-areas: '. ident' 'name name' 'time time' 'data data' + border: 1px solid var(--color-grey) + padding: 7px + min-width: calc((100vw - 40px - 8 * 7px) / 4) + + @media (min-width: 426px) + min-width: calc((100vw - var(--asidenav-width-md, 50px) - 40px - 8 * 7px) / 4) + @media (min-width: 769px) + min-width: calc((100vw - var(--asidenav-width-lg, 20%) - 80px - 8 * 7px) / 4) + @media (min-width: 1200px) + min-width: calc((100vw - var(--asidenav-width-xl, 250px) - 80px - 8 * 7px) / 4) + +a.active-allocations__allocation-ident + white-space: nowrap + text-decoration: none + color: var(--color-fontsec) + font-weight: 600 + font-size: 0.9rem + text-align: right + grid-area: ident + +.active-allocations__allocation-name + grid-area: name + text-align: center + +.active-allocations__allocation-time + grid-area: time + +.active-allocations__allocation-info + grid-area: data + margin: 0 + + tbody + th + text-align: right + padding-right: 14px + td + text-align: center + + thead th + text-align: center + padding: 5px + + td.active-allocations__allocation-info-item--old + font-style: italic + color: var(--color-fontsec) + + th.active-allocations__allocation-info-item--old + color: var(--color-fontsec) + + .faq__question font-size: 18px font-weight: 400 diff --git a/messages/uniworx/categories/courses/allocation/de-de-formal.msg b/messages/uniworx/categories/courses/allocation/de-de-formal.msg index af8e9efe4..37b313201 100644 --- a/messages/uniworx/categories/courses/allocation/de-de-formal.msg +++ b/messages/uniworx/categories/courses/allocation/de-de-formal.msg @@ -117,8 +117,10 @@ AllocationSemester !ident-ok: Semester AllocationDescription: Beschreibung AllocationStaffDescription: Beschreibung für Dozierende AllocationStaffRegisterFrom: Eintragung der Kurse ab +AllocationStaffRegisterTo: Eintragung der Kurse bis AllocationStaffRegister: Eintragung der Kurse AllocationStaffAllocationFrom: Bewertung der Bewerbungen ab +AllocationStaffAllocationTo: Bewertung der Bewerbungen bis AllocationStaffAllocation: Bewertung der Bewerbungen AllocationRegisterFrom: Bewerbung ab AllocationRegister: Bewerbung @@ -126,6 +128,7 @@ AllocationRegisterClosed: Die Zentralanmeldung ist aktuell geschlossen. AllocationRegisterOpensIn difftime@Text: Die Zentralanmeldung öffnet voraussichtlich in #{difftime} AllocationRegisterByStaff: An- und Abmeldung durch Kursverwalter:in AllocationRegisterByStaffFrom: An- und Abmeldung durch Kursverwalter:in ab +AllocationRegisterByStaffTo: An- und Abmeldung durch Kursverwalter:in bis AllocationRegisterByStaffTip: In diesem Zeitraum können Kursverwalter:innen Teilnehmer:innen zu und von ihren Kursen an- und abmelden. AllocationRegisterByStaffFromTip: Ab diesem Zeitpunkt können Kursverwalter:innen Teilnehmer:innen zu und von ihren Kursen an- und abmelden. AllocationRegisterByCourseFrom: Direkte An- und Abmeldung ab @@ -176,6 +179,8 @@ AllocationFormTerm: Semester AllocationFormSchool: Institut AllocationFormShorthand: Kürzel AllocationFormName !ident-ok: Name +AllocationFormLegacyShorthands: Alte Kürzel +AllocationFormLegacyShorthandsTip: Zentralanmeldungen werden gelegentlich mit vorherigen Versionen in Bezug gesetzt (z.B. um Kapazität/Auslastung zu vergleichen). Dies geschieht anhand des Kürzels, bzw. anhand der hier angegebenen alten Kürzel. (Komma-separierte Liste) AllocationFormDescriptions: Beschreibungen AllocationFormDescription: Beschreibung AllocationFormDescriptionTip: Wird allen Benutzern auf der Seite der Zentralanmeldung angezeigt diff --git a/messages/uniworx/categories/courses/allocation/en-eu.msg b/messages/uniworx/categories/courses/allocation/en-eu.msg index 62312f26b..04a48ff7c 100644 --- a/messages/uniworx/categories/courses/allocation/en-eu.msg +++ b/messages/uniworx/categories/courses/allocation/en-eu.msg @@ -117,8 +117,10 @@ AllocationSemester: Semester AllocationDescription: Description AllocationStaffDescription: Staff description AllocationStaffRegisterFrom: Registration of courses starts +AllocationStaffRegisterTo: Register courses until AllocationStaffRegister: Registration of courses AllocationStaffAllocationFrom: Grading of applications starts +AllocationStaffAllocationTo: Rating of applications until AllocationStaffAllocation: Grading of applications AllocationRegisterFrom: Application period start AllocationRegister: Application period @@ -126,6 +128,7 @@ AllocationRegisterClosed: This central allocation is currently closed. AllocationRegisterOpensIn difftime: This central allocation is expected to open in #{difftime} AllocationRegisterByStaff: Enrollment by course administrators AllocationRegisterByStaffFrom: Enrollment by course administrators starts +AllocationRegisterByStaffTo: Enrollment by course administrators ends AllocationRegisterByStaffTip: In this periods course administrators may enroll participants in their courses. AllocationRegisterByStaffFromTip: Starting at this time course administrators may enroll participants in their courses. AllocationRegisterByCourseFrom: Direct enrollment starts @@ -175,6 +178,8 @@ AllocationFormTerm: Term AllocationFormSchool: Department AllocationFormShorthand: Shorthand AllocationFormName: Name +AllocationFormLegacyShorthands: Legacy shorthands +AllocationFormLegacyShorthandsTip: Allocations are occasionally related to previous versions (e.g. to compare capacity/utilisation). This is done via their shorthand and via the legacy shorthands given here. (Comma-separated list) AllocationFormDescriptions: Description AllocationFormDescription: Description AllocationFormDescriptionTip: Will be shown to all users on the page of the allocation diff --git a/messages/uniworx/categories/news/de-de-formal.msg b/messages/uniworx/categories/news/de-de-formal.msg index 948693369..721b9f1ec 100644 --- a/messages/uniworx/categories/news/de-de-formal.msg +++ b/messages/uniworx/categories/news/de-de-formal.msg @@ -14,3 +14,9 @@ SubmissionNew: Abgabe anlegen NoUpcomingSheetDeadlines: Keine anstehenden Übungsblätter NoUpcomingExams difftime@Text: In den nächsten #{difftime} gibt es keine Prüfungen oder ablaufende Prüfungsanmeldungen in Ihren Kursen CourseParticipant: Teilnehmer:in + +NewsActiveAllocations: Aktive Zentralanmeldungen (für Dozenten) +NewsActiveAllocationsPlaces: Plätze +NewsActiveAllocationsApplicants: Bewerber +NewsActiveAllocationsPlacementsMade: Zugeteilte Plätze +NewsActiveAllocationsApplicantsPlaced: Zugeteilte Bewerber \ No newline at end of file diff --git a/messages/uniworx/categories/news/en-eu.msg b/messages/uniworx/categories/news/en-eu.msg index 7c4781dff..2aef32c64 100644 --- a/messages/uniworx/categories/news/en-eu.msg +++ b/messages/uniworx/categories/news/en-eu.msg @@ -14,3 +14,9 @@ SubmissionNew: Create submission NoUpcomingSheetDeadlines: No upcoming sheets NoUpcomingExams difftime: No exams for your courses occur or allow registration in the next #{difftime} CourseParticipant: Participant + +NewsActiveAllocations: Active allocations (for lecturers) +NewsActiveAllocationsPlaces: Places +NewsActiveAllocationsApplicants: Applicants +NewsActiveAllocationsPlacementsMade: Placements made +NewsActiveAllocationsApplicantsPlaced: Applicants placed diff --git a/models/allocations.model b/models/allocations.model index a7773ab3b..cb275f2a2 100644 --- a/models/allocations.model +++ b/models/allocations.model @@ -3,6 +3,7 @@ Allocation -- attributes with prefix staff- affect lecturers only, but are invis school SchoolId -- school that manages this central allocation, not necessarily school of courses shorthand AllocationShorthand -- practical shorthand name AllocationName + legacyShorthands [AllocationShorthand] default='[]' -- just for association to previous allocations description StoredMarkup Maybe -- description for prospective students staffDescription StoredMarkup Maybe -- description seen by prospective lecturers only staffRegisterFrom UTCTime Maybe -- lectureres may register courses @@ -19,7 +20,7 @@ Allocation -- attributes with prefix staff- affect lecturers only, but are invis registerByStaffFrom UTCTime Maybe -- lecturers may directly enrol/disenrol students after a given date or prohibited registerByStaffTo UTCTime Maybe registerByCourse UTCTime Maybe -- course registration dates are ignored until this day has passed or always prohibited - overrideDeregister UTCTime Maybe -- course deregistration enforced to be this date, i.e. students may disenrol from course after or never + overrideDeregister UTCTime Maybe -- deregister prohibited after this time or always allowed (defaulting to course settings) -- overrideVisible not needed, since courses are always visible matchingSeed ByteString default='\x'::bytea TermSchoolAllocationShort term school shorthand -- shorthand must be unique within school and semester @@ -38,6 +39,7 @@ AllocationCourse 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 + overrideSumCapacity Int Maybe -- mark course as outlier (ridiculously large capacity) and use this capacity instead for computing overall capacity of allocation UniqueAllocationCourse course deriving Generic diff --git a/src/Database/Esqueleto/Utils.hs b/src/Database/Esqueleto/Utils.hs index cab53a24c..e61ab16bf 100644 --- a/src/Database/Esqueleto/Utils.hs +++ b/src/Database/Esqueleto/Utils.hs @@ -28,7 +28,7 @@ module Database.Esqueleto.Utils , (->.), (#>>.) , fromSqlKey , unKey - , selectCountRows + , selectCountRows, selectCountDistinct , selectMaybe , day, diffDays, diffTimes , exprLift @@ -436,6 +436,15 @@ selectCountRows q = do _other -> error "E.countRows did not return exactly one result" +selectCountDistinct :: (Num a, PersistField a, MonadIO m) => E.SqlQuery (E.SqlExpr (E.Value typ)) -> E.SqlReadT m a +selectCountDistinct q = do + res <- E.select $ E.countDistinct <$> q + case res of + [E.Value res'] + -> return res' + _other + -> error "E.countDistinct did not return exactly one result" + selectMaybe :: (E.SqlSelect a r, MonadIO m) => E.SqlQuery a -> E.SqlReadT m (Maybe r) selectMaybe = fmap listToMaybe . E.select . (<* E.limit 1) diff --git a/src/Handler/Allocation/Edit.hs b/src/Handler/Allocation/Edit.hs index 43fa5c5e3..2e3874269 100644 --- a/src/Handler/Allocation/Edit.hs +++ b/src/Handler/Allocation/Edit.hs @@ -7,6 +7,8 @@ import Handler.Utils import Handler.Allocation.Form +import qualified Data.Set as Set + getAEditR, postAEditR :: TermId -> SchoolId -> AllocationShorthand -> Handler Html getAEditR = postAEditR @@ -19,6 +21,7 @@ postAEditR tid ssh ash = do , afSchool = allocationSchool , afShorthand = allocationShorthand , afName = allocationName + , afLegacyShorthands = Set.fromList allocationLegacyShorthands , afDescription = allocationDescription , afStaffDescription = allocationStaffDescription , afStaffRegisterFrom = allocationStaffRegisterFrom @@ -41,6 +44,7 @@ postAEditR tid ssh ash = do , allocationSchool = afSchool , allocationShorthand = afShorthand , allocationName = afName + , allocationLegacyShorthands = Set.toList afLegacyShorthands , allocationDescription = afDescription , allocationStaffDescription = afStaffDescription , allocationStaffRegisterFrom = afStaffRegisterFrom diff --git a/src/Handler/Allocation/Form.hs b/src/Handler/Allocation/Form.hs index 249a1efb3..afe192155 100644 --- a/src/Handler/Allocation/Form.hs +++ b/src/Handler/Allocation/Form.hs @@ -13,6 +13,9 @@ import qualified Data.Map.Strict as Map import qualified Data.Set as Set import qualified Control.Monad.State.Class as State + +import qualified Data.CaseInsensitive as CI +import qualified Data.Text as Text data AllocationForm = AllocationForm @@ -20,6 +23,7 @@ data AllocationForm = AllocationForm , afSchool :: SchoolId , afShorthand :: AllocationShorthand , afName :: AllocationName + , afLegacyShorthands :: Set AllocationShorthand , afDescription, afStaffDescription :: Maybe StoredMarkup , afStaffRegisterFrom, afStaffRegisterTo , afRegisterFrom, afRegisterTo @@ -68,11 +72,15 @@ allocationForm mTemplate = validateAForm validateAllocationForm . wFormToAForm $ template <- maybe (lift . lift $ suggestAllocationForm termOptions schoolOptions) (return . Just) mTemplate + let cfCommaSeparatedSet :: forall m. Functor m => Field m Text -> Field m (Set (CI Text)) + cfCommaSeparatedSet = guardField (not . Set.null) . convertField (Set.fromList . mapMaybe (fmap CI.mk . assertM' (not . Text.null) . Text.strip) . Text.splitOn ",") (Text.intercalate ", " . map CI.original . Set.toList) + aFormToWForm . hoistAForm liftHandler $ AllocationForm <$> areq (selectField $ return termOptions) (fslI MsgAllocationFormTerm) (afTerm <$> template) <*> areq (selectField $ return schoolOptions) (fslI MsgAllocationFormSchool) (afSchool <$> template) <*> areq (textField & cfStrip & cfCI) (fslI MsgAllocationFormShorthand) (afShorthand <$> template) <*> areq (textField & cfStrip & cfCI) (fslI MsgAllocationFormName) (afName <$> template) + <*> (fromMaybe Set.empty <$> aopt (textField & cfCommaSeparatedSet) (fslI MsgAllocationFormLegacyShorthands & setTooltip MsgAllocationFormLegacyShorthandsTip) (fmap Just $ afLegacyShorthands <$> template)) <* aformSection MsgAllocationFormDescriptions <*> aopt htmlField (fslI MsgAllocationFormDescription & setTooltip MsgAllocationFormDescriptionTip) (afDescription <$> template) <*> aopt htmlField (fslI MsgAllocationFormStaffDescription & setTooltip MsgAllocationFormStaffDescriptionTip) (afStaffDescription <$> template) @@ -90,6 +98,8 @@ allocationForm mTemplate = validateAForm validateAllocationForm . wFormToAForm $ validateAllocationForm :: FormValidator AllocationForm (YesodDB UniWorX) () validateAllocationForm = do + State.modify $ \af -> af { afLegacyShorthands = Set.delete (afShorthand af) $ afLegacyShorthands af } + AllocationForm{..} <- State.get guardValidation MsgAllocationFormStaffRegisterToMustBeAfterFrom @@ -157,6 +167,7 @@ suggestAllocationForm (Set.fromList . map optionInternalValue . olOptions -> ter , afSchool = ssh , afShorthand = ash , afName = allocationName + , afLegacyShorthands = Set.delete ash $ Set.fromList allocationLegacyShorthands , afDescription = allocationDescription , afStaffDescription = allocationStaffDescription , afStaffRegisterFrom = addTime <$> allocationStaffRegisterFrom diff --git a/src/Handler/Allocation/New.hs b/src/Handler/Allocation/New.hs index b8e280512..68dac35f0 100644 --- a/src/Handler/Allocation/New.hs +++ b/src/Handler/Allocation/New.hs @@ -9,6 +9,8 @@ import Handler.Allocation.Form import qualified Crypto.Random as Crypto +import qualified Data.Set as Set + getAllocationNewR, postAllocationNewR :: Handler Html getAllocationNewR = postAllocationNewR @@ -24,6 +26,7 @@ postAllocationNewR = do , allocationSchool = afSchool , allocationShorthand = afShorthand , allocationName = afName + , allocationLegacyShorthands = Set.toList afLegacyShorthands , allocationDescription = afDescription , allocationStaffDescription = afStaffDescription , allocationStaffRegisterFrom = afStaffRegisterFrom diff --git a/src/Handler/Course/Edit.hs b/src/Handler/Course/Edit.hs index d2e687586..344a1140f 100644 --- a/src/Handler/Course/Edit.hs +++ b/src/Handler/Course/Edit.hs @@ -595,10 +595,11 @@ upsertAllocationCourse cid = \case prevAllocationCourse <- getBy $ UniqueAllocationCourse cid void $ upsert AllocationCourse - { allocationCourseAllocation = acfAllocation - , allocationCourseCourse = cid - , allocationCourseMinCapacity = acfMinCapacity - , allocationCourseAcceptSubstitutes = acfAcceptSubstitutes + { allocationCourseAllocation = acfAllocation + , allocationCourseCourse = cid + , allocationCourseMinCapacity = acfMinCapacity + , allocationCourseAcceptSubstitutes = acfAcceptSubstitutes + , allocationCourseOverrideSumCapacity = Nothing } [ AllocationCourseAllocation =. acfAllocation , AllocationCourseCourse =. cid diff --git a/src/Handler/News.hs b/src/Handler/News.hs index ba2ee8c9b..7ec2aeb1a 100644 --- a/src/Handler/News.hs +++ b/src/Handler/News.hs @@ -1,13 +1,15 @@ module Handler.News where -import Import +import Import hiding (maximum, minimum, minimumBy) import Handler.Utils import Handler.Utils.News import Handler.SystemMessage -import qualified Data.Map as Map +import qualified Data.Map.Strict as Map +import qualified Data.Set as Set + import Database.Esqueleto.Utils.TH import qualified Database.Esqueleto as E import qualified Database.Esqueleto.Utils as E @@ -20,6 +22,8 @@ import qualified Data.HashMap.Strict as HashMap import Handler.Utils.Exam (showExamOccurrenceRoom) +import Data.List (maximum, minimum, minimumBy) + getNewsR :: Handler Html getNewsR = do @@ -34,6 +38,7 @@ getNewsR = do case muid of Just uid -> do + newsActiveAllocations uid newsUpcomingExams uid newsUpcomingSheets uid Nothing -> @@ -346,3 +351,165 @@ newsUpcomingExams uid = do $(widgetFile "news/upcomingExams") +data AllocationUtilInfo = AllocationUtilInfo + { auiApplicants + , auiPlaces + , auiPlacementsMade + , auiApplicantsPlaced :: Word64 + } deriving (Eq, Ord, Read, Show, Generic, Typeable) + +newsActiveAllocations :: UserId -> Widget +newsActiveAllocations uid = maybeT_ $ do + now <- liftIO getCurrentTime + activeAllocs <- hoist (liftHandler . runDB) $ do + guardM . lift $ or2M (hasWriteAccessTo CourseNewR) (hasWriteAccessTo AllocationNewR) + + userSchools <- lift . fmap (map E.unValue) . E.select . E.from $ \userSchool -> E.distinctOnOrderBy [E.asc $ userSchool E.^. UserSchoolSchool] $ do + E.where_ $ userSchool E.^. UserSchoolUser E.==. E.val uid + return $ userSchool E.^. UserSchoolSchool + functionSchools <- lift . fmap (map E.unValue) . E.select . E.from $ \userFunction -> E.distinctOnOrderBy [E.asc $ userFunction E.^. UserFunctionSchool] $ do + E.where_ $ userFunction E.^. UserFunctionUser E.==. E.val uid + E.&&. userFunction E.^. UserFunctionFunction E.==. E.val SchoolAllocation + return $ userFunction E.^. UserFunctionSchool + + let allocSchools = Set.fromList $ userSchools <> functionSchools + + guard . not $ null allocSchools + + activeAllocs <- lift . E.select . E.from $ \allocation -> do + E.where_ $ allocation E.^. AllocationSchool `E.in_` E.valList (Set.toList allocSchools) + E.where_ $ E.maybe E.false (E.<=. E.val now) (allocation E.^. AllocationStaffRegisterFrom) E.&&. E.maybe E.true (E.>=. E.val now) (allocation E.^. AllocationStaffRegisterTo) + E.||. E.maybe E.false (E.<=. E.val now) (allocation E.^. AllocationStaffAllocationFrom) E.&&. E.maybe E.true (E.>=. E.val now) (allocation E.^. AllocationStaffAllocationTo) + E.||. E.maybe E.false (E.<=. E.val now) (allocation E.^. AllocationRegisterFrom) E.&&. E.maybe E.true (E.>=. E.val now) (allocation E.^. AllocationRegisterTo) + E.||. E.maybe E.true (E.>=. E.val now) (allocation E.^. AllocationRegisterByStaffFrom) E.||. E.maybe E.false (E.<=. E.val now) (allocation E.^. AllocationRegisterByStaffTo) + E.||. E.maybe E.false (E.>=. E.val now) (allocation E.^. AllocationRegisterByCourse) + + return allocation + + guard . not $ null activeAllocs + + fmap Map.fromList . forM activeAllocs $ \activeAlloc'@(Entity _ activeAlloc) -> lift $ ((allocationTerm activeAlloc, allocationSchool activeAlloc, allocationShorthand activeAlloc), ) <$> do + prevAllocs <- E.select . E.from $ \allocation -> E.distinctOnOrderBy [ E.desc $ allocation E.^. AllocationTerm ] $ do + E.where_ $ allocation E.^. AllocationShorthand `E.in_` E.valList (allocationShorthand activeAlloc : allocationLegacyShorthands activeAlloc) + E.&&. allocation E.^. AllocationTerm E.<. E.val (allocationTerm activeAlloc) + E.&&. allocation E.^. AllocationSchool E.==. E.val (allocationSchool activeAlloc) + E.orderBy [E.asc $ allocation E.^. AllocationSchool] + E.limit 2 + return allocation + + let allocInfo :: Entity Allocation -> DB (Entity Allocation, AllocationUtilInfo) + allocInfo ent@(Entity aId' _) = (ent, ) <$> do + auiApplicants <- E.selectCountRows . E.from $ \allocationUser -> do + E.where_ $ allocationUser E.^. AllocationUserAllocation E.==. E.val aId' + E.where_ $ allocationUser E.^. AllocationUserTotalCourses E.>=. E.val 1 -- wants at least one course + E.where_ . E.exists . E.from $ \(courseApplication `E.InnerJoin` allocationCourse) -> do -- at least one application + E.on $ courseApplication E.^. CourseApplicationCourse E.==. allocationCourse E.^. AllocationCourseCourse + E.&&. allocationCourse E.^. AllocationCourseAllocation E.==. E.val aId' + E.where_ $ courseApplication E.^. CourseApplicationUser E.==. allocationUser E.^. AllocationUserUser + E.&&. courseApplication E.^. CourseApplicationAllocation E.==. E.justVal aId' + auiPlaces <- fmap (fromMaybe 0 . (E.unValue =<<)) . E.selectMaybe . E.from $ \(allocationCourse `E.InnerJoin` course) -> do + E.on $ allocationCourse E.^. AllocationCourseCourse E.==. course E.^. CourseId + E.&&. allocationCourse E.^. AllocationCourseAllocation E.==. E.val aId' + return . E.explicitUnsafeCoerceSqlExprValue @(Maybe Word64) @(Maybe Rational) "integer" . E.sum_ . E.maybe (E.val 0) id . E.maybe (course E.^. CourseCapacity) E.just $ allocationCourse E.^. AllocationCourseOverrideSumCapacity + placementsCounts <- E.select . E.from $ \(courseParticipant `E.InnerJoin` allocationCourse) -> do + E.on $ courseParticipant E.^. CourseParticipantCourse E.==. allocationCourse E.^. AllocationCourseCourse + E.&&. allocationCourse E.^. AllocationCourseAllocation E.==. E.val aId' + E.where_ . E.isJust $ courseParticipant E.^. CourseParticipantAllocated -- count any allocations; course can only be in one allocation at a time + return ( E.countRows + , E.countDistinct $ courseParticipant E.^. CourseParticipantUser + ) + let (auiPlacementsMade, auiApplicantsPlaced) = case placementsCounts of + [(E.Value placementsMade, E.Value applicantsPlaced)] -> (placementsMade, applicantsPlaced) + _other -> error "Query `SELECT COUNT(*), COUNT(DISTINCT …) …` did not return exactly one row" + return AllocationUtilInfo{..} + + (:|) <$> allocInfo activeAlloc' + <*> traverse allocInfo prevAllocs + + let allocsToList allocs = toList allocs + & sortOn (Down . allocationTerm . views _1 entityVal) + allocationInfo = $(i18nWidgetFile "news/activeAllocations-info") + allocTime Allocation{..} | null timeOpts' = Nothing + | otherwise = Just . view _2 $ minimumBy (comparing $ view _1) timeOpts' + where + timeOpts' = flip mapMaybe timeOpts $ \(ts, w) + -> let ts' = flip mapMaybe ts $ \mt -> assertM' (>= 0) . (`diffUTCTime` now) =<< mt + in if | null ts' -> Nothing + | otherwise -> Just (minimum ts', w) + timeOpts = catMaybes + [ allocationRegisterByStaffFrom <&> \registerByStaffFrom -> + ( [allocationRegisterByStaffFrom, allocationRegisterByStaffTo] + , [whamlet| + $newline never + _{MsgAllocationRegisterByStaff}: # + ^{formatTimeRangeW (selFormat $ catMaybes [allocationRegisterByStaffFrom, allocationRegisterByStaffTo]) registerByStaffFrom allocationRegisterByStaffTo} + |] + ) + , allocationRegisterByStaffTo <&> \registerByStaffTo -> + ( [allocationRegisterByStaffTo] + , [whamlet| + $newline never + _{MsgAllocationRegisterByStaffTo}: # + ^{formatTimeW (selFormat $ catMaybes [allocationRegisterByStaffTo]) registerByStaffTo} + |] + ) + , allocationStaffRegisterFrom <&> \staffRegisterFrom -> + ( [allocationStaffRegisterFrom, allocationStaffRegisterTo] + , [whamlet| + $newline never + _{MsgAllocationStaffRegister}: # + ^{formatTimeRangeW (selFormat $ catMaybes [allocationStaffRegisterFrom, allocationStaffRegisterTo]) staffRegisterFrom allocationStaffRegisterTo} + |] + ) + , allocationStaffRegisterTo <&> \staffRegisterTo -> + ( [allocationStaffRegisterTo] + , [whamlet| + $newline never + _{MsgAllocationStaffRegisterTo}: # + ^{formatTimeW (selFormat $ catMaybes [allocationStaffRegisterTo]) staffRegisterTo} + |] + ) + , allocationRegisterFrom <&> \registerFrom -> + ( [allocationRegisterFrom, allocationRegisterTo] + , [whamlet| + $newline never + _{MsgAllocationRegister}: # + ^{formatTimeRangeW (selFormat $ catMaybes [allocationRegisterFrom, allocationRegisterTo]) registerFrom allocationRegisterTo} + |] + ) + , allocationRegisterTo <&> \registerTo -> + ( [allocationRegisterTo] + , [whamlet| + $newline never + _{MsgAllocationRegisterTo}: # + ^{formatTimeW (selFormat $ catMaybes [allocationRegisterTo]) registerTo} + |] + ) + , allocationStaffAllocationFrom <&> \staffAllocationFrom -> + ( [allocationStaffAllocationFrom, allocationStaffAllocationTo] + , [whamlet| + $newline never + _{MsgAllocationStaffAllocation}: # + ^{formatTimeRangeW (selFormat $ catMaybes [allocationStaffAllocationFrom, allocationStaffAllocationTo]) staffAllocationFrom allocationStaffAllocationTo} + |] + ) + , allocationStaffAllocationTo <&> \staffAllocationTo -> + ( [allocationStaffAllocationTo] + , [whamlet| + $newline never + _{MsgAllocationStaffAllocationTo}: # + ^{formatTimeW (selFormat $ catMaybes [allocationStaffAllocationTo]) staffAllocationTo} + |] + ) + ] + selFormat ts | not $ null ts = maximum $ map selFormat' ts + | otherwise = SelFormatDate + where selFormat' (utcToLocalTime -> t@LocalTime{..}) + | closeToEndOfDay = SelFormatDate + | otherwise = SelFormatDateTime + where closeToEndOfDay = any (\t' -> abs (t `diffLocalTime` t') <= 5 * nominalMinute) + [ LocalTime localDay midnight + , LocalTime (addDays 1 localDay) midnight + ] + + lift $(widgetFile "news/activeAllocations") diff --git a/src/Utils.hs b/src/Utils.hs index 0ba53c9fc..7f4201d54 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -118,7 +118,7 @@ import Network.HTTP.Types.Header import Data.Time.Clock -import Data.List.NonEmpty (NonEmpty, nonEmpty) +import Data.List.NonEmpty (NonEmpty(..), nonEmpty) import Algebra.Lattice (top, bottom, (/\), (\/), BoundedJoinSemiLattice, BoundedMeetSemiLattice) @@ -562,6 +562,10 @@ withoutSubsequenceBy cmp = go [] go acc a@(x:a') (y:b) | x `cmp` y = go acc a' b | otherwise = go (y:acc) a b + +pattern NonEmpty :: forall a. a -> [a] -> NonEmpty a +pattern NonEmpty x xs = x :| xs +{-# COMPLETE NonEmpty #-} ---------- -- Sets -- diff --git a/templates/i18n/news/activeAllocations-info/de-de-formal.hamlet b/templates/i18n/news/activeAllocations-info/de-de-formal.hamlet new file mode 100644 index 000000000..bb9b46662 --- /dev/null +++ b/templates/i18n/news/activeAllocations-info/de-de-formal.hamlet @@ -0,0 +1,20 @@ +$newline never +

+ + Die Zahlen der jeweils aktiven Zentralanmeldung können sich # + jederzeit ändern. + +
+ + Es werden i.A. auch die aktuellen Zahlen vergangener # + Zentralanmeldungen angezeigt um den aktuellen Zustand in Kontext zu # + setzen. + +
+ + Sie können diese Auflistung als Anhaltspunkt verwenden um grob # + abzuschätzen ob die aktuell zur Verfügung stehende Kapazität # + ausreichen wird oder ob es notwendig ist weitere Kurse anzubieten (es # + handelt sich hierbei natürlich nur um einen Orienterungswert und # + ersetzt nicht den Weisungen des jeweiligen Instituts in Bezug auf # + die anzubietenden Kurse zu folgen). diff --git a/templates/news/activeAllocations.hamlet b/templates/news/activeAllocations.hamlet new file mode 100644 index 000000000..b732d65a8 --- /dev/null +++ b/templates/news/activeAllocations.hamlet @@ -0,0 +1,54 @@ +$newline never +

+

_{MsgNewsActiveAllocations} + +
+ $forall allocs@(NonEmpty (Entity cId cAlloc, _) oldAllocs) <- toList activeAllocs + $with (tid, ssh, ash) <- (allocationTerm cAlloc, allocationSchool cAlloc, allocationShorthand cAlloc) +
+ + #{toPathPiece tid} + - + #{ssh} + - + #{ash} + + #{allocationName cAlloc} + $maybe tWidget <- allocTime cAlloc +
+ ^{tWidget} + + $if not (null oldAllocs) + + + + + + + +
+ $forall (Entity aId alloc, _) <- allocsToList allocs + + #{toPathPiece (allocationTerm alloc)} +
+ _{MsgNewsActiveAllocationsPlaces} + $forall (Entity aId _, allocInfo) <- allocsToList allocs + + #{auiPlaces allocInfo} +
+ _{MsgNewsActiveAllocationsApplicants} + $forall (Entity aId _, allocInfo) <- allocsToList allocs + + #{auiApplicants allocInfo} +
+ _{MsgNewsActiveAllocationsPlacementsMade} + $forall (Entity aId _, allocInfo) <- allocsToList allocs + + #{auiPlacementsMade allocInfo} +
+ _{MsgNewsActiveAllocationsApplicantsPlaced} + $forall (Entity aId _, allocInfo) <- allocsToList allocs + + #{auiApplicantsPlaced allocInfo} + + ^{allocationInfo} diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs index 2392d829e..a75b4f3f4 100644 --- a/test/Database/Fill.hs +++ b/test/Database/Fill.hs @@ -1090,6 +1090,7 @@ fillDb = do , allocationShorthand = "fun" , allocationTerm = TermKey $ seasonTerm True Summer , allocationSchool = ifi + , allocationLegacyShorthands = [] , allocationDescription = Nothing , allocationStaffDescription = Nothing , allocationStaffRegisterFrom = Just now @@ -1224,6 +1225,7 @@ fillDb = do , allocationShorthand = "big" , allocationTerm = TermKey $ seasonTerm True Summer , allocationSchool = ifi + , allocationLegacyShorthands = [] , allocationDescription = Nothing , allocationStaffDescription = Nothing , allocationStaffRegisterFrom = Just now