From 26f8f392a96893bc3c97f1c2212a9c71f0a610f7 Mon Sep 17 00:00:00 2001
From: Gregor Kleen <gregor.kleen@ifi.lmu.de>
Date: Thu, 12 Mar 2020 11:56:26 +0100
Subject: [PATCH] feat(allocations): improve display

---
 .gitignore                                    |   1 +
 frontend/src/app.sass                         |   2 +-
 src/Handler/Allocation/Users.hs               |   6 +-
 src/Handler/Utils/Table/Pagination.hs         |   5 +-
 src/Model/Types/Allocation.hs                 |  29 +++-
 .../de-de-formal.hamlet                       |  13 +-
 test/Database/Fill.hs                         | 141 ++++++++++++++++--
 7 files changed, 175 insertions(+), 22 deletions(-)

diff --git a/.gitignore b/.gitignore
index f90d75d56..e0ed9bbe2 100644
--- a/.gitignore
+++ b/.gitignore
@@ -40,3 +40,4 @@ tunnel.log
 /well-known
 /.well-known-cache
 /**/tmp-*
+/testdata/bigAlloc_*.csv
diff --git a/frontend/src/app.sass b/frontend/src/app.sass
index 3222acdcc..ab75944e7 100644
--- a/frontend/src/app.sass
+++ b/frontend/src/app.sass
@@ -1176,7 +1176,7 @@ a.breadcrumbs__home
   font-size: 14px
   font-family: monospace
 
-.func-field__wrapper
+.func-field__wrapper, .allocation-missing-prios
   max-height: 75vh
   overflow: auto
 
diff --git a/src/Handler/Allocation/Users.hs b/src/Handler/Allocation/Users.hs
index 914bd3f59..564e35d5a 100644
--- a/src/Handler/Allocation/Users.hs
+++ b/src/Handler/Allocation/Users.hs
@@ -156,7 +156,7 @@ postAUsersR tid ssh ash = do
             , guardOn resultsDone . coursesModalAssigned . bool id assignedHeated resultsDone $ colAllocationAssigned resultAssignedCourses
             , coursesModalNewAssigned . assignedHeated <$> do
                 allocMatching' <- allocMatching
-                pure . sortable Nothing (i18nCell MsgAllocationUserNewMatches) .
+                pure . sortable (Just "new-assigned") (i18nCell MsgAllocationUserNewMatches) .
                   views (resultUser . _entityKey) $ \uid -> cell . toWidget . toMarkup . maybe 0 olength $ allocMatching' !? uid
             , pure $ emptyOpticColonnade' emptyPriorityCell (resultAllocationUser . _entityVal . _allocationUserPriority . _Just) colAllocationPriority
             ]
@@ -211,6 +211,8 @@ postAUsersR tid ssh ash = do
             , sortAllocationRequested $ queryAllocationUser . to (E.^. AllocationUserTotalCourses)
             , sortAllocationVetoed queryVetoedCourses
             , sortAllocationPriority $ queryAllocationUser . to (E.^. AllocationUserPriority)
+            , singletonMap "new-assigned" $
+                SortProjected . comparing $ (\uid -> maybe 0 olength $ Map.lookup uid =<< allocMatching) . view (resultUser . _entityKey)
             ]
           dbtFilter = mconcat
             [ fltrUserName' $ queryUser . to (E.^. UserDisplayName)
@@ -237,7 +239,7 @@ postAUsersR tid ssh ash = do
           dbtCsvDecode = Nothing
       allocationUsersDBTableValidator = def
         & defaultSorting [SortAscBy "priority", SortAscBy "user-matriculation"]
-        & defaultPagesize PagesizeAll
+        & defaultPagesize (PagesizeLimit 500)
 
     usersTable <- dbTableDB' allocationUsersDBTableValidator allocationUsersDBTable
 
diff --git a/src/Handler/Utils/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs
index 816521ec0..f9fe0b669 100644
--- a/src/Handler/Utils/Table/Pagination.hs
+++ b/src/Handler/Utils/Table/Pagination.hs
@@ -1021,6 +1021,7 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
         case previousKeys of
           Nothing
             | PagesizeLimit l <- psLimit'
+            , selectPagesize
               -> do
                 E.limit l
                 E.offset (psPage * l)
@@ -1236,7 +1237,9 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
     _other      -> return ()
 
   let
-    rowCount = olength64 rows
+    rowCount
+      | selectPagesize = fromMaybe 0 $ rows' ^? _head . _1 . _Value
+      | otherwise = olength64 rows
 
     rawAction = tblLink
       $ setParam (wIdent "sorting") Nothing
diff --git a/src/Model/Types/Allocation.hs b/src/Model/Types/Allocation.hs
index b918deab0..f03b5ce69 100644
--- a/src/Model/Types/Allocation.hs
+++ b/src/Model/Types/Allocation.hs
@@ -4,6 +4,8 @@ module Model.Types.Allocation
   , AllocationPriorityComparison(..)
   , AllocationFingerprint
   , module Utils.Allocation
+  , AllocationPriorityNumericRecord(..)
+  , allocationPriorityNumericMap
   ) where
 
 import Import.NoModel
