feat(allocations): display participant counts to admins

src/Handler/Allocation/Show.hs

@@ -61,6 +61,8 @@ postAShowR tid ssh ash = do
     resultCourseVisible = _5 . _Value
     resultAllocationCourse :: _ => Lens' a AllocationCourse
     resultAllocationCourse = _6 . _entityVal
+    resultParticipantCount :: _ => Lens' a Int
+    resultParticipantCount = _7 . _Value
 
   (Entity aId Allocation{..}, School{..}, isAnyLecturer, isAdmin, courses, registration, wouldNotifyNewCourse) <- runDB $ do
     alloc@(Entity aId Allocation{allocationSchool}) <- getBy404 $ TermSchoolAllocationShort tid ssh ash
@@ -81,12 +83,16 @@ 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
+          participantCount = E.subSelectCount . E.from $ \courseParticipant ->
+            E.where_ $ courseParticipant E.^. CourseParticipantCourse E.==. course E.^. CourseId
+                 E.&&. courseParticipant E.^. CourseParticipantState E.==. E.val CourseParticipantActive
       return ( course
              , courseApplication
              , hasTemplate
              , E.not_ . E.isNothing $ registration E.?. CourseParticipantId
              , courseIsVisible now course . Just $ E.val aId
              , allocationCourse
+             , participantCount
              )
 
     registration <- fmap join . for muid $ getBy . UniqueAllocationUser aId
@@ -99,6 +105,7 @@ postAShowR tid ssh ash = do
     return (alloc, school, isAnyLecturer, isAdmin, nubOn (view $ resultCourse . _entityKey) courses, registration, wouldNotifyNewCourse)
 
   let nextSubstitutesDeadline = minimumOf (folded . resultAllocationCourse . _allocationCourseAcceptSubstitutes . _Just . filtered (>= now)) courses
+      freeCapacity = fmap getSum . getAp . flip foldMap courses $ \cEntry -> Ap . fmap (Sum . max 0) $ (subtract $ cEntry ^. resultParticipantCount) <$> preview (resultCourse . _entityVal . _courseCapacity . _Just) cEntry
 
   MsgRenderer mr <- getMsgRenderer
   let title = MsgAllocationTitle (mr . ShortTermIdentifier $ unTermKey allocationTerm) (unSchoolKey allocationSchool) allocationName
@@ -158,6 +165,7 @@ postAShowR tid ssh ash = do
               isRegistered           = cEntry ^. resultIsRegistered
               courseVisible          = cEntry ^. resultCourseVisible
               AllocationCourse{..}   = cEntry ^. resultAllocationCourse
+              partCount              = cEntry ^. resultParticipantCount
           cID <- encrypt cid :: WidgetFor UniWorX CryptoUUIDCourse
           mayApply <- hasWriteAccessTo . AllocationR tid ssh ash $ AApplyR cID
           mayEdit <- hasWriteAccessTo $ CourseR tid ssh courseShorthand CEditR

templates/allocation/show.hamlet

@@ -62,6 +62,16 @@ $newline never
           ^{formatTimeW SelFormatDateTime deadline}
         $nothing
           _{MsgAllocationNextSubstitutesDeadlineNever}
+      <dt .deflist__dt>
+        _{MsgAllocationFreeCapacity} #
+        ^{iconInvisible}
+      <dd .deflist__dd>
+        $maybe freeCap <- freeCapacity
+          #{freeCap}
+          $if freeCap <= 0
+            \ ^{iconOK}
+        $nothing
+          ∞
     $maybe fromT <- allocationRegisterByCourse
       <dt .deflist__dt>
         _{MsgAllocationRegisterByCourseFrom}

templates/allocation/show/course.hamlet

@@ -24,6 +24,15 @@ $if isAdmin
         _{MsgCourseAllocationCourseAcceptsSubstitutesNever}
       $if allocationCourseAcceptSubstitutes >= Just now
         \ ^{iconOK}
+    <p>
+      _{MsgCourseAllocationCourseParticipants}:
+      $maybe capacity <- courseCapacity
+        \ _{MsgCourseMembersCountLimited partCount capacity}
+        $if partCount < capacity
+          \ ^{iconProblem}
+      $nothing
+        \ _{MsgCourseMembersCount partCount}
+        \ ^{iconProblem}
 $if hasApplicationTemplate || is _Just courseApplicationsInstructions
   <div .allocation-course__instructions-label .allocation__label>
     _{MsgCourseApplicationInstructionsApplication}