{-# Language OverloadedStrings #-}
module Client.Mask
  ( Mask
  , matchMask
  , buildMask
  ) where

import Irc.UserInfo
import Irc.Identifier
import Data.Text (Text)
import qualified Data.Text as Text
import Text.Regex.TDFA
import Text.Regex.TDFA.String (compile)
import Data.List

newtype Mask = Mask Regex

-- | Compile a list of masks down to a single, reuseable 'Mask' value
-- suitable for being used with 'matchMask'.
--
-- Masks can match zero-to-many arbitrary characters with @*@.
--
-- Masks can match one arbitrary character with @?@.
--
-- Literal @*@ @?@ and @|@ can be matched with a preceding @\@.
--
-- Missing host or username components of a mask will automatically
-- be treated as wildcards.
buildMask ::
  [Identifier] {- ^ masks -} ->
  Mask
buildMask :: [Identifier] -> Mask
buildMask [Identifier]
patterns =
  case [String] -> Either String Mask
componentsToMask ((Identifier -> String) -> [Identifier] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String -> String
translate (String -> String)
-> (Identifier -> String) -> Identifier -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
parseMaskComponents (Text -> String) -> (Identifier -> Text) -> Identifier -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Identifier -> Text
idTextNorm) [Identifier]
patterns) of
    Left String
e -> String -> Mask
forall a. HasCallStack => String -> a
error String
e
    Right Mask
m -> Mask
m

-- | Determine if a given 'Mask' matches a given 'UserInfo'
matchMask :: Mask -> UserInfo -> Bool
matchMask :: Mask -> UserInfo -> Bool
matchMask (Mask Regex
re) UserInfo
userInfo =
  Regex -> String -> Bool
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 (Identifier -> Text) -> (Text -> Identifier) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Identifier
mkId

-- | Parse a mask into the nick, user, and hostname components
-- while replacing omitted components with @"*"@.
parseMaskComponents :: Text -> String
parseMaskComponents :: Text -> String
parseMaskComponents Text
str = Text -> String
Text.unpack Text
nick String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"!" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
user String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"@" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
host
  where
    (Text
nickuser,Text
rawhost) = (Char -> Bool) -> Text -> (Text, Text)
Text.break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'@') Text
str
    (Text
nick    ,Text
rawuser) = (Char -> Bool) -> Text -> (Text, Text)
Text.break (Char -> Char -> Bool
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 (Regex -> Mask) -> Either String Regex -> Either String Mask
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CompOption -> ExecOption -> String -> Either String Regex
compile CompOption
forall regex compOpt execOpt.
RegexOptions regex compOpt execOpt =>
compOpt
defaultCompOpt { multiline :: Bool
multiline     = Bool
False }
                   ExecOption
forall regex compOpt execOpt.
RegexOptions regex compOpt execOpt =>
execOpt
defaultExecOpt { captureGroups :: Bool
captureGroups = Bool
False }
                   (String
"^(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"|" [String]
xs String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")$")

-- | Translate from the languge of masks to the language of
-- regular expressions.
--
-- Masks support the @*@ (many) and @?@ (one) wildcards. Wildcards
-- and @\@ can be escaped by preceding them with a @\@. All other
-- uses of @\@ are treated as matching the literal backslash.
translate :: String -> String
translate :: String -> String
translate [] = []
translate (Char
'\\' : Char
'*'  : String
xs) = Char
'\\' Char -> String -> String
forall a. a -> [a] -> [a]
: Char
'*'  Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
translate String
xs
translate (Char
'\\' : Char
'?'  : String
xs) = Char
'\\' Char -> String -> String
forall a. a -> [a] -> [a]
: Char
'?'  Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
translate String
xs
translate (Char
'\\' : Char
'\\' : String
xs) = Char
'\\' Char -> String -> String
forall a. a -> [a] -> [a]
: Char
'\\' Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
translate String
xs
translate (Char
'*'         : String
xs) = Char
'.'  Char -> String -> String
forall a. a -> [a] -> [a]
: Char
'*'  Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
translate String
xs
translate (Char
'?'         : String
xs) = Char
'.'  Char -> String -> String
forall a. a -> [a] -> [a]
: Char
'?'  Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
translate String
xs
translate (Char
x           : String
xs)
  | Char -> Bool
isMetaChar Char
x = Char
'\\' Char -> String -> String
forall a. a -> [a] -> [a]
: Char
x Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
translate String
xs
  | Bool
otherwise    =        Char
x Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
translate String
xs

-- | returns True iff the charactr is a regular expression meta character:
-- @^$\\.|*?+()[]{}@
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