{-# Language OverloadedStrings #-}
module Client.Mask
( Mask
, matchMask
, buildMask
) where
import Data.List (intercalate)
import Data.Text (Text)
import Data.Text qualified as Text
import Irc.Identifier (Identifier, idTextNorm, mkId)
import Irc.UserInfo (UserInfo, renderUserInfo)
import Text.Regex.TDFA
import Text.Regex.TDFA.String (compile)
newtype Mask = Mask Regex
buildMask ::
[Identifier] ->
Mask
buildMask :: [Identifier] -> Mask
buildMask [Identifier]
patterns =
case [String] -> Either String Mask
componentsToMask (forall a b. (a -> b) -> [a] -> [b]
map (String -> String
translate forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
parseMaskComponents forall b c a. (b -> c) -> (a -> b) -> a -> c
. Identifier -> Text
idTextNorm) [Identifier]
patterns) of
Left String
e -> forall a. HasCallStack => String -> a
error String
e
Right Mask
m -> Mask
m
matchMask :: Mask -> UserInfo -> Bool
matchMask :: Mask -> UserInfo -> Bool
matchMask (Mask Regex
re) UserInfo
userInfo =
forall regex source.
RegexLike regex source =>
regex -> source -> Bool
matchTest Regex
re (Text -> String
Text.unpack (Text -> Text
normalized (UserInfo -> Text
renderUserInfo UserInfo
userInfo)))
normalized :: Text -> Text
normalized :: Text -> Text
normalized = Identifier -> Text
idTextNorm forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Identifier
mkId
parseMaskComponents :: Text -> String
parseMaskComponents :: Text -> String
parseMaskComponents Text
str = Text -> String
Text.unpack Text
nick forall a. [a] -> [a] -> [a]
++ String
"!" forall a. [a] -> [a] -> [a]
++ String
user forall a. [a] -> [a] -> [a]
++ String
"@" forall a. [a] -> [a] -> [a]
++ String
host
where
(Text
nickuser,Text
rawhost) = (Char -> Bool) -> Text -> (Text, Text)
Text.break (forall a. Eq a => a -> a -> Bool
==Char
'@') Text
str
(Text
nick ,Text
rawuser) = (Char -> Bool) -> Text -> (Text, Text)
Text.break (forall a. Eq a => a -> a -> Bool
==Char
'!') Text
nickuser
user :: String
user = Text -> String
defaultWild Text
rawuser
host :: String
host = Text -> String
defaultWild Text
rawhost
defaultWild :: Text -> String
defaultWild Text
x =
case Text -> Maybe (Char, Text)
Text.uncons Text
x of
Maybe (Char, Text)
Nothing -> String
"*"
Just (Char
_, Text
y) -> Text -> String
Text.unpack Text
y
componentsToMask :: [String] -> Either String Mask
componentsToMask :: [String] -> Either String Mask
componentsToMask [String]
xs =
Regex -> Mask
Mask forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CompOption -> ExecOption -> String -> Either String Regex
compile forall regex compOpt execOpt.
RegexOptions regex compOpt execOpt =>
compOpt
defaultCompOpt { multiline :: Bool
multiline = Bool
False }
forall regex compOpt execOpt.
RegexOptions regex compOpt execOpt =>
execOpt
defaultExecOpt { captureGroups :: Bool
captureGroups = Bool
False }
(String
"^(" forall a. [a] -> [a] -> [a]
++ forall a. [a] -> [[a]] -> [a]
intercalate String
"|" [String]
xs forall a. [a] -> [a] -> [a]
++ String
")$")
translate :: String -> String
translate :: String -> String
translate [] = []
translate (Char
'\\' : Char
'*' : String
xs) = Char
'\\' forall a. a -> [a] -> [a]
: Char
'*' forall a. a -> [a] -> [a]
: String -> String
translate String
xs
translate (Char
'\\' : Char
'?' : String
xs) = Char
'\\' forall a. a -> [a] -> [a]
: Char
'?' forall a. a -> [a] -> [a]
: String -> String
translate String
xs
translate (Char
'\\' : Char
'\\' : String
xs) = Char
'\\' forall a. a -> [a] -> [a]
: Char
'\\' forall a. a -> [a] -> [a]
: String -> String
translate String
xs
translate (Char
'*' : String
xs) = Char
'.' forall a. a -> [a] -> [a]
: Char
'*' forall a. a -> [a] -> [a]
: String -> String
translate String
xs
translate (Char
'?' : String
xs) = Char
'.' forall a. a -> [a] -> [a]
: Char
'?' forall a. a -> [a] -> [a]
: String -> String
translate String
xs
translate (Char
x : String
xs)
| Char -> Bool
isMetaChar Char
x = Char
'\\' forall a. a -> [a] -> [a]
: Char
x forall a. a -> [a] -> [a]
: String -> String
translate String
xs
| Bool
otherwise = Char
x forall a. a -> [a] -> [a]
: String -> String
translate String
xs
isMetaChar :: Char -> Bool
isMetaChar :: Char -> Bool
isMetaChar Char
c = case Char
c of
Char
'^' -> Bool
True
Char
'\\' -> Bool
True
Char
'.' -> Bool
True
Char
'|' -> Bool
True
Char
'*' -> Bool
True
Char
'?' -> Bool
True
Char
'+' -> Bool
True
Char
'(' -> Bool
True
Char
')' -> Bool
True
Char
'[' -> Bool
True
Char
']' -> Bool
True
Char
'{' -> Bool
True
Char
'}' -> Bool
True
Char
'$' -> Bool
True
Char
_ -> Bool
False