feat(allocations): improve accept ui and logging

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

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

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

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

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 <- is _Just <$> allocationStarted aId
-    resultsDone <- (<= NTop (Just now)) . NTop <$> allocationDone aId
 
     csvName <- getMessageRender <*> pure (MsgAllocationUsersCsvName tid ssh ash)
 

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)
+allocationStarted :: AllocationId -> DB (Maybe UTCTime)
-allocationDone allocId = fmap (E.unValue <=< listToMaybe) . E.select . E.from $ \participant -> do
+-- ^ Time the first allocation was made
-  E.where_ $ participant E.^. CourseParticipantAllocated E.==. E.just (E.val allocId)
+allocationStarted allocId = fmap (E.unValue <=< listToMaybe) . E.select . E.from $ \allocationMatching -> do
-  return . E.max_ $ participant E.^. CourseParticipantRegistration
+  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
+  excludedMatchings <- flip execStateT mempty . forM_ applications' $ \(Entity _ CourseApplication{..}) -> do
-        [ exists [ TransactionLogInfo ==. toJSON (TransactionCourseParticipantDeleted courseApplicationCourse courseApplicationUser) ]
+    let
-        , exists [ CourseParticipantCourse ==. courseApplicationCourse, CourseParticipantUser ==. courseApplicationUser ]
+      tellExcluded :: MatchingExcludedReason -> StateT _ _ ()
-        ]
+      tellExcluded reason = State.modify' $ Map.insertWith (<>) (courseApplicationUser, courseApplicationCourse) (opoint reason :: NonNull (Set MatchingExcludedReason))
-  applications'' <- applications'
+    
-    & filter ((\CourseApplication{..} -> not courseApplicationRatingVeto && fromMaybe True (courseApplicationRatingPoints ^? _Just . passingGrade . _Wrapped)) . entityVal)
+    when (courseApplicationRatingVeto || maybe False not (courseApplicationRatingPoints ^? _Just . passingGrade . _Wrapped)) $
-    & filterM (fmap not . alreadyAssigned)
+      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
+    allocationLoop :: Set CourseId -> Writer (Seq MatchingLogRun) (Set (UserId, CourseId))
-      | not $ null belowMin = doAllocationWithout $ cs <> Set.fromList belowMin
+    allocationLoop cs = do
-      | otherwise           = (allocs, mLog)
+      allocs <- mapWriter (over _2 $ pure . MatchingLogRun cRestr cs excludedMatchings) $ doAllocationWithout cs
-      where
+      let
-        (allocs, mLog) = doAllocationWithout cs
+        belowMin = catMaybes . flip map courses' $ \(Entity _ AllocationCourse{..}, _, E.Value minCap) -> do
-        belowMin = catMaybes . flip map courses' $ \(Entity _ AllocationCourse{..}, _, E.Value minCap) ->
+          guard . not $ Set.member allocationCourseCourse cs
-          guardOn (Set.size (Set.filter (\(_, c) -> c == allocationCourseCourse) allocs) < minCap) allocationCourseCourse
+          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.
+ppMatchingLog :: Seq MatchingLogRun -> Text
-                 ( MonoFoldable mono
+ppMatchingLog = unlines . map prettyRun . otoList
-                 , Element mono ~ MatchingLog UserId CourseId Natural
-                 )
-              => mono -> Text
-ppMatchingLog = unlines . map (tshow . pretty) . 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

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

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"
+    )
   ]
 
 

templates/allocation/accept.hamlet

@@ -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'
+      $forall ((Entity _ AllocationCourse{allocationCourseMinCapacity}, Entity cid Course{courseTerm, courseSchool, courseName, courseCapacity, courseShorthand}, participants), allocated) <- allocationCourses'
-        <tr .table__row>
+        <tr .table__row :member cid matchingLogRunCoursesExcluded:.allocation-course--excluded>
           $if showTerms
             <td .table__td>
               <div .table__td-content>