feat(allocations): improve acceptance display

.gitignore

@@ -41,3 +41,4 @@ tunnel.log
 /.well-known-cache
 /**/tmp-*
 /testdata/bigAlloc_*.csv
+/sessions

db.sh

@@ -6,4 +6,6 @@ set -e
 [ "${FLOCKER}" != "$0" ] && exec env FLOCKER="$0" flock -en .stack-work.lock "$0" "$@" || :
 
 stack build --fast --flag uniworx:-library-only --flag uniworx:dev
+
+export SERVER_SESSION_ACID_FALLBACK=${SERVER_SESSION_ACID_FALLBACK:-true}
 stack exec uniworxdb -- $@

frontend/src/app.sass

@@ -674,6 +674,12 @@ section
    background-color: hsla($hue, 75%, 50%, $opacity) !important
    font-weight: calc(((var(--hotness) - 1) * (var(--hotness) - 1)) * 200 + 400)
 
+   .degenerate
+     $hue: calc(240 + var(--hotness) * 60)
+   
+     background-color: hsla($hue, 75%, 50%, $opacity) !important
+
+
 .uuid
   font-family: monospace
 

messages/uniworx/de-de-formal.msg

@@ -2420,5 +2420,7 @@ AllocationTime: Zeitpunkt der Vergabe
 AllocationRequestedPlaces: Angefragte Plätze
 AllocationOfferedPlaces: Angebotene Plätze
 AllocationUserNewMatches: Neue Zuteilungen
+AllocationUsersCount: Teilnehmer
+AllocationCoursesCount: Kurse
 
 CourseOption tid@TermId ssh@SchoolId coursen@CourseName: #{tid} - #{ssh} - #{coursen}

src/Application.hs

@@ -88,7 +88,7 @@ import qualified Data.Set as Set
 
 import Handler.Utils.Routes (classifyHandler)
 
-import qualified Data.Acid.Memory as Acid
+import qualified Data.Acid as Acid
 import qualified Web.ServerSession.Backend.Acid as Acid
 
 -- Import all relevant handler modules here.
@@ -250,7 +250,7 @@ mkSessionStore AppSettings{..} mcdSqlConnPool
       let mcdSqlMemcachedExpiration = memcachedExpiry
       return $ _SessionStorageMemcachedSql # MemcachedSqlStorage{..}
   | appServerSessionAcidFallback = liftIO $
-      review _SessionStorageAcid . Acid.AcidStorage <$> Acid.openMemoryState Acid.emptyState
+      review _SessionStorageAcid . Acid.AcidStorage <$> Acid.openLocalStateFrom "sessions" Acid.emptyState
   | otherwise = throwM SessionStoreNotAvailable
 
 

src/Handler/Allocation/Accept.hs

@@ -95,7 +95,7 @@ allocationAcceptForm aId = runMaybeT $ do
                                           , Map.delete cid allocCounts
                                           ))
                                 ([] , courseAllocations) allocationCourses
-     in guardOn (null leftoverAllocs) res :: Maybe [((Entity AllocationCourse, Entity Course, Int), Integer)]
+     in guardOn (null leftoverAllocs) res :: Maybe [((Entity AllocationCourse, Entity Course, Int), Int)]
 
   let unmatchedCourses = olength $ filter ((<= 0) . view _2) allocationCourses'
 
@@ -123,10 +123,9 @@ allocationAcceptForm aId = runMaybeT $ do
                 | allocationCapacity == 0 = 0
                 | otherwise = fromIntegral allocationPlacesRequested % fromIntegral allocationCapacity
       allocHeat capN allocated
-        | optimumAllocated capN >= capN
+        = invDualHeat (optimumAllocated capN) capN allocated
-        = 2 - coHeat capN allocated * 2
+      degenerateHeat capN
-        | otherwise
+        = capN <= optimumAllocated capN
-        = 2 - dualHeat (optimumAllocated capN) capN allocated
       
     return (prevAllocMatches, $(widgetFile "allocation/accept"))
 

src/Handler/Allocation/Users.hs

@@ -153,22 +153,23 @@ postAUsersR tid ssh ash = do
             , pure $ colAllocationRequested (resultAllocationUser . _entityVal . _allocationUserTotalCourses)
             , pure . coursesModalApplied $ colAllocationApplied resultAppliedCourses
             , pure . coursesModalVetoed $ colAllocationVetoed resultVetoedCourses
-            , guardOn resultsDone . coursesModalAssigned . bool id assignedHeated resultsDone $ colAllocationAssigned resultAssignedCourses
+            , guardOn resultsDone . coursesModalAssigned . bool id (assignedHeated $ view resultAssignedCourses) resultsDone $ colAllocationAssigned resultAssignedCourses
-            , coursesModalNewAssigned . assignedHeated <$> do
+            , coursesModalNewAssigned <$> do
                 allocMatching' <- allocMatching
