From 83e1c9418a0461baebd6da8e0d835738d611f188 Mon Sep 17 00:00:00 2001
From: Gregor Kleen <kleen@cip.ifi.lmu.de>
Date: Thu, 12 Sep 2019 14:38:54 +0200
Subject: [PATCH] feat(allocations): allow changing course capacity during
 allocation

Also refine display of allocation registration bounds
---
 messages/uniworx/de.msg                   | 3 ++-
 src/Handler/Course/Application/List.hs    | 9 +++++++--
 src/Handler/Course/Edit.hs                | 5 +++--
 templates/course/applications-list.hamlet | 7 +++++--
 templates/course/applications-list.lucius | 4 ++++
 5 files changed, 21 insertions(+), 7 deletions(-)
 create mode 100644 templates/course/applications-list.lucius

diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg
index 427941cf4..7334bbf32 100644
--- a/messages/uniworx/de.msg
+++ b/messages/uniworx/de.msg
@@ -1650,4 +1650,5 @@ UserCollision: Benutzer konnte wegen Eindeutigkeit nicht angelegt werden
 CourseAllocationsBounds n@Int: Voraussichtliche Zuteilungen durch #{pluralDE n "Zentralanmeldung" "Zentralanmeldungen"}
 CourseAllocationsBoundCoincide numFirstChoice@Int: Vstl. #{numFirstChoice} Teilnehmer
 CourseAllocationsBound numApps@Int numFirstChoice@Int: Vstl. zwischen #{numFirstChoice} und #{numApps} Teilnehmer
-CourseAllocationsBoundCapped: Die Anzahl von Zuteilungen wird wmgl. durch die Kurskapazität eingeschränkt
\ No newline at end of file
+CourseAllocationsBoundCapped: Die Anzahl von Zuteilungen wird wmgl. durch die Kurskapazität eingeschränkt.
+CourseAllocationsBoundWarningOpen: Diese Informationen entsprechen nur dem aktuellen Stand der Bewerbungen und können sich noch ändern.
\ No newline at end of file
diff --git a/src/Handler/Course/Application/List.hs b/src/Handler/Course/Application/List.hs
index 87184db38..7ada9cbff 100644
--- a/src/Handler/Course/Application/List.hs
+++ b/src/Handler/Course/Application/List.hs
@@ -532,6 +532,9 @@ postCApplicationsR tid ssh csh = do
       psValidator = def
         & defaultSorting [SortAscBy "user-name"]
 
+    participants <- count [ CourseParticipantCourse ==. cid ]
+    let remainingCapacity = subtract participants <$> courseCapacity
+
     allocationsBounds' <- E.select . E.from $ \(allocation `E.InnerJoin` allocationCourse) -> do
       E.on $ allocation E.^. AllocationId E.==. allocationCourse E.^. AllocationCourseAllocation
        E.&&. allocationCourse E.^. AllocationCourseCourse E.==. E.val cid
@@ -557,15 +560,17 @@ postCApplicationsR tid ssh csh = do
     let
       allocationsBounds = [ (allocation, numApps', numFirstChoice', capped)
                           | (Entity _ allocation, E.Value numApps, E.Value numFirstChoice) <- allocationsBounds'
-                          , let numApps' = maybe id min courseCapacity numApps
-                                numFirstChoice' = maybe id min courseCapacity numFirstChoice
+                          , let numApps' = max 0 $ maybe id min remainingCapacity numApps
+                                numFirstChoice' = max 0 $ maybe id min remainingCapacity numFirstChoice
                                 capped = numApps' /= numApps
                                       || numFirstChoice' /= numFirstChoice
                           ]
 
     (, allocationsBounds) <$> dbTableWidget' psValidator DBTable{..}
 
+  now <- liftIO getCurrentTime
   let title = prependCourseTitle tid ssh csh MsgCourseApplicationsListTitle
+      registrationOpen = maybe True (now <)
 
   siteLayoutMsg title $ do
     setTitleI title
diff --git a/src/Handler/Course/Edit.hs b/src/Handler/Course/Edit.hs
index 67913bf09..6347b1d38 100644
--- a/src/Handler/Course/Edit.hs
+++ b/src/Handler/Course/Edit.hs
@@ -303,10 +303,11 @@ validateCourse = do
     prevAllocationCourse <- getBy $ UniqueAllocationCourse cid
     prevAllocation <- fmap join . traverse get $ allocationCourseAllocation . entityVal <$> prevAllocationCourse
 
-    fmap join . for prevAllocation $ \Allocation{allocationStaffRegisterTo} -> if
+    fmap join . for prevAllocation $ \Allocation{allocationStaffAllocationTo, allocationRegisterByCourse} -> if
       | userAdmin
         -> return Nothing
-      | NTop allocationStaffRegisterTo <= NTop (Just now)
+      | NTop allocationStaffAllocationTo <= NTop (Just now)
+      , NTop allocationRegisterByCourse > NTop (Just now)
         -> Just . courseCapacity <$> getJust cid
       | otherwise
         -> return Nothing
diff --git a/templates/course/applications-list.hamlet b/templates/course/applications-list.hamlet
index 9e3adb337..9cb6253fc 100644
--- a/templates/course/applications-list.hamlet
+++ b/templates/course/applications-list.hamlet
@@ -2,7 +2,7 @@ $newline never
 $if not (null allocationsBounds)
   <h2>_{MsgCourseAllocationsBounds (length allocationsBounds)}
   <dl .deflist>
-    $forall (Allocation{allocationName}, numApps, numFirstChoice, capped) <- allocationsBounds
+    $forall (Allocation{allocationName, allocationRegisterTo}, numApps, numFirstChoice, capped) <- allocationsBounds
       <dt .deflist__dt>
         #{allocationName}
       <dd .deflist__dd>
@@ -12,8 +12,11 @@ $if not (null allocationsBounds)
           $else
             _{MsgCourseAllocationsBound numApps numFirstChoice}
         $if capped
-          <p>
+          <p .bound_explanation>
             _{MsgCourseAllocationsBoundCapped}
+        $if registrationOpen allocationRegisterTo
+          <p .bound_explanation>
+            _{MsgCourseAllocationsBoundWarningOpen}
 
 <h2>_{MsgMenuCourseApplications}
 ^{table}
diff --git a/templates/course/applications-list.lucius b/templates/course/applications-list.lucius
new file mode 100644
index 000000000..55579838c
--- /dev/null
+++ b/templates/course/applications-list.lucius
@@ -0,0 +1,4 @@
+.bound_explanation {
+  color: var(--color-fontsec);
+  font-style: italic;
+}