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