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, void, when)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Trans.RWS (ask)
import Data.List (transpose)
import Data.Maybe (catMaybes, fromMaybe)
import Data.Time.Interval
import Data.Time.Units
import Network.IRC.Fun.Bot.Internal.Event
import Network.IRC.Fun.Bot.Internal.Logger
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)
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))
defConfig :: Config
defConfig = Config
{ connection = Connection
{ server = "irc.freenode.net"
, port = 6667
, tls = False
, nick = "bot_test_joe"
, password = Nothing
}
, channels = ["#freepost-bot-test"]
, logDir = "state/chanlogs"
, stateRepo = Nothing
, stateFile = "state/state.json"
, saveInterval = time (3 :: Second)
, botEventLogFile = "state/bot.log"
, maxMsgChars = Nothing
, lagCheck = Just $ time (1 :: Minute)
, lagMax = time (5 :: Minute)
}
startBot :: Session e s ()
startBot = do
liftIO $ putStrLn "Bot: Logging in as IRC user with nickname"
login
liftIO $ putStrLn "Bot: Joining IRC channels"
joinConfig
listenToEvent :: Chan (Msg a)
-> EventHandler e s a
-> Session e s Bool
listenToEvent chan handler = do
msg <- liftIO $ readChan chan
case msg of
MsgLogEvent event -> handleEvent (Left event) >> return True
MsgBotEvent event -> handleEvent (Right event) >> return True
MsgExtEvent event -> handler event >> return True
MsgQuit -> return False
getNow :: IO TimeSpec
getNow = getTime Realtime
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) (botEventLogFile $ beConfig bot)
putStrLn "Bot: IRC event source listening to IRC events"
let match e = matchEvent ms e (beConfig bot) (commandSets $ beBehavior bot)
loop = do
r <- tryIOError $ hGetIrcEvents $ beHandle bot
case r of
Left e -> do
putStrLn "Bot: IRC event listener hGetIrcEvents IO error"
print e
writeChan chan MsgQuit
Right ircEvents -> do
let botEvents = map match ircEvents
logEvents = catMaybes $ map fromClientEvent ircEvents
interleave logs bots = concat $ transpose
[map MsgLogEvent logs, map MsgBotEvent bots]
isPong (C.Pong _ _) = True
isPong _ = False
when (any isPong ircEvents) $ do
now <- getNow
void $ tryTakeMVar pongvar
putMVar pongvar now
mapM_ (logLine logger . show) botEvents
writeList2Chan chan $ interleave logEvents botEvents
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
}
manageLag :: BotEnv e s
-> Chan (Msg a)
-> MVar TimeSpec
-> IO ()
manageLag bot chan pongvar =
case lagCheck $ beConfig bot of
Nothing -> return ()
Just iv -> do
putStrLn "Bot: IRC lag manager thread running"
let maxdiff = intervalToSpec $ lagMax $ 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 = server $ connection $ beConfig bot
hPutIrc (beHandle bot) $ PingMessage serv Nothing
threadDelay $ fromInteger $ microseconds iv
loop pong
loop =<< getNow
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 $ 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
runBot :: Config
-> [EventMatcher e s]
-> Behavior e s
-> [EventSource e s a]
-> EventHandler e s a
-> e
-> s
-> Session e s ()
-> 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"