module Network.IRC.Fun.Bot.Internal.Event
( modId
, modPrefix
, modPrefixes
, modPrefixCI
, modPrefixesCI
, modPleasePrefix
, modPleasePrefix'
, matchPrefixedCommand
, matchPrefixedCommandFromSet
, matchPrefixedCommandFromNames
, matchRefCommand
, matchRefCommandFromSet
, matchRefCommandFromNames
, matchPlainPrivateCommand
, matchNotice
, matchRef
, defaultMatch
, matchEvent
, handleEvent
)
where
import Control.Monad (when)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Trans.RWS
import Data.Char (isSpace, toLower)
import Data.Maybe
import Data.List (find, stripPrefix)
import Network.IRC.Fun.Bot.Internal.Chat (pong, sendBack)
import Network.IRC.Fun.Bot.Internal.Failure
import Network.IRC.Fun.Bot.Internal.Nicks
import Network.IRC.Fun.Bot.Internal.State
import Network.IRC.Fun.Bot.Internal.Types hiding (Logger)
import Network.IRC.Fun.Bot.Behavior (findCmd, findCmdInSet)
import Network.IRC.Fun.Client.ChannelLogger hiding (LogEvent (..))
import Network.IRC.Fun.Client.IO (connNick)
import Network.IRC.Fun.Client.Util (mentions)
import qualified Data.HashMap.Lazy as M
import qualified Network.IRC.Fun.Client.ChannelLogger as L
import qualified Network.IRC.Fun.Client.Events as C (Event (..))
modId :: String -> String
modId = id
modPrefix :: String -> Bool -> String -> String
modPrefix p d s =
case stripPrefix p s of
Just s' -> if d then dropWhile isSpace s' else s'
Nothing -> s
modPrefixes :: [String] -> Bool -> String -> String
modPrefixes ps d s =
case listToMaybe $ mapMaybe (flip stripPrefix s) ps of
Just s' -> if d then dropWhile isSpace s' else s'
Nothing -> s
stripPrefixCI :: String -> String -> Maybe String
stripPrefixCI [] ys = Just ys
stripPrefixCI (_:_) [] = Nothing
stripPrefixCI (x:xs) (y:ys) =
if toLower x == toLower y
then stripPrefixCI xs ys
else Nothing
modPrefixCI :: String -> Bool -> String -> String
modPrefixCI p d s =
case stripPrefixCI p s of
Just s' -> if d then dropWhile isSpace s' else s'
Nothing -> s
modPrefixesCI :: [String] -> Bool -> String -> String
modPrefixesCI ps d s =
case listToMaybe $ mapMaybe (flip stripPrefixCI s) ps of
Just s' -> if d then dropWhile isSpace s' else s'
Nothing -> s
modPleasePrefix :: String -> String
modPleasePrefix = modPrefixCI "please" True
modPleasePrefix' :: String -> String
modPleasePrefix' = modPrefixesCI ["please", "plz", "pls"] True
detectRef :: Config -> String -> Maybe String
detectRef conf msg =
let bnick = connNick (cfgConnection conf)
dw = Just . dropWhile isSpace
in case stripPrefix bnick msg of
Nothing -> Nothing
Just (',' : s) -> dw s
Just (':' : s) -> dw s
Just (';' : s) -> dw s
Just (c : s) -> if isSpace c then dw s else Nothing
Just s -> dw s
mkCmd :: String -> (String, [String])
mkCmd message =
let w = words message
name = if null w then "" else head w
args = if null w then [] else tail w
in (name, args)
expand :: [String] -> Maybe (CommandSet e s) -> [String]
expand ns Nothing = ns
expand ns (Just cset) =
let ls = map cmdNames $ csetCommands cset
in concat $ mapMaybe (\ n -> find (n `elem`) ls) ns
makePrefixedCommand :: Maybe Config
-> [CommandSet e s]
-> MessageSource
-> Char
-> String
-> Maybe Event
makePrefixedCommand mconf csets src pref msg =
let (pref', msg') =
case mconf >>= flip detectRef (pref:msg) of
Just (p:m) -> (p, m)
_ -> (pref, msg)
in if pref' `elem` map csetPrefix csets && not (null msg')
then
let (name, args) = mkCmd msg'
in Just $ BotCommand src (Just pref') name args
else Nothing
makePrefixedCommandFromSet :: Maybe Config
-> CommandSet e s
-> MessageSource
-> Char
-> String
-> Maybe Event
makePrefixedCommandFromSet mconf cset =
let names = concatMap cmdNames $ csetCommands cset
in makePrefixedCommandFromNames mconf (Left $ csetPrefix cset) names
makePrefixedCommandFromNames :: Maybe Config
-> Either Char (CommandSet e s)
-> [String]
-> MessageSource
-> Char
-> String
-> Maybe Event
makePrefixedCommandFromNames mconf eith names src pref msg =
let (pref', msg') =
case mconf >>= flip detectRef (pref:msg) of
Just (p:m) -> (p, m)
_ -> (pref, msg)
in if pref' == either id csetPrefix eith && not (null msg')
then
let (name, args) = mkCmd msg'
cset = either (const Nothing) Just eith
in if name `elem` expand names cset
then Just $ BotCommand src (Just pref') name args
else Nothing
else Nothing
makeRefCommand :: Config
-> MessageSource
-> (String -> String)
-> String
-> Maybe Event
makeRefCommand conf src f msg =
case detectRef conf msg of
Just s ->
let (name, args) = mkCmd $ f s
in Just $ BotCommand src Nothing name args
Nothing -> Nothing
makeRefCommandFromSet :: Config
-> CommandSet e s
-> MessageSource
-> (String -> String)
-> String
-> Maybe Event
makeRefCommandFromSet conf cset =
let names = concatMap cmdNames $ csetCommands cset
in makeRefCommandFromNames conf Nothing names
makeRefCommandFromNames :: Config
-> Maybe (CommandSet e s)
-> [String]
-> MessageSource
-> (String -> String)
-> String
-> Maybe Event
makeRefCommandFromNames conf cset names src f msg =
case detectRef conf msg of
Just s ->
let (name, args) = mkCmd $ f s
in if name `elem` expand names cset
then Just $ BotCommand src Nothing name args
else Nothing
Nothing -> Nothing
makePlainCommand :: MessageSource
-> String
-> Maybe Event
makePlainCommand src msg =
let (name, args) = mkCmd msg
in Just $ BotCommand src Nothing name args
makeRefC :: Config -> String -> String -> String -> Maybe Event
makeRefC conf chan nick msg =
case detectRef conf msg of
Just s -> Just $ BotMessage chan nick s msg
Nothing -> Nothing
makeRefP :: Config -> String -> String -> Maybe Event
makeRefP conf nick msg =
case detectRef conf msg of
Just s -> Just $ PersonalMessage nick s
Nothing -> Nothing
ifPriv :: EventMatchSpace -> Maybe Event -> Maybe Event
ifPriv MatchInChannel _ = Nothing
ifPriv _ e = e
ifChan :: EventMatchSpace -> Maybe Event -> Maybe Event
ifChan MatchInPrivate _ = Nothing
ifChan _ e = e
matchPrefixedCommand :: EventMatchSpace
-> Bool
-> EventMatcher e s
matchPrefixedCommand space ref event conf csets =
case event of
C.ChannelMessage chan nick (c:cs) False ->
ifChan space $
makePrefixedCommand mconf csets (Channel chan nick) c cs
C.PrivateMessage nick (c:cs) False ->
ifPriv space $
makePrefixedCommand mconf csets (User nick) c cs
_ -> Nothing
where
mconf = if ref then Just conf else Nothing
matchPrefixedCommandFromSet :: EventMatchSpace
-> Bool
-> Maybe (CommandSet e s)
-> EventMatcher e s
matchPrefixedCommandFromSet space ref mcset event conf csets =
case maybe (listToMaybe csets) Just mcset of
Nothing -> Nothing
Just cset ->
case event of
C.ChannelMessage chan nick (c:cs) False ->
ifChan space $
makePrefixedCommandFromSet
mconf cset (Channel chan nick) c cs
C.PrivateMessage nick (c:cs) False ->
ifPriv space $
makePrefixedCommandFromSet
mconf cset (User nick) c cs
_ -> Nothing
where
mconf = if ref then Just conf else Nothing
matchPrefixedCommandFromNames :: EventMatchSpace
-> Bool
-> Either Char (CommandSet e s)
-> [String]
-> EventMatcher e s
matchPrefixedCommandFromNames space ref eith names event conf csets =
case event of
C.ChannelMessage chan nick (c:cs) False ->
ifChan space $
makePrefixedCommandFromNames
mconf eith names (Channel chan nick) c cs
C.PrivateMessage nick (c:cs) False ->
ifPriv space $
makePrefixedCommandFromNames
mconf eith names (User nick) c cs
_ -> Nothing
where
mconf = if ref then Just conf else Nothing
matchRefCommand :: EventMatchSpace -> (String -> String) -> EventMatcher e s
matchRefCommand space f event conf _csets =
case event of
C.ChannelMessage chan nick msg False ->
ifChan space $ makeRefCommand conf (Channel chan nick) f msg
C.PrivateMessage nick msg False ->
ifPriv space $ makeRefCommand conf (User nick) f msg
_ -> Nothing
matchRefCommandFromSet :: EventMatchSpace
-> (String -> String)
-> EventMatcher e s
matchRefCommandFromSet _ _ _ _ [] = Nothing
matchRefCommandFromSet space f event conf (cset:_) =
case event of
C.ChannelMessage chan nick msg False -> ifChan space $
makeRefCommandFromSet conf cset (Channel chan nick) f msg
C.PrivateMessage nick msg False -> ifPriv space $
makeRefCommandFromSet conf cset (User nick) f msg
_ -> Nothing
matchRefCommandFromNames :: EventMatchSpace
-> (String -> String)
-> Bool
-> [String]
-> EventMatcher e s
matchRefCommandFromNames space f ex names event conf csets =
case event of
C.ChannelMessage chan nick msg False -> ifChan space $
makeRefCommandFromNames conf cset names (Channel chan nick) f msg
C.PrivateMessage nick msg False -> ifPriv space $
makeRefCommandFromNames conf cset names (User nick) f msg
_ -> Nothing
where
cset = if ex then listToMaybe csets else Nothing
matchPlainPrivateCommand :: EventMatcher e s
matchPlainPrivateCommand event _conf _csets =
case event of
C.PrivateMessage nick msg False ->
makePlainCommand (User nick) msg
_ -> Nothing
matchNotice :: EventMatchSpace -> EventMatcher e s
matchNotice space event _conf _csets =
case event of
C.ChannelMessage chan nick msg True ->
ifChan space $ Just $ Notice (Just chan) nick msg
C.PrivateMessage nick msg True ->
ifPriv space $ Just $ Notice Nothing nick msg
_ -> Nothing
matchRef :: EventMatchSpace -> EventMatcher e s
matchRef space event conf _csets =
case event of
C.ChannelMessage chan nick msg False ->
ifChan space $ makeRefC conf chan nick msg
C.PrivateMessage nick msg False ->
ifPriv space $ makeRefP conf nick msg
_ -> Nothing
defaultMatch :: EventMatcher e s
defaultMatch event conf csets =
case event of
C.Ping server1 server2 -> Just $ Ping server1 server2
C.Kick channel nicks reason -> Just $ Kick channel nicks reason
C.Join channel nick -> Just $ Join channel nick
C.Part channel nick reason -> Just $ Part channel nick reason
C.Quit nick reason -> Just $ Quit nick reason
C.ChannelMessage channel nick msg False ->
Just $ Message channel nick msg $ msg `mentions` bnick
C.ChannelAction channel nick msg ->
Just $ Action channel nick msg $ msg `mentions` bnick
C.PrivateMessage nick msg False -> Just $ PersonalMessage nick msg
C.PrivateAction nick msg -> Just $ PersonalAction nick msg
C.NickChange oldnick newnick -> Just $ NickChange oldnick newnick
C.Topic channel nick topic -> Just $ TopicChange channel nick topic
C.Names priv chan pnicks -> Just $ Names chan priv pnicks
_ -> Nothing
where
bnick = connNick (cfgConnection conf)
combineMatchers :: [EventMatcher e s] -> EventMatcher e s
combineMatchers [] _event _conf _csets = Nothing
combineMatchers (m:ms) event conf csets =
case m event conf csets of
ev@(Just _) -> ev
Nothing -> combineMatchers ms event conf csets
applyMatchers :: [EventMatcher e s]
-> C.Event
-> Config
-> [CommandSet e s]
-> Event
applyMatchers ms event conf csets =
fromMaybe (OtherEvent $ show event) $ combineMatchers ms event conf csets
matchEvent :: [EventMatcher e s]
-> C.Event
-> Config
-> [CommandSet e s]
-> Event
matchEvent = applyMatchers
findCommand :: Maybe Char
-> String
-> [CommandSet e s]
-> Maybe (Either (CommandSet e s) (Command e s))
findCommand (Just cpref) cname csets = findCmd cpref cname csets
findCommand Nothing _ [] = Nothing
findCommand Nothing cname (cset:_) =
Just $ maybe (Left cset) Right $ findCmdInSet cname cset
runCommand :: Maybe Char
-> String
-> [String]
-> Maybe String
-> String
-> Session e s ()
runCommand cpref cname cparams mchan sender = do
csets <- askBehaviorS commandSets
case findCommand cpref cname csets of
Nothing ->
case mchan of
Just chan -> defaultRespondToChan chan cpref cname Nothing
Nothing -> defaultRespondToUser sender cpref cname Nothing
Just (Left cset) ->
case mchan of
Just chan ->
defaultRespondToChan
chan (Just $ csetPrefix cset) cname (Just cset)
Nothing ->
defaultRespondToUser
sender (Just $ csetPrefix cset) cname (Just cset)
Just (Right cmd) ->
cmdRespond cmd mchan sender cparams (sendBack mchan sender)
handleBotEvent :: Event -> Session e s ()
handleBotEvent event = do
b <- askBehavior
case event of
Ping s1 s2 -> pong s1 s2
Kick chan users why -> return ()
Join chan user -> do
tracked <- channelIsTracked chan
when tracked $ addMember chan user
self <- askConfigS $ connNick . cfgConnection
when (user == self) $ addCurrChan chan
handleJoin b chan user
Part chan nick why -> do
tracked <- channelIsTracked chan
when tracked $ removeMemberOnce chan nick
handlePart b chan nick why
Quit nick why -> do
removeMember nick
handleQuit b nick why
Message chan sender msg mentioned ->
handleMsg b chan sender msg mentioned
Action chan sender msg mentioned ->
handleAction b chan sender msg mentioned
Notice mchan sender msg -> return ()
BotMessage chan sender msg full -> handleBotMsg b chan sender msg full
BotCommand (Channel chan sender) cpref cname cargs ->
runCommand cpref cname cargs (Just chan) sender
BotCommand (User sender) cpref cname cargs ->
runCommand cpref cname cargs Nothing sender
PersonalMessage sender msg -> handlePersonalMsg b sender msg
PersonalAction sender msg -> handlePersonalAction b sender msg
NickChange oldnick newnick -> do
changeNick oldnick newnick
handleNickChange b oldnick newnick
TopicChange chan nick topic -> handleTopicChange b chan nick topic
Names chan priv pnicks -> do
tracked <- channelIsTracked chan
let nicks = map snd pnicks
when tracked $ addChannel chan nicks
handleNames b chan priv pnicks
OtherEvent s -> return ()
detectLogEvents :: L.LogEvent -> Session e s [(Logger, ChanLogEvent)]
detectLogEvents e =
let detect event cstate = fmap (\ cl -> (cl, event)) $ csLogger cstate
detectOne chan event = do
cstates <- gets bsChannels
return $ maybeToList $ M.lookup chan cstates >>= detect event
detectMany nick event = do
chans <- presence nick
cstates <- gets bsChannels
let cstatesP =
cstates `M.difference` M.fromList (zip chans (repeat ()))
return $ catMaybes $ map (detect event) $ M.elems cstatesP
in case e of
L.Enter nick chan -> detectOne chan $ EnterChan nick
L.Leave nick chan -> detectOne chan $ LeaveChan nick
L.LeaveAll nick -> detectMany nick $ LeaveChan nick
L.Message nick chan msg -> detectOne chan $ MessageChan nick msg
L.Action nick chan msg -> detectOne chan $ ActInChan nick msg
L.Rename oldN newN -> detectMany oldN $ RenameInChan oldN newN
handleLogEvent :: L.LogEvent -> Session e s ()
handleLogEvent e = do
l <- detectLogEvents e
liftIO $ mapM_ (\ (logger, event) -> logEvent logger event) l
handleEvent :: Either L.LogEvent Event -> Session e s ()
handleEvent = either handleLogEvent handleBotEvent