diff --git a/.gitignore b/.gitignore index e0ed9bbe2..e91237ad7 100644 --- a/.gitignore +++ b/.gitignore @@ -41,3 +41,4 @@ tunnel.log /.well-known-cache /**/tmp-* /testdata/bigAlloc_*.csv +/sessions \ No newline at end of file diff --git a/db.sh b/db.sh index a66af88ba..afb0e1720 100755 --- a/db.sh +++ b/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 -- $@ diff --git a/frontend/src/app.sass b/frontend/src/app.sass index ab75944e7..3001da5b6 100644 --- a/frontend/src/app.sass +++ b/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 diff --git a/messages/uniworx/de-de-formal.msg b/messages/uniworx/de-de-formal.msg index 54089ced3..854adf135 100644 --- a/messages/uniworx/de-de-formal.msg +++ b/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} \ No newline at end of file diff --git a/src/Application.hs b/src/Application.hs index 918495cc6..1f6587ff4 100644 --- a/src/Application.hs +++ b/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 diff --git a/src/Handler/Allocation/Accept.hs b/src/Handler/Allocation/Accept.hs index 4bc740cbe..62f821ca8 100644 --- a/src/Handler/Allocation/Accept.hs +++ b/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 - = 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")) diff --git a/src/Handler/Allocation/Users.hs b/src/Handler/Allocation/Users.hs index 564e35d5a..c44c10ad1 100644 --- a/src/Handler/Allocation/Users.hs +++ b/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 - , 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 diff --git a/src/Handler/Utils/Widgets.hs b/src/Handler/Utils/Widgets.hs index e09b98142..1e1f1ea76 100644 --- a/src/Handler/Utils/Widgets.hs +++ b/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 diff --git a/templates/allocation/accept.hamlet b/templates/allocation/accept.hamlet index 1e7c01b0d..fad573c3e 100644 --- a/templates/allocation/accept.hamlet +++ b/templates/allocation/accept.hamlet @@ -6,6 +6,14 @@ $newline never _{MsgComputedAllocation}
+
+ _{MsgAllocationUsersCount} +
+ #{olength allocationUsers} +
+ _{MsgAllocationCoursesCount} +
+ #{olength allocationCourses}
_{MsgAllocationRequestedPlaces}
@@ -76,7 +84,7 @@ $newline never
#{participants} $maybe capN <- courseCapacity - +
#{allocated} $nothing diff --git a/templates/table/cell/allocation-courses.hamlet b/templates/table/cell/allocation-courses.hamlet index f3bb50c70..26996d42e 100644 --- a/templates/table/cell/allocation-courses.hamlet +++ b/templates/table/cell/allocation-courses.hamlet @@ -1,5 +1,11 @@ $newline never
    - $forall Entity _ Course{courseTerm, courseSchool, courseName} <- courses + $forall (Entity _ Course{courseTerm, courseSchool, courseName}, E.Value mbRating, E.Value mbVeto) <- courses
  • #{courseTerm} - #{courseSchool} - #{courseName} + $case (mbRating, mbVeto) + $of (_, Just True) + \ (_{MsgApplicationVeto}) + $of (Just g, _) + \ (_{g}) + $of _