From 5480e2d7b72ebfab14231c55d86a761aa4bbfe13 Mon Sep 17 00:00:00 2001 From: Wolfgang Witt Date: Thu, 18 Feb 2021 17:22:06 +0100 Subject: [PATCH] chore: names with non-ascii prefix get a ExamOccurrenceMappingSpecial --- src/Handler/Utils/Exam.hs | 101 ++++++++++++++++++--------------- test/Handler/Utils/ExamSpec.hs | 19 +++++-- 2 files changed, 69 insertions(+), 51 deletions(-) diff --git a/src/Handler/Utils/Exam.hs b/src/Handler/Utils/Exam.hs index dfc895c92..2c63fe41c 100644 --- a/src/Handler/Utils/Exam.hs +++ b/src/Handler/Utils/Exam.hs @@ -1,4 +1,5 @@ {-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-} +{-# OPTIONS_GHC -Wwarn #-} module Handler.Utils.Exam ( fetchExamAux @@ -540,60 +541,68 @@ examAutoOccurrence (hash -> seed) rule ExamAutoOccurrenceConfig{..} occurrences rangeAlphabet :: [CI Char] rangeAlphabet = case rule of ExamRoomSurname -> map CI.mk ['A'..'Z'] - -- ExamRoomSurname -> map CI.mk [c | c <- universeF, isPrint c] -- all printable unicode characters ExamRoomMatriculation-> map CI.mk ['0'..'9'] _rule -> [] resultAscList :: Map ExamOccurrenceId (Set ExamOccurrenceMappingDescription) resultAscList = case fromNullable rangeAlphabet of Nothing -> Map.empty - (Just alphabet) -> Map.map Set.singleton $ Map.fromList $ go (singleton $ head alphabet) [] result + (Just alphabet) -> Map.fromList $ go (singleton $ head alphabet) 1 [] result where - go :: NonNull [CI Char] -> [(ExamOccurrenceId, ExamOccurrenceMappingDescription)] -> [(ExamOccurrenceId, [[CI Char]])] -> [(ExamOccurrenceId, ExamOccurrenceMappingDescription)] - go _start acc [] = acc + go :: NonNull [CI Char] + -> Int + -> [(ExamOccurrenceId, Set ExamOccurrenceMappingDescription)] + -> [(ExamOccurrenceId, [[CI Char]])] + -> [(ExamOccurrenceId, Set ExamOccurrenceMappingDescription)] + go _start _borderLength acc [] = acc -- special case necessary, so ranges always end on last alphabet - go start acc [(_occurrenceId, [])] = case acc of + go start _borderLength acc [(_occurrenceId, [])] = case acc of [] -> [] - ((occurrenceId, mappingDescription):t) -> (occurrenceId, mappingDescription {eaomrEnd}) : t + ((occurrenceId, mappingDescription):t) -> (occurrenceId, Set.map extendEnd mappingDescription) : t where + extendEnd :: ExamOccurrenceMappingDescription -> ExamOccurrenceMappingDescription + extendEnd ExamOccurrenceMappingRange {eaomrStart} = ExamOccurrenceMappingRange {eaomrStart, eaomrEnd} + extendEnd examOccurrenceMappingSpecial = examOccurrenceMappingSpecial eaomrEnd :: [CI Char] eaomrEnd = replicate (length start) $ last alphabet - go start acc ((_occurrenceId, []):t) = go start acc t - go start acc ((occurrenceId, userTags):t) + go start borderLength acc ((_occurrenceId, []):t) = go start borderLength acc t + go start borderLength acc ((occurrenceId, userTags):t) | matchMappingDescription mappingDescription userTags - = go nextStart ((occurrenceId, mappingDescription) : acc) t - | length start < maxTagLength - = go (impureNonNull $ replicate (succ $ length start) $ head alphabet) [] result + = go nextStart borderLength ((occurrenceId, mappingDescription) : acc) t + | borderLength < maxTagLength + = go (singleton $ head alphabet) (succ borderLength) [] result | otherwise = [] where - mappingDescription :: ExamOccurrenceMappingDescription - mappingDescription = ExamOccurrenceMappingRange (toNullable start) end - -- | pre/suffix of larges user tag - end :: [CI Char] - -- userTags is guaranteed nonNull - end = case t of - [] -> replicate (length start) $ last alphabet - _nonEmpty - | length biggestTag < length start - -- add padding, to keep equal length - -> biggestTag ++ replicate (length start - length biggestTag) paddingChar - | otherwise -> biggestTag - where - biggestTag :: [CI Char] - biggestTag = maximum $ impureNonNull $ map (transformTag start) userTags - paddingChar :: CI Char - paddingChar = CI.mk ' ' + mappingDescription :: Set ExamOccurrenceMappingDescription + mappingDescription = Set.fromList $ case maybeEnd of + (Just end) -> ExamOccurrenceMappingRange (toNullable start) end : specialMapping + Nothing -> specialMapping + + specialMapping :: [ExamOccurrenceMappingDescription] + specialMapping = [ExamOccurrenceMappingSpecial $ transformTag borderLength tag | tag <- specialTags] + + alphabetTags, specialTags :: [[CI Char]] + (alphabetTags, specialTags) = partition (all (`elem` alphabet) . take (length start)) userTags + -- | pre/suffix of largest user tag + maybeEnd :: Maybe [CI Char] + maybeEnd = case t of + [] -> Just $ replicate borderLength $ last alphabet + _nonEmpty -> transformTag borderLength . maximum <$> fromNullable alphabetTags nextStart :: NonNull [CI Char] -- end is guaranteed nonNull, all empty tags are filtered out in users' - nextStart = impureNonNull $ reverse $ increase $ reverse end + nextStart + | Nothing <- maybeEnd + = start + | length start < borderLength + = start <> impureNonNull [head alphabet] + | (Just end) <- maybeEnd + = impureNonNull $ reverse $ increase $ reverse end alphabetCycle :: [CI Char] alphabetCycle = List.cycle $ toNullable alphabet increase :: [CI Char] -> [CI Char] increase [] = [] increase (c:cs) - | c < head alphabet - = head alphabet : cs | nextChar == head alphabet = nextChar : increase cs | otherwise @@ -603,25 +612,25 @@ examAutoOccurrence (hash -> seed) rule ExamAutoOccurrenceConfig{..} occurrences nextChar | c `elem` alphabet = dropWhile (/= c) alphabetCycle List.!! 1 - | otherwise -- includes padding char - = head alphabet - -- TODO what if the border is between to non-ascii characters? + | otherwise -- shouldn't happen, simply use head alphabet + = error $ "uncaught non-alphabet char: " ++ show c --TODO head alphabet - transformTag :: (MonoFoldable f) => f -> [CI Char] -> [CI Char] - transformTag (length -> l) tag = case rule of + transformTag :: Int -> [CI Char] -> [CI Char] + transformTag l tag = case rule of ExamRoomMatriculation -> drop (max 0 $ length tag - l) tag _rule -> take l tag - matchMappingDescription :: ExamOccurrenceMappingDescription -> [[CI Char]] -> Bool - matchMappingDescription ExamOccurrenceMappingRange {eaomrStart, eaomrEnd} = all $ \tag -> - (eaomrStart <= transformTag eaomrStart tag) && (transformTag eaomrEnd tag <= eaomrEnd) - - matchMappingDescription ExamOccurrenceMappingSpecial {eaomrSpecial} = all $ checkSpecial eaomrSpecial - where - checkSpecial :: [CI Char] -> [CI Char] -> Bool - checkSpecial = case rule of - ExamRoomMatriculation -> isSuffixOf - _rule -> isPrefixOf + matchMappingDescription :: Set ExamOccurrenceMappingDescription -> [[CI Char]] -> Bool + matchMappingDescription mappingDescription userTags = flip all userTags $ \tag -> flip any mappingDescription $ \case + ExamOccurrenceMappingRange {eaomrStart, eaomrEnd} + -- non-rangeAlphabet-chars get a special mapping, so <= is fine here + -> (eaomrStart <= transformTag (length eaomrStart) tag) && (transformTag (length eaomrEnd) tag <= eaomrEnd) + ExamOccurrenceMappingSpecial {eaomrSpecial} -> checkSpecial eaomrSpecial tag + where + checkSpecial :: [CI Char] -> [CI Char] -> Bool + checkSpecial = case rule of + ExamRoomMatriculation -> isSuffixOf + _rule -> isPrefixOf resultUsers :: Map UserId (Maybe ExamOccurrenceId) resultUsers = Map.fromList $ do diff --git a/test/Handler/Utils/ExamSpec.hs b/test/Handler/Utils/ExamSpec.hs index 9de995308..7251b867f 100644 --- a/test/Handler/Utils/ExamSpec.hs +++ b/test/Handler/Utils/ExamSpec.hs @@ -1,4 +1,5 @@ {-# OPTIONS_GHC -Wno-redundant-constraints #-} +{-# OPTIONS_GHC -Wwarn #-} module Handler.Utils.ExamSpec (spec) where @@ -15,6 +16,8 @@ import qualified Data.Set as Set import qualified Data.Text as Text import qualified Data.CaseInsensitive as CI +import qualified Data.RFC5051 as RFC5051 + import Handler.Utils.Exam @@ -244,15 +247,21 @@ spec = do | otherwise -> userMatrikelnummer _rule -> Nothing fitsInRange :: ExamOccurrenceMappingDescription -> Bool - fitsInRange ExamOccurrenceMappingRange {eaomrStart, eaomrEnd} = case ciTag of - Nothing -> True - (Just tag) -> (eaomrStart <= transformTag eaomrStart tag) && (transformTag eaomrEnd tag <= eaomrEnd) - fitsInRange ExamOccurrenceMappingSpecial {} - = True -- FIXME what is the meaning of special? + fitsInRange mappingDescription = case (ciTag, mappingDescription) of + (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?