fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

feat(allocations): improve acceptance display

Browse Source
This commit is contained in:
Gregor Kleen 2020-03-14 14:15:29 +01:00
parent 648d733f3f
commit cf03277874
10 changed files with 97 additions and 22 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
.gitignore vendored
View File

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

2
db.sh
View File

@ -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 -- $@

6
frontend/src/app.sass
View File

@ -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

2
messages/uniworx/de-de-formal.msg
View File

@ -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}

4
src/Application.hs
View File

@ -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

9
src/Handler/Allocation/Accept.hs
View File

@ -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
= 2 - coHeat capN allocated * 2
| otherwise
= 2 - dualHeat (optimumAllocated capN) capN allocated
= invDualHeat (optimumAllocated capN) capN allocated
degenerateHeat capN
= capN <= optimumAllocated capN
return (prevAllocMatches, $(widgetFile "allocation/accept"))

34
src/Handler/Allocation/Users.hs
View File

@ -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
, coursesModalNewAssigned . assignedHeated <$> do
, guardOn resultsDone . coursesModalAssigned . bool id (assignedHeated $ view resultAssignedCourses) resultsDone $ colAllocationAssigned resultAssignedCourses
, coursesModalNewAssigned <$> do
allocMatching' <- allocMatching
pure . sortable (Just "new-assigned") (i18nCell MsgAllocationUserNewMatches) .
views (resultUser . _entityKey) $ \uid -> cell . toWidget . toMarkup . maybe 0 olength $ allocMatching' !? uid
let newAssigned uid = 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

43
src/Handler/Utils/Widgets.hs
View File

@ -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

10
templates/allocation/accept.hamlet
View File

@ -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

8
templates/table/cell/allocation-courses.hamlet
View File

@ -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 _