fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

fix(test): add arbitrart instances and adjust argument changes to tests

Browse Source
This commit is contained in:
Steffen Jost 2024-10-07 12:58:22 +02:00
parent c9ecb30542
commit 72b2b6876b
3 changed files with 12 additions and 11 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

16
test/Handler/Utils/SubmissionSpec.hs
View File

@ -1,4 +1,4 @@
-- SPDX-FileCopyrightText: 2022-23 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,Steffen Jost <s.jost@fraport.de>
-- SPDX-FileCopyrightText: 2022-24 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,Steffen Jost <s.jost@fraport.de>
--
-- SPDX-License-Identifier: AGPL-3.0-or-later
@ -49,7 +49,7 @@ makeUsers (fromIntegral -> n) = do
users <- forM users' $ \u -> do
i <- atomically $ readTVar userNumber <* modifyTVar userNumber succ
let baseid = "user." <> tshow i
u' = u { userIdent = CI.mk baseid
u' = u { userIdent = CI.mk baseid
, userEmail = CI.mk $ baseid <> "@example.com"
, userLdapPrimaryKey = Just $ baseid <> ".ldap"
}
@ -82,7 +82,7 @@ distributionExample mkParameters setupHook cont = do
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
@ -102,7 +102,7 @@ distributionExample mkParameters setupHook cont = do
mapM_ (\(n, (subs, corrs)) -> setupHook n subs corrs) . zip [1..] $ map snd situations
-- situations' <-
-- situations' <-
forM situations $ \(sid, (submissions, sheetCorrectors)) -> (sid, ) <$> do
submissions' <- mapM (fmap fromJust . getEntity . entityKey) submissions
sheetCorrectors' <- mapM (fmap fromJust . getEntity . entityKey) sheetCorrectors
@ -126,7 +126,7 @@ distributionExample mkParameters setupHook cont = do
let key = find (\ (Entity _ (SheetCorrector uid _ _ _)) -> Just uid == submissionRatingBy) $ concatMap (\(_, (_, corrs)) -> corrs) situations
sheet = getFirst . foldMap (\(n, (sid, _)) -> First $ guardOn (sid == submissionSheet) n) $ zip [1..] situations
return (entityVal <$> key, Set.singleton (subId, sheet))
spec :: Spec
spec = withApp . describe "Submission distribution" $ do
@ -196,16 +196,16 @@ spec = withApp . describe "Submission distribution" $ do
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)
return $ TutorialParticipant E.<# E.val tutId E.<&> (submissionUser E.^. SubmissionUserUser) E.<&> E.nothing
)
(\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) -> 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
--
--
-- let subs = fold tutSubIds'
-- forM_ subs $ \subId -> do
-- let tutors = Map.keysSet $ Map.filter (Set.member subId) tutSubIds'

2
test/Model/TypesSpec.hs
View File

@ -318,7 +318,7 @@ instance Arbitrary CsvOptions where
arbitrary = CsvOptions
<$> arbitrary
<*> arbitrary
<*> suchThat arbitrary (maybe True $ not . elem (Char.chr 0))
<*> suchThat arbitrary (maybe True $ notElem (Char.chr 0))
shrink = genericShrink
instance Arbitrary CsvPreset where

5
test/ModelSpec.hs
View File

@ -1,4 +1,4 @@
-- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <jost@cip.ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
-- SPDX-FileCopyrightText: 2022-24 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <jost@cip.ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Steffen Jost <s.jost@fraport.de>
--
-- SPDX-License-Identifier: AGPL-3.0-or-later
@ -41,6 +41,8 @@ import System.IO.Unsafe (unsafePerformIO)
import Data.Universe
deriving newtype instance Arbitrary a => Arbitrary (JSONB a)
instance Arbitrary EmailAddress where
arbitrary = do
local <- suchThat (CBS.pack . getPrintableString <$> arbitrary) (\l -> isEmail l (CBS.pack "example.com"))
@ -86,7 +88,6 @@ instance Arbitrary Tutorial where
<*> (fmap getPositive <$> arbitrary)
<*> arbitrary
<*> arbitrary
<*> arbitrary
<*> (fmap (CI.mk . pack . getPrintableString) <$> arbitrary)
<*> arbitrary
<*> arbitrary