Build failing testcase for assignSubmissions

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

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
+      )

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

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

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