@@ -44,13 +46,36 @@ deriving via E.JSONB AllocationPriority instance E.PersistFieldSql AllocationPri
 
 instance Binary AllocationPriority
 
-instance Csv.FromRecord (Map UserMatriculation AllocationPriority) where
+data AllocationPriorityNumericRecord = AllocationPriorityNumericRecord
+  { apmrMatrikelnummer :: UserMatriculation
+  , apmrPriority :: Vector Integer
+  } deriving (Eq, Ord, Read, Show, Generic, Typeable)
+
+allocationPriorityNumericMap :: Prism' (Map UserMatriculation AllocationPriority) AllocationPriorityNumericRecord
+allocationPriorityNumericMap = prism' fromPrioRecord toPrioRecord
+  where
+    fromPrioRecord AllocationPriorityNumericRecord{..}
+      = Map.singleton apmrMatrikelnummer $ AllocationPriorityNumeric apmrPriority
+
+    toPrioRecord recordMap = do
+      [(matr, AllocationPriorityNumeric{..})] <- pure $ Map.toList recordMap
+      return $ AllocationPriorityNumericRecord matr allocationPriorities
+
+instance Csv.FromRecord AllocationPriorityNumericRecord where
   parseRecord v = parseNumeric
     where
       parseNumeric
-        | Vector.length v >= 1 = Map.singleton <$> v Csv..! 0 <*> (AllocationPriorityNumeric <$> mapM Csv.parseField (Vector.tail v))
+        | Vector.length v >= 1 = AllocationPriorityNumericRecord <$> v Csv..! 0 <*> mapM Csv.parseField (Vector.tail v)
         | otherwise = mzero
 
+instance Csv.ToRecord AllocationPriorityNumericRecord where
+  toRecord AllocationPriorityNumericRecord{..} = Csv.record $
+      Csv.toField apmrMatrikelnummer
+    : map Csv.toField (otoList apmrPriority)
+
+instance Csv.FromRecord (Map UserMatriculation AllocationPriority) where
+  parseRecord = fmap (review allocationPriorityNumericMap) . Csv.parseRecord
+
 
 instance Csv.ToField AllocationPriority where
   toField (AllocationPriorityOrdinal n ) = Csv.toField n
diff --git a/templates/i18n/allocation-confirm-missing-prios/de-de-formal.hamlet b/templates/i18n/allocation-confirm-missing-prios/de-de-formal.hamlet
index 16ed09324..467be35e7 100644
--- a/templates/i18n/allocation-confirm-missing-prios/de-de-formal.hamlet
+++ b/templates/i18n/allocation-confirm-missing-prios/de-de-formal.hamlet
@@ -2,12 +2,13 @@ $newline never
 <p>
   Die folgenden Benutzer nehmen nicht an der Zentralvergabe teil, da #
   ihnen keine zentrale Dringlichkeit zugeordnet wurde:
