refactor(allocations): store log/fingerprint separately

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

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

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)
+        & mapMaybe ( runMaybeT $ do
-                                     <*> ( (,) <$> lift (allocationUserTotalCourses . entityVal)
+                       user <- lift $ allocationUserUser . entityVal
-                                               <*> MaybeT (allocationUserPriority . 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)
+  let alreadyAssigned (Entity _ CourseApplication{..}) = orM
-      preferences = Map.fromList $ do
+        [ 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
+storeAllocationResult allocId (allocFp, allocMatchings, ppMatchingLog -> allocLog) = do
-  storeAllocationFingerprint allocId allocFp
+  now <- liftIO getCurrentTime
+  insert_ . AllocationMatching allocId allocFp <=< insert $ File "matchings.log" (Just $ encodeUtf8 allocLog) now
+
   doAllocation allocId allocMatchings
-  storeMatchingLog allocId allocLog

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

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