Event.hs

{- This file is part of irc-fun-bot.
 -
 - Written in 2015 by fr33domlover <fr33domlover@rel4tion.org>.
 -
 - ♡ 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
 - <http://creativecommons.org/publicdomain/zero/1.0/>.
 -}

{-# LANGUAGE OverloadedStrings #-}

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 Data.Char (isSpace)
import Data.Maybe
import Data.List (find)
import Data.Text (Text)
import Network.IRC.Fun.Bot.Internal.Chat (pong, sendBack)
import Network.IRC.Fun.Bot.Internal.Failure
import Network.IRC.Fun.Bot.Internal.Monad (gets)
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 (connNickname)
import Network.IRC.Fun.Client.Util (mentions)
import Network.IRC.Fun.Types hiding (Command)

import qualified Data.CaseInsensitive as CI
import qualified Data.HashMap.Lazy as M
import qualified Data.Text as T
import qualified Network.IRC.Fun.Client.ChannelLogger as L
import qualified Network.IRC.Fun.Client.Events as C (Event (..))

-------------------------------------------------------------------------------
-- Modifiers
-------------------------------------------------------------------------------

modId :: Text -> Text
modId = id

modPrefix :: Text -> Bool -> Text -> Text
modPrefix p d s =
    case T.stripPrefix p s of
        Just s' -> if d then T.stripStart s' else s'
        Nothing -> s

modPrefixes :: [Text] -> Bool -> Text -> Text
modPrefixes ps d s =
    case listToMaybe $ mapMaybe (flip T.stripPrefix s) ps of
        Just s' -> if d then T.stripStart s' else s'
        Nothing -> s

stripPrefixCI :: Text -> Text -> Maybe Text
stripPrefixCI pref t =
    let len = T.length pref
        (p, r) = T.splitAt len t
    in  if T.toCaseFold p == T.toCaseFold pref
            then Just r
            else Nothing

modPrefixCI :: Text -> Bool -> Text -> Text
modPrefixCI p d s =
    case stripPrefixCI p s of
        Just s' -> if d then T.stripStart s' else s'
        Nothing -> s

modPrefixesCI :: [Text] -> Bool -> Text -> Text
modPrefixesCI ps d s =
    case listToMaybe $ mapMaybe (flip stripPrefixCI s) ps of
        Just s' -> if d then T.stripStart s' else s'
        Nothing -> s

modPleasePrefix :: Text -> Text
modPleasePrefix = modPrefixCI "please" True

modPleasePrefix' :: Text -> Text
modPleasePrefix' = modPrefixesCI ["please", "plz", "pls"] True

-------------------------------------------------------------------------------
-- Make Events
-------------------------------------------------------------------------------

detectRef :: Config -> MsgContent -> Maybe MsgContent
detectRef conf msg =
    let bnick = unNickname $ connNickname (cfgConnection conf)
        dw = Just . MsgContent . T.stripStart
    in  case T.stripPrefix bnick (unMsgContent msg) >>= T.uncons 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

mkCmd :: MsgContent -> (CommandName, [Text])
mkCmd message =
    let w = T.words $ unMsgContent message
        name = CommandName $ CI.mk $ if null w then T.empty else head w
        args = if null w then [] else tail w
    in  (name, args)

expand :: [CommandName] -> Maybe (CommandSet e s) -> [CommandName]
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
    -> MsgContent
    -> Maybe Event
makePrefixedCommand mconf csets src pref (MsgContent msg) =
    let (pref', msg') = fromMaybe (pref, msg) $ do
            conf <- mconf
            rest <- detectRef conf (MsgContent $ pref `T.cons` msg)
            T.uncons $ unMsgContent rest
    in  if pref' `elem` map csetPrefix csets && not (T.null msg')
            then
                let (name, args) = mkCmd $ MsgContent msg'
                in  Just $ BotCommand src (Just pref') name args
            else Nothing

makePrefixedCommandFromSet
    :: Maybe Config
    -> CommandSet e s
    -> MessageSource
    -> Char
    -> MsgContent
    -> 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)
    -> [CommandName]
    -> MessageSource
    -> Char
    -> MsgContent
    -> Maybe Event
makePrefixedCommandFromNames mconf eith names src pref (MsgContent msg) =
    let (pref', msg') = fromMaybe (pref, msg) $ do
            conf <- mconf
            rest <- detectRef conf $ MsgContent $ pref `T.cons` msg
            T.uncons $ unMsgContent rest
    in  if pref' == either id csetPrefix eith && not (T.null msg')
            then
                let (name, args) = mkCmd $ MsgContent 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
               -> (Text -> Text)
               -> MsgContent
               -> Maybe Event
makeRefCommand conf src f msg =
    case detectRef conf msg of
        Just (MsgContent s) ->
            let (name, args) = mkCmd $ MsgContent $ f s
            in  Just $ BotCommand src Nothing name args
        Nothing -> Nothing

makeRefCommandFromSet :: Config
                      -> CommandSet e s
                      -> MessageSource
                      -> (Text -> Text)
                      -> MsgContent
                      -> Maybe Event
makeRefCommandFromSet conf cset =
    let names = concatMap cmdNames $ csetCommands cset
    in  makeRefCommandFromNames conf Nothing names

makeRefCommandFromNames :: Config
                        -> Maybe (CommandSet e s)
                        -> [CommandName]
                        -> MessageSource
                        -> (Text -> Text)
                        -> MsgContent
                        -> Maybe Event