-                pure . sortable (Just "new-assigned") (i18nCell MsgAllocationUserNewMatches) .
+                let newAssigned uid = maybe 0 olength $ allocMatching' !? uid
-                  views (resultUser . _entityKey) $ \uid -> cell . toWidget . toMarkup . maybe 0 olength $ allocMatching' !? uid
+                pure . assignedHeated (views (resultUser . _entityKey) newAssigned) . sortable (Just "new-assigned") (i18nCell MsgAllocationUserNewMatches) .
+                  views (resultUser . _entityKey) $ cell . toWidget . toMarkup . newAssigned
             , pure $ emptyOpticColonnade' emptyPriorityCell (resultAllocationUser . _entityVal . _allocationUserPriority . _Just) colAllocationPriority
             ]
             where
               emptyPriorityCell = addCellClass ("table__td--center" :: Text) . cell $
                 messageTooltip =<< messageIconI Error IconMissingAllocationPriority MsgAllocationMissingPrioritiesIgnored
-              assignedHeated = imapColonnade assignedHeated'
+              assignedHeated fAssigned = imapColonnade assignedHeated'
                 where
                   assignedHeated' res
                     = let maxAssign = min (res ^. resultAllocationUser . _entityVal . _allocationUserTotalCourses . to fromIntegral)
                                           (res ^. resultAppliedCourses)
