From 3422fd70a73bf005622f4e9b94caa503eb92f553 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 11 Mar 2020 14:16:02 +0100 Subject: [PATCH] feat(allocations): improve accept ui and logging --- frontend/src/app.sass | 2 +- models/allocations.model | 1 + src/Data/NonNull/Instances.hs | 4 + src/Handler/Allocation/Accept.hs | 10 ++- src/Handler/Allocation/Users.hs | 3 +- src/Handler/Utils/Allocation.hs | 124 +++++++++++++++++++++-------- src/Jobs/Crontab.hs | 5 +- src/Model/Migration.hs | 4 + templates/allocation/accept.hamlet | 4 +- 9 files changed, 111 insertions(+), 46 deletions(-) diff --git a/frontend/src/app.sass b/frontend/src/app.sass index 012dd8d13..3222acdcc 100644 --- a/frontend/src/app.sass +++ b/frontend/src/app.sass @@ -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 diff --git a/models/allocations.model b/models/allocations.model index 7cbfe58bc..a382269cb 100644 --- a/models/allocations.model +++ b/models/allocations.model @@ -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 diff --git a/src/Data/NonNull/Instances.hs b/src/Data/NonNull/Instances.hs index 8c7c3dca8..ad472219a 100644 --- a/src/Data/NonNull/Instances.hs +++ b/src/Data/NonNull/Instances.hs @@ -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 diff --git a/src/Handler/Allocation/Accept.hs b/src/Handler/Allocation/Accept.hs index f52641ad3..5ac324f9a 100644 --- a/src/Handler/Allocation/Accept.hs +++ b/src/Handler/Allocation/Accept.hs @@ -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 diff --git a/src/Handler/Allocation/Users.hs b/src/Handler/Allocation/Users.hs index 567b2f7cb..a99bd703c 100644 --- a/src/Handler/Allocation/Users.hs +++ b/src/Handler/Allocation/Users.hs @@ -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) diff --git a/src/Handler/Utils/Allocation.hs b/src/Handler/Utils/Allocation.hs index 084cb4b56..1b7d90e63 100644 --- a/src/Handler/Utils/Allocation.hs +++ b/src/Handler/Utils/Allocation.hs @@ -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 diff --git a/src/Jobs/Crontab.hs b/src/Jobs/Crontab.hs index b631b052e..c087a1b3a 100644 --- a/src/Jobs/Crontab.hs +++ b/src/Jobs/Crontab.hs @@ -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 diff --git a/src/Model/Migration.hs b/src/Model/Migration.hs index 4fd3bbd83..cc4a45502 100644 --- a/src/Model/Migration.hs +++ b/src/Model/Migration.hs @@ -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" + ) ] diff --git a/templates/allocation/accept.hamlet b/templates/allocation/accept.hamlet index a684bc880..1e7c01b0d 100644 --- a/templates/allocation/accept.hamlet +++ b/templates/allocation/accept.hamlet @@ -48,8 +48,8 @@ $newline never _{MsgAllocationMatchedUsers} - $forall ((Entity _ AllocationCourse{allocationCourseMinCapacity}, Entity _ Course{courseTerm, courseSchool, courseName, courseCapacity, courseShorthand}, participants), allocated) <- allocationCourses' - + $forall ((Entity _ AllocationCourse{allocationCourseMinCapacity}, Entity cid Course{courseTerm, courseSchool, courseName, courseCapacity, courseShorthand}, participants), allocated) <- allocationCourses' + $if showTerms