feat(news): active allocations for lecturers

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

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

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

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

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

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
 

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)
 

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

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

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

src/Handler/Course/Edit.hs

@@ -595,10 +595,11 @@ upsertAllocationCourse cid = \case
     prevAllocationCourse <- getBy $ UniqueAllocationCourse cid
 
     void $ upsert AllocationCourse
-      { allocationCourseAllocation        =  acfAllocation
+      { allocationCourseAllocation          =  acfAllocation
-      , allocationCourseCourse            =  cid
+      , allocationCourseCourse              =  cid
-      , allocationCourseMinCapacity       =  acfMinCapacity
+      , allocationCourseMinCapacity         =  acfMinCapacity
-      , allocationCourseAcceptSubstitutes =  acfAcceptSubstitutes
+      , allocationCourseAcceptSubstitutes   =  acfAcceptSubstitutes
+      , allocationCourseOverrideSumCapacity = Nothing
       }
       [ AllocationCourseAllocation        =. acfAllocation
       , AllocationCourseCourse            =. cid

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")

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 --

templates/i18n/news/activeAllocations-info/de-de-formal.hamlet

@@ -0,0 +1,20 @@
+$newline never
+<p .explanation>
+
+  Die Zahlen der jeweils aktiven Zentralanmeldung können sich #
+  jederzeit ändern.
+
+  <br>
+
+  Es werden i.A. auch die aktuellen Zahlen vergangener #
+  Zentralanmeldungen angezeigt um den aktuellen Zustand in Kontext zu #
+  setzen.
+
+  <br>
+
+  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).

templates/news/activeAllocations.hamlet

@@ -0,0 +1,54 @@
+$newline never
+<section .news__active-allocations>
+  <h2>_{MsgNewsActiveAllocations}
+
+  <div .active-allocations__wrapper>
+    $forall allocs@(NonEmpty (Entity cId cAlloc, _) oldAllocs) <- toList activeAllocs
+      $with (tid, ssh, ash) <- (allocationTerm cAlloc, allocationSchool cAlloc, allocationShorthand cAlloc)
+        <div .active-allocations__allocation>
+          <a href=@{AllocationR tid ssh ash AShowR} .active-allocations__allocation-ident>
+            #{toPathPiece tid}
+            -
+            #{ssh}
+            -
+            #{ash}
+          <a href=@{AllocationR tid ssh ash AShowR} .active-allocations__allocation-name>
+            #{allocationName cAlloc}
+          $maybe tWidget <- allocTime cAlloc
+            <div .active-allocations__allocation-time>
+              ^{tWidget}
+          <table .active-allocations__allocation-info .table .table--hover .table--condensed>
+            $if not (null oldAllocs)
+              <thead>
+                <tr .table__row--head>
+                  <td>
+                  $forall (Entity aId alloc, _) <- allocsToList allocs
+                    <th .table__th .table__th--bright :aId == cId:.active-allocations__allocation-info-item--current :aId /= cId:.active-allocations__allocation-info-item--old>
+                      #{toPathPiece (allocationTerm alloc)}
+            <tbody>
+              <tr .table__row>
+                <th .table__th .table__th--bright>
+                  _{MsgNewsActiveAllocationsPlaces}
+                $forall (Entity aId _, allocInfo) <- allocsToList allocs
+                  <td .table__td :aId == cId:.active-allocations__allocation-info-item--current :aId /= cId:.active-allocations__allocation-info-item--old>
+                    #{auiPlaces allocInfo}
+              <tr .table__row>
+                <th .table__th .table__th--bright>
+                  _{MsgNewsActiveAllocationsApplicants}
+                $forall (Entity aId _, allocInfo) <- allocsToList allocs
+                  <td .table__td :aId == cId:.active-allocations__allocation-info-item--current :aId /= cId:.active-allocations__allocation-info-item--old>
+                    #{auiApplicants allocInfo}
+              <tr .table__row>
+                <th .table__th .table__th--bright>
+                  _{MsgNewsActiveAllocationsPlacementsMade}
+                $forall (Entity aId _, allocInfo) <- allocsToList allocs
+                  <td .table__td :aId == cId:.active-allocations__allocation-info-item--current :aId /= cId:.active-allocations__allocation-info-item--old>
+                    #{auiPlacementsMade allocInfo}
+              <tr .table__row>
+                <th .table__th .table__th--bright>
+                  _{MsgNewsActiveAllocationsApplicantsPlaced}
+                $forall (Entity aId _, allocInfo) <- allocsToList allocs
+                  <td .table__td :aId == cId:.active-allocations__allocation-info-item--current :aId /= cId:.active-allocations__allocation-info-item--old>
+                    #{auiApplicantsPlaced allocInfo}
+
+  ^{allocationInfo}

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