-                          assigned = maxAssign - res ^. resultAssignedCourses
+                          assigned = fAssigned res
                        in cellAttrs <>~ [ ("class", "heated")
                                         , ("style", [st|--hotness: #{tshow (coHeat maxAssign assigned)}|])
                                         ]
@@ -177,23 +178,36 @@ postAUsersR tid ssh ash = do
                 E.where_ $ courseApplication E.^. CourseApplicationAllocation E.==. E.val (Just aId)
                      E.&&. courseApplication E.^. CourseApplicationUser E.==. E.val (res ^. resultUser . _entityKey)
                 E.orderBy [E.desc $ courseApplication E.^. CourseApplicationAllocationPriority]
-                return course
+                return ( course
+                       , courseApplication E.^. CourseApplicationRatingPoints
+                       , E.just $ courseApplication E.^. CourseApplicationRatingVeto
+                       )
               coursesModalVetoed = coursesModal $ \res -> E.from $ \(course `E.InnerJoin` courseApplication) -> do
                 E.on $ course E.^. CourseId E.==. courseApplication E.^. CourseApplicationCourse
                 E.where_ $ courseApplication E.^. CourseApplicationAllocation E.==. E.val (Just aId)
                      E.&&. courseApplication E.^. CourseApplicationUser E.==. E.val (res ^. resultUser . _entityKey)
                 E.where_ $ courseApplication E.^. CourseApplicationRatingVeto
                      E.||. courseApplication E.^. CourseApplicationRatingPoints `E.in_` E.valList (map Just $ filter (view $ passingGrade . _Wrapped . to not) universeF)
-                return course
+                return ( course
+                       , E.nothing
+                       , E.nothing
+                       )
               coursesModalAssigned = coursesModal $ \res -> E.from $ \(course `E.InnerJoin` courseParticipant) -> do
                 E.on $ courseParticipant E.^. CourseParticipantCourse E.==. course E.^. CourseId
                  E.&&. courseParticipant E.^. CourseParticipantAllocated E.==. E.val (Just aId)
                 E.where_ $ courseParticipant E.^. CourseParticipantUser E.==. E.val (res ^. resultUser . _entityKey)
                 E.orderBy [E.asc $ courseParticipant E.^. CourseParticipantRegistration]
-                return course
+                return ( course
+                       , E.nothing
+                       , E.nothing
+                       )
               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
+                return ( course
+                       , E.nothing
+                       , E.nothing
+                       )
+              coursesModal :: (_ -> E.SqlQuery (E.SqlExpr (Entity Course), E.SqlExpr (E.Value (Maybe ExamGrade)), E.SqlExpr (E.Value (Maybe Bool)))) -> _ -> _
               coursesModal courseSel = imapColonnade coursesModal'
                 where
                   coursesModal' res innerCell = review dbCell . (innerCell ^. cellAttrs, ) $ do

src/Handler/Utils/Widgets.hs

@@ -97,20 +97,57 @@ editedByW fmt tm usr  = do
 
 heat :: ( Real a, Real b )
      => a -> b -> Milli
+-- ^ Distinguishes @full@, zero is mapped to 1, @full@ is mapped to 0
 heat (realToFrac -> full) (realToFrac -> achieved)
-  = fromRational $ cutOffCoPercent 0.3 (full^2) (achieved^2) --
+  = fromRational $ cutOffCoPercent 0.3 (full^2) (achieved^2)
+  
+invHeat :: ( Real a, Real b )
+        => a -> b -> Milli
+-- ^ Distinguishes @full@, zero is mapped to 0, @full@ is mapped to 1
+invHeat full achieved = 1 - heat full achieved
 
 coHeat :: ( Real a, Real b)
        => a -> b -> Milli
-coHeat (realToFrac -> full) (realToFrac -> achieved)
+-- ^ Distinguishes zero, zero is mapped to 1, @full@ is mapped to 0
+coHeat full achieved = 1 - invCoHeat full achieved
+  
+invCoHeat :: ( Real a, Real b)
+          => a -> b -> Milli
+-- ^ Distinguishes zero, zero is mapped to 0, @full@ is mapped to 1
+invCoHeat (realToFrac -> full) (realToFrac -> achieved)
   = fromRational $ cutOffPercent 0.3 (full^2) (achieved^2)
 
+
 dualHeat :: ( Real a, Real b, Real c )
          => a -> b -> c -> Milli
+-- ^ Distinguishes zero, zero is mapped to 0, @optimal@ is mapped to 1, @full@ is mapped to 2
+--
+-- Falls back to `invCoHeat` if @full <= optimal@
 dualHeat (realToFrac -> optimal) (realToFrac -> full) (realToFrac -> achieved)
-  | achieved <= optimal = fromRational $ cutOffPercent 0.3 (optimal ^ 2) (achieved ^ 2)
+  | full <= optimal     =                2 * invCoHeat full    achieved
+  | achieved <= optimal =                    invCoHeat optimal achieved
   | otherwise           = fromRational $ 1 + cutOffPercent 0 ((full - optimal) ^ 2) ((achieved - optimal) ^ 2)
 
+dualCoHeat :: ( Real a, Real b, Real c )
+           => a -> b -> c -> Milli
+-- ^ Distinguishes @full@, zero is mapped to 0, @optimal@ is mapped to 1, @full@ is mapped to 2
+--
+-- Falls back to `invHeat` if @full <= optimal@
+dualCoHeat (realToFrac -> optimal) (realToFrac -> full) (realToFrac -> achieved)
+  | full <= optimal     =                2 * invHeat full    achieved
+  | achieved <= optimal = fromRational $     cutOffPercent 0 (optimal ^ 2) (achieved ^ 2)
+  | otherwise           =                1 + invHeat (full - optimal) (achieved - optimal)
+
+invDualHeat :: ( Real a, Real b, Real c )
+            => a -> b -> c -> Milli
+-- ^ Distinguishes zero, zero is mapped to 2, @optimal@ is mapped to 1, @full@ is mapped to 0
+invDualHeat optimal full achieved = 2 - dualHeat optimal full achieved
+  
+invDualCoHeat :: ( Real a, Real b, Real c )
+              => a -> b -> c -> Milli
+-- ^ Distinguishes @full@, zero is mapped to 2, @optimal@ is mapped to 1, @full@ is mapped to 0
+invDualCoHeat optimal full achieved = 2 - dualCoHeat optimal full achieved
+
 i18n :: forall m msg.
         ( MonadWidget m
         , RenderMessage (HandlerSite m) msg

templates/allocation/accept.hamlet

@@ -6,6 +6,14 @@ $newline never
   _{MsgComputedAllocation}
   
 <dl .deflist>
+  <dt .deflist__dt>
+    _{MsgAllocationUsersCount}
+  <dd .deflist__dd>
+    #{olength allocationUsers}
+  <dt .deflist__dt>
+    _{MsgAllocationCoursesCount}
+  <dd .deflist__dd>
+    #{olength allocationCourses}
   <dt .deflist__dt>
     _{MsgAllocationRequestedPlaces}
   <dd .deflist__dd>
@@ -76,7 +84,7 @@ $newline never
             <div .table__td-content>
               #{participants}
           $maybe capN <- courseCapacity
-            <td .table__td .dual-heated style="--hotness: #{allocHeat capN allocated}">
+            <td .table__td .dual-heated :degenerateHeat capN:.degenerate style="--hotness: #{allocHeat capN (allocated + participants)}">
               <div .table__td-content>
                 #{allocated}
           $nothing

templates/table/cell/allocation-courses.hamlet

@@ -1,5 +1,11 @@
 $newline never
 <ul>
-  $forall Entity _ Course{courseTerm, courseSchool, courseName} <- courses
+  $forall (Entity _ Course{courseTerm, courseSchool, courseName}, E.Value mbRating, E.Value mbVeto) <- courses
     <li>
       #{courseTerm} - #{courseSchool} - #{courseName}
+      $case (mbRating, mbVeto)
+        $of (_, Just True)
+          \ (_{MsgApplicationVeto})
+        $of (Just g, _)
+          \ (_{g})
+        $of _