Bot.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/>.
 -}

-- | This module allows you to define bot event handlers and commands, and then
-- just run event source and sink threads in your @main@ function and let them
-- handle all the details.
module Network.IRC.Fun.Bot
    ( defConfig
    , runBot
    )
where

import Control.Concurrent (threadDelay, forkIO)
import Control.Concurrent.Chan
import Control.Concurrent.MVar
import Control.Monad (liftM, forever, void, when)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Trans.RWS (ask)
import Data.List (transpose)
import Data.Maybe (fromMaybe, isJust, mapMaybe)
import Data.Time.Interval
import Data.Time.Units
import Network.IRC.Fun.Bot.Internal.Chat (sendIO)
import Network.IRC.Fun.Bot.Internal.Event
import Network.IRC.Fun.Bot.Internal.History
import Network.IRC.Fun.Bot.Internal.Logger
import Network.IRC.Fun.Bot.Internal.MsgCount
import Network.IRC.Fun.Bot.Internal.Types
import Network.IRC.Fun.Bot.Chat (login, joinConfig, run)
import Network.IRC.Fun.Bot.Types (Connection (..))
import Network.IRC.Fun.Client.ChannelLogger (fromClientEvent)
import Network.IRC.Fun.Client.Events (hGetIrcEvents, hGetIrcEvents')
import Network.IRC.Fun.Client.IO (hPutIrc)
import Network.IRC.Fun.Messages.Types (Message (PingMessage))
import System.Clock
import System.IO.Error (tryIOError)

import qualified Network.IRC.Fun.Client.Events as C (Event (Pong))

-- | A default bot configuration. You can use it with record syntax to override
-- just the fields you need. It also allows your code to remain valid when a
-- new config option is added, since you won't be using the 'Config'
-- constructor directy.
--
-- In the future the constructor may be removed, and then this function will be
-- the only way to create a configuration. It allows adding a field without
-- incrementing the library's major version and breaking compatibility.
defConfig :: Config
defConfig = Config
    { cfgConnection = Connection
        { connServer   = "irc.freenode.net"
        , connPort     = 6667
        , connTls      = False -- not supported yet
        , connNick     = "bot_test_joe"
        , connPassword = Nothing
        }
    , cfgChannels        = ["#freepost-bot-test"]
    , cfgLogDir          = "state/chanlogs"
    , cfgStateRepo       = Nothing
    , cfgStateFile       = "state/state.json"
    , cfgSaveInterval    = time (3 :: Second)
    , cfgBotEventLogFile = "state/bot.log"
    , cfgIrcErrorLogFile = Nothing
    , cfgMaxMsgChars     = Nothing
    , cfgLagCheck        = Just $ time (1 :: Minute)
    , cfgLagMax          = time (5 :: Minute)
    , cfgMaxMsgCount     = 1000
    , cfgMsgDelay        = time (100 :: Millisecond)
    }

-- Get the bot ready for listening to IRC messages.
startBot :: Session e s ()
startBot = do
    liftIO $ putStrLn "Bot: Logging in as IRC user with nickname"
    login
    liftIO $ putStrLn "Bot: Joining IRC channels"
    joinConfig

-- Wait for an IRC event, then handle it according to bot behavior definition.
-- Return whether listening should continue.
listenToEvent :: Chan (Msg a)       -- Chan from which to read events
              -> EventHandler e s a -- Handler for external events
              -> Session e s Bool
listenToEvent q handler = do
    m <- liftIO $ readChan q
    case m of
        MsgLogEvent event -> do
            handleEvent $ Left event
            return True
        MsgHistoryEvent nick chan msg action -> do
            rememberMsg chan nick msg action
            return True
        MsgCountLogMsg chan -> do
            recordMsg chan
            return True
        MsgCountLogJoin nick chan -> do
            recordJoin nick chan
            return True
        MsgCountLogPart nick chan -> do
            recordPart nick chan
            return True
        MsgCountLogQuit nick -> do
            recordQuit nick
            return True
        MsgBotEvent event -> do
            handleEvent $ Right event
            return True
        MsgExtEvent event -> do
            handler event
            return True
        MsgQuit -> return False

-- Get time since epoch.
getNow :: IO TimeSpec
getNow = getTime Realtime

-- Collect IRC events from the server and push into a 'Chan' for the main
-- thread to handle.
listenToIrc :: [EventMatcher e s]
            -> BotEnv e s
            -> Chan (Msg a)
            -> MVar TimeSpec
            -> IO ()
listenToIrc ms bot chan pongvar = do
    logger <-
        newLogger
            (liftM snd $ beGetTime bot)
            (cfgBotEventLogFile $ beConfig bot)
    elogger <-
        case cfgIrcErrorLogFile $ beConfig bot of
            Just path -> fmap Just $ newLogger (liftM snd $ beGetTime bot) path
            Nothing ->   return Nothing
    putStrLn "Bot: IRC event source listening to IRC events"
    let match e = matchEvent ms e (beConfig bot) (commandSets $ beBehavior bot)
        getEvents =
            if isJust elogger
                then hGetIrcEvents'
                else \ h -> liftM (\ es -> ([], es)) $ hGetIrcEvents h
        loop = do
            r <- tryIOError $ getEvents $ beHandle bot
            case r of
                Left e -> do
                    putStrLn "Bot: IRC event listener hGetIrcEvents IO error"
                    print e
                    writeChan chan MsgQuit
                Right (errs, ircEvents) -> do
                    let botEvents = map match ircEvents
                        logEvents = mapMaybe fromClientEvent ircEvents
                        hisEvents = mapMaybe checkEvent ircEvents
                        cntEvents = mapMaybe countEvent ircEvents
                        interleaved = concat $ transpose
                            [ map MsgLogEvent logEvents
                            , hisEvents
                            , cntEvents
                            , map MsgBotEvent botEvents
                            ]
                        isPong (C.Pong _ _) = True
                        isPong _            = False
                    when (any isPong ircEvents) $ do
                        now <- getNow
                        void $ tryTakeMVar pongvar
                        putMVar pongvar now
                    mapM_ (logLine logger . show) botEvents
                    case elogger of
                        Nothing -> return ()
                        Just lg -> mapM_ (logLine lg) errs
                    writeList2Chan chan interleaved
                    loop
    loop

intervalToSpec :: TimeInterval -> TimeSpec
intervalToSpec ti =
    let t = microseconds ti
        (s, us) = t `divMod` (1000 * 1000)
    in  TimeSpec
            { sec  = fromInteger s
            , nsec = 1000 * fromInteger us
            }

-- Send pings periodically to the server, and track the latest PONGs received,
-- as reported by the receiver thread. If it has been long enough since the
-- last PONG, tell the main thread to shut down.
manageLag :: BotEnv e s
          -> Chan (Msg a)
          -> MVar TimeSpec
          -> IO ()
manageLag bot chan pongvar =
    case cfgLagCheck $ beConfig bot of
        Nothing -> return ()
        Just iv -> do
            putStrLn "Bot: IRC lag manager thread running"
            let maxdiff = intervalToSpec $ cfgLagMax $ beConfig bot
                loop prev = do
                    mpong <- tryTakeMVar pongvar
                    let pong = fromMaybe prev mpong
                    now <- getNow
                    if now - pong > maxdiff
                        then do
                            putStrLn "Bot: IRC max lag reached"
                            writeChan chan MsgQuit
                        else do
                            let serv =
                                    connServer $ cfgConnection $ beConfig bot
                            hPutIrc (beHandle bot) $ PingMessage serv Nothing
                            threadDelay $ fromInteger $ microseconds iv
                            loop pong
            loop =<< getNow

-- Wait for requests to send IRC messages, and send them while maintaining a
-- delay to avoid flood.
sendMessages :: BotEnv e s -> IO ()
sendMessages bot = do
    putStrLn "Bot: IRC message sending scheduler thread running"
    let q = beMsgQueue bot
        h = beHandle bot
        delay = fromInteger $ microseconds $ cfgMsgDelay $ beConfig bot
    forever $ do
        msg <- readChan q
        sendIO h msg
        threadDelay delay

-- Connect, login, join. Then listen to events and handle them, forever.
botSession :: [EventMatcher e s]
           -> [EventSource e s a]
           -> EventHandler e s a
           -> Session e s ()
           -> Session e s ()
botSession matchers sources handler actInit = do
    actInit
    chan <- liftIO newChan
    bot <- ask
    pongvar <- liftIO newEmptyMVar
    liftIO $ void $ forkIO $ sendMessages bot
    liftIO $ void $ forkIO $ listenToIrc matchers bot chan pongvar
    liftIO $ void $ forkIO $ manageLag bot chan pongvar
    let launch s = forkIO $ s (beConfig bot)
                              (beCustom bot)
                              (writeChan chan . MsgExtEvent)
                              (writeList2Chan chan . map MsgExtEvent)
                              (newLogger $ liftM snd $ beGetTime bot)
    liftIO $ mapM_ launch sources
    startBot
    liftIO $ putStrLn "Bot: Event sink listening to events"
    let loop = do
            proceed <- listenToEvent chan handler
            if proceed
                then loop
                else liftIO $ putStrLn "Bot: Event sink asked to stop"
    loop

-- | Start the bot and run its event loop. The bot will listen to messages from
-- the IRC server and other provided sources, and will respond according to the
-- behavior definitions.
runBot :: Config              -- ^ IRC connection configuration
       -> [EventMatcher e s]  -- ^ Event detection (high-to-low priority)
       -> Behavior e s        -- ^ Behavior definition for IRC events
       -> [EventSource e s a] -- ^ Additional event source threads to run
       -> EventHandler e s a  -- ^ Handler for events coming from those sources
       -> e                   -- ^ Custom bot environment (read-only state)
       -> s                   -- ^ Initial state to hold in the background
       -> Session e s ()      -- ^ Initialization action to run at the very
                              --   beginning of the session
       -> IO ()
runBot conf matchers behav sources handler env state actInit = do
    putStrLn "Bot: Starting"
    run conf behav env state $ botSession matchers sources handler actInit
    putStrLn "Bot: Disconnected"