diff --git a/config/settings.yml b/config/settings.yml index 12150c38e..0f439d9d6 100644 --- a/config/settings.yml +++ b/config/settings.yml @@ -130,5 +130,11 @@ user-defaults: download-files: false warning-days: 1209600 +# During central allocations lecturer-given ratings of applications (as +# ExamGrades) are combined with a central priority. +# This encodes the weight of the lecturer ratings on the same scale as the +# centrally supplied priorities. +allocation-grade-scale: 25 + instance-id: "_env:INSTANCE_ID:instance" ribbon: "_env:RIBBON:" diff --git a/models/allocations.model b/models/allocations.model index 9ddbd59bd..dbca97b85 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 + 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 @@ -35,6 +36,7 @@ AllocationUser allocation AllocationId user UserId totalCourses Natural -- number of total allocated courses for this user must be <= than this number + priority AllocationPriority Maybe UniqueAllocationUser allocation user AllocationDeregister -- self-inflicted user-deregistrations from an allocated course diff --git a/models/courses.model b/models/courses.model index 5cdecddd6..ebdf6e62a 100644 --- a/models/courses.model +++ b/models/courses.model @@ -51,7 +51,7 @@ CourseParticipant -- course enrolement user UserId registration UTCTime -- time of last enrolement for this course field StudyFeaturesId Maybe -- associated degree course, user-defined; required for communicating grades - allocated Bool default=false -- participant was centrally allocated + allocated AllocationId Maybe -- participant was centrally allocated UniqueParticipant user course -- Replace the last two by the following, once an audit log is available -- CourseUserNote -- lecturers of a specific course may share a text note on each enrolled student diff --git a/src/Handler/Allocation/Register.hs b/src/Handler/Allocation/Register.hs index eb5e55255..c502ab48a 100644 --- a/src/Handler/Allocation/Register.hs +++ b/src/Handler/Allocation/Register.hs @@ -50,6 +50,7 @@ postARegisterR tid ssh ash = do { allocationUserAllocation = aId , allocationUserUser = uid , allocationUserTotalCourses = arfTotalCourses + , allocationUserPriority = Nothing } [ AllocationUserTotalCourses =. arfTotalCourses ] diff --git a/src/Handler/Course/ParticipantInvite.hs b/src/Handler/Course/ParticipantInvite.hs index 9459346a3..fe9b96804 100644 --- a/src/Handler/Course/ParticipantInvite.hs +++ b/src/Handler/Course/ParticipantInvite.hs @@ -38,7 +38,7 @@ instance IsInvitableJunction CourseParticipant where data InvitableJunction CourseParticipant = JunctionParticipant { jParticipantRegistration :: UTCTime , jParticipantField :: Maybe StudyFeaturesId - , jParticipantAllocated :: Bool + , jParticipantAllocated :: Maybe AllocationId } deriving (Eq, Ord, Read, Show, Generic, Typeable) data InvitationDBData CourseParticipant = InvDBDataParticipant -- no data needed in DB to manage participant invitation @@ -90,7 +90,7 @@ participantInvitationConfig = InvitationConfig{..} now <- liftIO getCurrentTime studyFeatures <- wreq (studyFeaturesFieldFor Nothing False [] $ Just uid) (fslI MsgCourseStudyFeature & setTooltip MsgCourseStudyFeatureTip) Nothing - return . fmap (, ()) $ JunctionParticipant <$> pure now <*> studyFeatures <*> pure False + return . fmap (, ()) $ JunctionParticipant <$> pure now <*> studyFeatures <*> pure Nothing invitationInsertHook _ _ CourseParticipant{..} _ act = do res <- act audit $ TransactionCourseParticipantEdit courseParticipantCourse courseParticipantUser @@ -193,7 +193,7 @@ registerUser cid uid = exceptT tell tell $ do void . lift . lift . insert $ CourseParticipant { courseParticipantCourse = cid , courseParticipantUser = uid - , courseParticipantAllocated = False + , courseParticipantAllocated = Nothing , .. } lift . lift . audit $ TransactionCourseParticipantEdit cid uid diff --git a/src/Handler/Course/Register.hs b/src/Handler/Course/Register.hs index abef977ae..3cbc7e2e8 100644 --- a/src/Handler/Course/Register.hs +++ b/src/Handler/Course/Register.hs @@ -197,7 +197,7 @@ postCRegisterR tid ssh csh = do = return $ Just () mkRegistration = do audit $ TransactionCourseParticipantEdit cid uid - insertUnique $ CourseParticipant cid uid cTime crfStudyFeatures False + insertUnique $ CourseParticipant cid uid cTime crfStudyFeatures Nothing deleteApplications = do appIds <- selectKeysList [ CourseApplicationAllocation ==. Nothing, CourseApplicationCourse ==. cid, CourseApplicationUser ==. uid ] [] @@ -222,7 +222,7 @@ postCRegisterR tid ssh csh = do delete $ partId audit $ TransactionCourseParticipantDeleted cid uid - when courseParticipantAllocated $ do + when (is _Just courseParticipantAllocated) $ do now <- liftIO getCurrentTime insert_ $ AllocationDeregister courseParticipantUser (Just courseParticipantCourse) now Nothing diff --git a/src/Handler/Course/User.hs b/src/Handler/Course/User.hs index bd222d966..d60b3821e 100644 --- a/src/Handler/Course/User.hs +++ b/src/Handler/Course/User.hs @@ -150,7 +150,7 @@ postCUserR tid ssh csh uCId = do | otherwise = Nothing pId <- runDB $ do - pId <- insertUnique $ CourseParticipant cid uid now field False + pId <- insertUnique $ CourseParticipant cid uid now field Nothing when (is _Just pId) $ audit $ TransactionCourseParticipantEdit cid uid return pId diff --git a/src/Handler/Exam/AddUser.hs b/src/Handler/Exam/AddUser.hs index 23203d2f2..a475e7ef6 100644 --- a/src/Handler/Exam/AddUser.hs +++ b/src/Handler/Exam/AddUser.hs @@ -147,7 +147,7 @@ postEAddUserR tid ssh csh examn = do { courseParticipantCourse = cid , courseParticipantUser = uid , courseParticipantRegistration = now - , courseParticipantAllocated = False + , courseParticipantAllocated = Nothing , .. } lift . lift . audit $ TransactionCourseParticipantEdit cid uid diff --git a/src/Handler/Exam/RegistrationInvite.hs b/src/Handler/Exam/RegistrationInvite.hs index ff707cf04..483071cad 100644 --- a/src/Handler/Exam/RegistrationInvite.hs +++ b/src/Handler/Exam/RegistrationInvite.hs @@ -97,7 +97,7 @@ examRegistrationInvitationConfig = InvitationConfig{..} (True , _ ) -> return $ pure (JunctionExamRegistration invDBExamRegistrationOccurrence now, Nothing) invitationInsertHook (Entity eid Exam{..}) _ ExamRegistration{..} mField act = do whenIsJust mField $ \cpField -> do - insert_ $ CourseParticipant examCourse examRegistrationUser examRegistrationTime cpField False + insert_ $ CourseParticipant examCourse examRegistrationUser examRegistrationTime cpField Nothing audit $ TransactionCourseParticipantEdit examCourse examRegistrationUser let doAudit = audit $ TransactionExamRegister eid examRegistrationUser diff --git a/src/Handler/Exam/Users.hs b/src/Handler/Exam/Users.hs index 87f8e1cb5..084263183 100644 --- a/src/Handler/Exam/Users.hs +++ b/src/Handler/Exam/Users.hs @@ -742,7 +742,7 @@ postEUsersR tid ssh csh examn = do , courseParticipantUser = examUserCsvActUser , courseParticipantRegistration = now , courseParticipantField = examUserCsvActCourseField - , courseParticipantAllocated = False + , courseParticipantAllocated = Nothing } audit $ TransactionCourseParticipantEdit examCourse examUserCsvActUser insert_ ExamRegistration diff --git a/src/Handler/Utils/Allocation.hs b/src/Handler/Utils/Allocation.hs new file mode 100644 index 000000000..d5fe3fb72 --- /dev/null +++ b/src/Handler/Utils/Allocation.hs @@ -0,0 +1,133 @@ +module Handler.Utils.Allocation + ( sinkAllocationPriorities + , computeAllocation + , doAllocation + , ppMatchingLog, storeMatchingLog + ) where + +import Import + +import qualified Data.Map.Strict as Map + +import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Utils as E + +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 Utils.Allocation + +import qualified Data.Conduit.List as C + +import Data.Generics.Product.Param + + +sinkAllocationPriorities :: AllocationId + -> ConduitT (Map UserMatriculation AllocationPriority) Void DB () +sinkAllocationPriorities allocId = C.mapM_ . imapM_ $ \matr prio -> + E.update $ \allocationUser -> do + E.set allocationUser [ AllocationUserPriority E.=. E.val (Just prio) ] + E.where_ $ allocationUser E.^. AllocationUserAllocation E.==. E.val allocId + E.where_ . E.exists . E.from $ \user -> + E.where_ $ user E.^. UserId E.==. allocationUser E.^. AllocationUserUser + E.&&. user E.^. UserMatrikelnummer E.==. E.val (Just matr) + + +computeAllocation :: AllocationId + -> DB (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' + + courses' <- E.select . E.from $ \(allocationCourse `E.InnerJoin` course) -> do + E.on $ allocationCourse E.^. AllocationCourseCourse E.==. course E.^. CourseId + E.&&. allocationCourse E.^. AllocationCourseAllocation E.==. E.val allocId + + let participants = E.sub_select . E.from $ \participant -> do + E.where_ $ participant E.^. CourseParticipantCourse E.==. course E.^. CourseId + E.where_ . E.not_ . E.exists . E.from $ \lecturer -> do + E.where_ $ lecturer E.^. LecturerCourse E.==. course E.^. CourseId + E.&&. lecturer E.^. LecturerUser E.==. participant E.^. CourseParticipantUser + return E.countRows + + return ( allocationCourse + , E.maybe E.nothing (\c -> E.just $ c E.-. participants) (course E.^. CourseCapacity) + , allocationCourse E.^. AllocationCourseMinCapacity E.-. participants + ) + 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 + Entity _ CourseApplication{..} <- applications'' + 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 + where + allocationPrio = allocationUserPriority . entityVal =<< listToMaybe (filter ((== user) . allocationUserUser . entityVal) users') + + 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 + | otherwise + = fromInteger + + g <- liftIO newStdGen + + let + doAllocationWithout cs = runWriter $ 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 + | not $ null belowMin = doAllocationWithout $ cs <> Set.fromList belowMin + | otherwise = (allocs, mLog) + where + (allocs, mLog) = doAllocationWithout cs + 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 + +doAllocation :: AllocationId + -> Set (UserId, CourseId) + -> DB () +doAllocation allocId regs = do + now <- liftIO getCurrentTime + forM_ regs $ \(uid, cid) -> do + mField <- (courseApplicationField . entityVal =<<) . listToMaybe <$> selectList [CourseApplicationCourse ==. cid, CourseApplicationUser ==. uid, CourseApplicationAllocation ==. Just allocId] [] + void . insertUnique $ CourseParticipant cid uid now mField (Just allocId) + +ppMatchingLog :: ( MonoFoldable mono + , Element mono ~ MatchingLog UserId CourseId Natural + ) + => mono -> Text +ppMatchingLog = unlines . map (tshow . pretty) . otoList + where + 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 ] diff --git a/src/Handler/Utils/Csv.hs b/src/Handler/Utils/Csv.hs index bc0617d29..00ae7af49 100644 --- a/src/Handler/Utils/Csv.hs +++ b/src/Handler/Utils/Csv.hs @@ -1,7 +1,7 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} module Handler.Utils.Csv - ( decodeCsv + ( decodeCsv, decodeCsvPositional , encodeCsv , encodeDefaultOrderedCsv , respondCsv, respondCsvDB @@ -35,9 +35,17 @@ import qualified Data.ByteString.Lazy as LBS import qualified Data.Attoparsec.ByteString.Lazy as A +import Control.Monad.Except (ExceptT) + decodeCsv :: (MonadThrow m, FromNamedRecord csv, MonadLogger m) => ConduitT ByteString csv m () -decodeCsv = transPipe throwExceptT $ do +decodeCsv = decodeCsv' fromNamedCsv + +decodeCsvPositional :: (MonadThrow m, FromRecord csv, MonadLogger m) => HasHeader -> ConduitT ByteString csv m () +decodeCsvPositional hdr = decodeCsv' (\opts -> fromCsv opts hdr) + +decodeCsv' :: (MonadThrow m, MonadLogger m) => (forall m'. Monad m' => DecodeOptions -> ConduitT ByteString csv (ExceptT CsvParseError m') ()) -> ConduitT ByteString csv m () +decodeCsv' fromCsv' = transPipe throwExceptT $ do testBuffer <- accumTestBuffer LBS.empty mapM_ leftover $ LBS.toChunks testBuffer @@ -45,7 +53,7 @@ decodeCsv = transPipe throwExceptT $ do & guessDelimiter testBuffer $logInfoS "decodeCsv" [st|Guessed Csv.DecodeOptions from buffer of size #{tshow (LBS.length testBuffer)}/#{tshow testBufferSize}: #{tshow decodeOptions}|] - fromNamedCsv decodeOptions + fromCsv' decodeOptions where testBufferSize = 4096 accumTestBuffer acc diff --git a/src/Model/Migration.hs b/src/Model/Migration.hs index 2c033b534..869db73e5 100644 --- a/src/Model/Migration.hs +++ b/src/Model/Migration.hs @@ -550,6 +550,17 @@ customMigrations = Map.fromListWith (>>) UPDATE "exam" SET "bonus_rule" = jsonb_insert("bonus_rule", '{round}' :: text[], '0.01' :: jsonb) WHERE "bonus_rule"->>'rule' = 'bonus-points'; |] ) + , ( AppliedMigrationKey [migrationVersion|23.0.0|] [version|24.0.0|] + , whenM (tableExists "course_participant") $ do + queryRes <- [sqlQQ|SELECT (EXISTS (SELECT 1 FROM "course_participant" WHERE "allocated" <> false))|] + case queryRes of + [Single False] -> + [executeQQ| + ALTER TABLE "course_participant" DROP COLUMN "allocated"; + ALTER TABLE "course_participant" ADD COLUMN "allocated" bigint; + |] + _other -> error "Cannot reconstruct course_participant.allocated" + ) ] diff --git a/src/Model/Types.hs b/src/Model/Types.hs index f6cc46755..2dff836fe 100644 --- a/src/Model/Types.hs +++ b/src/Model/Types.hs @@ -13,3 +13,4 @@ import Model.Types.Sheet as Types import Model.Types.Submission as Types import Model.Types.Misc as Types import Model.Types.School as Types +import Model.Types.Allocation as Types diff --git a/src/Model/Types/Allocation.hs b/src/Model/Types/Allocation.hs new file mode 100644 index 000000000..26fbaa6ad --- /dev/null +++ b/src/Model/Types/Allocation.hs @@ -0,0 +1,34 @@ +module Model.Types.Allocation + ( AllocationPriority(..) + , module Utils.Allocation + ) where + +import Import.NoModel +import Utils.Allocation (MatchingLog(..)) +import Model.Types.Common + +import qualified Data.Csv as Csv +import qualified Data.Vector as Vector + +import qualified Data.Map.Strict as Map + + +data AllocationPriority + = AllocationPriorityNumeric { allocationPriorities :: Vector Integer } + deriving (Eq, Ord, Read, Show, Generic, Typeable) +deriveJSON defaultOptions + { fieldLabelModifier = camelToPathPiece' 1 + , constructorTagModifier = camelToPathPiece' 2 + , allNullaryToStringTag = False + , sumEncoding = TaggedObject "mode" "value" + , unwrapUnaryRecords = False + , tagSingleConstructors = True + } ''AllocationPriority +derivePersistFieldJSON ''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 diff --git a/src/Settings.hs b/src/Settings.hs index 48d70d396..46cd62a3f 100644 --- a/src/Settings.hs +++ b/src/Settings.hs @@ -38,7 +38,7 @@ import qualified Yesod.Auth.Util.PasswordStore as PWStore import Data.Time (NominalDiffTime, nominalDay) -import Data.Scientific (toBoundedInteger) +import Data.Scientific (Scientific, toBoundedInteger) import Data.Word (Word16) import qualified Data.Text as Text @@ -130,6 +130,8 @@ data AppSettings = AppSettings , appTransactionLogIPRetentionTime :: NominalDiffTime + , appAllocationGradeScale :: Rational + , appReloadTemplates :: Bool -- ^ Use the reload version of templates , appMutableStatic :: Bool @@ -426,6 +428,8 @@ instance FromJSON AppSettings where appTransactionLogIPRetentionTime <- o .: "ip-retention-time" + appAllocationGradeScale <- o .: "allocation-grade-scale" <|> fmap toRational (o .: "allocation-grade-scale" :: Aeson.Parser Scientific) + appUserDefaults <- o .: "user-defaults" appAuthPWHash <- o .: "auth-pw-hash" diff --git a/src/Utils/Allocation.hs b/src/Utils/Allocation.hs index a00b0deb1..716faa2f2 100644 --- a/src/Utils/Allocation.hs +++ b/src/Utils/Allocation.hs @@ -29,12 +29,16 @@ type StudentIndex = Int type CloneIndex = Int data MatchingLog student course cloneIndex - = MatchingConsider student cloneIndex - | MatchingApply student cloneIndex course - | MatchingNoApplyCloneInstability student cloneIndex course - | MatchingLostSpot student cloneIndex course + = MatchingConsider + { mlStudent :: student, mlClone :: cloneIndex } + | MatchingApply + { mlStudent :: student, mlClone :: cloneIndex, mlCourse :: course } + | MatchingNoApplyCloneInstability + { mlStudent :: student, mlClone :: cloneIndex, mlCourse :: course } + | MatchingLostSpot + { mlStudent :: student, mlClone :: cloneIndex, mlCourse :: course } deriving (Eq, Ord, Read, Show, Generic, Typeable) - +instance (NFData student, NFData course, NFData cloneIndex) => NFData (MatchingLog student course cloneIndex) computeMatching :: forall randomGen student course cloneCount cloneIndex capacity studentRatingCourse courseRatingStudent courseRatingStudent'. ( RandomGen randomGen diff --git a/src/Utils/Lens.hs b/src/Utils/Lens.hs index c094419a1..234ab1075 100644 --- a/src/Utils/Lens.hs +++ b/src/Utils/Lens.hs @@ -206,6 +206,8 @@ makeLenses_ ''UserFunction makeLenses_ ''CourseUserExamOfficeOptOut makeLenses_ ''CourseNewsFile + +makeLenses_ ''AllocationCourse -- makeClassy_ ''Load diff --git a/test/Database.hs b/test/Database.hs index 78416f2fe..92d2a1473 100755 --- a/test/Database.hs +++ b/test/Database.hs @@ -469,7 +469,7 @@ fillDb = do insert_ $ SheetEdit gkleen now feste keine <- insert $ Sheet ffp "Keine Gruppen" Nothing NotGraded NoGroups Nothing Nothing now now Nothing Nothing (SubmissionMode False . Just $ UploadAny True Nothing) False insert_ $ SheetEdit gkleen now keine - void . insertMany $ map (\(u,sf) -> CourseParticipant ffp u now sf False) + void . insertMany $ map (\(u,sf) -> CourseParticipant ffp u now sf Nothing) [(fhamann , Nothing) ,(maxMuster , Just sfMMs) ,(tinaTester, Just sfTTc) @@ -592,7 +592,7 @@ fillDb = do insert_ $ CourseEdit jost now pmo void . insert $ DegreeCourse pmo sdBsc sdInf void . insert $ Lecturer jost pmo CourseAssistant - void . insertMany $ map (\(u,sf) -> CourseParticipant pmo u now sf False) + void . insertMany $ map (\(u,sf) -> CourseParticipant pmo u now sf Nothing) [(fhamann , Nothing) ,(maxMuster , Just sfMMp) ,(tinaTester, Just sfTTb) @@ -779,6 +779,7 @@ fillDb = do , allocationRegisterByStaffTo = Nothing , allocationRegisterByCourse = Nothing , allocationOverrideDeregister = Just now + , allocationMatchingLog = Nothing } insert_ $ AllocationCourse funAlloc pmo 100 insert_ $ AllocationCourse funAlloc ffp 2