106 lines
4.2 KiB
Haskell
106 lines
4.2 KiB
Haskell
-- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
|
|
--
|
|
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
|
|
|
-- TODO: why is this Handler.Utils.Profile instead of Utils.Profile?
|
|
-- TODO: consider merging with Handler.Utils.Users?
|
|
module Handler.Utils.Profile
|
|
( checkDisplayName
|
|
, validDisplayName
|
|
, fixDisplayName
|
|
, validPostAddress
|
|
, validEmail, validEmail'
|
|
, pickValidEmail, pickValidEmail'
|
|
) where
|
|
|
|
import Import.NoFoundation
|
|
|
|
import Data.Char
|
|
import qualified Data.Text as Text
|
|
import qualified Data.Text.Lazy as LT
|
|
import qualified Data.CaseInsensitive as CI
|
|
|
|
import qualified Data.MultiSet as MultiSet
|
|
import qualified Data.Set as Set
|
|
|
|
import qualified Text.Email.Validate as Email
|
|
|
|
-- | Instead of CI.mk, this still allows use of Text.isInfixOf, etc.
|
|
stripFold :: Text -> Text
|
|
stripFold = Text.toCaseFold . Text.strip
|
|
|
|
-- | remove last comma and swap order of the two parts, ie. transforming "surname, givennames" into "givennames surname".
|
|
-- Input "givennames surname" is left unchanged, except for removing excess whitespace
|
|
fixDisplayName :: UserDisplayName -> UserDisplayName
|
|
fixDisplayName udn =
|
|
let (Text.strip . Text.dropEnd 1 -> surname, Text.strip -> firstnames) = Text.breakOnEnd "," udn
|
|
in Text.toTitle $ Text.strip $ firstnames <> Text.cons ' ' surname
|
|
|
|
-- | Like `validDisplayName` but may return an automatically corrected name
|
|
checkDisplayName :: Maybe UserTitle -> UserFirstName -> UserSurname -> UserDisplayName -> Maybe UserDisplayName
|
|
checkDisplayName mTitle fName sName (fixDisplayName -> dName)
|
|
| validDisplayName mTitle fName sName dName = Just dName
|
|
| otherwise = Nothing
|
|
|
|
validDisplayName :: Maybe UserTitle
|
|
-> UserFirstName
|
|
-> UserSurname
|
|
-> UserDisplayName
|
|
-> Bool
|
|
validDisplayName (fmap stripFold -> mTitle) (stripFold -> fName) (stripFold -> sName) (stripFold -> dName)
|
|
= and [ dNameFrags `MultiSet.isSubsetOf` MultiSet.unions [titleFrags, fNameFrags, sNameFrags]
|
|
, sName `Text.isInfixOf` dName
|
|
, all ((<= 1) . Text.length) . filter (Text.any isAdd) $ Text.group dName
|
|
, dNameLetters `Set.isSubsetOf` Set.unions [titleLetters, fNameLetters, sNameLetters, addLetters]
|
|
]
|
|
where
|
|
titleFrags = foldMap makeMultiSet mTitle
|
|
dNameFrags = makeMultiSet dName
|
|
fNameFrags = makeMultiSet fName
|
|
sNameFrags = makeMultiSet sName
|
|
|
|
titleLetters = foldMap (Set.fromList . unpack) mTitle
|
|
fNameLetters = Set.fromList $ unpack fName
|
|
sNameLetters = Set.fromList $ unpack sName
|
|
dNameLetters = Set.fromList $ unpack dName
|
|
addLetters = Set.fromList [' ', '.', '-']
|
|
|
|
isAdd = (`Set.member` addLetters)
|
|
splitAdd = Text.split isAdd
|
|
makeMultiSet = MultiSet.fromList . filter (not . Text.null) . splitAdd
|
|
|
|
|
|
-- | Primitive postal address requires at least one alphabetic character, one digit and a line break
|
|
validPostAddress :: Maybe StoredMarkup -> Bool
|
|
validPostAddress (Just StoredMarkup {markupInput = addr})
|
|
| Just _ <- LT.find isLetter addr
|
|
, Just _ <- LT.find isNumber addr
|
|
-- , Just _ <- LT.find ((LineSeparator ==) . generalCategory) addr -- THIS DID NOT WORK
|
|
, 1 < length (LT.lines addr)
|
|
= True
|
|
validPostAddress _ = False
|
|
|
|
-- also see `Handler.Utils.Users.getEmailAddress` for Tests accepting User Type
|
|
validEmail :: Email -> Bool -- Email = Text
|
|
validEmail email = validRFC5322 && not invalidFraport
|
|
where
|
|
validRFC5322 = Email.isValid $ encodeUtf8 email
|
|
invalidFraport = case Text.stripSuffix "@fraport.de" email of
|
|
Just fralogin -> all isDigit $ drop 1 fralogin
|
|
Nothing -> False
|
|
|
|
validEmail' :: UserEmail -> Bool -- UserEmail = CI Text
|
|
validEmail' = validEmail . CI.original
|
|
|
|
-- | returns first argument, if it is a valid email address; returns second argument untested otherwise; convenience function
|
|
pickValidEmail :: UserEmail -> UserEmail -> UserEmail
|
|
pickValidEmail x y
|
|
| validEmail' x = x
|
|
| otherwise = y
|
|
|
|
-- | returns first valid email address or none if none are valid
|
|
pickValidEmail' :: UserEmail -> UserEmail -> Maybe UserEmail
|
|
pickValidEmail' x y
|
|
| validEmail' x = Just x
|
|
| validEmail' y = Just y
|
|
| otherwise = Nothing |