From fce531cdda756b4da03c74927e67f8b89f4e1554 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Sun, 19 May 2019 10:34:18 +0200 Subject: [PATCH 01/11] Fix tests --- test/Model/TypesSpec.hs | 25 +++++++++++++++++-------- 1 file changed, 17 insertions(+), 8 deletions(-) diff --git a/test/Model/TypesSpec.hs b/test/Model/TypesSpec.hs index 7e725c166..289df3136 100644 --- a/test/Model/TypesSpec.hs +++ b/test/Model/TypesSpec.hs @@ -13,6 +13,9 @@ import System.IO.Unsafe import Yesod.Auth.Util.PasswordStore +instance (Arbitrary a, MonoFoldable a) => Arbitrary (NonNull a) where + arbitrary = arbitrary `suchThatMap` fromNullable + instance Arbitrary Season where arbitrary = genericArbitrary shrink = genericShrink @@ -62,10 +65,18 @@ instance Arbitrary SubmissionFileType where arbitrary = genericArbitrary shrink = genericShrink +instance Arbitrary UploadSpecificFile where + arbitrary = genericArbitrary + shrink = genericShrink + instance Arbitrary UploadMode where arbitrary = genericArbitrary shrink = genericShrink +instance Arbitrary UploadModeDescr where + arbitrary = genericArbitrary + shrink = genericShrink + instance Arbitrary SubmissionMode where arbitrary = genericArbitrary shrink = genericShrink @@ -148,10 +159,6 @@ instance Arbitrary AuthenticationMode where instance Arbitrary LecturerType where arbitrary = genericArbitrary shrink = genericShrink - -instance Arbitrary a => Arbitrary (ZIPArchiveName a) where - arbitrary = genericArbitrary - shrink = genericShrink spec :: Spec @@ -177,10 +184,14 @@ spec = do [ eqLaws, showReadLaws, ordLaws, boundedEnumLaws, persistFieldLaws, pathPieceLaws, finiteLaws ] lawsCheckHspec (Proxy @SubmissionFileType) [ eqLaws, showReadLaws, ordLaws, boundedEnumLaws, pathPieceLaws, finiteLaws ] + lawsCheckHspec (Proxy @UploadSpecificFile) + [ eqLaws, showReadLaws, ordLaws, jsonLaws, persistFieldLaws ] lawsCheckHspec (Proxy @UploadMode) - [ eqLaws, showReadLaws, ordLaws, jsonLaws, persistFieldLaws, pathPieceLaws, finiteLaws ] + [ eqLaws, showReadLaws, ordLaws, jsonLaws, persistFieldLaws ] + lawsCheckHspec (Proxy @UploadModeDescr) + [ eqLaws, showReadLaws, ordLaws, boundedEnumLaws, finiteLaws, pathPieceLaws ] lawsCheckHspec (Proxy @SubmissionMode) - [ eqLaws, showReadLaws, ordLaws, jsonLaws, persistFieldLaws, finiteLaws ] + [ eqLaws, showReadLaws, ordLaws, jsonLaws, persistFieldLaws ] lawsCheckHspec (Proxy @SubmissionModeDescr) [ eqLaws, showReadLaws, ordLaws, boundedEnumLaws, finiteLaws, pathPieceLaws ] lawsCheckHspec (Proxy @ExamStatus) @@ -215,8 +226,6 @@ spec = do [ eqLaws, ordLaws, showReadLaws, jsonLaws, persistFieldLaws ] lawsCheckHspec (Proxy @LecturerType) [ eqLaws, ordLaws, showReadLaws, boundedEnumLaws, finiteLaws, jsonLaws, pathPieceLaws, persistFieldLaws ] - lawsCheckHspec (Proxy @(ZIPArchiveName (CI Text))) - [ eqLaws, ordLaws, showReadLaws, pathPieceLaws ] describe "TermIdentifier" $ do it "has compatible encoding/decoding to/from Text" . property $ From b18b3b95a9adde2ac53d8e8a7f181ca6128f2cdb Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Sun, 19 May 2019 13:55:56 +0200 Subject: [PATCH 02/11] Build failing testcase for assignSubmissions --- test/FoundationSpec.hs | 6 -- test/Handler/Utils/SubmissionSpec.hs | 135 +++++++++++++++++++++++++++ test/Model/TypesSpec.hs | 38 +++++++- test/ModelSpec.hs | 21 +++++ test/TestImport.hs | 3 +- 5 files changed, 194 insertions(+), 9 deletions(-) create mode 100644 test/Handler/Utils/SubmissionSpec.hs diff --git a/test/FoundationSpec.hs b/test/FoundationSpec.hs index 04081f1b9..b7af14fe9 100644 --- a/test/FoundationSpec.hs +++ b/test/FoundationSpec.hs @@ -7,12 +7,6 @@ import ModelSpec () import qualified Data.CryptoID as CID import Yesod.EmbeddedStatic -instance Arbitrary TermId where - arbitrary = TermKey <$> arbitrary - -instance Arbitrary SchoolId where - arbitrary = SchoolKey <$> arbitrary - instance Arbitrary (Route Auth) where arbitrary = oneof [ return CheckR diff --git a/test/Handler/Utils/SubmissionSpec.hs b/test/Handler/Utils/SubmissionSpec.hs new file mode 100644 index 000000000..995ae63d5 --- /dev/null +++ b/test/Handler/Utils/SubmissionSpec.hs @@ -0,0 +1,135 @@ +module Handler.Utils.SubmissionSpec where + +import qualified Yesod + +import TestImport + +import Handler.Utils.Submission +import ModelSpec () + +import qualified Data.Set as Set +import qualified Data.Map as Map + +import Data.List (genericLength) + +import qualified Data.CaseInsensitive as CI + +import System.IO.Unsafe + +import System.Random.Shuffle +import Control.Monad.Random.Class + +import Database.Persist.Sql (fromSqlKey) + + +userNumber :: TVar Natural +userNumber = unsafePerformIO $ newTVarIO 1 +{-# NOINLINE userNumber #-} + +makeUsers :: Natural -> SqlPersistM [Entity User] +makeUsers (fromIntegral -> n) = do + users' <- liftIO . replicateM n $ generate arbitrary + users <- forM users' $ \u -> do + i <- atomically $ readTVar userNumber <* modifyTVar userNumber succ + let u' = u { userIdent = CI.mk $ "user." <> tshow i + , userEmail = CI.mk $ "user." <> tshow i <> "@example.com" + } + return u' + uids <- insertMany users + return $ zipWith Entity uids users + +distributionExample :: SqlPersistM [(Natural, [Maybe Load])] -- ^ Number of submissions and corrector specification + -> ([Entity Submission] -> [Entity SheetCorrector] -> SqlPersistM ()) -- ^ Setup hook + -> (Map (Maybe SheetCorrector) (Set SubmissionId) -> Expectation) + -> YesodExample UniWorX () +distributionExample mkParameters setupHook cont = do + situations <- runDB $ do + term <- liftIO $ generate arbitrary + void . insert $ term + school <- liftIO $ generate arbitrary + void . insert $ school + course <- liftIO $ generate arbitrary <&> \c -> c { courseTerm = TermKey $ termName term, courseSchool = SchoolKey $ schoolShorthand school } + cid <- insert course + + steps <- mkParameters + let subsN = maybe 0 maximum . fromNullable $ map fst steps + correctorsN = maybe 0 maximum . fromNullable $ map (genericLength . snd) steps + participants <- makeUsers subsN + correctors <- makeUsers correctorsN + + situations <- forM steps $ \(subsN', loads) -> do + sheet <- liftIO $ generate arbitrary <&> \s -> s { sheetCourse = cid } + sid <- insert sheet + + participants' <- liftIO $ take (fromIntegral subsN') <$> shuffleM participants + let loads' = loads ++ replicate (fromIntegral $ correctorsN - genericLength loads) Nothing + + submissions <- forM participants' $ \(Entity uid _) -> do + sub@(Entity subId _) <- insertEntity $ Submission + sid + Nothing + Nothing + Nothing + Nothing + Nothing + void . insert $ SubmissionUser uid subId + return sub + + let sheetCorrectors = [ SheetCorrector corr sid load CorrectorNormal | (Entity corr _, Just load) <- zip correctors loads'] + scIds <- insertMany sheetCorrectors + let sheetCorrectors' = zipWith Entity scIds sheetCorrectors + + return (sid, (submissions, sheetCorrectors')) + + mapM_ (uncurry setupHook) $ map snd situations + + return situations + + let subIds = concatMap (\(_, (subs, _)) -> map entityKey subs) situations + + results <- runHandler . Yesod.runDB . mapM (\sid -> assignSubmissions sid Nothing) $ map fst situations + + submissions <- fmap concat . forM results $ \(assigned, unassigned) -> runDB $ selectList ([ SubmissionId <-. Set.toList assigned ] ||. [ SubmissionId <-. Set.toList unassigned ]) [] + + liftIO $ do + let (assigned, unassigned) = bimap concat concat $ unzip results + Set.union assigned unassigned `shouldBe` Set.fromList subIds + cont . Map.fromListWith mappend $ do + Entity subId Submission{..} <- submissions + let key = listToMaybe . filter (\(Entity _ (SheetCorrector uid _ _ _)) -> Just uid == submissionRatingBy) $ concatMap (\(_, (_, corrs)) -> corrs) situations + return (entityVal <$> key, Set.singleton subId) + + +spec :: Spec +spec = withApp . describe "Submission distribution" $ do + it "is fair" $ + distributionExample + (return [(500, replicate 10 (Just $ Load Nothing 1))]) + (\_ _ -> return ()) + (\result -> do + let countResult = Map.map Set.size result + countResult `shouldNotSatisfy` Map.member Nothing + countResult `shouldSatisfy` all (== 50) + ) + it "follows distribution" $ + distributionExample + (return [(500, replicate 6 (Just $ Load Nothing 1) ++ replicate 2 (Just $ Load Nothing 2))]) + (\_ _ -> return ()) + (\result -> do + let countResult = Map.map Set.size result + countResult `shouldNotSatisfy` Map.member Nothing + countResult `shouldSatisfy` all (\(Just (SheetCorrector _ _ (Load _ prop) _), subsSet) -> (== 50 * prop) $ fromIntegral subsSet) . Map.toList + ) + it "follows cumulative distribution over multiple sheets" $ do + ns <- liftIO . replicateM 5 . fmap fromInteger $ getRandomR (0, 100) + let ns' = ns ++ [500 - sum ns] + loads = replicate 6 (Just $ Load Nothing 1) ++ replicate 2 (Just $ Load Nothing 2) + distributionExample + (return [ (n, loads) | n <- ns' ]) + (\_ _ -> return ()) + (\result -> do + let countResult = Map.map Set.size result + countResult' = Map.mapKeysWith (+) (fmap $ \SheetCorrector{..} -> (fromSqlKey sheetCorrectorUser, byProportion sheetCorrectorLoad)) countResult + countResult `shouldNotSatisfy` Map.member Nothing + countResult' `shouldSatisfy` all (\(Just (_, prop), subsSet) -> (== 50 * prop) $ fromIntegral subsSet) . Map.toList + ) diff --git a/test/Model/TypesSpec.hs b/test/Model/TypesSpec.hs index 289df3136..354ef20e6 100644 --- a/test/Model/TypesSpec.hs +++ b/test/Model/TypesSpec.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE UndecidableInstances #-} + module Model.TypesSpec where import TestImport @@ -12,6 +14,13 @@ import MailSpec () import System.IO.Unsafe import Yesod.Auth.Util.PasswordStore +import Database.Persist.Sql (SqlBackend, fromSqlKey, toSqlKey) + +import Text.Blaze.Html +import Text.Blaze.Renderer.Text + +import qualified Data.Set as Set + instance (Arbitrary a, MonoFoldable a) => Arbitrary (NonNull a) where arbitrary = arbitrary `suchThatMap` fromNullable @@ -27,6 +36,14 @@ instance Arbitrary TermIdentifier where return $ TermIdentifier{..} shrink = genericShrink +instance Arbitrary TermId where + arbitrary = TermKey <$> arbitrary + shrink = map TermKey . shrink . unTermKey + +instance Arbitrary SchoolId where + arbitrary = SchoolKey <$> arbitrary + shrink = map SchoolKey . shrink . unSchoolKey + instance Arbitrary Pseudonym where arbitrary = Pseudonym <$> arbitraryBoundedIntegral @@ -66,11 +83,20 @@ instance Arbitrary SubmissionFileType where shrink = genericShrink instance Arbitrary UploadSpecificFile where - arbitrary = genericArbitrary + arbitrary = UploadSpecificFile + <$> (pack . getPrintableString <$> arbitrary) + <*> (pack . getPrintableString <$> arbitrary) + <*> arbitrary shrink = genericShrink instance Arbitrary UploadMode where - arbitrary = genericArbitrary + arbitrary = oneof + [ pure NoUpload + , UploadAny + <$> arbitrary + <*> (fromNullable . Set.fromList . map (pack . getPrintableString) <$> arbitrary) + , UploadSpecific <$> arbitrary + ] shrink = genericShrink instance Arbitrary UploadModeDescr where @@ -159,6 +185,14 @@ instance Arbitrary AuthenticationMode where instance Arbitrary LecturerType where arbitrary = genericArbitrary shrink = genericShrink + +instance {-# OVERLAPPABLE #-} ToBackendKey SqlBackend record => Arbitrary (Key record) where + arbitrary = toSqlKey <$> arbitrary + shrink = map toSqlKey . shrink . fromSqlKey + +instance Arbitrary Html where + arbitrary = (preEscapedToHtml :: String -> Html) . getPrintableString <$> arbitrary + shrink = map preEscapedToHtml . shrink . renderMarkup spec :: Spec diff --git a/test/ModelSpec.hs b/test/ModelSpec.hs index 3850363a6..f530ec26a 100644 --- a/test/ModelSpec.hs +++ b/test/ModelSpec.hs @@ -33,6 +33,27 @@ instance Arbitrary EmailAddress where isEmail l d = Email.isValid (makeEmailLike l d) makeEmailLike l d = CBS.concat [l, CBS.singleton '@', d] +instance Arbitrary Course where + arbitrary = genericArbitrary + shrink = genericShrink + +instance Arbitrary Sheet where + arbitrary = Sheet + <$> arbitrary + <*> (CI.mk . pack . getPrintableString <$> arbitrary) + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + shrink = genericShrink + instance Arbitrary User where arbitrary = do userIdent <- CI.mk . pack <$> oneof diff --git a/test/TestImport.hs b/test/TestImport.hs index 522201f4c..a9c5cd88d 100644 --- a/test/TestImport.hs +++ b/test/TestImport.hs @@ -6,7 +6,8 @@ module TestImport import Application (makeFoundation, makeLogWare) import ClassyPrelude as X hiding (delete, deleteBy, Handler, Index, (<.>), (<|), index, uncons, unsnoc, cons, snoc) import Database.Persist as X hiding (get) -import Database.Persist.Sql (SqlPersistM, runSqlPersistMPool) +import Database.Persist.Sql as X (SqlPersistM) +import Database.Persist.Sql (runSqlPersistMPool) import Foundation as X import Model as X import Test.Hspec as X From 27a5b83f55aeb7526d407d5b58518bdfb39bdfcb Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Sun, 19 May 2019 17:18:29 +0200 Subject: [PATCH 03/11] Re-do assignSubmissions to pass tests --- src/Handler/Utils/Submission.hs | 258 ++++++++++++++++---------------- src/Utils/Lens.hs | 2 + 2 files changed, 134 insertions(+), 126 deletions(-) diff --git a/src/Handler/Utils/Submission.hs b/src/Handler/Utils/Submission.hs index 09c59f6b3..17bcc2b73 100644 --- a/src/Handler/Utils/Submission.hs +++ b/src/Handler/Utils/Submission.hs @@ -13,27 +13,25 @@ module Handler.Utils.Submission import Import hiding (joinPath) import Jobs.Queue -import Prelude (lcm) import Yesod.Core.Types (HandlerContents(..), ErrorResponse(..)) import Utils.Lens -import Control.Monad.State hiding (forM_, mapM_,foldM) +import Control.Monad.State as State (StateT) +import Control.Monad.State.Class as State import Control.Monad.Writer (MonadWriter(..), execWriterT, execWriter) -import Control.Monad.RWS.Lazy (RWST) +import Control.Monad.RWS.Lazy (MonadRWS, RWST, execRWST) import qualified Control.Monad.Random as Rand import qualified System.Random.Shuffle as Rand (shuffleM) import Data.Maybe () -import qualified Data.List as List import Data.Set (Set) import qualified Data.Set as Set -import Data.Map (Map) +import Data.Map (Map, (!), (!?)) import qualified Data.Map as Map import qualified Data.Text as Text -import Data.Ratio import Data.Monoid (Monoid, Any(..), Sum(..)) import Generics.Deriving.Monoid (memptydefault, mappenddefault) @@ -56,155 +54,163 @@ import Text.Hamlet (ihamletFile) import qualified Control.Monad.Catch as E (Handler(..)) -data AssignSubmissionException = NoCorrectorsByProportion +data AssignSubmissionException = NoCorrectors + | NoCorrectorsByProportion + | SubmissionsNotFound (NonNull (Set SubmissionId)) deriving (Typeable, Show) instance Exception AssignSubmissionException -- | Assigns all submissions according to sheet corrector loads -assignSubmissions :: SheetId -- ^ Sheet do distribute to correction +assignSubmissions :: SheetId -- ^ Sheet to distribute to correctors -> Maybe (Set SubmissionId) -- ^ Optionally restrict submission to consider -> YesodDB UniWorX ( Set SubmissionId , Set SubmissionId ) -- ^ Returns assigned and unassigned submissions; unassigned submissions occur only if no tutors have an assigned load assignSubmissions sid restriction = do Sheet{..} <- getJust sid - correctors <- selectList [ SheetCorrectorSheet ==. sid, SheetCorrectorState ==. CorrectorNormal ] [] - let - -- byTutorial' uid = join . Map.lookup uid $ Map.fromList [ (sheetCorrectorUser, byTutorial sheetCorrectorLoad) | Entity _ SheetCorrector{..} <- corrsTutorial ] - corrsTutorial = filter hasTutorialLoad correctors -- needed as List within Esqueleto - corrsProp = filter hasPositiveLoad correctors - countsToLoad' :: UserId -> Bool - countsToLoad' uid = Map.findWithDefault True uid loadMap - loadMap :: Map UserId Bool - loadMap = Map.fromList [(sheetCorrectorUser,b) | Entity _ SheetCorrector{ sheetCorrectorLoad = (Load {byTutorial = Just b}), .. } <- corrsTutorial] - - currentSubs <- E.select . E.from $ \(submission `E.LeftOuterJoin` tutor') -> do - let tutors = E.subList_select . E.from $ \(submissionUser `E.InnerJoin` tutorialUser `E.InnerJoin` tutorial `E.InnerJoin` tutor) -> do - -- Uncomment next line for equal chance between tutors, irrespective of the number of students per tutor per submission group - -- E.distinctOn [E.don $ tutorial E.^. TutorialTutor] $ do - E.on (tutorial E.^. TutorialId E.==. tutor E.^. TutorTutorial) - E.on (tutorial E.^. TutorialId E.==. tutorialUser E.^. TutorialParticipantTutorial) - E.on (submissionUser E.^. SubmissionUserUser E.==. tutorialUser E.^. TutorialParticipantUser) - E.where_ (tutor E.^. TutorUser `E.in_` E.valList (map (sheetCorrectorUser . entityVal) corrsTutorial)) - return $ tutor E.^. TutorUser - E.on $ tutor' E.?. UserId `E.in_` E.justList tutors - E.where_ $ submission E.^. SubmissionSheet E.==. E.val sid - E.&&. maybe (E.val True) (submission E.^. SubmissionId `E.in_`) (E.valList . Set.toList <$> restriction) - return (submission E.^. SubmissionId, tutor' E.?. UserId) - - let subTutor' :: Map SubmissionId (Set UserId) - subTutor' = Map.fromListWith Set.union $ currentSubs - & mapped._2 %~ (maybe Set.empty Set.singleton . E.unValue) - & mapped._1 %~ E.unValue - - prevSubs <- E.select . E.from $ \((sheet `E.InnerJoin` sheetCorrector) `E.LeftOuterJoin` submission) -> do - E.on $ E.joinV (submission E.?. SubmissionRatingBy) E.==. E.just (sheetCorrector E.^. SheetCorrectorUser) - E.on $ sheetCorrector E.^. SheetCorrectorSheet E.==. sheet E.^. SheetId - let isByTutorial = E.exists . E.from $ \(submissionUser `E.InnerJoin` tutorialUser `E.InnerJoin` tutorial `E.InnerJoin` tutor) -> do - E.on (tutorial E.^. TutorialId E.==. tutor E.^. TutorTutorial) - E.on $ tutorial E.^. TutorialId E.==. tutorialUser E.^. TutorialParticipantTutorial - E.on $ submissionUser E.^. SubmissionUserUser E.==. tutorialUser E.^. TutorialParticipantUser - E.where_ $ tutor E.^. TutorUser E.==. sheetCorrector E.^. SheetCorrectorUser - E.&&. submission E.?. SubmissionId E.==. E.just (submissionUser E.^. SubmissionUserSubmission) - E.where_ $ sheet E.^. SheetCourse E.==. E.val sheetCourse - E.&&. sheetCorrector E.^. SheetCorrectorUser `E.in_` E.valList (map (sheetCorrectorUser . entityVal) correctors) - return (sheetCorrector, isByTutorial, E.isNothing (submission E.?. SubmissionId)) + correctorsRaw <- E.select . E.from $ \(sheet `E.InnerJoin` sheetCorrector) -> do + E.on $ sheet E.^. SheetId E.==. sheetCorrector E.^. SheetCorrectorSheet + E.where_ $ sheetCorrector E.^. SheetCorrectorState `E.in_` E.valList [CorrectorNormal, CorrectorMissing] + return (sheet E.^. SheetId, sheetCorrector) let - prevSubs' :: Map SheetId (Map UserId (Rational, Integer)) - prevSubs' = Map.unionsWith (Map.unionWith $ \(prop, n) (_, n') -> (prop, n + n')) $ do - (Entity _ SheetCorrector{ sheetCorrectorLoad = Load{..}, .. }, E.Value isByTutorial, E.Value isPlaceholder) <- prevSubs - guard $ maybe True (not isByTutorial ||) byTutorial - let proportion - | CorrectorExcused <- sheetCorrectorState = 0 - | otherwise = byProportion - return . Map.singleton sheetCorrectorSheet $ Map.singleton sheetCorrectorUser (proportion, bool 1 0 isPlaceholder) + correctors :: Map SheetId (Map UserId (Load, CorrectorState)) + correctors = Map.fromList $ do + E.Value sheetId <- Set.toList $ setOf (folded . _1) correctorsRaw + let loads = Map.fromList $ do + (E.Value sheetId', Entity _ SheetCorrector{..}) + <- correctorsRaw + guard $ sheetId' == sheetId + return (sheetCorrectorUser, (sheetCorrectorLoad, sheetCorrectorState)) + return (sheetId, loads) - deficit :: Map UserId Integer - deficit = Map.filter (> 0) $ Map.foldr (Map.unionWith (+) . toDeficit) Map.empty prevSubs' - - toDeficit :: Map UserId (Rational, Integer) -> Map UserId Integer - toDeficit assignments = toDeficit' <$> assignments + sheetCorrectors :: Map UserId Load + sheetCorrectors = Map.mapMaybe filterLoad $ correctors ! sid where - assigned' = getSum $ foldMap (Sum . snd) assignments - props = getSum $ foldMap (Sum . fst) assignments + filterLoad (l@Load{..}, CorrectorNormal) = l <$ guard (isJust byTutorial || byProportion /= 0) + filterLoad _ = Nothing - toDeficit' (prop, assigned) = let - target - | props == 0 = 0 - | otherwise = round $ fromInteger assigned' * (prop / props) - in target - assigned + unless (Map.member sid correctors) $ + throwM NoCorrectors - $logDebugS "assignSubmissions" $ "Previous submissions: " <> tshow prevSubs' - $logDebugS "assignSubmissions" $ "Current deficit: " <> tshow deficit + submissionDataRaw <- E.select . E.from $ \((sheet `E.InnerJoin` submission `E.InnerJoin` submissionUser) `E.LeftOuterJoin` (tutorialUser `E.InnerJoin` tutor)) -> do + E.on $ tutor E.?. TutorTutorial E.==. tutorialUser E.?. TutorialParticipantTutorial + E.on $ tutorialUser E.?. TutorialParticipantUser E.==. E.just (submissionUser E.^. SubmissionUserUser) + E.&&. tutor E.?. TutorUser `E.in_` E.justList (E.valList $ foldMap Map.keys correctors) + E.on $ submission E.^. SubmissionId E.==. submissionUser E.^. SubmissionUserSubmission + E.on $ submission E.^. SubmissionSheet E.==. sheet E.^. SheetId + + E.where_ $ sheet E.^. SheetCourse E.==. E.val sheetCourse + + return (sheet E.^. SheetId, submission, tutor E.?. TutorUser) let - lcd :: Integer - lcd = foldr lcm 1 $ map (denominator . byProportion . sheetCorrectorLoad . entityVal) corrsProp - wholeProps :: Map UserId Integer - wholeProps = Map.fromList [ ( sheetCorrectorUser, round $ byProportion * fromInteger lcd ) | Entity _ SheetCorrector{ sheetCorrectorLoad = Load{..}, .. } <- corrsProp ] - detQueueLength = fromIntegral (Map.size $ Map.filter (\tuts -> all countsToLoad' tuts) subTutor') - sum deficit - detQueue = concat . List.genericReplicate (detQueueLength `div` sum wholeProps) . concatMap (uncurry $ flip List.genericReplicate) $ Map.toList wholeProps + -- | All submissions in this course so far + submissionData :: Map SubmissionId + ( Maybe UserId -- Corrector + , Map UserId (Sum Natural) -- Tutors + , SheetId + ) + submissionData = Map.fromListWith merge $ map process submissionDataRaw + where + process (E.Value sheetId, Entity subId Submission{..}, E.Value mTutId) = (subId, (submissionRatingBy, maybe Map.empty (flip Map.singleton $ Sum 1) mTutId, sheetId)) + merge (corrA, tutorsA, sheetA) (corrB, tutorsB, sheetB) + | corrA /= corrB = error "Same submission seen with different correctors" + | sheetA /= sheetB = error "Same submission seen with different sheets" + | otherwise = (corrA, Map.unionWith mappend tutorsA tutorsB, sheetA) - $logDebugS "assignSubmissions" $ "Deterministic Queue: " <> tshow detQueue + targetSubmissions = Set.fromList $ do + (E.Value sheetId, Entity subId Submission{..}, _) <- submissionDataRaw + guard $ sheetId == sid + case restriction of + Just restriction' -> + guard $ subId `Set.member` restriction' + Nothing -> + guard $ is _Nothing submissionRatingBy + return subId - queue <- liftIO . Rand.evalRandIO . execWriterT $ do - tell $ map Just detQueue - forever $ - tell . pure =<< Rand.weightedMay [ (sheetCorrectorUser, byProportion sheetCorrectorLoad) | Entity _ SheetCorrector{..} <- corrsProp ] + targetSubmissionData = set _1 Nothing <$> Map.restrictKeys submissionData targetSubmissions + oldSubmissionData = Map.withoutKeys submissionData targetSubmissions - $logDebugS "assignSubmissions" $ "Queue: " <> tshow (take (Map.size subTutor') queue) + whenIsJust (fromNullable =<< fmap (`Set.difference` targetSubmissions) restriction) $ \missing -> + throwM $ SubmissionsNotFound missing let - assignSubmission :: MonadState (Map SubmissionId UserId, [Maybe UserId], Map UserId Integer) m => Bool -> SubmissionId -> UserId -> m () - assignSubmission countsToLoad smid tutid = do - _1 %= Map.insert smid tutid - _3 . at tutid %= assertM' (> 0) . maybe (-1) pred - when countsToLoad $ - _2 %= List.delete (Just tutid) + withSubmissionData :: MonadRWS (Map SubmissionId a) w (Map SubmissionId a) m + => (Map SubmissionId a -> b) + -> m b + withSubmissionData f = f <$> (mappend <$> ask <*> State.get) + + -- | How many additional submission should the given corrector be assigned, if possible? + calculateDeficit :: UserId -> Map SubmissionId (Maybe UserId, Map UserId _, SheetId) -> Integer + calculateDeficit corrector submissionState = getSum $ foldMap Sum deficitBySheet + where + sheetSizes :: Map SheetId Integer + -- ^ Number of assigned submissions (to anyone) per sheet + sheetSizes = Map.map getSum . Map.fromListWith mappend $ do + (_, (Just _, _, sheetId)) <- Map.toList submissionState + return (sheetId, Sum 1) - maximumDeficit :: (MonadState (_a, _b, Map UserId Integer) m, MonadIO m) => m (Maybe UserId) - maximumDeficit = do - transposed <- uses _3 invertMap - traverse (liftIO . Rand.evalRandIO . Rand.uniform . snd) (Map.lookupMax transposed) + deficitBySheet :: Map SheetId Integer + -- ^ Deficite of @corrector@ per sheet + deficitBySheet = flip Map.mapMaybeWithKey sheetSizes $ \sheetId sheetSize -> do + let assigned :: Integer + assigned = fromIntegral . Map.size $ Map.filter (\(mCorr, _, sheetId') -> mCorr == Just corrector && sheetId == sheetId') submissionState + proportionSum :: Rational + proportionSum = getSum . foldMap corrProportion . fromMaybe Map.empty $ correctors !? sheetId + where corrProportion (_, CorrectorExcused) = mempty + corrProportion (Load{..}, _) = Sum byProportion + extra + | Just (Load{..}, corrState) <- correctors !? sheetId >>= Map.lookup corrector + = sum + [ assigned + , fromMaybe 0 $ do -- If corrections assigned by tutorial do not count against proportion, substract them from deficit + tutCounts <- byTutorial + guard $ not tutCounts + guard $ corrState /= CorrectorExcused + return . negate . fromIntegral . Map.size $ Map.filter (\(mCorr, tutors, sheetId') -> mCorr == Just corrector && sheetId == sheetId' && Map.member corrector tutors) submissionState + , fromMaybe 0 $ do + guard $ corrState /= CorrectorExcused + return . negate . floor $ (byProportion / proportionSum) * fromIntegral sheetSize + ] + | otherwise + = assigned + return $ negate extra - subTutor'' <- liftIO . Rand.evalRandIO . Rand.shuffleM $ Map.toList subTutor' + targetSubmissions' <- liftIO . Rand.shuffleM $ Set.toList targetSubmissions - subTutor <- fmap (view _1) . flip execStateT (Map.empty, queue, deficit) . forM_ subTutor'' $ \(smid, tuts) -> do - let - restrictTuts - | Set.null tuts = id - | otherwise = flip Map.restrictKeys tuts - byDeficit <- withStateT (over _3 restrictTuts) maximumDeficit - case byDeficit of - Just q' -> do - $logDebugS "assignSubmissions" $ tshow smid <> " -> " <> tshow q' <> " (byDeficit)" - assignSubmission False smid q' - Nothing - | Set.null tuts -> do - q <- preuse $ _2 . _head . _Just - case q of - Just q' -> do - $logDebugS "assignSubmissions" $ tshow smid <> " -> " <> tshow q' <> " (queue)" - assignSubmission True smid q' - Nothing -> return () - | otherwise -> do - q <- liftIO . Rand.evalRandIO $ Rand.uniform tuts - $logDebugS "assignSubmissions" $ tshow smid <> " -> " <> tshow q <> " (tutorial)" - assignSubmission (countsToLoad' q) smid q + (newSubmissionData, ()) <- (\act -> execRWST act oldSubmissionData targetSubmissionData) . forM_ targetSubmissions' $ \subId -> do + tutors <- gets $ view _2 . (! subId) -- :: Map UserId (Sum Natural) + let acceptableCorrectors + | correctorsByTut <- Map.filter (is _Just . view _byTutorial) $ sheetCorrectors `Map.restrictKeys` Map.keysSet tutors + , not $ null correctorsByTut + = Map.keysSet correctorsByTut + | otherwise + = Map.keysSet $ Map.filter (views _byProportion (/= 0)) sheetCorrectors + + when (not $ null acceptableCorrectors) $ do + deficits <- sequence . flip Map.fromSet acceptableCorrectors $ withSubmissionData . calculateDeficit + let + bestCorrectors :: Set UserId + bestCorrectors = acceptableCorrectors + & maximumsBy (deficits !) + & maximumsBy (tutors !?) + + ix subId . _1 <~ Just <$> liftIO (Rand.uniform bestCorrectors) now <- liftIO getCurrentTime - forM_ (Map.toList subTutor) $ - \(smid, tutid) -> update smid [ SubmissionRatingBy =. Just tutid - , SubmissionRatingAssigned =. Just now ] - - let assignedSubmissions = Map.keysSet subTutor - unassigendSubmissions = Map.keysSet subTutor' \\ assignedSubmissions - return (assignedSubmissions, unassigendSubmissions) - where - hasPositiveLoad = (> 0) . byProportion . sheetCorrectorLoad . entityVal - hasTutorialLoad = isJust . byTutorial . sheetCorrectorLoad . entityVal + execWriterT . forM_ (Map.toList newSubmissionData) $ \(subId, (mCorrector, _, _)) -> case mCorrector of + Just corrector -> do + lift $ update subId [ SubmissionRatingBy =. Just corrector + , SubmissionRatingAssigned =. Just now + ] + tell (Set.singleton subId, mempty) + Nothing -> + tell (mempty, Set.singleton subId) + where + maximumsBy :: (Ord a, Ord b) => (a -> b) -> Set a -> Set a + maximumsBy f xs = flip Set.filter xs $ \x -> maybe True (((==) `on` f) x . maximumBy (comparing f)) $ fromNullable xs submissionFileSource :: SubmissionId -> Source (YesodDB UniWorX) (Entity File) diff --git a/src/Utils/Lens.hs b/src/Utils/Lens.hs index 51aa57fd0..b4cd5a572 100644 --- a/src/Utils/Lens.hs +++ b/src/Utils/Lens.hs @@ -77,6 +77,8 @@ hasEntityUser = hasEntity makeLenses_ ''SheetCorrector +makeLenses_ ''Load + makeLenses_ ''SubmissionGroup makeLenses_ ''SheetGrading From 848dc7470a79e200bb48cee505b3f7b6311fb209 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Sun, 19 May 2019 20:19:46 +0200 Subject: [PATCH 04/11] Additional testing --- models/tutorials | 1 + src/Handler/Utils/Submission.hs | 31 +++++++++++++++++++++------- test/Handler/Utils/SubmissionSpec.hs | 31 ++++++++++++++++++++++++++-- test/Model/TypesSpec.hs | 17 +++++++++++++++ test/ModelSpec.hs | 15 ++++++++++++++ 5 files changed, 85 insertions(+), 10 deletions(-) diff --git a/models/tutorials b/models/tutorials index 444d988cd..4961e0bd5 100644 --- a/models/tutorials +++ b/models/tutorials @@ -11,6 +11,7 @@ Tutorial json deregisterUntil UTCTime Maybe lastChanged UTCTime default=now() UniqueTutorial course name + deriving Generic Tutor tutorial TutorialId user UserId diff --git a/src/Handler/Utils/Submission.hs b/src/Handler/Utils/Submission.hs index 17bcc2b73..9f604afd1 100644 --- a/src/Handler/Utils/Submission.hs +++ b/src/Handler/Utils/Submission.hs @@ -94,10 +94,12 @@ assignSubmissions sid restriction = do unless (Map.member sid correctors) $ throwM NoCorrectors - submissionDataRaw <- E.select . E.from $ \((sheet `E.InnerJoin` submission `E.InnerJoin` submissionUser) `E.LeftOuterJoin` (tutorialUser `E.InnerJoin` tutor)) -> do - E.on $ tutor E.?. TutorTutorial E.==. tutorialUser E.?. TutorialParticipantTutorial + submissionDataRaw <- E.select . E.from $ \((sheet `E.InnerJoin` submission `E.InnerJoin` submissionUser) `E.LeftOuterJoin` (tutorial `E.InnerJoin` tutorialUser `E.InnerJoin` tutor)) -> do + E.on $ tutor E.?. TutorTutorial E.==. tutorial E.?. TutorialId + E.on $ tutorialUser E.?. TutorialParticipantTutorial E.==. tutorial E.?. TutorialId E.on $ tutorialUser E.?. TutorialParticipantUser E.==. E.just (submissionUser E.^. SubmissionUserUser) E.&&. tutor E.?. TutorUser `E.in_` E.justList (E.valList $ foldMap Map.keys correctors) + E.&&. tutorial E.?. TutorialCourse E.==. E.just (E.val sheetCourse) E.on $ submission E.^. SubmissionId E.==. submissionUser E.^. SubmissionUserSubmission E.on $ submission E.^. SubmissionSheet E.==. sheet E.^. SheetId @@ -114,12 +116,15 @@ assignSubmissions sid restriction = do ) submissionData = Map.fromListWith merge $ map process submissionDataRaw where - process (E.Value sheetId, Entity subId Submission{..}, E.Value mTutId) = (subId, (submissionRatingBy, maybe Map.empty (flip Map.singleton $ Sum 1) mTutId, sheetId)) + process (E.Value sheetId, Entity subId Submission{..}, E.Value mTutId) = (subId, (submissionRatingBy, maybe Map.empty (flip Map.singleton $ Sum 1) $ assertM isCorrectorByTutorial mTutId, sheetId)) merge (corrA, tutorsA, sheetA) (corrB, tutorsB, sheetB) | corrA /= corrB = error "Same submission seen with different correctors" | sheetA /= sheetB = error "Same submission seen with different sheets" | otherwise = (corrA, Map.unionWith mappend tutorsA tutorsB, sheetA) + -- Not done in esqueleto, since inspection of `Load`-Values is difficult + isCorrectorByTutorial = maybe False (\Load{..} -> is _Just byTutorial) . flip Map.lookup sheetCorrectors + targetSubmissions = Set.fromList $ do (E.Value sheetId, Entity subId Submission{..}, _) <- submissionDataRaw guard $ sheetId == sid @@ -143,7 +148,7 @@ assignSubmissions sid restriction = do withSubmissionData f = f <$> (mappend <$> ask <*> State.get) -- | How many additional submission should the given corrector be assigned, if possible? - calculateDeficit :: UserId -> Map SubmissionId (Maybe UserId, Map UserId _, SheetId) -> Integer + calculateDeficit :: UserId -> Map SubmissionId (Maybe UserId, Map UserId _, SheetId) -> Rational calculateDeficit corrector submissionState = getSum $ foldMap Sum deficitBySheet where sheetSizes :: Map SheetId Integer @@ -152,10 +157,10 @@ assignSubmissions sid restriction = do (_, (Just _, _, sheetId)) <- Map.toList submissionState return (sheetId, Sum 1) - deficitBySheet :: Map SheetId Integer + deficitBySheet :: Map SheetId Rational -- ^ Deficite of @corrector@ per sheet deficitBySheet = flip Map.mapMaybeWithKey sheetSizes $ \sheetId sheetSize -> do - let assigned :: Integer + let assigned :: Rational assigned = fromIntegral . Map.size $ Map.filter (\(mCorr, _, sheetId') -> mCorr == Just corrector && sheetId == sheetId') submissionState proportionSum :: Rational proportionSum = getSum . foldMap corrProportion . fromMaybe Map.empty $ correctors !? sheetId @@ -172,13 +177,16 @@ assignSubmissions sid restriction = do return . negate . fromIntegral . Map.size $ Map.filter (\(mCorr, tutors, sheetId') -> mCorr == Just corrector && sheetId == sheetId' && Map.member corrector tutors) submissionState , fromMaybe 0 $ do guard $ corrState /= CorrectorExcused - return . negate . floor $ (byProportion / proportionSum) * fromIntegral sheetSize + return . negate $ (byProportion / proportionSum) * fromIntegral sheetSize ] | otherwise = assigned return $ negate extra - targetSubmissions' <- liftIO . Rand.shuffleM $ Set.toList targetSubmissions + -- Sort target submissions by those that have tutors first and otherwise random + -- + -- Deficit produced by restriction to tutors can thus be fixed by later submissions + targetSubmissions' <- liftIO . unstableSortBy (comparing $ \subId -> Map.null . view _2 $ submissionData ! subId) $ Set.toList targetSubmissions (newSubmissionData, ()) <- (\act -> execRWST act oldSubmissionData targetSubmissionData) . forM_ targetSubmissions' $ \subId -> do tutors <- gets $ view _2 . (! subId) -- :: Map UserId (Sum Natural) @@ -197,6 +205,10 @@ assignSubmissions sid restriction = do & maximumsBy (deficits !) & maximumsBy (tutors !?) + $logDebugS "assignSubmissions" [st|Tutors for #{tshow subId}: #{tshow tutors}|] + $logDebugS "assignSubmissions" [st|Current (#{tshow subId}) relevant deficits: #{tshow deficits}|] + $logDebugS "assignSubmissions" [st|Assigning #{tshow subId} to one of #{tshow bestCorrectors}|] + ix subId . _1 <~ Just <$> liftIO (Rand.uniform bestCorrectors) now <- liftIO getCurrentTime @@ -212,6 +224,9 @@ assignSubmissions sid restriction = do maximumsBy :: (Ord a, Ord b) => (a -> b) -> Set a -> Set a maximumsBy f xs = flip Set.filter xs $ \x -> maybe True (((==) `on` f) x . maximumBy (comparing f)) $ fromNullable xs + unstableSortBy :: MonadRandom m => (a -> a -> Ordering) -> [a] -> m [a] + unstableSortBy cmp = fmap concat . mapM Rand.shuffleM . groupBy (\a b -> cmp a b == EQ) . sortBy cmp + submissionFileSource :: SubmissionId -> Source (YesodDB UniWorX) (Entity File) submissionFileSource = E.selectSource . fmap snd . E.from . submissionFileQuery diff --git a/test/Handler/Utils/SubmissionSpec.hs b/test/Handler/Utils/SubmissionSpec.hs index 995ae63d5..e25a087fb 100644 --- a/test/Handler/Utils/SubmissionSpec.hs +++ b/test/Handler/Utils/SubmissionSpec.hs @@ -21,6 +21,8 @@ import Control.Monad.Random.Class import Database.Persist.Sql (fromSqlKey) +import qualified Database.Esqueleto as E + userNumber :: TVar Natural userNumber = unsafePerformIO $ newTVarIO 1 @@ -57,8 +59,8 @@ distributionExample mkParameters setupHook cont = do participants <- makeUsers subsN correctors <- makeUsers correctorsN - situations <- forM steps $ \(subsN', loads) -> do - sheet <- liftIO $ generate arbitrary <&> \s -> s { sheetCourse = cid } + situations <- forM (zip [1..] steps) $ \(i, (subsN', loads)) -> do + sheet <- liftIO $ generate arbitrary <&> \s -> s { sheetName = CI.mk $ "Sheet " <> tshow (i :: Integer), sheetCourse = cid } sid <- insert sheet participants' <- liftIO $ take (fromIntegral subsN') <$> shuffleM participants @@ -133,3 +135,28 @@ spec = withApp . describe "Submission distribution" $ do countResult `shouldNotSatisfy` Map.member Nothing countResult' `shouldSatisfy` all (\(Just (_, prop), subsSet) -> (== 50 * prop) $ fromIntegral subsSet) . Map.toList ) + it "handles tutorials with proportion" $ do + ns <- liftIO . replicateM 5 . fmap fromInteger $ getRandomR (0, 100) + let ns' = ns ++ [500 - sum ns] + loads = replicate 6 (Just $ Load Nothing 1) ++ replicate 2 (Just $ Load Nothing 2) + distributionExample + (return [ (n, loads) | n <- ns' ]) + (\subs corrs -> do + tutSubmissions <- liftIO $ getRandomR (1,500) + subs' <- liftIO $ shuffleM subs + forM_ (take tutSubmissions subs') $ \(Entity subId Submission{..}) -> do + Entity _ SheetCorrector{..} <- liftIO $ uniform corrs + Sheet{..} <- getJust submissionSheet + tut <- liftIO $ generate arbitrary <&> \c -> c { tutorialName = CI.mk $ "Tut for " <> tshow (fromSqlKey subId), tutorialCourse = sheetCourse } + tutId <- insert tut + void . insert $ Tutor tutId sheetCorrectorUser + E.insertSelect . E.from $ \submissionUser -> do + E.where_ $ submissionUser E.^. SubmissionUserSubmission E.==. E.val subId + return $ TutorialParticipant E.<# E.val tutId E.<&> (submissionUser E.^. SubmissionUserUser) + ) + (\result -> do + let countResult = Map.map Set.size result + countResult' = Map.mapKeysWith (+) (fmap $ \SheetCorrector{..} -> (fromSqlKey sheetCorrectorUser, byProportion sheetCorrectorLoad)) countResult + countResult `shouldNotSatisfy` Map.member Nothing + countResult' `shouldSatisfy` all (\(Just (_, prop), subsSet) -> (== 50 * prop) $ fromIntegral subsSet) . Map.toList + ) diff --git a/test/Model/TypesSpec.hs b/test/Model/TypesSpec.hs index 354ef20e6..ad74f5831 100644 --- a/test/Model/TypesSpec.hs +++ b/test/Model/TypesSpec.hs @@ -21,6 +21,8 @@ import Text.Blaze.Renderer.Text import qualified Data.Set as Set +import Time.Types (WeekDay(..)) + instance (Arbitrary a, MonoFoldable a) => Arbitrary (NonNull a) where arbitrary = arbitrary `suchThatMap` fromNullable @@ -193,6 +195,21 @@ instance {-# OVERLAPPABLE #-} ToBackendKey SqlBackend record => Arbitrary (Key r instance Arbitrary Html where arbitrary = (preEscapedToHtml :: String -> Html) . getPrintableString <$> arbitrary shrink = map preEscapedToHtml . shrink . renderMarkup + +instance Arbitrary WeekDay where + arbitrary = oneof $ map pure [minBound..maxBound] + +instance Arbitrary OccurenceSchedule where + arbitrary = genericArbitrary + shrink = genericShrink + +instance Arbitrary OccurenceException where + arbitrary = genericArbitrary + shrink = genericShrink + +instance Arbitrary Occurences where + arbitrary = genericArbitrary + shrink = genericShrink spec :: Spec diff --git a/test/ModelSpec.hs b/test/ModelSpec.hs index f530ec26a..e5fbdb9c3 100644 --- a/test/ModelSpec.hs +++ b/test/ModelSpec.hs @@ -54,6 +54,21 @@ instance Arbitrary Sheet where <*> arbitrary shrink = genericShrink +instance Arbitrary Tutorial where + arbitrary = Tutorial + <$> (CI.mk . pack . getPrintableString <$> arbitrary) + <*> arbitrary + <*> (CI.mk . pack . getPrintableString <$> arbitrary) + <*> (fmap getPositive <$> arbitrary) + <*> (pack . getPrintableString <$> arbitrary) + <*> arbitrary + <*> (fmap (CI.mk . pack . getPrintableString) <$> arbitrary) + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + shrink = genericShrink + instance Arbitrary User where arbitrary = do userIdent <- CI.mk . pack <$> oneof From 7deba8132004626fe4c2ea7b9efa176caf59c03b Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Mon, 20 May 2019 00:06:15 +0200 Subject: [PATCH 05/11] Additional testing --- package.yaml | 1 + src/Handler/Utils/Submission.hs | 8 +++--- test/Handler/Utils/SubmissionSpec.hs | 41 +++++++++++++++++++++++++--- 3 files changed, 42 insertions(+), 8 deletions(-) diff --git a/package.yaml b/package.yaml index 098fb0bec..417b74e26 100644 --- a/package.yaml +++ b/package.yaml @@ -243,6 +243,7 @@ tests: - uniworx - hspec >=2.0.0 - QuickCheck + - HUnit - yesod-test - conduit-extra - quickcheck-classes diff --git a/src/Handler/Utils/Submission.hs b/src/Handler/Utils/Submission.hs index 9f604afd1..8fededf3f 100644 --- a/src/Handler/Utils/Submission.hs +++ b/src/Handler/Utils/Submission.hs @@ -188,7 +188,7 @@ assignSubmissions sid restriction = do -- Deficit produced by restriction to tutors can thus be fixed by later submissions targetSubmissions' <- liftIO . unstableSortBy (comparing $ \subId -> Map.null . view _2 $ submissionData ! subId) $ Set.toList targetSubmissions - (newSubmissionData, ()) <- (\act -> execRWST act oldSubmissionData targetSubmissionData) . forM_ targetSubmissions' $ \subId -> do + (newSubmissionData, ()) <- (\act -> execRWST act oldSubmissionData targetSubmissionData) . forM_ (zip [1..] targetSubmissions') $ \(i, subId) -> do tutors <- gets $ view _2 . (! subId) -- :: Map UserId (Sum Natural) let acceptableCorrectors | correctorsByTut <- Map.filter (is _Just . view _byTutorial) $ sheetCorrectors `Map.restrictKeys` Map.keysSet tutors @@ -205,9 +205,9 @@ assignSubmissions sid restriction = do & maximumsBy (deficits !) & maximumsBy (tutors !?) - $logDebugS "assignSubmissions" [st|Tutors for #{tshow subId}: #{tshow tutors}|] - $logDebugS "assignSubmissions" [st|Current (#{tshow subId}) relevant deficits: #{tshow deficits}|] - $logDebugS "assignSubmissions" [st|Assigning #{tshow subId} to one of #{tshow bestCorrectors}|] + $logDebugS "assignSubmissions" [st|#{tshow i} Tutors for #{tshow subId}: #{tshow tutors}|] + $logDebugS "assignSubmissions" [st|#{tshow i} Current (#{tshow subId}) relevant deficits: #{tshow deficits}|] + $logDebugS "assignSubmissions" [st|#{tshow i} Assigning #{tshow subId} to one of #{tshow bestCorrectors}|] ix subId . _1 <~ Just <$> liftIO (Rand.uniform bestCorrectors) diff --git a/test/Handler/Utils/SubmissionSpec.hs b/test/Handler/Utils/SubmissionSpec.hs index e25a087fb..4caeba5fa 100644 --- a/test/Handler/Utils/SubmissionSpec.hs +++ b/test/Handler/Utils/SubmissionSpec.hs @@ -3,11 +3,13 @@ module Handler.Utils.SubmissionSpec where import qualified Yesod import TestImport +-- import qualified Test.HUnit.Base as HUnit import Handler.Utils.Submission import ModelSpec () import qualified Data.Set as Set +import Data.Map ((!?)) import qualified Data.Map as Map import Data.List (genericLength) @@ -19,10 +21,12 @@ import System.IO.Unsafe import System.Random.Shuffle import Control.Monad.Random.Class -import Database.Persist.Sql (fromSqlKey) +import Database.Persist.Sql (toSqlKey, fromSqlKey) import qualified Database.Esqueleto as E +-- import Data.Maybe (fromJust) + userNumber :: TVar Natural userNumber = unsafePerformIO $ newTVarIO 1 @@ -135,10 +139,27 @@ spec = withApp . describe "Submission distribution" $ do countResult `shouldNotSatisfy` Map.member Nothing countResult' `shouldSatisfy` all (\(Just (_, prop), subsSet) -> (== 50 * prop) $ fromIntegral subsSet) . Map.toList ) + it "follows non-constant cumulative distribution over multiple sheets" $ do + let ns = replicate 4 100 + loads = do + (onesBefore, onesAfter) <- zip [0,2..6] [6,4..0] + return $ replicate onesBefore (Just $ Load Nothing 1) + ++ replicate 2 (Just $ Load Nothing 2) + ++ replicate onesAfter (Just $ Load Nothing 1) + distributionExample + (return $ zip ns loads) + (\_ _ -> return ()) + (\result -> do + let countResult = Map.map Set.size result + countResult' = Map.mapKeysWith (+) (fmap $ \SheetCorrector{..} -> fromSqlKey sheetCorrectorUser) countResult + countResult `shouldNotSatisfy` Map.member Nothing + countResult' `shouldSatisfy` all (\(Just _, subsSet) -> subsSet == 50) . Map.toList + ) it "handles tutorials with proportion" $ do ns <- liftIO . replicateM 5 . fmap fromInteger $ getRandomR (0, 100) let ns' = ns ++ [500 - sum ns] - loads = replicate 6 (Just $ Load Nothing 1) ++ replicate 2 (Just $ Load Nothing 2) + loads = replicate 6 (Just $ Load (Just True) 1) ++ replicate 2 (Just $ Load (Just True) 2) + tutSubIds <- liftIO $ newTVarIO Map.empty distributionExample (return [ (n, loads) | n <- ns' ]) (\subs corrs -> do @@ -146,6 +167,7 @@ spec = withApp . describe "Submission distribution" $ do subs' <- liftIO $ shuffleM subs forM_ (take tutSubmissions subs') $ \(Entity subId Submission{..}) -> do Entity _ SheetCorrector{..} <- liftIO $ uniform corrs + atomically . modifyTVar tutSubIds . Map.insertWith mappend sheetCorrectorUser $ Set.singleton subId Sheet{..} <- getJust submissionSheet tut <- liftIO $ generate arbitrary <&> \c -> c { tutorialName = CI.mk $ "Tut for " <> tshow (fromSqlKey subId), tutorialCourse = sheetCourse } tutId <- insert tut @@ -157,6 +179,17 @@ spec = withApp . describe "Submission distribution" $ do (\result -> do let countResult = Map.map Set.size result countResult' = Map.mapKeysWith (+) (fmap $ \SheetCorrector{..} -> (fromSqlKey sheetCorrectorUser, byProportion sheetCorrectorLoad)) countResult - countResult `shouldNotSatisfy` Map.member Nothing - countResult' `shouldSatisfy` all (\(Just (_, prop), subsSet) -> (== 50 * prop) $ fromIntegral subsSet) . Map.toList + tutSubIds' <- liftIO $ readTVarIO tutSubIds + + countResult' `shouldNotSatisfy` Map.member Nothing + countResult' `shouldSatisfy` all (\(Just (corr, prop), subsSet) -> fromIntegral subsSet <= max (50 * prop) (maybe 0 (fromIntegral . Set.size) $ tutSubIds' !? toSqlKey corr)) . Map.toList + + -- -- Does not currently work, because `User`s are reused within `distributionExample`, so submissions end up having more associated course-tutors, because the same user might be a member of a tutorial created for another submission + -- + -- let subs = fold tutSubIds' + -- forM_ subs $ \subId -> do + -- let tutors = Map.keysSet $ Map.filter (Set.member subId) tutSubIds' + -- assignedTo = Set.map (sheetCorrectorUser . fromJust) . Map.keysSet $ Map.filter (Set.member subId) result + -- HUnit.assertEqual ("Submission " <> show (fromSqlKey subId) <> " assigned to multiple correctors") 1 $ Set.size assignedTo + -- HUnit.assertEqual ("Submission " <> show (fromSqlKey subId) <> " assigned to non-tutors (" <> show (Set.map fromSqlKey tutors) <> ")") Set.empty (Set.map fromSqlKey $ assignedTo `Set.difference` tutors) ) From 10b34b9915b3298ef6cfcbdd0bc3a75123bc0d7e Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Mon, 20 May 2019 14:07:25 +0200 Subject: [PATCH 06/11] Bump ChangeLog --- ChangeLog.md | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/ChangeLog.md b/ChangeLog.md index 9f07bd783..64cf0b8f7 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,7 @@ + * Version 20.05.2019 + + Komplett überarbeitete Funktionalität zur automatischen Verteilung von Korrekturen + * Version 13.05.2019 Kursverwalter können Teilnehmer hinzufügen From 0c1c647189904bfa9a78e85c22d74f685761729e Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Mon, 20 May 2019 14:10:12 +0200 Subject: [PATCH 07/11] Handle AssignSubmissionException in correctionsR Fix #382 --- messages/uniworx/de.msg | 4 ++++ src/Handler/Corrections.hs | 13 ++++++++++++- src/Handler/Utils/Submission.hs | 2 +- templates/messages/submissionsAssignNotFound.hamlet | 4 ++++ 4 files changed, 21 insertions(+), 2 deletions(-) create mode 100644 templates/messages/submissionsAssignNotFound.hamlet diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 70f005dfc..1ab2e4bf5 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -394,6 +394,10 @@ UpdatedAssignedCorrectorsAuto num@Int64: #{display num} Abgaben wurden unter den CouldNotAssignCorrectorsAuto num@Int64: #{display num} Abgaben konnten nicht automatisch zugewiesen werden: SelfCorrectors num@Int64: #{display num} Abgaben wurden Abgebenden als eigenem Korrektor zugeteilt! +AssignSubmissionExceptionNoCorrectors: Es sind keine Korrektoren eingestellt +AssignSubmissionExceptionNoCorrectorsByProportion: Es sind keine Korrektoren mit Anteil ungleich Null eingestellt +AssignSubmissionExceptionSubmissionsNotFound n@Int: #{tshow n} Abgaben konnten nicht gefunden werden + CorrectionsUploaded num@Int64: #{display num} Korrekturen wurden gespeichert: NoCorrectionsUploaded: In der hochgeladenen Datei wurden keine Korrekturen gefunden. diff --git a/src/Handler/Corrections.hs b/src/Handler/Corrections.hs index 78b5d187a..ca358a335 100644 --- a/src/Handler/Corrections.hs +++ b/src/Handler/Corrections.hs @@ -432,7 +432,18 @@ correctionsR whereClause displayColumns dbtFilterUI psValidator actions = do redirect currentRoute FormSuccess (CorrAutoSetCorrectorData shid, subs') -> do subs <- mapM decrypt $ Set.toList subs' - runDB $ do + let + assignExceptions :: AssignSubmissionException -> Handler () + assignExceptions NoCorrectors = addMessageI Error MsgAssignSubmissionExceptionNoCorrectors + assignExceptions NoCorrectorsByProportion = addMessageI Error MsgAssignSubmissionExceptionNoCorrectorsByProportion + assignExceptions (SubmissionsNotFound subIds) = do + subCIDs <- mapM encrypt . Set.toList $ toNullable subIds :: Handler [CryptoFileNameSubmission] + let errorModal = msgModal + [whamlet|_{MsgAssignSubmissionExceptionSubmissionsNotFound (length subCIDs)}|] + (Right $(widgetFile "messages/submissionsAssignNotFound")) + addMessageWidget Error errorModal + + handle assignExceptions . runDB $ do alreadyAssigned <- selectList [SubmissionId <-. subs, SubmissionRatingBy !=. Nothing] [] unless (null alreadyAssigned) $ do mr <- (toHtml . ) <$> getMessageRender diff --git a/src/Handler/Utils/Submission.hs b/src/Handler/Utils/Submission.hs index 8fededf3f..be6745a6a 100644 --- a/src/Handler/Utils/Submission.hs +++ b/src/Handler/Utils/Submission.hs @@ -57,7 +57,7 @@ import qualified Control.Monad.Catch as E (Handler(..)) data AssignSubmissionException = NoCorrectors | NoCorrectorsByProportion | SubmissionsNotFound (NonNull (Set SubmissionId)) - deriving (Typeable, Show) + deriving (Eq, Ord, Read, Show, Generic, Typeable) instance Exception AssignSubmissionException diff --git a/templates/messages/submissionsAssignNotFound.hamlet b/templates/messages/submissionsAssignNotFound.hamlet new file mode 100644 index 000000000..570e81459 --- /dev/null +++ b/templates/messages/submissionsAssignNotFound.hamlet @@ -0,0 +1,4 @@ +

_{MsgAssignSubmissionExceptionSubmissionsNotFound (length subCIDs)} +
    + $forall cID <- subCIDs + 
  • #{toPathPiece cID}

From 88b91108650ba2978858b4a57032ad79101d9f8a Mon Sep 17 00:00:00 2001
From: Gregor Kleen 
Date: Mon, 20 May 2019 14:23:15 +0200
Subject: [PATCH 08/11] Make test produce fewer false negatives

---
 test/Handler/Utils/SubmissionSpec.hs | 6 ++----
 1 file changed, 2 insertions(+), 4 deletions(-)

diff --git a/test/Handler/Utils/SubmissionSpec.hs b/test/Handler/Utils/SubmissionSpec.hs
index 4caeba5fa..763c40b14 100644
--- a/test/Handler/Utils/SubmissionSpec.hs
+++ b/test/Handler/Utils/SubmissionSpec.hs
@@ -163,7 +163,7 @@ spec = withApp . describe "Submission distribution" $ do
     distributionExample
       (return [ (n, loads) | n <- ns' ])
       (\subs corrs -> do
-          tutSubmissions <- liftIO $ getRandomR (1,500)
+          tutSubmissions <- liftIO $ getRandomR (1,50)
           subs' <- liftIO $ shuffleM subs
           forM_ (take tutSubmissions subs') $ \(Entity subId Submission{..}) -> do
             Entity _ SheetCorrector{..} <- liftIO $ uniform corrs
@@ -179,10 +179,8 @@ spec = withApp . describe "Submission distribution" $ do
       (\result -> do
           let countResult = Map.map Set.size result
               countResult' = Map.mapKeysWith (+) (fmap $ \SheetCorrector{..} -> (fromSqlKey sheetCorrectorUser, byProportion sheetCorrectorLoad)) countResult
-          tutSubIds' <- liftIO $ readTVarIO tutSubIds
-
           countResult' `shouldNotSatisfy` Map.member Nothing
-          countResult' `shouldSatisfy` all (\(Just (corr, prop), subsSet) -> fromIntegral subsSet <= max (50 * prop) (maybe 0 (fromIntegral . Set.size) $ tutSubIds' !? toSqlKey corr)) . Map.toList
+          countResult' `shouldSatisfy` all (\(Just (corr, prop), subsSet) -> fromIntegral subsSet == 50 * prop) . Map.toList
           
           -- -- Does not currently work, because `User`s are reused within `distributionExample`, so submissions end up having more associated course-tutors, because the same user might be a member of a tutorial created for another submission
           -- 

From 8152b3b5cab0b091d2c4b3d60cbe207f3fbd5315 Mon Sep 17 00:00:00 2001
From: Gregor Kleen 
Date: Mon, 20 May 2019 14:37:52 +0200
Subject: [PATCH 09/11] fix tests

---
 test/Handler/Utils/SubmissionSpec.hs | 5 ++---
 1 file changed, 2 insertions(+), 3 deletions(-)

diff --git a/test/Handler/Utils/SubmissionSpec.hs b/test/Handler/Utils/SubmissionSpec.hs
index 763c40b14..32aba67df 100644
--- a/test/Handler/Utils/SubmissionSpec.hs
+++ b/test/Handler/Utils/SubmissionSpec.hs
@@ -9,7 +9,6 @@ import Handler.Utils.Submission
 import ModelSpec ()
 
 import qualified Data.Set as Set
-import Data.Map ((!?))
 import qualified Data.Map as Map
 
 import Data.List (genericLength)
@@ -21,7 +20,7 @@ import System.IO.Unsafe
 import System.Random.Shuffle
 import Control.Monad.Random.Class
 
-import Database.Persist.Sql (toSqlKey, fromSqlKey)
+import Database.Persist.Sql (fromSqlKey)
 
 import qualified Database.Esqueleto as E
 
@@ -180,7 +179,7 @@ spec = withApp . describe "Submission distribution" $ do
           let countResult = Map.map Set.size result
               countResult' = Map.mapKeysWith (+) (fmap $ \SheetCorrector{..} -> (fromSqlKey sheetCorrectorUser, byProportion sheetCorrectorLoad)) countResult
           countResult' `shouldNotSatisfy` Map.member Nothing
-          countResult' `shouldSatisfy` all (\(Just (corr, prop), subsSet) -> fromIntegral subsSet == 50 * prop) . Map.toList
+          countResult' `shouldSatisfy` all (\(Just (_, prop), subsSet) -> fromIntegral subsSet == 50 * prop) . Map.toList
           
           -- -- Does not currently work, because `User`s are reused within `distributionExample`, so submissions end up having more associated course-tutors, because the same user might be a member of a tutorial created for another submission
           -- 

From aa7f451a81a5e37f12ef5d0a43d8d702fdfb9a8a Mon Sep 17 00:00:00 2001
From: Gregor Kleen 
Date: Mon, 20 May 2019 15:22:41 +0200
Subject: [PATCH 10/11] Adjust JSON-Encoding of UploadMode to avoid migration

---
 src/Model/Types/Sheet.hs | 4 +++-
 1 file changed, 3 insertions(+), 1 deletion(-)

diff --git a/src/Model/Types/Sheet.hs b/src/Model/Types/Sheet.hs
index 6ec4ae4f0..426e375c5 100644
--- a/src/Model/Types/Sheet.hs
+++ b/src/Model/Types/Sheet.hs
@@ -250,7 +250,9 @@ defaultExtensionRestriction :: Maybe (NonNull (Set Extension))
 defaultExtensionRestriction = fromNullable $ Set.fromList ["txt", "pdf"]
 
 deriveJSON defaultOptions
-  { constructorTagModifier = camelToPathPiece
+  { constructorTagModifier = \c -> if
+      | c == "UploadAny" -> "upload"
+      | otherwise        -> camelToPathPiece c
   , fieldLabelModifier = camelToPathPiece
   , sumEncoding = TaggedObject "mode" "settings"
   , omitNothingFields = True

From e2315dd28eb9ad1750f85ed66bb02ec61cdac446 Mon Sep 17 00:00:00 2001
From: Gregor Kleen 
Date: Mon, 20 May 2019 18:22:53 +0200
Subject: [PATCH 11/11] Fix sheetForm

---
 messages/uniworx/de.msg   |  1 +
 src/Handler/Utils/Form.hs |  6 +++---
 src/Utils/Form.hs         | 33 +++++++++++++++++++++------------
 3 files changed, 25 insertions(+), 15 deletions(-)

diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg
index 1ab2e4bf5..d7a6a484b 100644
--- a/messages/uniworx/de.msg
+++ b/messages/uniworx/de.msg
@@ -525,6 +525,7 @@ UploadModeUnpackZipsTip: Wenn die Abgabe mehrerer Dateien erlaubt ist, werden au
 
 UploadModeExtensionRestriction: Zulässige Dateiendungen
 UploadModeExtensionRestrictionTip: Komma-separiert. Wenn keine Dateiendungen angegeben werden erfolgt keine Einschränkung.
+UploadModeExtensionRestrictionEmpty: Liste von zulässigen Dateiendungen darf nicht leer sein
 
 UploadSpecificFiles: Vorgegebene Dateinamen
 NoUploadSpecificFilesConfigured: Wenn der Abgabemodus vorgegebene Dateinamen vorsieht, muss mindestens ein vorgegebener Dateiname konfiguriert werden.
diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs
index a9dbe1ede..12fdc847c 100644
--- a/src/Handler/Utils/Form.hs
+++ b/src/Handler/Utils/Form.hs
@@ -359,15 +359,15 @@ uploadModeForm prev = multiActionA actions (fslI MsgSheetUploadMode) (classifyUp
       , ( UploadModeAny
         , UploadAny
           <$> apreq checkBoxField (fslI MsgUploadModeUnpackZips & setTooltip MsgUploadModeUnpackZipsTip) (prev ^? _Just . _unpackZips)
-          <*> apreq extensionRestrictionField (fslI MsgUploadModeExtensionRestriction & setTooltip MsgUploadModeExtensionRestrictionTip) ((prev ^? _Just . _extensionRestriction) <|> fmap Just defaultExtensionRestriction)
+          <*> aopt extensionRestrictionField (fslI MsgUploadModeExtensionRestriction & setTooltip MsgUploadModeExtensionRestrictionTip) ((prev ^? _Just . _extensionRestriction) <|> fmap Just defaultExtensionRestriction)
         )
       , ( UploadModeSpecific
         , UploadSpecific <$> specificFileForm
         )
       ]
   
-    extensionRestrictionField :: Field Handler (Maybe (NonNull (Set Extension)))
-    extensionRestrictionField = convertField (fromNullable . toSet) (maybe "" $ intercalate ", " . Set.toList . toNullable) textField
+    extensionRestrictionField :: Field Handler (NonNull (Set Extension))
+    extensionRestrictionField = checkMMap (return . maybe (Left MsgUploadModeExtensionRestrictionEmpty) Right . fromNullable . toSet) (intercalate ", " . Set.toList . toNullable) textField
       where
         toSet = Set.fromList . filter (not . Text.null) . map (stripDot . Text.strip) . Text.splitOn ","
         stripDot ext
diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs
index c2797980d..2c04192ec 100644
--- a/src/Utils/Form.hs
+++ b/src/Utils/Form.hs
@@ -690,23 +690,32 @@ mforced Field{..} FieldSettings{..} val = do
 
 aforced :: (RenderMessage site FormMessage, HandlerSite m ~ site, MonadHandler m)
         => Field m a -> FieldSettings site -> a -> AForm m a
-aforced field settings val = formToAForm $ second pure <$> mforced field settings val
-
-apreq :: (RenderMessage site FormMessage, HandlerSite m ~ site, MonadHandler m)
-      => Field m a -> FieldSettings site -> Maybe a -> AForm m a
--- ^ Pseudo required
-apreq f fs mx = formToAForm $ do
-  mr <- getMessageRender
-  over _1 (maybe (FormFailure [mr MsgValueRequired]) return =<<) . over _2 (pure . (\fv -> fv { fvRequired = True } )) <$> mopt f fs (Just <$> mx)
+aforced field settings val = formToAForm $ over _2 pure <$> mforced field settings val
 
 mpreq :: (RenderMessage site FormMessage, HandlerSite m ~ site, MonadHandler m)
       => Field m a -> FieldSettings site -> Maybe a -> MForm m (FormResult a, FieldView site)
+-- ^ Pseudo required
+--
+-- `FieldView` has `fvRequired` set to `True` and @FormSuccess Nothing@ is cast to `FormFailure`.
+-- Otherwise acts exactly like `mopt`.
 mpreq f fs mx = do
   mr <- getMessageRender
-  over _1 (maybe (FormFailure [mr MsgValueRequired]) return =<<) . over _2 (\fv -> fv { fvRequired = True } ) <$> mopt f fs (Just <$> mx)
+  (res, fv) <- mopt f fs (Just <$> mx)
+  let fv' = fv { fvRequired = True }
+  return $ case res of
+    FormSuccess (Just res')
+      -> (FormSuccess res', fv')
+    FormSuccess Nothing
+      -> (FormFailure [mr MsgValueRequired], fv' { fvErrors = Just . toHtml $ mr MsgValueRequired })
+    FormFailure errs
+      -> (FormFailure errs, fv')
+    FormMissing
+      -> (FormMissing, fv')
+
+apreq :: (RenderMessage site FormMessage, HandlerSite m ~ site, MonadHandler m)
+      => Field m a -> FieldSettings site -> Maybe a -> AForm m a
+apreq f fs mx = formToAForm $ over _2 pure <$> mpreq f fs mx
 
 wpreq :: (RenderMessage site FormMessage, HandlerSite m ~ site, MonadHandler m)
       => Field m a -> FieldSettings site -> Maybe a -> WForm m (FormResult a)
-wpreq f fs mx = mFormToWForm $ do
-  mr <- getMessageRender
-  over _1 (maybe (FormFailure [mr MsgValueRequired]) return =<<) . over _2 (\fv -> fv { fvRequired = True } ) <$> mopt f fs (Just <$> mx)
+wpreq f fs mx = mFormToWForm $ mpreq f fs mx