feat(allocations): improve accept ui and logging
This commit is contained in:
Gregor Kleen
parent
20ef95c142
commit
3422fd70a7
@ -872,7 +872,7 @@ th, td
|
||||
right: 5px
|
||||
top: 5px
|
||||
|
||||
.occurrence--not-registered, .no-bonus
|
||||
.occurrence--not-registered, .no-bonus, .allocation-course--excluded
|
||||
text-decoration: line-through
|
||||
|
||||
.result
|
||||
|
||||
@ -28,6 +28,7 @@ Allocation -- attributes with prefix staff- affect lecturers only, but are invis
|
||||
AllocationMatching
|
||||
allocation AllocationId
|
||||
fingerprint AllocationFingerprint
|
||||
time UTCTime
|
||||
log FileId
|
||||
|
||||
AllocationCourse
|
||||
|
||||
@ -28,3 +28,7 @@ instance Hashable a => Hashable (NonNull a) where
|
||||
instance (Binary a, MonoFoldable a) => Binary (NonNull a) where
|
||||
get = Binary.get >>= maybe (fail "Expected non-empty structure") return . fromNullable
|
||||
put = Binary.put . toNullable
|
||||
|
||||
|
||||
instance NFData a => NFData (NonNull a) where
|
||||
rnf = rnf . toNullable
|
||||
|
||||
@ -17,6 +17,8 @@ import qualified Control.Monad.State.Class as State
|
||||
|
||||
import Data.Semigroup (Dual(..))
|
||||
|
||||
import Data.Sequence (Seq((:|>)))
|
||||
|
||||
|
||||
newtype SessionDataAllocationResults = SessionDataAllocationResults
|
||||
{ getSessionDataAllocationResults :: Map ( TermId
|
||||
@ -26,11 +28,11 @@ newtype SessionDataAllocationResults = SessionDataAllocationResults
|
||||
( UTCTime
|
||||
, AllocationFingerprint
|
||||
, Set (UserId, CourseId)
|
||||
, Seq (MatchingLog UserId CourseId Natural)
|
||||
, Seq MatchingLogRun
|
||||
)
|
||||
} deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
deriving newtype (ToJSON, FromJSON)
|
||||
deriving (Monoid, Semigroup) via Dual (Map (TermId, SchoolId, AllocationShorthand) (UTCTime, AllocationFingerprint, Set (UserId, CourseId), Seq (MatchingLog UserId CourseId Natural)))
|
||||
deriving (Monoid, Semigroup) via Dual (Map (TermId, SchoolId, AllocationShorthand) (UTCTime, AllocationFingerprint, Set (UserId, CourseId), Seq MatchingLogRun))
|
||||
|
||||
makeWrapped ''SessionDataAllocationResults
|
||||
|
||||
@ -47,11 +49,11 @@ instance Button UniWorX AllocationAcceptButton where
|
||||
btnClasses BtnAllocationAccept = [BCIsButton, BCPrimary]
|
||||
|
||||
|
||||
allocationAcceptForm :: AllocationId -> DB (Maybe (Form (UTCTime, AllocationFingerprint, Set (UserId, CourseId), Seq (MatchingLog UserId CourseId Natural))))
|
||||
allocationAcceptForm :: AllocationId -> DB (Maybe (Form (UTCTime, AllocationFingerprint, Set (UserId, CourseId), Seq MatchingLogRun)))
|
||||
allocationAcceptForm aId = runMaybeT $ do
|
||||
Allocation{..} <- MaybeT $ get aId
|
||||
SessionDataAllocationResults allocMap <- MaybeT $ lookupSessionJson SessionAllocationResults
|
||||
allocRes@(allocTime, allocFp, allocMatching, _) <- hoistMaybe $ allocMap !? (allocationTerm, allocationSchool, allocationShorthand)
|
||||
allocRes@(allocTime, allocFp, allocMatching, _ :|> MatchingLogRun{..}) <- hoistMaybe $ allocMap !? (allocationTerm, allocationSchool, allocationShorthand)
|
||||
$logInfoS "allocationAcceptForm" $ tshow allocRes
|
||||
|
||||
allocationUsers <- fmap (map $ bimap E.unValue E.unValue) . lift . E.select . E.from $ \allocationUser -> do
|
||||
|
||||
@ -107,8 +107,7 @@ getAUsersR = postAUsersR
|
||||
postAUsersR tid ssh ash = do
|
||||
(usersTable, acceptForm) <- runDB $ do
|
||||
Entity aId _ <- getBy404 $ TermSchoolAllocationShort tid ssh ash
|
||||
now <- liftIO getCurrentTime
|
||||
resultsDone <- (<= NTop (Just now)) . NTop <$> allocationDone aId
|
||||
resultsDone <- is _Just <$> allocationStarted aId
|
||||
|
||||
csvName <- getMessageRender <*> pure (MsgAllocationUsersCsvName tid ssh ash)
|
||||
|
||||
|
||||
@ -1,7 +1,8 @@
|
||||
module Handler.Utils.Allocation
|
||||
( allocationDone
|
||||
( allocationStarted
|
||||
, ordinalPriorities
|
||||
, sinkAllocationPriorities
|
||||
, MatchingLogRun(..)
|
||||
, computeAllocation
|
||||
-- , doAllocation -- Use `storeAllocationResult`
|
||||
, ppMatchingLog
|
||||
@ -15,6 +16,7 @@ import qualified Data.Map.Strict as Map
|
||||
import qualified Database.Esqueleto as E
|
||||
import qualified Database.Esqueleto.Utils as E
|
||||
|
||||
import Control.Monad.Trans.State (execStateT)
|
||||
import qualified Control.Monad.State.Class as State (get, modify')
|
||||
|
||||
import Data.List (genericLength, elemIndex)
|
||||
@ -33,13 +35,36 @@ import Data.Generics.Product.Param
|
||||
import qualified Crypto.Hash as Crypto
|
||||
import qualified Data.Binary as Binary
|
||||
|
||||
import qualified Data.ByteArray as BA (convert)
|
||||
|
||||
data MatchingExcludedReason
|
||||
= MatchingExcludedParticipationExisted
|
||||
| MatchingExcludedParticipationExists
|
||||
| MatchingExcludedVeto
|
||||
| MatchingExcludedLecturer
|
||||
deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
|
||||
deriving anyclass (Universe, Finite, NFData)
|
||||
|
||||
nullaryPathPiece ''MatchingExcludedReason $ camelToPathPiece' 2
|
||||
pathPieceJSON ''MatchingExcludedReason
|
||||
|
||||
data MatchingLogRun = MatchingLogRun
|
||||
{ matchingLogRunCourseRestriction :: Maybe (Set CourseId)
|
||||
, matchingLogRunCoursesExcluded :: Set CourseId
|
||||
, matchingLogMatchingsExcluded :: Map (UserId, CourseId) (NonNull (Set MatchingExcludedReason))
|
||||
, matchingLogRunLog :: Seq (MatchingLog UserId CourseId Natural)
|
||||
} deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
deriving anyclass (NFData)
|
||||
|
||||
deriveJSON defaultOptions
|
||||
{ fieldLabelModifier = camelToPathPiece' 3
|
||||
} ''MatchingLogRun
|
||||
|
||||
|
||||
allocationDone :: AllocationId -> DB (Maybe UTCTime)
|
||||
allocationDone allocId = fmap (E.unValue <=< listToMaybe) . E.select . E.from $ \participant -> do
|
||||
E.where_ $ participant E.^. CourseParticipantAllocated E.==. E.just (E.val allocId)
|
||||
return . E.max_ $ participant E.^. CourseParticipantRegistration
|
||||
allocationStarted :: AllocationId -> DB (Maybe UTCTime)
|
||||
-- ^ Time the first allocation was made
|
||||
allocationStarted allocId = fmap (E.unValue <=< listToMaybe) . E.select . E.from $ \allocationMatching -> do
|
||||
E.where_ $ allocationMatching E.^. AllocationMatchingAllocation E.==. E.val allocId
|
||||
return . E.min_ $ allocationMatching E.^. AllocationMatchingTime
|
||||
|
||||
|
||||
ordinalPriorities :: Monad m => ConduitT UserMatriculation (Map UserMatriculation AllocationPriority) m ()
|
||||
@ -60,7 +85,7 @@ computeAllocation :: AllocationId
|
||||
-> Maybe (Set CourseId) -- ^ Optionally restrict allocation to only consider the given courses
|
||||
-> DB ( AllocationFingerprint
|
||||
, Set (UserId, CourseId)
|
||||
, Seq (MatchingLog UserId CourseId Natural)
|
||||
, Seq MatchingLogRun
|
||||
)
|
||||
computeAllocation allocId cRestr = do
|
||||
allocations <- selectList [ CourseParticipantAllocated ==. Just allocId ] []
|
||||
@ -106,20 +131,36 @@ computeAllocation allocId cRestr = do
|
||||
let capacities = Map.filter (maybe True (> 0)) . Map.fromList $ (view (_1 . _entityVal . _allocationCourseCourse) &&& view (_2 . _Value)) <$> courses'
|
||||
|
||||
applications' <- selectList [ CourseApplicationAllocation ==. Just allocId ] []
|
||||
let alreadyAssigned (Entity _ CourseApplication{..}) = orM
|
||||
[ exists [ TransactionLogInfo ==. toJSON (TransactionCourseParticipantDeleted courseApplicationCourse courseApplicationUser) ]
|
||||
, exists [ CourseParticipantCourse ==. courseApplicationCourse, CourseParticipantUser ==. courseApplicationUser ]
|
||||
]
|
||||
applications'' <- applications'
|
||||
& filter ((\CourseApplication{..} -> not courseApplicationRatingVeto && fromMaybe True (courseApplicationRatingPoints ^? _Just . passingGrade . _Wrapped)) . entityVal)
|
||||
& filterM (fmap not . alreadyAssigned)
|
||||
excludedMatchings <- flip execStateT mempty . forM_ applications' $ \(Entity _ CourseApplication{..}) -> do
|
||||
let
|
||||
tellExcluded :: MatchingExcludedReason -> StateT _ _ ()
|
||||
tellExcluded reason = State.modify' $ Map.insertWith (<>) (courseApplicationUser, courseApplicationCourse) (opoint reason :: NonNull (Set MatchingExcludedReason))
|
||||
|
||||
when (courseApplicationRatingVeto || maybe False not (courseApplicationRatingPoints ^? _Just . passingGrade . _Wrapped)) $
|
||||
tellExcluded MatchingExcludedVeto
|
||||
|
||||
allocStarted <- lift $ allocationStarted allocId
|
||||
whenIsJust allocStarted $ \allocStarted' -> do
|
||||
let partDeleted = lift $ exists [ TransactionLogInfo ==. toJSON (TransactionCourseParticipantDeleted courseApplicationCourse courseApplicationUser), TransactionLogTime >=. allocStarted' ]
|
||||
whenM partDeleted $
|
||||
tellExcluded MatchingExcludedParticipationExisted
|
||||
|
||||
let partExists :: StateT _ DB Bool
|
||||
partExists = lift $ exists [ CourseParticipantCourse ==. courseApplicationCourse, CourseParticipantUser ==. courseApplicationUser ]
|
||||
whenM partExists $
|
||||
tellExcluded MatchingExcludedParticipationExists
|
||||
|
||||
let lecturerExists = lift $ exists [ LecturerCourse ==. courseApplicationCourse, LecturerUser ==. courseApplicationUser ]
|
||||
whenM lecturerExists $
|
||||
tellExcluded MatchingExcludedLecturer
|
||||
let applications'' = applications'
|
||||
& map entityVal
|
||||
& filter (\CourseApplication{..} -> Map.notMember (courseApplicationUser, courseApplicationCourse) excludedMatchings)
|
||||
let preferences = Map.fromList $ do
|
||||
Entity _ CourseApplication{..} <- applications''
|
||||
CourseApplication{..} <- applications''
|
||||
guard $ Map.member courseApplicationCourse capacities
|
||||
return ((courseApplicationUser, courseApplicationCourse), (courseApplicationAllocationPriority, courseApplicationRatingPoints))
|
||||
|
||||
$logErrorS "computeAllocation" $ tshow preferences
|
||||
|
||||
gradeScale <- getsYesod $ view _appAllocationGradeScale
|
||||
gradeOrdinalProportion <- getsYesod $ view _appAllocationGradeOrdinalProportion
|
||||
let ordinalUsers = getSum . flip foldMap users'' $ \(_, prio) -> case prio of
|
||||
@ -155,23 +196,28 @@ computeAllocation allocId cRestr = do
|
||||
fingerprint :: AllocationFingerprint
|
||||
fingerprint = Crypto.hash . toStrict $ Binary.encode (users'', capacities, preferences, gradeScale, gradeOrdinalPlaces)
|
||||
|
||||
g = mkStdGen $ hash (BA.convert fingerprint :: ByteString)
|
||||
g = mkStdGen $ hash fingerprint
|
||||
|
||||
let
|
||||
doAllocationWithout cs = runWriter $ computeMatchingLog g cloneCounts capacities' preferences' centralNudge
|
||||
doAllocationWithout :: Set CourseId -> Writer (Seq (MatchingLog UserId CourseId Natural)) (Set (UserId, CourseId))
|
||||
doAllocationWithout cs = computeMatchingLog g cloneCounts capacities' preferences' centralNudge
|
||||
where
|
||||
capacities' = Map.filterWithKey (\ c _ -> Set.notMember c cs) capacities
|
||||
preferences' = Map.filterWithKey (\(_, c) _ -> Set.notMember c cs) preferences
|
||||
|
||||
allocationLoop cs
|
||||
| not $ null belowMin = doAllocationWithout $ cs <> Set.fromList belowMin
|
||||
| otherwise = (allocs, mLog)
|
||||
where
|
||||
(allocs, mLog) = doAllocationWithout cs
|
||||
belowMin = catMaybes . flip map courses' $ \(Entity _ AllocationCourse{..}, _, E.Value minCap) ->
|
||||
guardOn (Set.size (Set.filter (\(_, c) -> c == allocationCourseCourse) allocs) < minCap) allocationCourseCourse
|
||||
allocationLoop :: Set CourseId -> Writer (Seq MatchingLogRun) (Set (UserId, CourseId))
|
||||
allocationLoop cs = do
|
||||
allocs <- mapWriter (over _2 $ pure . MatchingLogRun cRestr cs excludedMatchings) $ doAllocationWithout cs
|
||||
let
|
||||
belowMin = catMaybes . flip map courses' $ \(Entity _ AllocationCourse{..}, _, E.Value minCap) -> do
|
||||
guard . not $ Set.member allocationCourseCourse cs
|
||||
guard $ Set.size (Set.filter (\(_, c) -> c == allocationCourseCourse) allocs) < minCap
|
||||
return allocationCourseCourse
|
||||
if
|
||||
| not $ null belowMin -> allocationLoop $ cs <> Set.fromList belowMin
|
||||
| otherwise -> return allocs
|
||||
|
||||
return . (\(ms, mLog) -> (fingerprint, ms, mLog)) $!! allocationLoop Set.empty
|
||||
return . (\(ms, mLog) -> (fingerprint, ms, mLog)) $!! runWriter (allocationLoop Set.empty)
|
||||
|
||||
|
||||
doAllocation :: AllocationId
|
||||
@ -183,22 +229,30 @@ doAllocation allocId now regs =
|
||||
mField <- (courseApplicationField . entityVal =<<) . listToMaybe <$> selectList [CourseApplicationCourse ==. cid, CourseApplicationUser ==. uid, CourseApplicationAllocation ==. Just allocId] []
|
||||
void . insertUnique $ CourseParticipant cid uid now mField (Just allocId)
|
||||
|
||||
ppMatchingLog :: forall mono.
|
||||
( MonoFoldable mono
|
||||
, Element mono ~ MatchingLog UserId CourseId Natural
|
||||
)
|
||||
=> mono -> Text
|
||||
ppMatchingLog = unlines . map (tshow . pretty) . otoList
|
||||
ppMatchingLog :: Seq MatchingLogRun -> Text
|
||||
ppMatchingLog = unlines . map prettyRun . otoList
|
||||
where
|
||||
prettyRun MatchingLogRun{..} = unlines
|
||||
[ "----- STARTING RUN -----"
|
||||
, "Course restriction: " <> tshow (Set.toAscList <$> matchingLogRunCourseRestriction)
|
||||
, "Courses excluded: " <> tshow (Set.toAscList matchingLogRunCoursesExcluded)
|
||||
, "Matchings excluded (user, course): "
|
||||
, unlines . map (" " <>) . flip ifoldMap matchingLogMatchingsExcluded $ \(uid, cid) (otoList -> reasons) -> pure $
|
||||
"(" <> tshow (fromSqlKey uid) <> ", " <> tshow (fromSqlKey cid) <> ") " <> intercalate ", " (map tshow reasons) :: [Text]
|
||||
, "------------------------"
|
||||
, unlines . map (tshow . pretty) $ otoList matchingLogRunLog
|
||||
, "------ RUN ENDED -------"
|
||||
]
|
||||
|
||||
pretty :: MatchingLog UserId CourseId Natural -> MatchingLog Int64 Int64 Natural
|
||||
pretty = over (param @1) fromSqlKey
|
||||
. over (param @2) fromSqlKey
|
||||
|
||||
storeAllocationResult :: AllocationId
|
||||
-> UTCTime
|
||||
-> (AllocationFingerprint, Set (UserId, CourseId), Seq (MatchingLog UserId CourseId Natural))
|
||||
-> (AllocationFingerprint, Set (UserId, CourseId), Seq MatchingLogRun)
|
||||
-> DB ()
|
||||
storeAllocationResult allocId now (allocFp, allocMatchings, ppMatchingLog -> allocLog) = do
|
||||
insert_ . AllocationMatching allocId allocFp <=< insert $ File "matchings.log" (Just $ encodeUtf8 allocLog) now
|
||||
insert_ . AllocationMatching allocId allocFp now <=< insert $ File "matchings.log" (Just $ encodeUtf8 allocLog) now
|
||||
|
||||
doAllocation allocId now allocMatchings
|
||||
|
||||
@ -16,7 +16,6 @@ import Data.Time.Zones
|
||||
import Data.Time.Clock.POSIX
|
||||
|
||||
import Handler.Utils.DateTime
|
||||
import Handler.Utils.Allocation (allocationDone)
|
||||
|
||||
import Control.Monad.Writer.Class (MonadWriter(..))
|
||||
|
||||
@ -379,7 +378,9 @@ determineCrontab = execWriterT $ do
|
||||
}
|
||||
_other
|
||||
-> return ()
|
||||
doneSince <- lift $ allocationDone nAllocation
|
||||
doneSince <- lift $ fmap (E.unValue <=< listToMaybe) . E.select . E.from $ \participant -> do
|
||||
E.where_ $ participant E.^. CourseParticipantAllocated E.==. E.just (E.val nAllocation)
|
||||
return . E.max_ $ participant E.^. CourseParticipantRegistration
|
||||
|
||||
whenIsJust doneSince $ \doneSince' ->
|
||||
tell $ HashMap.singleton
|
||||
|
||||
@ -620,6 +620,10 @@ customMigrations = Map.fromListWith (>>)
|
||||
ALTER TABLE "external_exam" ALTER COLUMN "grading_mode" SET NOT NULL;
|
||||
|]
|
||||
)
|
||||
, ( AppliedMigrationKey [migrationVersion|33.0.0|] [version|34.0.0|]
|
||||
, whenM (tableExists "allocation_matching") $
|
||||
tableDropEmpty "allocation_matching"
|
||||
)
|
||||
]
|
||||
|
||||
|
||||
|
||||
@ -48,8 +48,8 @@ $newline never
|
||||
<th .table__th>
|
||||
_{MsgAllocationMatchedUsers}
|
||||
<tbody>
|
||||
$forall ((Entity _ AllocationCourse{allocationCourseMinCapacity}, Entity _ Course{courseTerm, courseSchool, courseName, courseCapacity, courseShorthand}, participants), allocated) <- allocationCourses'
|
||||
<tr .table__row>
|
||||
$forall ((Entity _ AllocationCourse{allocationCourseMinCapacity}, Entity cid Course{courseTerm, courseSchool, courseName, courseCapacity, courseShorthand}, participants), allocated) <- allocationCourses'
|
||||
<tr .table__row :member cid matchingLogRunCoursesExcluded:.allocation-course--excluded>
|
||||
$if showTerms
|
||||
<td .table__td>
|
||||
<div .table__td-content>
|
||||
|
||||
Loading…
Reference in New Issue
Block a user