diff --git a/src/Handler/Allocation/Show.hs b/src/Handler/Allocation/Show.hs index f58b1be58..6cbd6250c 100644 --- a/src/Handler/Allocation/Show.hs +++ b/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 diff --git a/templates/allocation/show.hamlet b/templates/allocation/show.hamlet index 9f49e5a3c..5be1369df 100644 --- a/templates/allocation/show.hamlet +++ b/templates/allocation/show.hamlet @@ -62,6 +62,16 @@ $newline never ^{formatTimeW SelFormatDateTime deadline} $nothing _{MsgAllocationNextSubstitutesDeadlineNever} +
+ _{MsgAllocationFreeCapacity} # + ^{iconInvisible} +
+ $maybe freeCap <- freeCapacity + #{freeCap} + $if freeCap <= 0 + \ ^{iconOK} + $nothing + ∞ $maybe fromT <- allocationRegisterByCourse
_{MsgAllocationRegisterByCourseFrom} diff --git a/templates/allocation/show/course.hamlet b/templates/allocation/show/course.hamlet index 322b5ea6d..56c967d06 100644 --- a/templates/allocation/show/course.hamlet +++ b/templates/allocation/show/course.hamlet @@ -24,6 +24,15 @@ $if isAdmin _{MsgCourseAllocationCourseAcceptsSubstitutesNever} $if allocationCourseAcceptSubstitutes >= Just now \ ^{iconOK} +

+ _{MsgCourseAllocationCourseParticipants}: + $maybe capacity <- courseCapacity + \ _{MsgCourseMembersCountLimited partCount capacity} + $if partCount < capacity + \ ^{iconProblem} + $nothing + \ _{MsgCourseMembersCount partCount} + \ ^{iconProblem} $if hasApplicationTemplate || is _Just courseApplicationsInstructions

_{MsgCourseApplicationInstructionsApplication}