{-# Language QuasiQuotes, OverloadedStrings #-}
{-|
Module      : Client.Hook.DroneBLRelay
Description : Hook for interpreting DroneBL relay messages
Copyright   : (c) Eric Mertens 2019
License     : ISC
Maintainer  : emertens@gmail.com

The #dronebl channels use a bot to relay messages from
other networks. This hook integrates those messages into the native
format.

-}
module Client.Hook.DroneBLRelay
  ( droneblRelayHook
  ) where

import           Data.List (uncons)
import qualified Data.Text as Text
import           Data.Text (Text)
import           Data.Foldable (asum)

import           Text.Regex.TDFA (match, defaultCompOpt, defaultExecOpt, Regex)
import           Text.Regex.TDFA.String (compile)

import           Client.Hook (MessageHook(..), MessageResult(..))
import           Irc.Message
import           Irc.Identifier (mkId, Identifier)
import           Irc.UserInfo (UserInfo(..))
import           StrQuote (str)

-- | Hook for mapping messages in #dronebl
-- to appear like native messages.
droneblRelayHook :: [Text] -> Maybe MessageHook
droneblRelayHook :: [Text] -> Maybe MessageHook
droneblRelayHook [Text]
args = MessageHook -> Maybe MessageHook
forall a. a -> Maybe a
Just (Text -> Bool -> (IrcMsg -> MessageResult) -> MessageHook
MessageHook Text
"droneblrelay" Bool
False ([Identifier] -> IrcMsg -> MessageResult
remap ((Text -> Identifier) -> [Text] -> [Identifier]
forall a b. (a -> b) -> [a] -> [b]
map Text -> Identifier
mkId [Text]
args)))

-- | Remap messages from #dronebl that match one of the
-- rewrite rules.
remap :: [Identifier] -> IrcMsg -> MessageResult
remap :: [Identifier] -> IrcMsg -> MessageResult
remap [Identifier]
nicks (Privmsg (Source (UserInfo Identifier
nick Text
_ Text
_) Text
_) chan :: Identifier
chan@Identifier
"#dronebl" Text
msg)
  | Identifier
nick Identifier -> [Identifier] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Identifier]
nicks
  , Just IrcMsg
sub <- Identifier -> Text -> Maybe IrcMsg
rules Identifier
chan Text
msg = IrcMsg -> MessageResult
RemapMessage IrcMsg
sub
remap [Identifier]
_ IrcMsg
_ = MessageResult
PassMessage

-- | Generate a replacement message for a chat message
-- when the message matches one of the replacement rules.
rules ::
  Identifier {- ^ channel -} ->
  Text       {- ^ message -} ->
  Maybe IrcMsg
rules :: Identifier -> Text -> Maybe IrcMsg
rules Identifier
chan Text
msg =
  [Maybe IrcMsg] -> Maybe IrcMsg
forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum
    [ (Text -> Text -> IrcMsg) -> Regex -> Text -> Maybe IrcMsg
forall r. Rule r => r -> Regex -> Text -> Maybe IrcMsg
rule (Identifier -> Text -> Text -> IrcMsg
chatMsg Identifier
chan) Regex
chatRe Text
msg
    , (Text -> Text -> IrcMsg) -> Regex -> Text -> Maybe IrcMsg
forall r. Rule r => r -> Regex -> Text -> Maybe IrcMsg
rule (Identifier -> Text -> Text -> IrcMsg
actionMsg Identifier
chan) Regex
actionRe Text
msg
    , (Text -> Text -> Text -> Text -> IrcMsg)
-> Regex -> Text -> Maybe IrcMsg
forall r. Rule r => r -> Regex -> Text -> Maybe IrcMsg
rule (Identifier -> Text -> Text -> Text -> Text -> IrcMsg
joinMsg Identifier
chan) Regex
joinRe Text
msg
    , (Text -> Text -> Text -> Text -> IrcMsg)
-> Regex -> Text -> Maybe IrcMsg
forall r. Rule r => r -> Regex -> Text -> Maybe IrcMsg
rule (Identifier -> Text -> Text -> Text -> Text -> IrcMsg
partMsg Identifier
chan) Regex
partRe Text
msg
    , (Text -> Text -> Text -> IrcMsg) -> Regex -> Text -> Maybe IrcMsg
forall r. Rule r => r -> Regex -> Text -> Maybe IrcMsg
rule Text -> Text -> Text -> IrcMsg
quitMsg Regex
quitRe Text
msg
    , (Text -> Text -> Text -> IrcMsg) -> Regex -> Text -> Maybe IrcMsg
forall r. Rule r => r -> Regex -> Text -> Maybe IrcMsg
rule Text -> Text -> Text -> IrcMsg
nickMsg Regex
nickRe Text
msg
    , (Text -> Text -> Text -> Text -> IrcMsg)
-> Regex -> Text -> Maybe IrcMsg
forall r. Rule r => r -> Regex -> Text -> Maybe IrcMsg
rule (Identifier -> Text -> Text -> Text -> Text -> IrcMsg
kickMsg Identifier
chan) Regex
kickRe Text
msg
    , (Text -> Text -> Text -> IrcMsg) -> Regex -> Text -> Maybe IrcMsg
forall r. Rule r => r -> Regex -> Text -> Maybe IrcMsg
rule (Identifier -> Text -> Text -> Text -> IrcMsg
modeMsg Identifier
chan) Regex
modeRe Text
msg
    ]

