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

chore(test): property test with preselected users

Browse Source
This commit is contained in:
Wolfgang Witt 2021-02-01 13:10:44 +01:00 committed by Wolfgang Witt
parent 5de8f0ae23
commit 4d9ef2a64d
1 changed files with 39 additions and 21 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -41,29 +41,47 @@ instance Arbitrary ExamOccurrence where
spec :: Spec
spec = do
describe "examAutoOccurrence" $ do
prop "Surname, no Nudges, no preselection" $ do -- TODO
users <- genUsers
occurrences <- genOccurrences $ length users
let result@(_maybeMapping, userMap) = examAutoOccurrence seed rule config occurrences users
pure $ ioProperty $ do
-- every user got assigned a room
shouldBe (length userMap) (length users)
shouldSatisfy userMap $ all isJust
-- no room is overfull
shouldSatisfy userMap $ fitsInRooms occurrences
-- all users match the shown ranges
shouldSatisfy result $ showsCorrectRanges users
describe "Surname" $ do
let rule :: ExamOccurrenceRule
rule = ExamRoomSurname
prop "no Nudges, no preselection" $ do
(users, occurrences) <- genUsersWithOccurrences False
let result@(_maybeMapping, userMap) = examAutoOccurrence seed rule config occurrences users
pure $ ioProperty $ do
-- every user got assigned a room
shouldBe (length userMap) (length users)
shouldSatisfy userMap $ all isJust
-- no room is overfull
shouldSatisfy (occurrences, userMap) $ uncurry fitsInRooms
-- all users match the shown ranges
shouldSatisfy (users, result) $ uncurry showsCorrectRanges
prop "no Nudges, some preselected" $ do
(users, occurrences) <- genUsersWithOccurrences True
let result@(_maybeMapping, userMap) = examAutoOccurrence seed rule config occurrences users
pure $ ioProperty $ do
-- every user got assigned a room
shouldBe (length userMap) (length users)
shouldSatisfy userMap $ all isJust
-- no room is overfull
shouldSatisfy (occurrences, userMap) $ uncurry fitsInRooms
-- all users match the shown ranges or their preselection
shouldSatisfy (users, result) $ uncurry showsCorrectRanges
-- TODO test with some users fixed/preselected to certain rooms
-- TODO test with ExamRoomManual, ExamRoomFifo, (ExamRoomSurname), ExamRoomMatriculation, ExamRoomRandom
where
-- | generate users without any pre-assigned rooms
genUsers :: Gen (Map UserId (User, Maybe ExamOccurrenceId))
genUsers = do
genUsersWithOccurrences :: Bool -> Gen (Map UserId (User, Maybe ExamOccurrenceId), Map ExamOccurrenceId Natural)
genUsersWithOccurrences assignSomeUsers = do
rawUsers <- listOf1 $ Entity <$> arbitrary <*> arbitrary
occurrences <- genOccurrences $ length rawUsers
-- user surnames anpassen, sodass interessante instanz
fmap Map.fromList $ forM rawUsers $ \Entity {entityKey, entityVal} -> do
users <- fmap Map.fromList $ forM rawUsers $ \Entity {entityKey, entityVal} -> do
userSurname <- elements surnames
pure (entityKey, (entityVal {userSurname}, Nothing))
assignedRoom <- if assignSomeUsers
then frequency [(97, pure Nothing), (3, elements $ map Just $ Map.keys occurrences)]
else pure Nothing
pure (entityKey, (entityVal {userSurname}, assignedRoom))
pure (users, occurrences)
genOccurrences :: Int -> Gen (Map ExamOccurrenceId Natural)
genOccurrences numUsers = do
-- TODO is this realistic?
@ -89,8 +107,6 @@ spec = do
]
seed :: ()
seed = ()
rule :: ExamOccurrenceRule
rule = ExamRoomSurname
config :: ExamAutoOccurrenceConfig
config = def
-- TODO adjust with different nudges, depended on occurrences list/map
@ -117,13 +133,15 @@ spec = do
-> (Maybe (ExamOccurrenceMapping ExamOccurrenceId), Map UserId (Maybe ExamOccurrenceId))
-> Bool
showsCorrectRanges _users (Nothing, _userMap) = False
showsCorrectRanges users (Just (examOccurrenceMappingMapping -> m), userMap)
showsCorrectRanges users (Just (examOccurrenceMappingMapping -> mappingRanges), userMap)
= all userFitsInRange $ Map.toAscList $ occurrenceMap userMap
where
userFitsInRange :: (ExamOccurrenceId, [UserId]) -> Bool
userFitsInRange (roomId, userIds) = flip all userIds $ \userId ->
case (Map.lookup roomId m, Map.lookup userId users) of
(Just ranges, Just (User {userSurname}, _fixedRoom))
case (Map.lookup roomId mappingRanges, Map.lookup userId users) of
(_maybeRanges, Just (User {}, Just fixedRoomId))
-> roomId == fixedRoomId
(Just ranges, Just (User {userSurname}, Nothing))
-> any fitsInRange ranges
where
ciSurname :: [CI Char]