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

chore(test): increase test size + prepare for matriculation tests

Browse Source
This commit is contained in:
Wolfgang Witt 2021-02-01 18:49:08 +01:00 committed by Wolfgang Witt
parent abb2342ab5
commit eadbbce661
1 changed files with 42 additions and 24 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

66
test/Handler/Utils/ExamSpec.hs
View File

@ -1,6 +1,9 @@
module Handler.Utils.ExamSpec where
{-# OPTIONS_GHC -Wwarn #-}
module Handler.Utils.ExamSpec (spec) where
import TestImport
import Data.Universe (Universe, Finite, universeF)
import ModelSpec () -- instance Arbitrary User
@ -18,21 +21,26 @@ import Handler.Utils.Exam
-- are these capacity values realistic?
instance Arbitrary ExamOccurrence where
arbitrary = ExamOccurrence
<$> arbitrary -- examOccurrenceExam
<*> arbitrary -- examOccurrenceName
<*> arbitrary -- examOccurrenceRoom
<*> arbitrary -- examOccurrenceRoomHidden
<*> elements [10, 20, 50, 100, 200] -- examOccurrenceCapacity
<*> arbitrary -- examOccurrenceStart
<*> arbitrary -- examOccurrenceEnd
<*> arbitrary -- examOccurrenceDescription
<$> arbitrary -- examOccurrenceExam
<*> arbitrary -- examOccurrenceName
<*> arbitrary -- examOccurrenceRoom
<*> arbitrary -- examOccurrenceRoomHidden
<*> frequency [(let d = fromIntegral i in ceiling $ 100 * exp(- d*d / 50), pure i) | i <- [10 ..1000]] -- examOccurrenceCapacity
<*> arbitrary -- examOccurrenceStart
<*> arbitrary -- examOccurrenceEnd
<*> arbitrary -- examOccurrenceDescription
data Preselection = NoPreselection | SomePreselection
deriving (Show, Bounded, Enum)
deriving stock (Show, Bounded, Enum)
deriving anyclass (Universe, Finite)
data Nudges = NoNudges | SmallNudges | LargeNudges
deriving (Show, Bounded, Enum)
deriving stock (Show, Bounded, Enum)
deriving anyclass (Universe, Finite)
uncurry3 :: (a -> b -> c -> d) -> (a, b, c) -> d
uncurry3 f (a, b, c) = f a b c
-- function Handler.Utils.examAutoOccurrence
-- examAutoOccurrence :: forall seed.
@ -50,8 +58,14 @@ spec = do
describe "Surname" $ do
let rule :: ExamOccurrenceRule
rule = ExamRoomSurname
forM_ [minBound .. maxBound] $ \nudges -> describe (show nudges) $
forM_ [minBound .. maxBound] $ \preselection ->
forM_ universeF $ \nudges -> describe (show nudges) $
forM_ universeF $ \preselection ->
prop (show preselection) $ propertyTest rule nudges preselection
describe "Matriculation" $ do
let rule :: ExamOccurrenceRule
rule = ExamRoomMatriculation
forM_ universeF $ \nudges -> describe (show nudges) $
forM_ universeF $ \preselection ->
prop (show preselection) $ propertyTest rule nudges preselection
-- TODO test with ExamRoomManual, ExamRoomFifo, (ExamRoomSurname), ExamRoomMatriculation, ExamRoomRandom
where
@ -78,13 +92,13 @@ spec = do
shouldBe (length userMap) (length users)
shouldSatisfy userMap $ all isJust
-- no room is overfull
shouldSatisfy (occurrences, userMap) $ uncurry $ fitsInRooms users
shouldSatisfy (users, occurrences, userMap) $ uncurry3 fitsInRooms
-- all users match the shown ranges
shouldSatisfy (users, result) $ uncurry showsCorrectRanges
shouldSatisfy (rule, users, result) $ uncurry3 showsCorrectRanges
-- | generate users without any pre-assigned rooms
genUsersWithOccurrences :: Preselection -> Gen (Map UserId (User, Maybe ExamOccurrenceId), Map ExamOccurrenceId Natural)
genUsersWithOccurrences preselection = do
rawUsers <- listOf1 $ Entity <$> arbitrary <*> arbitrary
rawUsers <- scale (50 *) $ listOf1 $ Entity <$> arbitrary <*> arbitrary
occurrences <- genOccurrences $ length rawUsers
-- user surnames anpassen, sodass interessante instanz
users <- fmap Map.fromList $ forM rawUsers $ \Entity {entityKey, entityVal} -> do
@ -98,7 +112,7 @@ spec = do
genOccurrences numUsers = do
-- TODO is this realistic?
-- extra space to get nice borders
extraSpace <- elements [numUsers `div` 4 .. numUsers `div` 2]
extraSpace <- elements [numUsers `div` 5 .. numUsers `div` 2]
let totalSpaceRequirement = fromIntegral $ numUsers + extraSpace
createOccurrences acc
| sum (map snd acc) < totalSpaceRequirement = do
@ -146,11 +160,12 @@ spec = do
|| all (isJust . snd) (Map.restrictKeys users $ Set.fromList userIds)
-- | Does the (currently surname) User fit to the displayed ranges?
-- Users with a previously assigned room are checked if the assignment stays the same, regardless of the ranges.
showsCorrectRanges :: Map UserId (User, Maybe ExamOccurrenceId)
showsCorrectRanges :: ExamOccurrenceRule
-> Map UserId (User, Maybe ExamOccurrenceId)
-> (Maybe (ExamOccurrenceMapping ExamOccurrenceId), Map UserId (Maybe ExamOccurrenceId))
-> Bool
showsCorrectRanges _users (Nothing, _userMap) = False
showsCorrectRanges users (Just (examOccurrenceMappingMapping -> mappingRanges), userMap)
showsCorrectRanges _rule _users (Nothing, _userMap) = False
showsCorrectRanges rule users (Just (examOccurrenceMappingMapping -> mappingRanges), userMap)
= all userFitsInRange $ Map.toAscList $ occurrenceMap userMap
where
userFitsInRange :: (ExamOccurrenceId, [UserId]) -> Bool
@ -158,14 +173,17 @@ spec = do
case (Map.lookup roomId mappingRanges, Map.lookup userId users) of
(_maybeRanges, Just (User {}, Just fixedRoomId))
-> roomId == fixedRoomId
(Just ranges, Just (User {userSurname}, Nothing))
(Just ranges, Just (User {userSurname, userMatrikelnummer}, Nothing))
-> any fitsInRange ranges
where
ciSurname :: [CI Char]
ciSurname = map CI.mk $ Text.unpack userSurname
ciTag :: [CI Char]
ciTag = map CI.mk $ Text.unpack $ case rule of
ExamRoomSurname -> userSurname
ExamRoomMatriculation -> error $ show userMatrikelnummer
_rule -> error $ show rule
fitsInRange :: ExamOccurrenceMappingDescription -> Bool
fitsInRange ExamOccurrenceMappingRange {eaomrStart, eaomrEnd}
= eaomrStart <= ciSurname && (take (length eaomrEnd) ciSurname <= eaomrEnd)
= eaomrStart <= ciTag && (take (length eaomrEnd) ciTag <= eaomrEnd)
fitsInRange ExamOccurrenceMappingSpecial {}
= True -- FIXME what is the meaning of special?
_otherwise -> False