feat(allocations): fingerprints & ordinal ratings

config/settings.yml

@@ -136,6 +136,9 @@ user-defaults:
 # This encodes the weight of the lecturer ratings on the same scale as the
 # centrally supplied priorities.
 allocation-grade-scale: 25
+# This encodes how many ordinal places lecturer ratings may move students up or
+# down when central priorities are supplied as ordered list.
+allocation-grade-ordinal-places: 3
 
 instance-id: "_env:INSTANCE_ID:instance"
 ribbon: "_env:RIBBON:"

models/allocations.model

@@ -21,6 +21,7 @@ Allocation -- attributes with prefix staff- affect lecturers only, but are invis
     registerByCourse    UTCTime Maybe   -- course registration dates are ignored until this day has passed or always prohibited
     overrideDeregister  UTCTime Maybe   -- course deregistration enforced to be this date, i.e. students may disenrol from course after or never
     -- overrideVisible not needed, since courses are always visible
+    fingerprint         AllocationFingerprint Maybe
     matchingLog         FileId Maybe
     TermSchoolAllocationShort  term school shorthand    -- shorthand must be unique within school and semester
     TermSchoolAllocationName   term school name         -- name must be unique within school and semester

src/Handler/Utils/Allocation.hs

@@ -1,8 +1,12 @@
 module Handler.Utils.Allocation
