{- This file is part of irc-fun-bot. - - Written in 2015 by fr33domlover . - - ♡ Copying is an act of love. Please copy, reuse and share. - - The author(s) have dedicated all copyright and related and neighboring - rights to this software to the public domain worldwide. This software is - distributed without any warranty. - - You should have received a copy of the CC0 Public Domain Dedication along - with this software. If not, see - . -} 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 (nick) 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 (..)) ------------------------------------------------------------------------------- -- Modifiers ------------------------------------------------------------------------------- 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 ------------------------------------------------------------------------------- -- Make Events ------------------------------------------------------------------------------- detectRef :: Config -> String -> Maybe String detectRef conf msg = let bnick = nick (connection 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 ------------------------------------------------------------------------------- -- Match Events ------------------------------------------------------------------------------- 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 = nick (connection 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 -- Run the command with the given prefix character, command name and list of -- parameters. If a command with the given prefix and name isn't found, the bot -- sends a default friendly response. runCommand :: Maybe Char -- Command prefix, 'Nothing' picks the default prefix -> String -- Command name -> [String] -- List of parameters -> Maybe String -- Channel in which the command was triggered -> String -- Nickname of user who triggered the command -> 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) -- React to a bot event. 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 $ nick . connection 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 () -- Using nick tracking and logging state, determine from a general log event a -- set of channel loggers and channel-specific log events to write into them. detectLogEvents :: L.LogEvent -> Session e s [(Logger, ChanLogEvent)] detectLogEvents e = let detect event cstate = fmap (\ cl -> (cl, event)) $ chanLogger 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 -- Possibly write a log event into the right file(s), according to logging -- settings. handleLogEvent :: L.LogEvent -> Session e s () handleLogEvent e = do l <- detectLogEvents e liftIO $ mapM_ (\ (logger, event) -> logEvent logger event) l -- | Handle a bot event, or log a log event into a file. handleEvent :: Either L.LogEvent Event -> Session e s () handleEvent = either handleLogEvent handleBotEvent