From 60603cb6ec43738bdbd98b5a2620366b20bf98bf Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Fri, 4 Oct 2019 16:37:11 +0200 Subject: [PATCH] feat(allocations): fingerprints & ordinal ratings --- config/settings.yml | 3 ++ models/allocations.model | 1 + src/Handler/Utils/Allocation.hs | 89 ++++++++++++++++++++++++++------- src/Jobs/Crontab.hs | 9 ++-- src/Model/Types/Allocation.hs | 16 ++++++ src/Model/Types/Exam.hs | 2 + src/Settings.hs | 2 + test/Database.hs | 1 + 8 files changed, 100 insertions(+), 23 deletions(-) diff --git a/config/settings.yml b/config/settings.yml index 4277e85d5..0e2dbe810 100644 --- a/config/settings.yml +++ b/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:" diff --git a/models/allocations.model b/models/allocations.model index dbca97b85..8f0805b34 100644 --- a/models/allocations.model +++ b/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 diff --git a/src/Handler/Utils/Allocation.hs b/src/Handler/Utils/Allocation.hs index d5fe3fb72..a7b7114d5 100644 --- a/src/Handler/Utils/Allocation.hs +++ b/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,7 +32,21 @@ 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 () sinkAllocationPriorities allocId = C.mapM_ . imapM_ $ \matr prio -> @@ -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 - | Just AllocationPriorityNumeric{..} <- allocationPrio - = let allocationPriorities' = under vector (sortOn Down) allocationPriorities - minPrio | Vector.null allocationPriorities' = 0 - | otherwise = Vector.last allocationPriorities' - in withNumericGrade . fromMaybe minPrio $ allocationPriorities Vector.!? cloneIndex - | otherwise - = withNumericGrade 0 + gradeOrdinalPlaces <- getsYesod $ view _appAllocationGradeOrdinalPlaces + let centralNudge user cloneIndex grade = case allocationPrio user of + AllocationPriorityNumeric{..} + -> let allocationPriorities' = under vector (sortOn Down) allocationPriorities + minPrio | Vector.null allocationPriorities' = 0 + | otherwise = Vector.last allocationPriorities' + in AllocationPriorityComparisonNumeric . withNumericGrade . fromInteger . fromMaybe minPrio $ allocationPriorities Vector.!? fromIntegral cloneIndex + 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 diff --git a/src/Jobs/Crontab.hs b/src/Jobs/Crontab.hs index 6e8117e1a..a852dcdc7 100644 --- a/src/Jobs/Crontab.hs +++ b/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 - E.where_ $ participant E.^. CourseParticipantAllocated E.==. E.just (E.val nAllocation) - return . E.max_ $ participant E.^. CourseParticipantRegistration - whenIsJust lastResult $ \lastResult' -> + doneSince <- lift $ allocationDone nAllocation + whenIsJust doneSince $ \doneSince' -> 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 diff --git a/src/Model/Types/Allocation.hs b/src/Model/Types/Allocation.hs index 3ee8d6299..7eca27b58 100644 --- a/src/Model/Types/Allocation.hs +++ b/src/Model/Types/Allocation.hs @@ -1,5 +1,7 @@ module Model.Types.Allocation ( AllocationPriority(..) + , AllocationPriorityComparison(..) + , AllocationFingerprint , module Utils.Allocation ) where @@ -11,12 +13,15 @@ import qualified Data.Csv as Csv 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) diff --git a/src/Model/Types/Exam.hs b/src/Model/Types/Exam.hs index d7a1ae6e3..afd09396e 100644 --- a/src/Model/Types/Exam.hs +++ b/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) diff --git a/src/Settings.hs b/src/Settings.hs index f03f02733..9fc92048b 100644 --- a/src/Settings.hs +++ b/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" diff --git a/test/Database.hs b/test/Database.hs index 8b8e9515e..9605531e2 100755 --- a/test/Database.hs +++ b/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