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

chore: names with non-ascii prefix get a ExamOccurrenceMappingSpecial

Browse Source
This commit is contained in:
Wolfgang Witt 2021-02-18 17:22:06 +01:00 committed by Wolfgang Witt
parent d60f93561f
commit 5480e2d7b7
2 changed files with 69 additions and 51 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

101
src/Handler/Utils/Exam.hs
View File

@ -1,4 +1,5 @@
{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-} {-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-}
{-# OPTIONS_GHC -Wwarn #-}
module Handler.Utils.Exam module Handler.Utils.Exam
( fetchExamAux ( fetchExamAux
@ -540,60 +541,68 @@ examAutoOccurrence (hash -> seed) rule ExamAutoOccurrenceConfig{..} occurrences
rangeAlphabet :: [CI Char] rangeAlphabet :: [CI Char]
rangeAlphabet = case rule of rangeAlphabet = case rule of
ExamRoomSurname -> map CI.mk ['A'..'Z'] 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'] ExamRoomMatriculation-> map CI.mk ['0'..'9']
_rule -> [] _rule -> []
resultAscList :: Map ExamOccurrenceId (Set ExamOccurrenceMappingDescription) resultAscList :: Map ExamOccurrenceId (Set ExamOccurrenceMappingDescription)
resultAscList = case fromNullable rangeAlphabet of resultAscList = case fromNullable rangeAlphabet of
Nothing -> Map.empty 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 where
go :: NonNull [CI Char] -> [(ExamOccurrenceId, ExamOccurrenceMappingDescription)] -> [(ExamOccurrenceId, [[CI Char]])] -> [(ExamOccurrenceId, ExamOccurrenceMappingDescription)] go :: NonNull [CI Char]
go _start acc [] = acc -> 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 -- 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 where
extendEnd :: ExamOccurrenceMappingDescription -> ExamOccurrenceMappingDescription
extendEnd ExamOccurrenceMappingRange {eaomrStart} = ExamOccurrenceMappingRange {eaomrStart, eaomrEnd}
extendEnd examOccurrenceMappingSpecial = examOccurrenceMappingSpecial
eaomrEnd :: [CI Char] eaomrEnd :: [CI Char]
eaomrEnd = replicate (length start) $ last alphabet eaomrEnd = replicate (length start) $ last alphabet
go start acc ((_occurrenceId, []):t) = go start acc t go start borderLength acc ((_occurrenceId, []):t) = go start borderLength acc t
go start acc ((occurrenceId, userTags):t) go start borderLength acc ((occurrenceId, userTags):t)
| matchMappingDescription mappingDescription userTags | matchMappingDescription mappingDescription userTags
= go nextStart ((occurrenceId, mappingDescription) : acc) t = go nextStart borderLength ((occurrenceId, mappingDescription) : acc) t
| length start < maxTagLength | borderLength < maxTagLength
= go (impureNonNull $ replicate (succ $ length start) $ head alphabet) [] result = go (singleton $ head alphabet) (succ borderLength) [] result
| otherwise | otherwise
= [] = []
where where
mappingDescription :: ExamOccurrenceMappingDescription mappingDescription :: Set ExamOccurrenceMappingDescription
mappingDescription = ExamOccurrenceMappingRange (toNullable start) end mappingDescription = Set.fromList $ case maybeEnd of
-- | pre/suffix of larges user tag (Just end) -> ExamOccurrenceMappingRange (toNullable start) end : specialMapping
end :: [CI Char] Nothing -> specialMapping
-- userTags is guaranteed nonNull
end = case t of specialMapping :: [ExamOccurrenceMappingDescription]
[] -> replicate (length start) $ last alphabet specialMapping = [ExamOccurrenceMappingSpecial $ transformTag borderLength tag | tag <- specialTags]
_nonEmpty
| length biggestTag < length start alphabetTags, specialTags :: [[CI Char]]
-- add padding, to keep equal length (alphabetTags, specialTags) = partition (all (`elem` alphabet) . take (length start)) userTags
-> biggestTag ++ replicate (length start - length biggestTag) paddingChar -- | pre/suffix of largest user tag
| otherwise -> biggestTag maybeEnd :: Maybe [CI Char]
where maybeEnd = case t of
biggestTag :: [CI Char] [] -> Just $ replicate borderLength $ last alphabet
biggestTag = maximum $ impureNonNull $ map (transformTag start) userTags _nonEmpty -> transformTag borderLength . maximum <$> fromNullable alphabetTags
paddingChar :: CI Char
paddingChar = CI.mk ' '
nextStart :: NonNull [CI Char] nextStart :: NonNull [CI Char]
-- end is guaranteed nonNull, all empty tags are filtered out in users' -- 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 :: [CI Char]
alphabetCycle = List.cycle $ toNullable alphabet alphabetCycle = List.cycle $ toNullable alphabet
increase :: [CI Char] -> [CI Char] increase :: [CI Char] -> [CI Char]
increase [] = [] increase [] = []
increase (c:cs) increase (c:cs)
| c < head alphabet
= head alphabet : cs
| nextChar == head alphabet | nextChar == head alphabet
= nextChar : increase cs = nextChar : increase cs
| otherwise | otherwise
@ -603,25 +612,25 @@ examAutoOccurrence (hash -> seed) rule ExamAutoOccurrenceConfig{..} occurrences
nextChar nextChar
| c `elem` alphabet | c `elem` alphabet
= dropWhile (/= c) alphabetCycle List.!! 1 = dropWhile (/= c) alphabetCycle List.!! 1
| otherwise -- includes padding char | otherwise -- shouldn't happen, simply use head alphabet
= head alphabet = error $ "uncaught non-alphabet char: " ++ show c --TODO head alphabet
-- TODO what if the border is between to non-ascii characters?
transformTag :: (MonoFoldable f) => f -> [CI Char] -> [CI Char] transformTag :: Int -> [CI Char] -> [CI Char]
transformTag (length -> l) tag = case rule of transformTag l tag = case rule of
ExamRoomMatriculation -> drop (max 0 $ length tag - l) tag ExamRoomMatriculation -> drop (max 0 $ length tag - l) tag
_rule -> take l tag _rule -> take l tag
matchMappingDescription :: ExamOccurrenceMappingDescription -> [[CI Char]] -> Bool matchMappingDescription :: Set ExamOccurrenceMappingDescription -> [[CI Char]] -> Bool
matchMappingDescription ExamOccurrenceMappingRange {eaomrStart, eaomrEnd} = all $ \tag -> matchMappingDescription mappingDescription userTags = flip all userTags $ \tag -> flip any mappingDescription $ \case
(eaomrStart <= transformTag eaomrStart tag) && (transformTag eaomrEnd tag <= eaomrEnd) ExamOccurrenceMappingRange {eaomrStart, eaomrEnd}
-- non-rangeAlphabet-chars get a special mapping, so <= is fine here
matchMappingDescription ExamOccurrenceMappingSpecial {eaomrSpecial} = all $ checkSpecial eaomrSpecial -> (eaomrStart <= transformTag (length eaomrStart) tag) && (transformTag (length eaomrEnd) tag <= eaomrEnd)
where ExamOccurrenceMappingSpecial {eaomrSpecial} -> checkSpecial eaomrSpecial tag
checkSpecial :: [CI Char] -> [CI Char] -> Bool where
checkSpecial = case rule of checkSpecial :: [CI Char] -> [CI Char] -> Bool
ExamRoomMatriculation -> isSuffixOf checkSpecial = case rule of
_rule -> isPrefixOf ExamRoomMatriculation -> isSuffixOf
_rule -> isPrefixOf
resultUsers :: Map UserId (Maybe ExamOccurrenceId) resultUsers :: Map UserId (Maybe ExamOccurrenceId)
resultUsers = Map.fromList $ do resultUsers = Map.fromList $ do

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

@ -1,4 +1,5 @@
{-# OPTIONS_GHC -Wno-redundant-constraints #-} {-# OPTIONS_GHC -Wno-redundant-constraints #-}
{-# OPTIONS_GHC -Wwarn #-}
module Handler.Utils.ExamSpec (spec) where 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.Text as Text
import qualified Data.CaseInsensitive as CI import qualified Data.CaseInsensitive as CI
import qualified Data.RFC5051 as RFC5051
import Handler.Utils.Exam import Handler.Utils.Exam
@ -244,15 +247,21 @@ spec = do
| otherwise -> userMatrikelnummer | otherwise -> userMatrikelnummer
_rule -> Nothing _rule -> Nothing
fitsInRange :: ExamOccurrenceMappingDescription -> Bool fitsInRange :: ExamOccurrenceMappingDescription -> Bool
fitsInRange ExamOccurrenceMappingRange {eaomrStart, eaomrEnd} = case ciTag of fitsInRange mappingDescription = case (ciTag, mappingDescription) of
Nothing -> True (Nothing, _mappingDescription) -> True
(Just tag) -> (eaomrStart <= transformTag eaomrStart tag) && (transformTag eaomrEnd tag <= eaomrEnd) (Just tag, ExamOccurrenceMappingRange {eaomrStart=(pack . map CI.foldedCase -> start), eaomrEnd=(pack . map CI.foldedCase-> end)})
fitsInRange ExamOccurrenceMappingSpecial {} -> (RFC5051.compareUnicode start (pack $ map CI.foldedCase $ transformTag start tag) /= GT)
= True -- FIXME what is the meaning of special? && (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 :: (MonoFoldable f) => f -> [CI Char] -> [CI Char]
transformTag (length -> rangeLength) = case rule of transformTag (length -> rangeLength) = case rule of
ExamRoomMatriculation -> reverse . take rangeLength . reverse ExamRoomMatriculation -> reverse . take rangeLength . reverse
_rule -> take rangeLength _rule -> take rangeLength
checkSpecial :: [CI Char] -> [CI Char] -> Bool
checkSpecial = case rule of
ExamRoomMatriculation -> isSuffixOf
_rule -> isPrefixOf
_otherwise -> (rule /= ExamRoomSurname) && (rule /= ExamRoomMatriculation) _otherwise -> (rule /= ExamRoomSurname) && (rule /= ExamRoomMatriculation)
{- {-
-- | Is mapping impossible? -- | Is mapping impossible?