-- | Match the message against the regular expression and use the given
-- consume to consume all of the captured groups.
rule ::
  Rule r =>
  r     {- ^ capture consumer   -} ->
  Regex {- ^ regular expression -} ->
  Text  {- ^ message            -} ->
  Maybe IrcMsg
rule :: r -> Regex -> Text -> Maybe IrcMsg
rule r
mk Regex
re Text
s =
  case ([String] -> [Text]) -> [[String]] -> [[Text]]
forall a b. (a -> b) -> [a] -> [b]
map ((String -> Text) -> [String] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map String -> Text
Text.pack) (Regex -> String -> [[String]]
forall regex source target.
RegexContext regex source target =>
regex -> source -> target
match Regex
re (Text -> String
Text.unpack Text
s)) of
    [Text
_:[Text]
xs] -> [Text] -> r -> Maybe IrcMsg
forall a. Rule a => [Text] -> a -> Maybe IrcMsg
matchRule [Text]
xs r
mk
    [[Text]]
_      -> Maybe IrcMsg
forall a. Maybe a
Nothing

chatRe, actionRe, joinRe, quitRe, nickRe, partRe, kickRe, modeRe :: Regex
Right Regex
chatRe   = Text -> Either String Regex
compRe [str|^<([^>]+)> (.*)$|]
Right Regex
actionRe = Text -> Either String Regex
compRe [str|^\* ([^ ]+) (.*)$|]
Right Regex
joinRe   = Text -> Either String Regex
compRe [str|^\*\*\* \[([^]]+)\] ([^ ]+) \(([^@]+)@([^)]+)\) has joined the channel$|]
Right Regex
quitRe   = Text -> Either String Regex
compRe [str|^\*\*\* \[([^]]+)\] ([^ ]+) has signed off \((.*)\)$|]
Right Regex
nickRe   = Text -> Either String Regex
compRe [str|^\*\*\* \[([^]]+)\] ([^ ]+) changed nick to ([^ ]+)$|]
Right Regex
partRe   = Text -> Either String Regex
compRe [str|^\*\*\* \[([^]]+)\] ([^ ]+) has left the channel( \((.*)\))?$|]
Right Regex
kickRe   = Text -> Either String Regex
compRe [str|^\*\*\* \[([^]]+)\] ([^ ]+) has been kicked by ([^ ]+) \((.*)\)$|]
Right Regex
modeRe   = Text -> Either String Regex
compRe [str|^\*\*\* \[([^]]+)\] ([^ ]+) sets mode (.*)$|]

-- | Compile a regular expression for using in message matching.
compRe ::
  Text                {- ^ regular expression           -} ->
  Either String Regex {- ^ error or compiled expression -}
compRe :: Text -> Either String Regex
compRe = CompOption -> ExecOption -> String -> Either String Regex
compile CompOption
forall regex compOpt execOpt.
RegexOptions regex compOpt execOpt =>
compOpt
defaultCompOpt ExecOption
forall regex compOpt execOpt.
RegexOptions regex compOpt execOpt =>
execOpt
defaultExecOpt (String -> Either String Regex)
-> (Text -> String) -> Text -> Either String Regex
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
Text.unpack

------------------------------------------------------------------------

chatMsg ::
  Identifier {- ^ channel  -} ->
  Text       {- ^ nickname -} ->
  Text       {- ^ message  -} ->
  IrcMsg
chatMsg :: Identifier -> Text -> Text -> IrcMsg
chatMsg Identifier
chan Text
nick Text
msg =
  Source -> Identifier -> Text -> IrcMsg
Privmsg
    (Text -> Source
userInfo Text
nick)
    Identifier
chan
    Text
msg

actionMsg ::
  Identifier {- ^ channel  -} ->
  Text       {- ^ nickname -} ->
  Text       {- ^ message  -} ->
  IrcMsg
actionMsg :: Identifier -> Text -> Text -> IrcMsg
actionMsg Identifier
chan Text
nick Text
msg =
  Source -> Identifier -> Text -> Text -> IrcMsg
Ctcp
    (Text -> Source
userInfo Text
nick)
    Identifier
chan
    Text
"ACTION"
    Text
msg

joinMsg ::
  Identifier {- ^ channel  -} ->
  Text       {- ^ server   -} ->
  Text       {- ^ nickname -} ->
  Text       {- ^ username -} ->
  Text       {- ^ hostname -} ->
  IrcMsg
joinMsg :: Identifier -> Text -> Text -> Text -> Text -> IrcMsg
joinMsg Identifier
chan Text
srv Text
nick Text
user Text
host =
  Source -> Identifier -> Text -> Text -> IrcMsg
Join
    (UserInfo -> Text -> Source
Source (Identifier -> Text -> Text -> UserInfo
UserInfo (Text -> Identifier
mkId (Text
nick Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"@" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
srv)) Text
user Text
host) Text
"")
    Identifier
