From bb20062d9f8fd7169b7dd6f7d14e82d244af83b2 Mon Sep 17 00:00:00 2001
From: Gregor Kleen <gregor.kleen@ifi.lmu.de>
Date: Wed, 11 Mar 2020 14:48:02 +0100
Subject: [PATCH] feat(allocations): display new allocations in user table

---
 messages/uniworx/de-de-formal.msg |  1 +
 src/Handler/Allocation/Users.hs   | 39 +++++++++++++++++++++----------
 2 files changed, 28 insertions(+), 12 deletions(-)

diff --git a/messages/uniworx/de-de-formal.msg b/messages/uniworx/de-de-formal.msg
index 80a9bd0b2..54089ced3 100644
--- a/messages/uniworx/de-de-formal.msg
+++ b/messages/uniworx/de-de-formal.msg
@@ -2419,5 +2419,6 @@ AllocationUnmatchedCourses: Kurse ohne zugeteilte Teilnehmer
 AllocationTime: Zeitpunkt der Vergabe
 AllocationRequestedPlaces: Angefragte Plätze
 AllocationOfferedPlaces: Angebotene Plätze
+AllocationUserNewMatches: Neue Zuteilungen
 
 CourseOption tid@TermId ssh@SchoolId coursen@CourseName: #{tid} - #{ssh} - #{coursen}
\ No newline at end of file
diff --git a/src/Handler/Allocation/Users.hs b/src/Handler/Allocation/Users.hs
index a99bd703c..914bd3f59 100644
--- a/src/Handler/Allocation/Users.hs
+++ b/src/Handler/Allocation/Users.hs
@@ -6,7 +6,7 @@ module Handler.Allocation.Users
 
 import Import
 
-import Handler.Allocation.Accept (allocationAcceptForm, AllocationAcceptButton(..))
+import Handler.Allocation.Accept
 
 import Handler.Utils
 import Handler.Utils.Allocation
@@ -16,6 +16,12 @@ import qualified Database.Esqueleto.Utils as E
 
 import qualified Data.Csv as Csv
 
+import Data.Map ((!?))
+import qualified Data.Map as Map
+import qualified Data.Set as Set
+
+import Text.Blaze (toMarkup)
+
 
 type UserTableExpr = E.SqlExpr (Entity User)
        `E.InnerJoin` E.SqlExpr (Entity AllocationUser)
@@ -108,6 +114,10 @@ postAUsersR tid ssh ash = do
   (usersTable, acceptForm) <- runDB $ do
     Entity aId _ <- getBy404 $ TermSchoolAllocationShort tid ssh ash
     resultsDone <- is _Just <$> allocationStarted aId
+    allocMatching <- runMaybeT $ do
+      SessionDataAllocationResults allocMap <- MaybeT $ lookupSessionJson SessionAllocationResults
+      allocMatching <- fmap (view _3) . hoistMaybe $ allocMap !? (tid, ssh, ash)
+      return $ Map.fromListWith (<>) [ (uid, opoint cid) | (uid, cid) <- Set.toList allocMatching ] :: _ (Map UserId (NonNull (Set CourseId)))
 
     csvName <- getMessageRender <*> pure (MsgAllocationUsersCsvName tid ssh ash)
 
@@ -137,21 +147,23 @@ postAUsersR tid ssh ash = do
             (,,,,)
               <$> view _1 <*> view _2 <*> view (_3 . _Value) <*> view (_4 . _Value) <*> view (_5 . _Value)
           dbtColonnade :: Colonnade Sortable _ _
-          dbtColonnade = mconcat
-            [ colUserDisplayName $ resultUser . _entityVal . $(multifocusL 2) _userDisplayName _userSurname
-            , colUserMatriculation $ resultUser . _entityVal . _userMatrikelnummer
-            , colAllocationRequested $ resultAllocationUser . _entityVal . _allocationUserTotalCourses
-            , coursesModalApplied $ colAllocationApplied resultAppliedCourses
-            , coursesModalVetoed $ colAllocationVetoed resultVetoedCourses
-            , coursesModalAssigned . assignedHeated $ colAllocationAssigned resultAssignedCourses
-            , emptyOpticColonnade' emptyPriorityCell (resultAllocationUser . _entityVal . _allocationUserPriority . _Just) colAllocationPriority
+          dbtColonnade = mconcat . catMaybes $
+            [ pure $ colUserDisplayName (resultUser . _entityVal . $(multifocusL 2) _userDisplayName _userSurname)
+            , pure $ colUserMatriculation (resultUser . _entityVal . _userMatrikelnummer)
+            , pure $ colAllocationRequested (resultAllocationUser . _entityVal . _allocationUserTotalCourses)
+            , pure . coursesModalApplied $ colAllocationApplied resultAppliedCourses
+            , pure . coursesModalVetoed $ colAllocationVetoed resultVetoedCourses
+            , guardOn resultsDone . coursesModalAssigned . bool id assignedHeated resultsDone $ colAllocationAssigned resultAssignedCourses
+            , coursesModalNewAssigned . assignedHeated <$> do
+                allocMatching' <- allocMatching
+                pure . sortable Nothing (i18nCell MsgAllocationUserNewMatches) .
+                  views (resultUser . _entityKey) $ \uid -> cell . toWidget . toMarkup . maybe 0 olength $ allocMatching' !? uid
+            , pure $ emptyOpticColonnade' emptyPriorityCell (resultAllocationUser . _entityVal . _allocationUserPriority . _Just) colAllocationPriority
             ]
             where
               emptyPriorityCell = addCellClass ("table__td--center" :: Text) . cell $
                 messageTooltip =<< messageIconI Error IconMissingAllocationPriority MsgAllocationMissingPrioritiesIgnored
-              assignedHeated
-                | resultsDone = imapColonnade assignedHeated'
-                | otherwise   = id
+              assignedHeated = imapColonnade assignedHeated'
                 where
                   assignedHeated' res
                     = let maxAssign = min (res ^. resultAllocationUser . _entityVal . _allocationUserTotalCourses . to fromIntegral)
@@ -179,6 +191,9 @@ postAUsersR tid ssh ash = do
                 E.where_ $ courseParticipant E.^. CourseParticipantUser E.==. E.val (res ^. resultUser . _entityKey)
                 E.orderBy [E.asc $ courseParticipant E.^. CourseParticipantRegistration]
                 return course
+              coursesModalNewAssigned = coursesModal $ \res -> E.from $ \course -> do
+                E.where_ $ course E.^. CourseId `E.in_` E.valList (maybe [] otoList $ Map.lookup (res ^. resultUser . _entityKey) =<< allocMatching)
+                return course
               coursesModal courseSel = imapColonnade coursesModal'
                 where
                   coursesModal' res innerCell = review dbCell . (innerCell ^. cellAttrs, ) $ do