-- SPDX-FileCopyrightText: 2022 Gregor Kleen ,Steffen Jost ,Wolfgang Witt -- -- SPDX-License-Identifier: AGPL-3.0-or-later {-# OPTIONS_GHC -Wno-redundant-constraints #-} {-# OPTIONS -Wno-unused-top-binds #-} module Handler.Utils.ExamSpec (spec) where import TestImport import Data.Universe (Universe, Finite, universeF) import ModelSpec () -- instance Arbitrary User import Test.Hspec.QuickCheck (prop) import Test.HUnit.Lang (HUnitFailure(..), FailureReason(..)) import qualified Data.Map as Map import qualified Data.Set as Set import qualified Data.Text as Text import qualified Data.CaseInsensitive as CI import qualified Data.Foldable as Foldable import qualified Data.RFC5051 as RFC5051 import Handler.Utils.Exam spec :: Spec -- spec = test_spec spec = return () -- TODO: tests deactivated since exams are currently not used -- direct copy&paste from an (currently) unmerged pull request for hspec-expectations -- https://github.com/hspec/hspec-expectations/blob/6b4a475e42b0d44008c150727dea25dd79f568f2/src/Test/Hspec/Expectations.hs -- | -- If you have a test case that has multiple assertions, you can use the -- 'annotate' function to provide a string message that will be attached to -- the 'Expectation'. -- -- @ -- describe "annotate" $ do -- it "adds the message" $ do -- annotate "obvious falsehood" $ do -- True `shouldBe` False -- -- ========> -- -- 1) annotate, adds the message -- obvious falsehood -- expected: False -- but got: True -- @ myAnnotate :: HasCallStack => String -> Expectation -> Expectation myAnnotate msg = handle $ \(HUnitFailure loc exn) -> throwIO $ HUnitFailure loc $ case exn of Reason str -> Reason $ msg ++ if null str then str else ": " <> str ExpectedButGot mmsg expected got -> let mmsg' = Just $ msg <> maybe "" (": " <>) mmsg in ExpectedButGot mmsg' expected got instance Arbitrary ExamOccurrence where arbitrary = ExamOccurrence <$> arbitrary -- examOccurrenceExam <*> arbitrary -- examOccurrenceName <*> arbitrary -- examOccurrenceRoom <*> arbitrary -- examOccurrenceRoomHidden <*> (Just <$> 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 stock (Show, Bounded, Enum) deriving anyclass (Universe, Finite) data Nudges = NoNudges | SmallNudges | LargeNudges 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 uncurry4 :: (a -> b -> c -> d -> e) -> (a, b, c, d) -> e uncurry4 f (a, b, c, d) = f a b c d -- | Kopie der User-Datenstruktur beschränkt auf interessante Felder (besser verständliche Show-Instanz) newtype UserProperties = UserProperties {user :: User} instance Show UserProperties where --show :: UserProperties -> String show UserProperties {user=User {userSurname, userMatrikelnummer}} = "User {userSurname=" ++ show userSurname ++ ", userMatrikelnummer=" ++ show userMatrikelnummer ++ "}" -- function Handler.Utils.examAutoOccurrence test_spec :: Spec test_spec = do describe "examAutoOccurrence" $ do describe "Surname" $ testWithRule ExamRoomSurname describe "Matriculation" $ testWithRule ExamRoomMatriculation describe "Random" $ testWithRule ExamRoomRandom where testWithRule :: ExamOccurrenceRule -> Spec testWithRule rule = forM_ universeF $ \nudges -> describe (show nudges) $ forM_ universeF $ \preselection -> prop (show preselection) $ propertyTest rule nudges preselection seed :: () seed = () propertyTest :: ExamOccurrenceRule -> Nudges -> Preselection -> Gen Property propertyTest rule nudges preselection = do (users, occurrences) <- genUsersWithOccurrences preselection eaocNudge <- case nudges of NoNudges -> pure Map.empty SmallNudges -> let nudgeFrequency = [(10, 0), (5, 1), (5, -1), (3, 2), (3, -2), (1, 3), (1, -3)] in foldM (genNudge nudgeFrequency) Map.empty $ Map.keys occurrences LargeNudges -> let nudgeFrequency = [(7, 0), (5, 3), (5, -3), (3, 6), (3, -6), (2, 9), (2, -9), (2, 11), (2, -11), (1, 15), (1,-15), (1, 17), (1, -17)] in foldM (genNudge nudgeFrequency) Map.empty $ Map.keys occurrences let config :: ExamAutoOccurrenceConfig config = def {eaocNudge} autoOccurrenceResult = examAutoOccurrence seed rule config occurrences users pure $ ioProperty $ do let userProperties :: Map UserId (UserProperties, Maybe ExamOccurrenceId) userProperties = Map.map (first UserProperties) users case autoOccurrenceResult of (Right (occurrenceMapping, userMap)) -> do -- user count stays constant myAnnotate "number of users changed" $ shouldBe (length userMap) (length users) -- no room is overfull myAnnotate "room capacity exceeded" $ shouldSatisfy (userProperties, occurrences, userMap) $ uncurry3 fitsInRooms -- mapping is a valid description myAnnotate "invalid mapping description" $ shouldSatisfy (rule, occurrenceMapping) $ uncurry validRangeDescription -- every (relevant) user got assigned a room let foldFn :: (UserId, Maybe ExamOccurrenceId) -> Bool -> Bool foldFn _userMapping False = False foldFn (_userId, Just _occurrenceId) True = True foldFn (userId, Nothing) True = (rule == ExamRoomMatriculation) -- every user with a userMatrikelnummer got a room -- fail on unknown user || maybe False (isNothing . userMatrikelnummer . fst) (Map.lookup userId users) myAnnotate "user didn't get a room" $ shouldSatisfy userMap $ foldr foldFn True . Map.toList -- all users match the shown ranges myAnnotate "shown ranges don't match userMap" $ shouldSatisfy (rule, userProperties, occurrenceMapping, userMap) $ uncurry4 showsCorrectRanges -- is a nullResult justified? (Left autoOccurrenceException) -> -- disabled for now, probably not correct with the current implementation myAnnotate "unjustified nullResult" $ shouldSatisfy (autoOccurrenceException, rule, userProperties, occurrences) $ uncurry4 isNullResultJustified -- | generate users without any pre-assigned rooms genUsersWithOccurrences :: Preselection -> Gen (Map UserId (User, Maybe ExamOccurrenceId), Map ExamOccurrenceId ExamOccurrenceCapacity) genUsersWithOccurrences preselection = do rawUsers <- listOf $ Entity <$> arbitrary <*> arbitrary -- consider applying `scale (50 *)` to uncover additional issues occurrences <- genOccurrences $ length rawUsers -- user surnames anpassen, sodass interessante instanz users <- fmap Map.fromList $ forM rawUsers $ \Entity {entityKey, entityVal} -> do userSurname <- elements surnames assignedRoom <- case preselection of NoPreselection -> pure Nothing SomePreselection -> frequency [(97, pure Nothing), (3, elements $ map Just $ Map.keys occurrences)] pure (entityKey, (entityVal {userSurname}, assignedRoom)) pure (users, occurrences) genOccurrences :: Int -> Gen (Map ExamOccurrenceId ExamOccurrenceCapacity) genOccurrences numUsers = do -- extra space to allow nice borders extraSpace <- elements [numUsers `div` 5 .. numUsers `div` 2] let totalSpaceRequirement = fromIntegral $ numUsers + extraSpace createOccurrences acc | fold (map snd acc) < Restricted totalSpaceRequirement = do Entity {entityKey, entityVal} <- Entity <$> arbitrary <*> arbitrary createOccurrences $ (entityKey, view (from _examOccurrenceCapacityIso) $ fromIntegral <$> examOccurrenceCapacity entityVal) : acc | otherwise = pure acc Map.fromList <$> createOccurrences [] genNudge :: [(Int, Integer)] -> Map ExamOccurrenceId Integer -> ExamOccurrenceId -> Gen (Map ExamOccurrenceId Integer) genNudge nudgesList acc occurrenceId = fmap appendNonZero $ frequency $ map (second pure) nudgesList where appendNonZero :: Integer -> Map ExamOccurrenceId Integer appendNonZero 0 = acc appendNonZero nudge = Map.insert occurrenceId nudge acc -- name list copied from test/Database/Fill.hs surnames :: [Text] surnames = [ "Smith", "Johnson", "Williams", "Brown" , "Jones", "Miller", "Davis", "Garcia" , "Rodriguez", "Wilson", "Martinez", "Anderson" , "Taylor", "Thomas", "Hernandez", "Moore" , "Martin", "Jackson", "Thompson", "White" , "Lopez", "Lee", "Gonzalez", "Harris" , "Clark", "Lewis", "Robinson", "Walker" , "Perez", "Hall", "Young", "zu Allen", "Fu" , "Meier", "Meyer", "Maier", "Mayer" , "Meir", "Müller", "Schulze", "Schmitt" , "FTB Modul", "Mártinèz", "zu Walker", "Schmidt" , "Únîcòdé", "Ähm-Ümlaüte", "von Leerzeichen" ] occurrenceMap :: Map UserId (Maybe ExamOccurrenceId) -> Map ExamOccurrenceId [UserId] occurrenceMap userMap = foldl' (\acc (userId, maybeOccurrenceId) -> appendJust maybeOccurrenceId userId acc) Map.empty $ Map.toAscList userMap where appendJust :: Maybe ExamOccurrenceId -> UserId -> Map ExamOccurrenceId [UserId] -> Map ExamOccurrenceId [UserId] appendJust Nothing _userId = id appendJust (Just occurrenceId) userId = Map.insertWith (++) occurrenceId [userId] -- | Are all rooms large enough to hold all assigned Users? fitsInRooms :: Map UserId (UserProperties, Maybe ExamOccurrenceId) -> Map ExamOccurrenceId ExamOccurrenceCapacity -> Map UserId (Maybe ExamOccurrenceId) -> Bool fitsInRooms userProperties occurrences userMap = all roomIsBigEnough $ Map.toAscList $ occurrenceMap userMap where roomIsBigEnough :: (ExamOccurrenceId, [UserId]) -> Bool roomIsBigEnough (roomId, userIds) = case lookup roomId occurrences of Nothing -> False (Just capacity) -> Restricted (fromIntegral $ length userIds) <= capacity || all (isJust . snd) (Map.restrictKeys userProperties $ Set.fromList userIds) -- | No range overlap for different rooms + end is always the greater value validRangeDescription :: ExamOccurrenceRule -> ExamOccurrenceMapping ExamOccurrenceId -> Bool validRangeDescription rule ExamOccurrenceMapping {examOccurrenceMappingMapping} = all (\(roomId, ranges) -> all (descriptionValid roomId) ranges) $ Map.toAscList examOccurrenceMappingMapping where descriptionValid:: ExamOccurrenceId -> ExamOccurrenceMappingDescription -> Bool descriptionValid roomId description = endAfterStart description && all (all $ noDirectOverlap description) (Map.delete roomId examOccurrenceMappingMapping) endAfterStart :: ExamOccurrenceMappingDescription -> Bool endAfterStart ExamOccurrenceMappingRange {eaomrStart=(pack . map CI.foldedCase -> start), eaomrEnd=(pack . map CI.foldedCase -> end)} = RFC5051.compareUnicode start end /= GT endAfterStart _mappingDescription = True -- also check for equal length with ExamRoomMatriculation noDirectOverlap :: ExamOccurrenceMappingDescription -> ExamOccurrenceMappingDescription -> Bool noDirectOverlap ExamOccurrenceMappingRandom other = other == ExamOccurrenceMappingRandom noDirectOverlap other ExamOccurrenceMappingRandom = other == ExamOccurrenceMappingRandom noDirectOverlap ExamOccurrenceMappingRange {eaomrStart=cs0@(pack . map CI.foldedCase -> s0), eaomrEnd=ce0@(pack . map CI.foldedCase -> e0)} ExamOccurrenceMappingRange {eaomrStart=cs1@(pack . map CI.foldedCase -> s1), eaomrEnd=ce1@(pack . map CI.foldedCase -> e1)} = equalLengthForMatriculation [cs0, ce0, cs1, ce1] && ((RFC5051.compareUnicode s0 s1 == LT && RFC5051.compareUnicode e0 s1 == LT) || (RFC5051.compareUnicode s0 e1 == GT && RFC5051.compareUnicode e0 s1 == GT)) noDirectOverlap ExamOccurrenceMappingRange {eaomrStart, eaomrEnd} ExamOccurrenceMappingSpecial {eaomrSpecial} = equalLengthForMatriculation [eaomrStart, eaomrEnd, eaomrSpecial] && noDirectOverlapRangeSpecial eaomrStart eaomrEnd eaomrSpecial noDirectOverlap ExamOccurrenceMappingSpecial {eaomrSpecial} ExamOccurrenceMappingRange {eaomrStart, eaomrEnd} = equalLengthForMatriculation [eaomrStart, eaomrEnd, eaomrSpecial] && noDirectOverlapRangeSpecial eaomrStart eaomrEnd eaomrSpecial noDirectOverlap ExamOccurrenceMappingSpecial {eaomrSpecial=s0} ExamOccurrenceMappingSpecial {eaomrSpecial=s1} = equalLengthForMatriculation [s0, s1] && s0 /= s1 equalLengthForMatriculation :: [[CI Char]] -> Bool equalLengthForMatriculation [] = True equalLengthForMatriculation (h:t) = (rule /= ExamRoomMatriculation) || all (== length h) (length <$> t) noDirectOverlapRangeSpecial :: [CI Char] -> [CI Char] -> [CI Char] -> Bool noDirectOverlapRangeSpecial (pack . map CI.foldedCase -> start) (pack . map CI.foldedCase -> end) (pack . map CI.foldedCase -> special) = RFC5051.compareUnicode special start == LT || RFC5051.compareUnicode special end == GT -- RFC5051.compareUnicode :: Text -> Text -> Ordering -- | 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 :: ExamOccurrenceRule -> Map UserId (UserProperties, Maybe ExamOccurrenceId) -> ExamOccurrenceMapping ExamOccurrenceId -> Map UserId (Maybe ExamOccurrenceId) -> Bool showsCorrectRanges rule userProperties ExamOccurrenceMapping {examOccurrenceMappingMapping} userMap = all userFitsInRange $ Map.toAscList $ occurrenceMap userMap where userFitsInRange :: (ExamOccurrenceId, [UserId]) -> Bool userFitsInRange (roomId, userIds) = flip all userIds $ \userId -> case (Map.lookup roomId examOccurrenceMappingMapping, Map.lookup userId userProperties) of (_maybeRanges, Just (_userProperty, Just fixedRoomId)) -> roomId == fixedRoomId (Just ranges, Just (UserProperties User {userSurname, userMatrikelnummer}, Nothing)) -> any fitsInRange ranges where ciTag :: Maybe [CI Char] ciTag = map CI.mk . Text.unpack <$> case rule of ExamRoomSurname | Text.null userSurname -> Nothing | otherwise-> Just userSurname ExamRoomMatriculation | maybe True Text.null userMatrikelnummer -> Nothing | otherwise -> userMatrikelnummer _rule -> Nothing fitsInRange :: ExamOccurrenceMappingDescription -> Bool fitsInRange mappingDescription = case (ciTag, mappingDescription) of (_tag, ExamOccurrenceMappingRandom) -> True (Nothing, _mappingDescription) -> True (Just tag, ExamOccurrenceMappingRange {eaomrStart=(pack . map CI.foldedCase -> start), eaomrEnd=(pack . map CI.foldedCase-> end)}) -> (RFC5051.compareUnicode start (pack $ map CI.foldedCase $ transformTag start tag) /= GT) && (RFC5051.compareUnicode end (pack $ map CI.foldedCase $ transformTag end tag) /= LT) (Just tag, ExamOccurrenceMappingSpecial {eaomrSpecial}) -> checkSpecial eaomrSpecial tag transformTag :: (MonoFoldable f) => f -> [CI Char] -> [CI Char] transformTag (length -> rangeLength) = case rule of ExamRoomMatriculation -> reverse . take rangeLength . reverse _rule -> take rangeLength checkSpecial :: [CI Char] -> [CI Char] -> Bool checkSpecial = case rule of ExamRoomMatriculation -> isSuffixOf _rule -> isPrefixOf _otherwise -> (rule /= ExamRoomSurname) && (rule /= ExamRoomMatriculation) -- | Is mapping impossible due to the given reason? isNullResultJustified :: ExamAutoOccurrenceException -> ExamOccurrenceRule -> Map UserId (UserProperties, Maybe ExamOccurrenceId) -> Map ExamOccurrenceId ExamOccurrenceCapacity -> Bool isNullResultJustified ExamAutoOccurrenceExceptionRuleNoOp rule _userProperties _occurrences = not $ examOccurrenceRuleAutomatic rule isNullResultJustified ExamAutoOccurrenceExceptionNotEnoughSpace rule userProperties occurrences = Restricted (fromIntegral $ length $ relevantUsers rule userProperties) > fold occurrences isNullResultJustified ExamAutoOccurrenceExceptionNoUsers rule userProperties _occurrences = noRelevantUsers rule userProperties isNullResultJustified ExamAutoOccurrenceExceptionRoomTooSmall rule userProperties occurrences = mappingImpossiblePlausible rule userProperties occurrences noRelevantUsers :: ExamOccurrenceRule -> Map UserId (UserProperties, Maybe ExamOccurrenceId) -> Bool noRelevantUsers rule = null . relevantUsers rule relevantUsers :: ExamOccurrenceRule -> Map UserId (UserProperties, Maybe ExamOccurrenceId) -> Map UserId (UserProperties, Maybe ExamOccurrenceId) relevantUsers rule = Map.filter $ isRelevantUser rule isRelevantUser :: ExamOccurrenceRule -> (UserProperties, Maybe ExamOccurrenceId) -> Bool isRelevantUser _rule (_user, Just _assignedRoom) = False isRelevantUser rule (UserProperties User {userSurname, userMatrikelnummer}, Nothing) = case rule of ExamRoomSurname -> not $ null userSurname ExamRoomMatriculation -> maybe False (not . null) userMatrikelnummer ExamRoomRandom -> True _rule -> False mappingImpossiblePlausible :: ExamOccurrenceRule -> Map UserId (UserProperties, Maybe ExamOccurrenceId) -> Map ExamOccurrenceId ExamOccurrenceCapacity -> Bool mappingImpossiblePlausible rule userProperties@(sortBy RFC5051.compareUnicode . mapRuleProperty rule . Map.elems . relevantUsers rule -> users') (map snd . Map.toList . adjustOccurrences userProperties -> occurrences') = go 0 users' occurrences' where smallestRoom :: ExamOccurrenceCapacity smallestRoom = maybe (Restricted 0) minimum $ fromNullable occurrences' -- If there exists a bucket with the same tag bigger than the smallest room a nullResult might be returned -- It may still work, but is not guaranteed (e.g. both the first bucket) go :: forall a. Eq a => Natural -> [a] -> [ExamOccurrenceCapacity] -> Bool go biggestUserBucket [] _occurrences = Restricted biggestUserBucket > smallestRoom go _biggestUserBucket _remainingUsers [] = True go biggestUserBucket remainingUsers (Restricted 0:t) = go biggestUserBucket remainingUsers t go biggestUserBucket remainingUsers@(h:_t) (firstOccurrence:laterOccurrences) | Restricted nextUsers <= firstOccurrence = go (max biggestUserBucket nextUsers) remainingUsers' $ (under (from _examOccurrenceCapacityIso) (fmap (flip (-) nextUsers)) firstOccurrence) : laterOccurrences | otherwise = go biggestUserBucket remainingUsers laterOccurrences where nextUsers :: Natural remainingUsers' :: [a] (fromIntegral . length -> nextUsers, remainingUsers') = span (== h) remainingUsers mapRuleProperty :: ExamOccurrenceRule -> [(UserProperties, b)] -> [Text] mapRuleProperty rule (map fst -> users') = map (ruleProperty rule minMatrLength) users' where minMatrLength :: Int minMatrLength = Foldable.minimum $ map (maybe 0 Text.length . userMatrikelnummer . user) users' ruleProperty :: ExamOccurrenceRule -> Int -> UserProperties -> Text ruleProperty rule n = case rule of ExamRoomSurname -> userSurname . user ExamRoomMatriculation -> maybe Text.empty (Text.takeEnd n) . userMatrikelnummer . user _rule -> const $ pack $ show rule -- copied and adjusted from Hander.Utils.Exam adjustOccurrences :: Map UserId (UserProperties, Maybe ExamOccurrenceId) -> Map ExamOccurrenceId ExamOccurrenceCapacity -> Map ExamOccurrenceId ExamOccurrenceCapacity -- ^ reduce room capacity for every pre-assigned user by 1 adjustOccurrences userProperties occurrences = foldl' (flip $ Map.update predToPositive) (Map.filter (> Restricted 0) occurrences) $ Map.mapMaybe snd userProperties predToPositive :: ExamOccurrenceCapacity -> Maybe ExamOccurrenceCapacity predToPositive Unrestricted = Just Unrestricted predToPositive (Restricted 0) = Nothing predToPositive (Restricted 1) = Nothing predToPositive (Restricted n) = Just $ Restricted $ pred n