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

chore(test): prepare for ExamRoomMatriculation-Tests

Browse Source
This commit is contained in:
Wolfgang Witt 2021-02-02 22:14:29 +01:00 committed by Wolfgang Witt
parent 44a52e034f
commit 4dccd2830b
1 changed files with 46 additions and 23 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -42,6 +42,13 @@ data Nudges = NoNudges | SmallNudges | LargeNudges
uncurry3 :: (a -> b -> c -> d) -> (a, b, c) -> d uncurry3 :: (a -> b -> c -> d) -> (a, b, c) -> d
uncurry3 f (a, b, c) = f a b c uncurry3 f (a, b, c) = f a b c
-- | Kopie der User-Datenstruktur beschränkt auf interessante Felder (besser verständliche Show-Instanz)
data UserProperties = UserProperties {pSurname :: Text, pMatrikelnummer :: Maybe Text}
deriving (Show)
extractProperties :: User -> UserProperties
extractProperties User {userSurname, userMatrikelnummer} = UserProperties userSurname userMatrikelnummer
-- function Handler.Utils.examAutoOccurrence -- function Handler.Utils.examAutoOccurrence
-- examAutoOccurrence :: forall seed. -- examAutoOccurrence :: forall seed.
-- Hashable seed -- Hashable seed
@ -55,12 +62,14 @@ uncurry3 f (a, b, c) = f a b c
spec :: Spec spec :: Spec
spec = do spec = do
describe "examAutoOccurrence" $ do describe "examAutoOccurrence" $ do
{-
describe "Surname" $ do describe "Surname" $ do
let rule :: ExamOccurrenceRule let rule :: ExamOccurrenceRule
rule = ExamRoomSurname rule = ExamRoomSurname
forM_ universeF $ \nudges -> describe (show nudges) $ forM_ universeF $ \nudges -> describe (show nudges) $
forM_ universeF $ \preselection -> forM_ universeF $ \preselection ->
prop (show preselection) $ propertyTest rule nudges preselection prop (show preselection) $ propertyTest rule nudges preselection
-}
describe "Matriculation" $ do describe "Matriculation" $ do
let rule :: ExamOccurrenceRule let rule :: ExamOccurrenceRule
rule = ExamRoomMatriculation rule = ExamRoomMatriculation
@ -76,7 +85,7 @@ spec = do
--ExamAutoOccurrenceConfig {eaocMinimizeRooms = False, eaocFinenessCost = 1 % 5, eaocNudge = fromList [(SqlBackendKey {unSqlBackendKey = 4},-11)], eaocNudgeSize = 1 % 20} --ExamAutoOccurrenceConfig {eaocMinimizeRooms = False, eaocFinenessCost = 1 % 5, eaocNudge = fromList [(SqlBackendKey {unSqlBackendKey = 4},-11)], eaocNudgeSize = 1 % 20}
propertyTest :: ExamOccurrenceRule -> Nudges -> Preselection -> Gen Property propertyTest :: ExamOccurrenceRule -> Nudges -> Preselection -> Gen Property
propertyTest rule nudges preselection = do propertyTest rule nudges preselection = do
(users, occurrences) <- genUsersWithOccurrences preselection (users, occurrences) <- genUsersWithOccurrences rule preselection
eaocNudge <- case nudges of eaocNudge <- case nudges of
NoNudges -> pure Map.empty NoNudges -> pure Map.empty
SmallNudges -> let nudgeFrequency = [(10, 0), (5, 1), (5, -1), (3, 2), (3, -2), (1, 3), (1, -3)] SmallNudges -> let nudgeFrequency = [(10, 0), (5, 1), (5, -1), (3, 2), (3, -2), (1, 3), (1, -3)]
@ -90,14 +99,18 @@ spec = do
pure $ ioProperty $ do pure $ ioProperty $ do
-- every user got assigned a room -- every user got assigned a room
shouldBe (length userMap) (length users) shouldBe (length userMap) (length users)
shouldSatisfy userMap $ all isJust shouldSatisfy userMap $ all isJust -- FIXME fails for users without a Just userMatrikelnummer
-- no room is overfull -- no room is overfull
shouldSatisfy (users, occurrences, userMap) $ uncurry3 fitsInRooms let userProperties :: Map UserId (UserProperties, Maybe ExamOccurrenceId)
userProperties = Map.map (first extractProperties) users
shouldSatisfy (userProperties, occurrences, userMap) $ uncurry3 fitsInRooms
-- all users match the shown ranges -- all users match the shown ranges
shouldSatisfy (rule, users, result) $ uncurry3 showsCorrectRanges shouldSatisfy (rule, userProperties, result) $ uncurry3 showsCorrectRanges
-- | generate users without any pre-assigned rooms -- | generate users without any pre-assigned rooms
genUsersWithOccurrences :: Preselection -> Gen (Map UserId (User, Maybe ExamOccurrenceId), Map ExamOccurrenceId Natural) genUsersWithOccurrences :: ExamOccurrenceRule
genUsersWithOccurrences preselection = do -> Preselection
-> Gen (Map UserId (User, Maybe ExamOccurrenceId), Map ExamOccurrenceId Natural)
genUsersWithOccurrences rule preselection = do
rawUsers <- scale (50 *) $ listOf1 $ Entity <$> arbitrary <*> arbitrary rawUsers <- scale (50 *) $ listOf1 $ Entity <$> arbitrary <*> arbitrary
occurrences <- genOccurrences $ length rawUsers occurrences <- genOccurrences $ length rawUsers
-- user surnames anpassen, sodass interessante instanz -- user surnames anpassen, sodass interessante instanz
@ -107,7 +120,16 @@ spec = do
NoPreselection -> pure Nothing NoPreselection -> pure Nothing
SomePreselection -> frequency [(97, pure Nothing), (3, elements $ map Just $ Map.keys occurrences)] SomePreselection -> frequency [(97, pure Nothing), (3, elements $ map Just $ Map.keys occurrences)]
pure (entityKey, (entityVal {userSurname}, assignedRoom)) pure (entityKey, (entityVal {userSurname}, assignedRoom))
pure (users, occurrences) case rule of
ExamRoomMatriculation | null matrUsersList -> discard
where
-- copied directly from examAutoOccurrence, user' definition
-- FIXME if it is empty an error is raised
matrUsersList = [ (map CI.mk $ unpack matriculation', Set.singleton uid)
| (uid, (User{..}, Nothing)) <- Map.toList users
, matriculation' <- userMatrikelnummer ^.. _Just . filtered (not . null)
]
_rule -> pure (users, occurrences)
genOccurrences :: Int -> Gen (Map ExamOccurrenceId Natural) genOccurrences :: Int -> Gen (Map ExamOccurrenceId Natural)
genOccurrences numUsers = do genOccurrences numUsers = do
-- TODO is this realistic? -- TODO is this realistic?
@ -146,44 +168,45 @@ spec = do
appendJust Nothing _userId = id appendJust Nothing _userId = id
appendJust (Just occurrenceId) userId = Map.insertWith (++) occurrenceId [userId] appendJust (Just occurrenceId) userId = Map.insertWith (++) occurrenceId [userId]
-- | Are all rooms large enough to hold all assigned Users? -- | Are all rooms large enough to hold all assigned Users?
fitsInRooms :: Map UserId (User, Maybe ExamOccurrenceId) fitsInRooms :: Map UserId (UserProperties, Maybe ExamOccurrenceId)
-> Map ExamOccurrenceId Natural -> Map ExamOccurrenceId Natural
-> Map UserId (Maybe ExamOccurrenceId) -> Map UserId (Maybe ExamOccurrenceId)
-> Bool -> Bool
fitsInRooms users occurrences userMap fitsInRooms userProperties occurrences userMap
= all roomIsBigEnough $ Map.toAscList $ occurrenceMap userMap = all roomIsBigEnough $ Map.toAscList $ occurrenceMap userMap
where where
roomIsBigEnough :: (ExamOccurrenceId, [UserId]) -> Bool roomIsBigEnough :: (ExamOccurrenceId, [UserId]) -> Bool
roomIsBigEnough (roomId, userIds) = case lookup roomId occurrences of roomIsBigEnough (roomId, userIds) = case lookup roomId occurrences of
Nothing -> False Nothing -> False
(Just capacity) -> length userIds <= fromIntegral capacity (Just capacity) -> length userIds <= fromIntegral capacity
|| all (isJust . snd) (Map.restrictKeys users $ Set.fromList userIds) || all (isJust . snd) (Map.restrictKeys userProperties $ Set.fromList userIds)
-- | Does the (currently surname) User fit to the displayed ranges? -- | 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. -- Users with a previously assigned room are checked if the assignment stays the same, regardless of the ranges.
showsCorrectRanges :: ExamOccurrenceRule showsCorrectRanges :: ExamOccurrenceRule
-> Map UserId (User, Maybe ExamOccurrenceId) -> Map UserId (UserProperties, Maybe ExamOccurrenceId)
-> (Maybe (ExamOccurrenceMapping ExamOccurrenceId), Map UserId (Maybe ExamOccurrenceId)) -> (Maybe (ExamOccurrenceMapping ExamOccurrenceId), Map UserId (Maybe ExamOccurrenceId))
-> Bool -> Bool
showsCorrectRanges _rule _users (Nothing, _userMap) = False showsCorrectRanges _rule _userProperties (Nothing, _userMap) = False
showsCorrectRanges rule users (Just (examOccurrenceMappingMapping -> mappingRanges), userMap) showsCorrectRanges rule userProperties (Just (examOccurrenceMappingMapping -> mappingRanges), userMap)
= all userFitsInRange $ Map.toAscList $ occurrenceMap userMap = all userFitsInRange $ Map.toAscList $ occurrenceMap userMap
where where
userFitsInRange :: (ExamOccurrenceId, [UserId]) -> Bool userFitsInRange :: (ExamOccurrenceId, [UserId]) -> Bool
userFitsInRange (roomId, userIds) = flip all userIds $ \userId -> userFitsInRange (roomId, userIds) = flip all userIds $ \userId ->
case (Map.lookup roomId mappingRanges, Map.lookup userId users) of case (Map.lookup roomId mappingRanges, Map.lookup userId userProperties) of
(_maybeRanges, Just (User {}, Just fixedRoomId)) (_maybeRanges, Just (_userProperty, Just fixedRoomId))
-> roomId == fixedRoomId -> roomId == fixedRoomId
(Just ranges, Just (User {userSurname, userMatrikelnummer}, Nothing)) (Just ranges, Just (UserProperties {pSurname, pMatrikelnummer}, Nothing))
-> any fitsInRange ranges -> any fitsInRange ranges
where where
ciTag :: [CI Char] ciTag :: Maybe [CI Char]
ciTag = map CI.mk $ Text.unpack $ case rule of ciTag = map CI.mk . Text.unpack <$> case rule of
ExamRoomSurname -> userSurname ExamRoomSurname -> Just pSurname
ExamRoomMatriculation -> error $ show userMatrikelnummer ExamRoomMatriculation -> pMatrikelnummer
_rule -> error $ show rule _rule -> Nothing
fitsInRange :: ExamOccurrenceMappingDescription -> Bool fitsInRange :: ExamOccurrenceMappingDescription -> Bool
fitsInRange ExamOccurrenceMappingRange {eaomrStart, eaomrEnd} fitsInRange ExamOccurrenceMappingRange {eaomrStart, eaomrEnd} = case ciTag of
= eaomrStart <= ciTag && (take (length eaomrEnd) ciTag <= eaomrEnd) Nothing -> True
(Just tag) -> eaomrStart <= tag && (take (length eaomrEnd) tag <= eaomrEnd)
fitsInRange ExamOccurrenceMappingSpecial {} fitsInRange ExamOccurrenceMappingSpecial {}
= True -- FIXME what is the meaning of special? = True -- FIXME what is the meaning of special?
_otherwise -> False _otherwise -> False