-<ul>
-  $forall User{userDisplayName, userSurname, userMatrikelnummer} <- usersWithoutPrio
-    <li>
-      ^{nameWidget userDisplayName userSurname}
-      $maybe matrikel <- userMatrikelnummer
-        \ (#{matrikel})
+<div .allocation-missing-prios>
+  <ul>
+    $forall User{userDisplayName, userSurname, userMatrikelnummer} <- usersWithoutPrio
+      <li>
+        ^{nameWidget userDisplayName userSurname}
+        $maybe matrikel <- userMatrikelnummer
+          \ (#{matrikel})
 ^{checkBoxFieldView}
 <p>
   Benutzern, die nicht an der Zentralvergabe teilnehmen, werden #
diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs
index c6e2c17ee..26a0399fb 100644
--- a/test/Database/Fill.hs
+++ b/test/Database/Fill.hs
@@ -5,8 +5,10 @@ module Database.Fill
 import "uniworx" Import hiding (Option(..), currentYear)
 
 import qualified Data.ByteString as BS
+import qualified Data.ByteString.Lazy as LBS
 
 import qualified Data.Set as Set
+import qualified Data.Map as Map
 
 import Data.Time.Calendar.OrdinalDate
 import Data.Time.Calendar.WeekDate
@@ -15,14 +17,21 @@ import Control.Applicative (ZipList(..))
 
 import Handler.Utils.DateTime
 
+import Control.Monad.Random.Class (weighted)
 import System.Random.Shuffle (shuffleM)
 
 import qualified Data.CaseInsensitive as CI
 
+import qualified Data.Csv as Csv
+
+
+testdataDir :: FilePath
+testdataDir = "testdata"
+
   
 insertFile :: FilePath -> DB FileId
 insertFile fileTitle = do
-  fileContent <- liftIO . fmap Just . BS.readFile $ "testdata" </> fileTitle
+  fileContent <- liftIO . fmap Just . BS.readFile $ testdataDir </> fileTitle
   fileModified <- liftIO getCurrentTime
   insert File{..}
 
@@ -267,6 +276,7 @@ fillDb = do
                  , "Clark", "Lewis", "Robinson", "Walker"
                  , "Perez", "Hall", "Young", "Allen"
                  ]
+    middlenames = [ Nothing, Just "Jamesson" ]
     toMatrikel :: [Int] -> [Text]
     toMatrikel ns
       | (cs, rest) <- splitAt 8 ns
@@ -274,7 +284,7 @@ fillDb = do
       = foldMap tshow cs : toMatrikel rest
       | otherwise
       = []
-    manyUser (userFirstName, userSurname) (Just -> userMatrikelnummer) = User
+    manyUser (firstName, middleName, userSurname) (Just -> userMatrikelnummer) = User
       { userIdent
       , userAuthentication = AuthLDAP
       , userLastAuthentication = Nothing
@@ -282,9 +292,11 @@ fillDb = do
       , userMatrikelnummer
       , userEmail = userIdent
       , userDisplayEmail = userIdent
-      , userDisplayName = [st|#{userFirstName} #{userSurname}|]
+      , userDisplayName = case middleName of
+          Just middleName' -> [st|#{firstName} #{middleName'} #{userSurname}|]
+          Nothing          -> [st|#{firstName} #{userSurname}|]
       , userSurname
-      , userFirstName
+      , userFirstName = maybe id (\m f -> f <> " " <> m) middleName firstName
       , userTitle = Nothing
       , userMaxFavourites = userDefaultMaxFavourites
       , userMaxFavouriteTerms = userDefaultMaxFavourites
@@ -304,9 +316,11 @@ fillDb = do
       }
       where
         userIdent :: IsString t => t
-        userIdent = fromString $ repack [st|#{userFirstName}.#{userSurname}@campus.lmu.de|]
+        userIdent = fromString $ case middleName of
+          Just middleName' -> repack [st|#{firstName}.#{middleName'}.#{userSurname}@example.invalid|]
+          Nothing          -> repack [st|#{firstName}.#{userSurname}@example.invalid|]
   matrikel <- toMatrikel <$> getRandomRs (0 :: Int, 9 :: Int)
-  manyUsers <- insertMany . getZipList $ manyUser <$> ZipList ((,) <$> firstNames <*> surnames) <*> ZipList matrikel
+  manyUsers <- insertMany . getZipList $ manyUser <$> ZipList ((,,) <$> firstNames <*> middlenames <*> surnames) <*> ZipList matrikel
   
   forM_ [prevPrevTerm, prevTerm, currentTerm, nextTerm] $ \term@TermIdentifier{..} -> case season of
     Summer -> let (wYearStart, wWeekStart, _) = toWeekDate $ fromGregorian year 04 01
@@ -933,7 +947,7 @@ fillDb = do
   insert_ $ CourseEdit gkleen now bs
   void . insert' $ Lecturer gkleen bs CourseLecturer
   void . insertMany $ do
-    uid <- manyUsers
+    uid <- take 1024 manyUsers
     return $ CourseParticipant bs uid now Nothing Nothing
   forM_ [1..14] $ \shNr -> do
     shId <- insert Sheet
@@ -951,7 +965,7 @@ fillDb = do
       , sheetSolutionFrom = Nothing
       , sheetAutoDistribute = False
       }
-    manyUsers' <- shuffleM manyUsers
+    manyUsers' <- shuffleM $ take 1024 manyUsers
     groupSizes <- getRandomRs (1, 3)
     let groups = go groupSizes manyUsers'
           where go []     _  = []
@@ -998,9 +1012,116 @@ fillDb = do
       , courseApplicationsRatingsVisible = False
       }
     insert_ $ CourseEdit gkleen now cid
-    void . insert' $ Lecturer gkleen cid CourseLecturer
+    -- void . insert' $ Lecturer gkleen cid CourseLecturer
 
     participants <- getRandomR (0, 50)
-    manyUsers' <- shuffleM manyUsers
+    manyUsers' <- shuffleM $ take 1024 manyUsers
     forM_ (take participants manyUsers') $ \uid ->
       void . insert $ CourseParticipant cid uid now Nothing Nothing
+  
+  bigAlloc <- insert' Allocation
+    { allocationName = "Große Zentralanmeldung"
+    , allocationShorthand = "big"
+    , allocationTerm = TermKey $ seasonTerm True Summer
+    , allocationSchool = ifi
+    , allocationDescription = Nothing
+    , allocationStaffDescription = Nothing
+    , allocationStaffRegisterFrom = Nothing
+    , allocationStaffRegisterTo = Nothing
+    , allocationStaffAllocationFrom = Nothing
+    , allocationStaffAllocationTo = Nothing
+    , allocationRegisterFrom = Nothing
+    , allocationRegisterTo = Just now
+    , allocationRegisterByStaffFrom = Nothing
+    , allocationRegisterByStaffTo = Nothing
+    , allocationRegisterByCourse = Nothing
+    , allocationOverrideDeregister = Just $ termTime True Summer 1 False Monday toMidnight
+    }
+  bigAllocCourses <- forM ([1..40] :: [Int]) $ \n -> do
+    csh <- pack . take 3 <$> getRandomRs ('A', 'Z')
+
+    cap <- getRandomR (10,50)
+
+    minCap <- round . (* fromIntegral cap) <$> getRandomR (0, 0.5 :: Double)
+    
+    cid <- insert' Course
+      { courseName = CI.mk [st|Zentralanmeldungskurs #{n} (#{csh})|]
+      , courseDescription = Nothing
+      , courseLinkExternal = Nothing
+      , courseShorthand = CI.mk csh
+      , courseTerm = TermKey $ seasonTerm False Winter
+      , courseSchool = ifi
+      , courseCapacity = Just cap
+      , courseRegisterFrom = Nothing
+      , courseRegisterTo = Nothing
+      , courseDeregisterUntil = Nothing
+      , courseRegisterSecret  = Nothing
+      , courseMaterialFree    = True
+      , courseApplicationsRequired = False
+      , courseApplicationsInstructions = Nothing
+      , courseApplicationsText = False
+      , courseApplicationsFiles = NoUpload
+      , courseApplicationsRatingsVisible = False
+      }
+    insert_ $ CourseEdit gkleen now cid
+    insert_ $ AllocationCourse bigAlloc cid minCap
+    -- void . insert' $ Lecturer gkleen cid CourseLecturer
+    return cid
+
+  forM_ manyUsers $ \uid -> do
+    totalCourses <- weighted $ do
+      n <- [1..10]
+      return (n, fromIntegral $ (1 - 10) ^ 2 - (1 - n) ^ 2)
+
+    void . insert $ AllocationUser bigAlloc uid (fromIntegral totalCourses) Nothing
+
+    appliedCourses <- weighted $ do
+      n <- [totalCourses - 2..totalCourses + 5]
+      return (n, fromIntegral $ (totalCourses + 1 - totalCourses - 5) ^ 2 - (totalCourses + 1 - n) ^ 2)
+
+    appliedCourses' <- take appliedCourses <$> shuffleM bigAllocCourses
+
+    forM_ (zip [0..] appliedCourses') $ \(prio, cid) -> do
+      rating <- weighted . Map.toList . Map.fromListWith (+) $ do
+        veto <- universeF :: [Bool]
+        grade <- universeF :: [ExamGrade]
+        rated <- universeF
+
+        return ( bool Nothing (Just (veto, grade)) rated
+               , bool 5 1 veto * bool 5 1 rated
+               )
+
+      void $ insert CourseApplication
+        { courseApplicationCourse = cid
+        , courseApplicationUser = uid
+        , courseApplicationField = Nothing
+        , courseApplicationText = Nothing
+        , courseApplicationRatingVeto = maybe False (view _1) rating
+        , courseApplicationRatingPoints = view _2 <$> rating
+        , courseApplicationRatingComment = Nothing
+        , courseApplicationAllocation = Just bigAlloc
+        , courseApplicationAllocationPriority = Just prio
+        , courseApplicationTime = now
+        , courseApplicationRatingTime = now <$ rating
+        }
+
+  numericPriorities <- flip foldMapM manyUsers $ \uid -> do
+    uRec <- get uid
+    case uRec of
+      Just User{ userMatrikelnummer = Just matr } -> do
+        prios <- replicateM 3 $ getRandomR (0, 300)
+        return . pure . AllocationPriorityNumericRecord matr . fromList $ sortOn Down prios
+      _other -> return mempty
+
+  liftIO . LBS.writeFile (testdataDir </> "bigAlloc_numeric.csv") $ Csv.encode numericPriorities
+
+  ordinalPriorities <- do
+    manyUsers' <- shuffleM manyUsers
+    flip foldMapM manyUsers' $ \uid -> do
+      uRec <- get uid
+      case uRec of
+        Just User{ userMatrikelnummer = Just matr } ->
+          return . pure $ Csv.Only matr
+        _other -> return mempty
+  
+  liftIO . LBS.writeFile (testdataDir </> "bigAlloc_ordinal.csv") $ Csv.encode ordinalPriorities