chan
    Text
"" -- account
    Text
"" -- gecos

partMsg ::
  Identifier {- ^ channel        -} ->
  Text       {- ^ server         -} ->
  Text       {- ^ nickname       -} ->
  Text       {- ^ reason wrapper -} ->
  Text       {- ^ reason         -} ->
  IrcMsg
partMsg :: Identifier -> Text -> Text -> Text -> Text -> IrcMsg
partMsg Identifier
chan Text
srv Text
nick Text
msg_outer Text
msg =
  Source -> Identifier -> Maybe Text -> IrcMsg
Part
    (Text -> Source
userInfo (Text
nick Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"@" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
srv))
    Identifier
chan
    (if Text -> Bool
Text.null Text
msg_outer then Maybe Text
forall a. Maybe a
Nothing else Text -> Maybe Text
forall a. a -> Maybe a
Just Text
msg)

quitMsg ::
  Text {- ^ server       -} ->
  Text {- ^ nickname     -} ->
  Text {- ^ quit message -} ->
  IrcMsg
quitMsg :: Text -> Text -> Text -> IrcMsg
quitMsg Text
srv Text
nick Text
msg =
  Source -> Maybe Text -> IrcMsg
Quit
    (Text -> Source
userInfo (Text
nick Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"@" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
srv))
    (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
msg)

nickMsg ::
  Text {- ^ server   -} ->
  Text {- ^ old nick -} ->
  Text {- ^ new nick -} ->
  IrcMsg
nickMsg :: Text -> Text -> Text -> IrcMsg
nickMsg Text
srv Text
old Text
new =
  Source -> Identifier -> IrcMsg
Nick
    (Text -> Source
userInfo (Text
old Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"@" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
srv))
    (Text -> Identifier
mkId (Text
new Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"@" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
srv))

kickMsg ::
  Identifier {- ^ channel     -} ->
  Text       {- ^ server      -} ->
  Text       {- ^ kickee nick -} ->
  Text       {- ^ kicker nick -} ->
  Text       {- ^ reason      -} ->
  IrcMsg
kickMsg :: Identifier -> Text -> Text -> Text -> Text -> IrcMsg
kickMsg Identifier
chan Text
srv Text
kickee Text
kicker Text
reason =
  Source -> Identifier -> Identifier -> Text -> IrcMsg
Kick
    (Text -> Source
userInfo (Text
kicker Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"@" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
srv))
    Identifier
chan
    (Text -> Identifier
mkId (Text
kickee Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"@" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
srv))
    Text
reason

modeMsg ::
  Identifier {- ^ channel     -} ->
  Text       {- ^ server      -} ->
  Text       {- ^ nickname    -} ->
  Text       {- ^ modes       -} ->
  IrcMsg
modeMsg :: Identifier -> Text -> Text -> Text -> IrcMsg
modeMsg Identifier
chan Text
srv Text
nick Text
modes =
  Source -> Identifier -> [Text] -> IrcMsg
Mode
    (Text -> Source
userInfo (Text
nick Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"@" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
srv))
    Identifier
chan
    (Text -> [Text]
Text.words Text
modes)

-- | Construct dummy user info when we don't know the user or host part.
userInfo ::
  Text {- ^ nickname -} ->
  Source
userInfo :: Text -> Source
userInfo Text
nick = UserInfo -> Text -> Source
Source (Identifier -> Text -> Text -> UserInfo
UserInfo (Text -> Identifier
mkId Text
nick) Text
"*" Text
"*") Text
""

------------------------------------------------------------------------

-- | The class allows n-ary functions of the form
-- `Text -> Text -> ... -> IrcMsg` to be used to exhaustively consume the
-- matched elements of a regular expression.
class Rule a where
  matchRule :: [Text] -> a -> Maybe IrcMsg

instance (RuleArg a, Rule b) => Rule (a -> b) where
  matchRule :: [Text] -> (a -> b) -> Maybe IrcMsg
matchRule [Text]
tts a -> b
f =
    do (Text
t,[Text]
ts) <- [Text] -> Maybe (Text, [Text])
forall a. [a] -> Maybe (a, [a])
uncons [Text]
tts
       a
a      <- Text -> Maybe a
forall a. RuleArg a => Text -> Maybe a
matchArg Text
t
       [Text] -> b -> Maybe IrcMsg
forall a. Rule a => [Text] -> a -> Maybe IrcMsg
matchRule [Text]
ts (a -> b
f a
a)

instance Rule IrcMsg where
  matchRule :: [Text] -> IrcMsg -> Maybe IrcMsg
matchRule [Text]
args IrcMsg
ircMsg
    | [Text] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
args = IrcMsg -> Maybe IrcMsg
forall a. a -> Maybe a
Just IrcMsg
ircMsg
    | Bool
otherwise = Maybe IrcMsg
forall a. Maybe a
Nothing

class    RuleArg a    where matchArg :: Text -> Maybe a
instance RuleArg Text where matchArg :: Text -> Maybe Text
matchArg = Text -> Maybe Text
forall a. a -> Maybe a
Just