-  ( sinkAllocationPriorities
+  ( allocationDone
+  , ordinalPriorities
+  , sinkAllocationPriorities
   , computeAllocation
+  , storeAllocationFingerprint
   , doAllocation
   , ppMatchingLog, storeMatchingLog
+  , storeAllocationResult
   ) where
 
 import Import
@@ -12,12 +16,15 @@ 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.Strict (evalStateT)
+import qualified Control.Monad.State.Class as State (get, modify')
+
 import Data.List (genericLength, elemIndex)
 import qualified Data.Vector as Vector
 import Data.Vector.Lens (vector)
 import qualified Data.Set as Set
 
-import System.Random (newStdGen)
+import System.Random (mkStdGen)
 
 import Utils.Allocation
 
@@ -25,6 +32,20 @@ import qualified Data.Conduit.List as C
 
 import Data.Generics.Product.Param
 
+import qualified Crypto.Hash as Crypto
+import qualified Data.Binary as Binary
+
+import qualified Data.ByteArray as BA (convert)
+
+
+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
+
+
+ordinalPriorities :: Monad m => ConduitT UserMatriculation (Map UserMatriculation AllocationPriority) m ()
+ordinalPriorities = transPipe (flip evalStateT 0) . C.mapM $ \matr -> singletonMap matr <$> (AllocationPriorityOrdinal <$> State.get <* State.modify' succ)
   
 sinkAllocationPriorities :: AllocationId
                          -> ConduitT (Map UserMatriculation AllocationPriority) Void DB ()
@@ -38,10 +59,19 @@ sinkAllocationPriorities allocId = C.mapM_ . imapM_ $ \matr prio ->
 
   
 computeAllocation :: AllocationId
-                  -> DB (Set (UserId, CourseId), Seq (MatchingLog UserId CourseId Natural))
+                  -> DB (AllocationFingerprint, Set (UserId, CourseId), Seq (MatchingLog UserId CourseId Natural))
 computeAllocation allocId = do
   users' <- selectList [ AllocationUserAllocation ==. allocId ] []
-  let cloneCounts = Map.filter (> 0) . Map.fromList $ (allocationUserUser . entityVal &&& allocationUserTotalCourses . entityVal) <$> users'
+  let users'' = users'
+        & mapMaybe ( runMaybeT $ (,) <$> lift (allocationUserUser . entityVal)
+                                     <*> ( (,) <$> lift (allocationUserTotalCourses . entityVal)
+                                               <*> MaybeT (allocationUserPriority . entityVal)
+                                         )
+                   )
+        & Map.fromList
+        & Map.filter ((> 0) . view _1)
+      cloneCounts = Map.map (view _1) users''
+      allocationPrio = view _2 . (Map.!) users''
 
   courses' <- E.select . E.from $ \(allocationCourse `E.InnerJoin` course) -> do
     E.on $ allocationCourse E.^. AllocationCourseCourse E.==. course E.^. CourseId
@@ -67,27 +97,35 @@ computeAllocation allocId = do
         return ((courseApplicationUser, courseApplicationCourse), (courseApplicationAllocationPriority, courseApplicationRatingPoints))
 
   gradeScale <- getsYesod $ view _appAllocationGradeScale
-  let centralNudge user (fromIntegral -> cloneIndex) grade
+  gradeOrdinalPlaces <- getsYesod $ view _appAllocationGradeOrdinalPlaces
-        | Just AllocationPriorityNumeric{..} <- allocationPrio
+  let centralNudge user cloneIndex grade = case allocationPrio user of
-        = let allocationPriorities' = under vector (sortOn Down) allocationPriorities
+        AllocationPriorityNumeric{..}
-              minPrio | Vector.null allocationPriorities' = 0
+          -> let allocationPriorities' = under vector (sortOn Down) allocationPriorities
-                      | otherwise = Vector.last allocationPriorities'
+                 minPrio | Vector.null allocationPriorities' = 0
-           in withNumericGrade . fromMaybe minPrio $ allocationPriorities Vector.!? cloneIndex
+                         | otherwise = Vector.last allocationPriorities'
-        | otherwise
+              in AllocationPriorityComparisonNumeric . withNumericGrade . fromInteger . fromMaybe minPrio $ allocationPriorities Vector.!? fromIntegral cloneIndex
-        = withNumericGrade 0
+        AllocationPriorityOrdinal{..}
+          | gradeOrdinalPlaces > 0
+            -> let allocationOrdinal' = gradeScale / fromIntegral gradeOrdinalPlaces * fromIntegral allocationOrdinal 
+                in AllocationPriorityComparisonOrdinal (Down cloneIndex) $ withNumericGrade allocationOrdinal'
+        AllocationPriorityOrdinal{..}
+          -> AllocationPriorityComparisonOrdinal (Down cloneIndex) $ fromIntegral allocationOrdinal
         where
-          allocationPrio = allocationUserPriority . entityVal =<< listToMaybe (filter ((== user) . allocationUserUser . entityVal) users')
+          withNumericGrade :: Rational -> Rational
-
           withNumericGrade
             | Just grade' <- grade
             = let numberGrade' = fromMaybe (error "non-passing grade") (fromIntegral <$> elemIndex grade' passingGrades) / pred (genericLength passingGrades)
                   passingGrades = sort $ filter (view $ passingGrade . _Wrapped) universeF
                   numericGrade = -gradeScale + numberGrade' * 2 * gradeScale
-               in (+) numericGrade . fromInteger
+               in (+) numericGrade
             | otherwise
-            = fromInteger
+            = id
 
-  g <- liftIO newStdGen
+  let
+    fingerprint :: AllocationFingerprint
+    fingerprint = Crypto.hash . toStrict $ Binary.encode (users'', capacities, preferences, gradeScale, gradeOrdinalPlaces)
+    
+    g = mkStdGen $ hash (BA.convert fingerprint :: ByteString)
 
   let
     doAllocationWithout cs = runWriter $ computeMatchingLog g cloneCounts capacities' preferences' centralNudge
@@ -103,7 +141,13 @@ computeAllocation allocId = do
         belowMin = catMaybes . flip map courses' $ \(Entity _ AllocationCourse{..}, _, E.Value minCap) ->
           guardOn (Set.size (Set.filter (\(_, c) -> c == allocationCourseCourse) allocs) < minCap) allocationCourseCourse
 
-  return $!! allocationLoop Set.empty
+  return . (\(ms, mLog) -> (fingerprint, ms, mLog)) $!! allocationLoop Set.empty
+
+
+storeAllocationFingerprint :: AllocationId
+                           -> AllocationFingerprint
+                           -> DB ()
+storeAllocationFingerprint allocId fp = update allocId [ AllocationFingerprint =. Just fp ]
 
 doAllocation :: AllocationId
              -> Set (UserId, CourseId)
@@ -131,3 +175,12 @@ storeMatchingLog allocationId (ppMatchingLog -> matchingLog) = do
   now <- liftIO getCurrentTime
   fId <- insert $ File "matchings.log" (Just $ encodeUtf8 matchingLog) now
   update allocationId [ AllocationMatchingLog =. Just fId ]
+
+
+storeAllocationResult :: AllocationId
+                      -> (AllocationFingerprint, Set (UserId, CourseId), Seq (MatchingLog UserId CourseId Natural))
+                      -> DB ()
+storeAllocationResult allocId (allocFp, allocMatchings, allocLog) = do
+  storeAllocationFingerprint allocId allocFp
+  doAllocation allocId allocMatchings
+  storeMatchingLog allocId allocLog

src/Jobs/Crontab.hs

@@ -15,6 +15,7 @@ import Data.Time.Zones
 import Data.Time.Clock.POSIX
 
 import Handler.Utils.DateTime
+import Handler.Utils.Allocation (allocationDone)
 
 import Control.Monad.Trans.Writer (WriterT, execWriterT)
 import Control.Monad.Writer.Class (MonadWriter(..))
@@ -336,14 +337,12 @@ determineCrontab = execWriterT $ do
                   }
         _other
           -> return ()
-      lastResult <- fmap (E.unValue <=< listToMaybe) . lift . E.select . E.from $ \participant -> do
+      doneSince <- lift $ allocationDone nAllocation
-        E.where_ $ participant E.^. CourseParticipantAllocated E.==. E.just (E.val nAllocation)
+      whenIsJust doneSince $ \doneSince' ->
-        return . E.max_ $ participant E.^. CourseParticipantRegistration
-      whenIsJust lastResult $ \lastResult' ->
         tell $ HashMap.singleton
           (JobCtlQueue $ JobQueueNotification NotificationAllocationResults{..})
           Cron
-            { cronInitial   = CronTimestamp . utcToLocalTimeTZ appTZ $ addUTCTime appNotificationCollateDelay lastResult'
+            { cronInitial   = CronTimestamp . utcToLocalTimeTZ appTZ $ addUTCTime appNotificationCollateDelay doneSince'
             , cronRepeat    = CronRepeatNever
             , cronRateLimit = appNotificationRateLimit
             , cronNotAfter  = Left appNotificationExpiration

src/Model/Types/Allocation.hs

@@ -1,5 +1,7 @@
 module Model.Types.Allocation
   ( AllocationPriority(..)
+  , AllocationPriorityComparison(..)
+  , AllocationFingerprint
   , module Utils.Allocation
   ) where
 
@@ -12,11 +14,14 @@ import qualified Data.Vector as Vector
 
 import qualified Data.Map.Strict as Map
   
+import Crypto.Hash (Digest, SHAKE128)
+
 {-# ANN module ("HLint: ignore Use newtype instead of data"::String) #-}
 
 
 data AllocationPriority
   = AllocationPriorityNumeric { allocationPriorities :: Vector Integer }
+  | AllocationPriorityOrdinal { allocationOrdinal :: Natural }
   deriving (Eq, Ord, Read, Show, Generic, Typeable)
 deriveJSON defaultOptions
   { fieldLabelModifier = camelToPathPiece' 1
@@ -28,9 +33,20 @@ deriveJSON defaultOptions
   } ''AllocationPriority
 derivePersistFieldJSON ''AllocationPriority
 
+instance Binary AllocationPriority
+
 instance Csv.FromRecord (Map UserMatriculation AllocationPriority) where
   parseRecord v = parseNumeric
     where
       parseNumeric
         | Vector.length v >= 1 = Map.singleton <$> v Csv..! 0 <*> (AllocationPriorityNumeric <$> mapM Csv.parseField (Vector.tail v))
         | otherwise = mzero
+
+
+data AllocationPriorityComparison
+  = AllocationPriorityComparisonNumeric { allocationGradeScale :: Rational }
+  | AllocationPriorityComparisonOrdinal { allocationCloneIndex :: Down Natural, allocationOrdinalScale :: Rational }
+  deriving (Eq, Ord, Read, Show, Generic, Typeable)
+
+
+type AllocationFingerprint = Digest (SHAKE128 128)

src/Model/Types/Exam.hs

@@ -218,6 +218,8 @@ instance PersistField ExamGrade where
 instance PersistFieldSql ExamGrade where
   sqlType _ = SqlNumeric 2 1
 
+instance Binary ExamGrade
+
 
 newtype ExamGradeDefCenter = ExamGradeDefCenter { examGradeDefCenter :: Maybe ExamGrade }
   deriving (Eq, Read, Show, Generic, Typeable)

src/Settings.hs

@@ -131,6 +131,7 @@ data AppSettings = AppSettings
     , appTransactionLogIPRetentionTime :: NominalDiffTime
 
     , appAllocationGradeScale :: Rational
+    , appAllocationGradeOrdinalPlaces :: Natural
 
     , appReloadTemplates        :: Bool
     -- ^ Use the reload version of templates
@@ -429,6 +430,7 @@ instance FromJSON AppSettings where
         appTransactionLogIPRetentionTime <- o .:  "ip-retention-time"
 
         appAllocationGradeScale   <- o .: "allocation-grade-scale" <|> fmap toRational (o .: "allocation-grade-scale" :: Aeson.Parser Scientific)
+        appAllocationGradeOrdinalPlaces <- o .: "allocation-grade-ordinal-places"
 
         appUserDefaults           <- o .:  "user-defaults"
         appAuthPWHash             <- o .:  "auth-pw-hash"

test/Database.hs

@@ -785,6 +785,7 @@ fillDb = do
     , allocationRegisterByStaffTo = Nothing
     , allocationRegisterByCourse = Nothing
     , allocationOverrideDeregister = Just now
+    , allocationFingerprint = Nothing
     , allocationMatchingLog = Nothing
     }
   insert_ $ AllocationCourse funAlloc pmo 100