makeRefCommandFromNames conf cset names src f msg =
    case detectRef conf msg of
        Just (MsgContent s) ->
            let (name, args) = mkCmd $ MsgContent $ f s
            in  if name `elem` expand names cset
                    then Just $ BotCommand src Nothing name args
                    else Nothing
        Nothing -> Nothing

makePlainCommand :: MessageSource
                 -> MsgContent
                 -> Maybe Event
makePlainCommand src msg =
    let (name, args) = mkCmd msg
    in  Just $ BotCommand src Nothing name args

makeRefC :: Config -> Channel -> Nickname -> MsgContent -> Maybe Event
makeRefC conf chan nick msg =
    case detectRef conf msg of
        Just s  -> Just $ BotMessage chan nick s msg
        Nothing -> Nothing

makeRefP :: Config -> Nickname -> MsgContent -> 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

unconsMsg :: MsgContent -> Maybe (Char, MsgContent)
unconsMsg msg =
    case T.uncons $ unMsgContent msg of
        Nothing     -> Nothing
        Just (c, t) -> Just (c, MsgContent t)

matchPrefixedCommand
    :: EventMatchSpace
    -> Bool
    -> EventMatcher e s
matchPrefixedCommand space ref event conf csets =
    case event of
        C.ChannelMessage chan nick msg False -> ifChan space $ do
            (c, t) <- unconsMsg msg
            makePrefixedCommand mconf csets (SrcChannel chan nick) c t
        C.PrivateMessage nick msg False -> ifPriv space $ do
            (c, t) <- unconsMsg msg
            makePrefixedCommand mconf csets (SrcUser nick) c t
        _ -> 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 msg False -> ifChan space $ do
                    (c, t) <- unconsMsg msg
                    makePrefixedCommandFromSet
                        mconf cset (SrcChannel chan nick) c t
                C.PrivateMessage nick msg False -> ifPriv space $ do
                    (c, t) <- unconsMsg msg
                    makePrefixedCommandFromSet
                        mconf cset (SrcUser nick) c t
                _ -> Nothing
    where
    mconf = if ref then Just conf else Nothing

matchPrefixedCommandFromNames
    :: EventMatchSpace
    -> Bool
    -> Either Char (CommandSet e s)
    -> [CommandName]
    -> EventMatcher e s
matchPrefixedCommandFromNames space ref eith names event conf _csets =
    case event of
        C.ChannelMessage chan nick msg False -> ifChan space $ do
            (c, t) <- unconsMsg msg
            makePrefixedCommandFromNames
                mconf eith names (SrcChannel chan nick) c t
        C.PrivateMessage nick msg False -> ifPriv space $ do
            (c, t) <- unconsMsg msg
            makePrefixedCommandFromNames
                mconf eith names (SrcUser nick) c t
        _ -> Nothing
    where
    mconf = if ref then Just conf else Nothing

matchRefCommand :: EventMatchSpace -> (Text -> Text) -> EventMatcher e s
matchRefCommand space f event conf _csets =
    case event of
        C.ChannelMessage chan nick msg False ->
            ifChan space $ makeRefCommand conf (SrcChannel chan nick) f msg
        C.PrivateMessage nick msg False ->
            ifPriv space $ makeRefCommand conf (SrcUser nick) f msg
        _ -> Nothing

matchRefCommandFromSet
    :: EventMatchSpace
    -> (Text -> Text)
    -> 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 (SrcChannel chan nick) f msg
        C.PrivateMessage nick msg False -> ifPriv space $
            makeRefCommandFromSet conf cset (SrcUser nick) f msg
        _ -> Nothing

matchRefCommandFromNames
    :: EventMatchSpace
    -> (Text -> Text)
    -> Bool
    -> [CommandName]
    -> 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 (SrcChannel chan nick) f msg
        C.PrivateMessage nick msg False -> ifPriv space $
            makeRefCommandFromNames conf cset names (SrcUser 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 (SrcUser 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 = connNickname (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 $ T.pack $ show event) $
    combineMatchers ms event conf csets

matchEvent
    :: [EventMatcher e s]
    -> C.Event
    -> Config
    -> [CommandSet e s]
    -> Event
matchEvent = applyMatchers

findCommand
    :: Maybe Char
    -> CommandName
    -> [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
    -> CommandName   -- Command name
    -> [Text]        -- List of parameters
    -> Maybe Channel -- Channel in which the command was triggered
    -> Nickname      -- Nickname of user who triggered the command
    -> Session e s ()
runCommand cpref cname cparams mchan sender = do
    csets <- askBehaviorS commandSets
    chans <- getChans
    let defresp chan =
            fromMaybe True $ fmap csDefResponse $ M.lookup chan chans
    case findCommand cpref cname csets of
        Nothing          ->
            case mchan of
                Just chan ->
                    when (defresp chan) $
                    defaultRespondToChan chan cpref cname Nothing
                Nothing -> defaultRespondToUser sender cpref cname Nothing
        Just (Left cset) ->
            case mchan of
                Just chan ->
                    when (defresp 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 $ connNickname . 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 (SrcChannel chan sender) cpref cname cargs ->
            runCommand cpref cname cargs (Just chan) sender
        BotCommand (SrcUser 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 _t -> 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)) $ 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

-- 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