From 5bc015ddcbcb62f99c69829669f74521841c2c9f Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Sun, 13 Oct 2019 21:41:29 +0200 Subject: [PATCH] refactor(allocations): store log/fingerprint separately --- models/allocations.model | 7 +++-- src/Crypto/Hash/Instances.hs | 34 +++++++++++++++++++- src/Handler/Utils/Allocation.hs | 56 +++++++++++++++++---------------- src/Model/Migration.hs | 9 ++++++ test/Database.hs | 2 -- 5 files changed, 76 insertions(+), 32 deletions(-) diff --git a/models/allocations.model b/models/allocations.model index 8f0805b34..7cbfe58bc 100644 --- a/models/allocations.model +++ b/models/allocations.model @@ -21,12 +21,15 @@ 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 deriving Show Eq Ord Generic +AllocationMatching + allocation AllocationId + fingerprint AllocationFingerprint + log FileId + AllocationCourse allocation AllocationId course CourseId diff --git a/src/Crypto/Hash/Instances.hs b/src/Crypto/Hash/Instances.hs index 66228a69e..3c07f0882 100644 --- a/src/Crypto/Hash/Instances.hs +++ b/src/Crypto/Hash/Instances.hs @@ -11,12 +11,44 @@ import Database.Persist import Database.Persist.Sql import Data.ByteArray (convert) +import Data.ByteArray.Encoding + +import qualified Data.ByteString.Char8 as CBS + +import Web.PathPieces +import Web.HttpApiData +import Data.Aeson as Aeson + +import Text.Read as Read instance HashAlgorithm hash => PersistField (Digest hash) where toPersistValue = PersistByteString . convert fromPersistValue (PersistByteString bs) = maybe (Left "Could not convert Digest from ByteString") Right $ digestFromByteString bs - fromPersistValue _ = Left "Digest values must be converted from PersistByteString" + fromPersistValue (PersistText t) = maybe (Left "Cours not convert Digest from String") Right $ readMay t + fromPersistValue _ = Left "Digest values must be converted from PersistByteString or PersistText" instance HashAlgorithm hash => PersistFieldSql (Digest hash) where sqlType _ = SqlBlob + +instance HashAlgorithm hash => Read (Digest hash) where + readPrec = do + str <- replicateM (2 * hashDigestSize (error "Value of type hash forced" :: hash)) Read.get + bs <- either fail return . convertFromBase Base16 $ CBS.pack str + maybe (fail "Could not convert digestFromByteString") return $ digestFromByteString (bs :: ByteString) + +instance HashAlgorithm hash => PathPiece (Digest hash) where + toPathPiece = showToPathPiece + fromPathPiece = readFromPathPiece + +instance HashAlgorithm hash => ToHttpApiData (Digest hash) where + toUrlPiece = tshow + +instance HashAlgorithm hash => FromHttpApiData (Digest hash) where + parseUrlPiece = maybe (Left "Could not read Digest") Right . readMay + +instance HashAlgorithm hash => ToJSON (Digest hash) where + toJSON = Aeson.String . toUrlPiece + +instance HashAlgorithm hash => FromJSON (Digest hash) where + parseJSON = withText "Digest" $ either (fail . unpack) return . parseUrlPiece diff --git a/src/Handler/Utils/Allocation.hs b/src/Handler/Utils/Allocation.hs index bcc17c0ef..827e1e467 100644 --- a/src/Handler/Utils/Allocation.hs +++ b/src/Handler/Utils/Allocation.hs @@ -3,9 +3,8 @@ module Handler.Utils.Allocation , ordinalPriorities , sinkAllocationPriorities , computeAllocation - , storeAllocationFingerprint , doAllocation - , ppMatchingLog, storeMatchingLog + , ppMatchingLog , storeAllocationResult ) where @@ -61,15 +60,26 @@ sinkAllocationPriorities allocId = C.mapM_ . imapM_ $ \matr prio -> computeAllocation :: AllocationId -> DB (AllocationFingerprint, Set (UserId, CourseId), Seq (MatchingLog UserId CourseId Natural)) computeAllocation allocId = do + allocations <- selectList [ CourseParticipantAllocated ==. Just allocId ] [] + let allocations' = allocations + & map ((, Sum 1) . courseParticipantUser . entityVal) + & Map.fromListWith (<>) + & fmap getSum + users' <- selectList [ AllocationUserAllocation ==. allocId ] [] let users'' = users' - & mapMaybe ( runMaybeT $ (,) <$> lift (allocationUserUser . entityVal) - <*> ( (,) <$> lift (allocationUserTotalCourses . entityVal) - <*> MaybeT (allocationUserPriority . entityVal) - ) + & mapMaybe ( runMaybeT $ do + user <- lift $ allocationUserUser . entityVal + totalCourses <- lift $ allocationUserTotalCourses . entityVal + priority <- MaybeT $ allocationUserPriority . entityVal + + let allocated = Map.findWithDefault 0 user allocations' + + guard $ totalCourses > allocated + + return (user, (totalCourses - allocated, priority)) ) & Map.fromList - & Map.filter ((> 0) . view _1) cloneCounts = Map.map (view _1) users'' allocationPrio = view _2 . (Map.!) users'' @@ -91,8 +101,14 @@ computeAllocation allocId = do let capacities = Map.filter (maybe True (> 0)) . Map.fromList $ (view (_1 . _entityVal . _allocationCourseCourse) &&& view (_2 . _Value)) <$> courses' applications' <- selectList [ CourseApplicationAllocation ==. Just allocId ] [] - let applications'' = applications' & filter ((\CourseApplication{..} -> not courseApplicationRatingVeto && fromMaybe True (courseApplicationRatingPoints ^? _Just . passingGrade . _Wrapped)) . entityVal) - preferences = Map.fromList $ do + 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) + let preferences = Map.fromList $ do Entity _ CourseApplication{..} <- applications'' return ((courseApplicationUser, courseApplicationCourse), (courseApplicationAllocationPriority, courseApplicationRatingPoints)) @@ -144,11 +160,6 @@ computeAllocation allocId = do 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) -> DB () @@ -167,20 +178,11 @@ ppMatchingLog = unlines . map (tshow . pretty) . otoList pretty = over (param @1) fromSqlKey . over (param @2) fromSqlKey -storeMatchingLog :: ( MonoFoldable mono - , Element mono ~ MatchingLog UserId CourseId Natural - ) - => AllocationId -> mono -> DB () -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 +storeAllocationResult allocId (allocFp, allocMatchings, ppMatchingLog -> allocLog) = do + now <- liftIO getCurrentTime + insert_ . AllocationMatching allocId allocFp <=< insert $ File "matchings.log" (Just $ encodeUtf8 allocLog) now + doAllocation allocId allocMatchings - storeMatchingLog allocId allocLog diff --git a/src/Model/Migration.hs b/src/Model/Migration.hs index 488d4c546..5f8ab418c 100644 --- a/src/Model/Migration.hs +++ b/src/Model/Migration.hs @@ -568,6 +568,15 @@ customMigrations = Map.fromListWith (>>) |] _other -> error "Cannot reconstruct course_participant.allocated" ) + , ( AppliedMigrationKey [migrationVersion|25.0.0|] [version|26.0.0|] + , whenM (tableExists "allocation") $ + [executeQQ| + CREATE TABLE "allocation_matching" ("id" SERIAL8 PRIMARY KEY UNIQUE, "allocation" INT8 NOT NULL, "fingerprint" BYTEA NOT NULL, "log" INT8 NOT NULL); + INSERT INTO "allocation_matching" ("allocation", "fingerprint", "log") (select "id" as "allocation", "fingerprint", "matching_log" as "log" from "allocation" where not ("matching_log" is null) and not ("fingerprint" is null)); + ALTER TABLE "allocation" DROP COLUMN "fingerprint"; + ALTER TABLE "allocation" DROP COLUMN "matching_log"; + |] + ) ] diff --git a/test/Database.hs b/test/Database.hs index 9605531e2..8473f7895 100755 --- a/test/Database.hs +++ b/test/Database.hs @@ -785,8 +785,6 @@ fillDb = do , allocationRegisterByStaffTo = Nothing , allocationRegisterByCourse = Nothing , allocationOverrideDeregister = Just now - , allocationFingerprint = Nothing - , allocationMatchingLog = Nothing } insert_ $ AllocationCourse funAlloc pmo 100 insert_ $ AllocationCourse funAlloc ffp 2