2014-06-06 19:58:53 +05:30
|
|
|
{-|
|
|
|
|
Module : Network.IRC.Client
|
2014-10-13 11:21:08 +05:30
|
|
|
Description : The IRC bot client used to create and run a bot.
|
2014-06-06 19:58:53 +05:30
|
|
|
Copyright : (c) Abhinav Sarkar, 2014
|
|
|
|
License : Apache-2.0
|
|
|
|
Maintainer : abhinav@abhinavsarkar.net
|
|
|
|
Stability : experimental
|
|
|
|
Portability : POSIX
|
|
|
|
-}
|
|
|
|
|
2014-05-22 01:08:36 +05:30
|
|
|
{-# LANGUAGE TemplateHaskell #-}
|
2014-05-04 04:28:08 +05:30
|
|
|
|
2014-05-21 12:17:00 +05:30
|
|
|
module Network.IRC.Client (runBot) where
|
2014-05-04 04:28:08 +05:30
|
|
|
|
2014-05-22 01:08:36 +05:30
|
|
|
import qualified System.Log.Logger as HSL
|
|
|
|
|
2014-05-11 14:01:09 +05:30
|
|
|
import ClassyPrelude
|
2014-10-04 21:22:24 +05:30
|
|
|
import Control.Concurrent.Lifted (fork, threadDelay, myThreadId)
|
2014-06-01 23:14:19 +05:30
|
|
|
import Control.Exception.Lifted (throwTo, AsyncException (UserInterrupt))
|
2014-05-21 11:20:53 +05:30
|
|
|
import Network (PortID (PortNumber), connectTo, withSocketsDo)
|
2014-05-21 12:17:00 +05:30
|
|
|
import System.IO (hSetBuffering, BufferMode(..))
|
2014-06-01 23:14:19 +05:30
|
|
|
import System.Log.Formatter (tfLogFormatter)
|
|
|
|
import System.Log.Handler (setFormatter)
|
|
|
|
import System.Log.Handler.Simple (streamHandler)
|
|
|
|
import System.Log.Logger (Priority (..), updateGlobalLogger, rootLoggerName,
|
|
|
|
setHandlers, setLevel)
|
2014-05-22 01:08:36 +05:30
|
|
|
import System.Log.Logger.TH (deriveLoggers)
|
2014-06-01 23:14:19 +05:30
|
|
|
import System.Posix.Signals (installHandler, sigINT, sigTERM, Handler (Catch))
|
2014-05-04 04:28:08 +05:30
|
|
|
|
2014-06-06 19:58:53 +05:30
|
|
|
import Network.IRC.Bot
|
|
|
|
import Network.IRC.Internal.Types
|
2014-10-04 21:22:24 +05:30
|
|
|
import Network.IRC.MessageBus
|
2014-06-08 07:12:33 +05:30
|
|
|
import Network.IRC.Types
|
2014-10-04 21:22:24 +05:30
|
|
|
import Network.IRC.Handlers.Core
|
2014-05-21 12:17:00 +05:30
|
|
|
import Network.IRC.Util
|
2014-05-21 00:06:37 +05:30
|
|
|
|
2014-05-22 01:08:36 +05:30
|
|
|
$(deriveLoggers "HSL" [HSL.DEBUG, HSL.ERROR])
|
|
|
|
|
2014-10-04 21:22:24 +05:30
|
|
|
data ConnectionResource = ConnectionResource
|
2014-10-05 15:58:20 +05:30
|
|
|
{ bot :: !Bot
|
2015-06-26 10:45:02 +05:30
|
|
|
, botStatus :: !(MVar BotStatus) -- TODO: is this really needed
|
2014-10-05 15:58:20 +05:30
|
|
|
, inChannel :: !(MessageChannel In)
|
|
|
|
, mainMsgChannel :: !(MessageChannel Message)
|
|
|
|
, handlerMsgChannels :: !(Map MsgHandlerName (MessageChannel Message))
|
2014-10-04 21:22:24 +05:30
|
|
|
}
|
2014-06-01 23:14:19 +05:30
|
|
|
|
2014-10-04 21:22:24 +05:30
|
|
|
connect :: BotConfig -> IO ConnectionResource
|
2014-05-11 16:29:22 +05:30
|
|
|
connect botConfig@BotConfig { .. } = do
|
2014-05-22 01:08:36 +05:30
|
|
|
debugM "Connecting ..."
|
2014-05-11 16:29:22 +05:30
|
|
|
socket <- connectToWithRetry
|
|
|
|
hSetBuffering socket LineBuffering
|
2014-05-22 01:08:36 +05:30
|
|
|
debugM "Connected"
|
2014-05-13 03:02:52 +05:30
|
|
|
|
2014-10-04 21:22:24 +05:30
|
|
|
messageBus <- newMessageBus
|
|
|
|
inBus <- newMessageBus
|
|
|
|
mvBotStatus <- newMVar Connected
|
|
|
|
|
|
|
|
inChannel <- newMessageChannel inBus
|
|
|
|
mainMsgChannel <- newMessageChannel messageBus
|
|
|
|
|
|
|
|
msgHandlersChans <- loadMsgHandlers messageBus
|
2015-06-26 10:45:02 +05:30
|
|
|
msgHandlerInfo' <- flip (`foldM` mempty) (mapToList msgHandlersChans)
|
|
|
|
$ \handlerInfo (handlerName, (handler, _)) -> do
|
|
|
|
handlerHelp <- getHelp handler botConfig
|
|
|
|
return $ insertMap handlerName handlerHelp handlerInfo
|
2014-10-04 21:22:24 +05:30
|
|
|
|
2015-06-29 21:14:14 +05:30
|
|
|
let botConfig' = botConfig { msgHandlerInfo = msgHandlerInfo' }
|
2014-10-05 15:58:20 +05:30
|
|
|
let msgHandlerChannels = map snd msgHandlersChans
|
2014-10-04 21:22:24 +05:30
|
|
|
let msgHandlers = map fst msgHandlersChans
|
|
|
|
|
2015-06-29 21:14:14 +05:30
|
|
|
return ConnectionResource { bot = Bot botConfig' socket msgHandlers
|
2015-06-26 10:45:02 +05:30
|
|
|
, botStatus = mvBotStatus
|
|
|
|
, inChannel = inChannel
|
|
|
|
, mainMsgChannel = mainMsgChannel
|
|
|
|
, handlerMsgChannels = msgHandlerChannels
|
|
|
|
}
|
2014-05-11 16:29:22 +05:30
|
|
|
where
|
2014-10-04 21:22:24 +05:30
|
|
|
connectToWithRetry = connectTo (unpack botServer) (PortNumber (fromIntegral botPort))
|
2015-06-26 10:45:02 +05:30
|
|
|
`catch` (\(e :: SomeException) -> do
|
|
|
|
errorM ("Error while connecting: " ++ show e ++ ". Retrying.")
|
|
|
|
threadDelay (5 * oneSec)
|
|
|
|
connectToWithRetry)
|
2014-05-11 14:01:09 +05:30
|
|
|
|
2015-06-29 21:14:14 +05:30
|
|
|
mkMsgHandler name messageBus = case lookup name msgHandlerMakers of
|
|
|
|
Nothing -> return Nothing
|
|
|
|
Just maker -> do
|
|
|
|
messageChannel <- newMessageChannel messageBus
|
|
|
|
handler <- msgHandlerMaker maker botConfig messageChannel
|
|
|
|
return $ Just (handler, messageChannel)
|
2014-05-21 00:06:37 +05:30
|
|
|
|
2014-10-04 21:22:24 +05:30
|
|
|
loadMsgHandlers messageBus =
|
2014-05-22 20:59:02 +05:30
|
|
|
flip (`foldM` mempty) (mapKeys msgHandlerInfo) $ \hMap msgHandlerName -> do
|
|
|
|
debugM . unpack $ "Loading msg handler: " ++ msgHandlerName
|
2014-10-04 21:22:24 +05:30
|
|
|
mMsgHandler <- mkMsgHandler msgHandlerName messageBus
|
2014-05-22 20:59:02 +05:30
|
|
|
case mMsgHandler of
|
2014-10-04 21:22:24 +05:30
|
|
|
Nothing -> do
|
2014-05-22 20:59:02 +05:30
|
|
|
debugM . unpack $ "No msg handler found with name: " ++ msgHandlerName
|
|
|
|
return hMap
|
2014-10-04 21:22:24 +05:30
|
|
|
Just msgHandlerAndChannel -> return $ insertMap msgHandlerName msgHandlerAndChannel hMap
|
2014-05-21 00:38:01 +05:30
|
|
|
|
2014-10-04 21:22:24 +05:30
|
|
|
disconnect :: ConnectionResource -> IO ()
|
|
|
|
disconnect ConnectionResource { bot = Bot { .. }, .. } = do
|
2014-05-22 01:08:36 +05:30
|
|
|
debugM "Disconnecting ..."
|
2014-10-05 14:48:47 +05:30
|
|
|
sendMessage mainMsgChannel =<< newMessage QuitCmd
|
|
|
|
awaitMessageChannel mainMsgChannel
|
2014-10-04 21:22:24 +05:30
|
|
|
|
|
|
|
swapMVar botStatus Disconnected
|
|
|
|
awaitMessageChannel inChannel
|
|
|
|
|
|
|
|
forM_ handlerMsgChannels awaitMessageChannel
|
2014-06-06 19:58:53 +05:30
|
|
|
handle (\(_ :: SomeException) -> return ()) $ hClose botSocket
|
2014-05-22 01:08:36 +05:30
|
|
|
debugM "Disconnected"
|
2014-05-04 04:28:08 +05:30
|
|
|
|
2014-06-01 23:14:19 +05:30
|
|
|
runBotIntenal :: BotConfig -> IO ()
|
|
|
|
runBotIntenal botConfig' = withSocketsDo $ do
|
|
|
|
status <- run
|
2014-05-04 07:03:23 +05:30
|
|
|
case status of
|
2015-06-29 21:14:14 +05:30
|
|
|
Disconnected -> debugM "Restarting .." >> runBotIntenal botConfigWithCoreHandlers
|
|
|
|
Errored -> debugM "Restarting .." >> runBotIntenal botConfigWithCoreHandlers
|
2015-06-21 15:14:32 +05:30
|
|
|
NickNotAvailable -> debugM "Trying new nick" >> runBotIntenal botConfigWithNewNick
|
|
|
|
NickAvailable -> debugM "Trying original nick" >> runBotIntenal botConfigWithOrigNick
|
2014-05-20 00:05:06 +05:30
|
|
|
Interrupted -> return ()
|
|
|
|
_ -> error "Unsupported status"
|
2014-05-04 07:03:23 +05:30
|
|
|
where
|
2015-06-29 21:14:14 +05:30
|
|
|
botConfigWithCoreHandlers = botConfig' {
|
2014-05-22 20:59:02 +05:30
|
|
|
msgHandlerInfo =
|
2015-06-26 10:45:02 +05:30
|
|
|
foldl' (flip (`insertMap` mempty)) mempty
|
2014-10-05 13:12:49 +05:30
|
|
|
(hashNub $ mapKeys (msgHandlerInfo botConfig') ++ mapKeys coreMsgHandlerMakers)
|
|
|
|
, msgHandlerMakers = coreMsgHandlerMakers <> msgHandlerMakers botConfig'
|
|
|
|
}
|
|
|
|
|
2015-06-29 21:14:14 +05:30
|
|
|
botConfigWithNewNick = botConfigWithCoreHandlers {
|
|
|
|
botNick = Nick $ nickToText (botNick botConfigWithCoreHandlers) ++ "_"
|
2014-05-22 20:59:02 +05:30
|
|
|
}
|
2014-05-13 03:02:52 +05:30
|
|
|
|
2015-06-29 21:14:14 +05:30
|
|
|
botConfigWithOrigNick = botConfigWithCoreHandlers {
|
|
|
|
botNick = botOrigNick botConfigWithCoreHandlers
|
2015-06-21 15:14:32 +05:30
|
|
|
}
|
|
|
|
|
2014-05-13 03:02:52 +05:30
|
|
|
handleErrors :: SomeException -> IO BotStatus
|
2014-05-15 12:02:31 +05:30
|
|
|
handleErrors e = case fromException e of
|
2014-05-22 01:08:36 +05:30
|
|
|
Just UserInterrupt -> debugM "User interrupt" >> return Interrupted
|
|
|
|
_ -> debugM ("Exception! " ++ show e) >> return Errored
|
2014-05-13 03:02:52 +05:30
|
|
|
|
2015-06-26 10:45:02 +05:30
|
|
|
-- TODO: handle handler errors?
|
2014-10-05 15:58:20 +05:30
|
|
|
runHandler :: BotConfig -> (MsgHandlerName, (MsgHandler, MessageChannel Message)) -> IO ()
|
2015-06-26 10:45:02 +05:30
|
|
|
runHandler botConfig (msgHandlerName, (handler, msgChannel)) = go =<< receiveMessage msgChannel
|
2014-10-04 21:22:24 +05:30
|
|
|
where
|
|
|
|
go msg@Message { .. }
|
|
|
|
| Just QuitCmd <- fromMessage message = do
|
|
|
|
debugM . unpack $ "Stopping msg handler: " ++ msgHandlerName
|
|
|
|
stopMsgHandler handler botConfig
|
|
|
|
closeMessageChannel msgChannel
|
|
|
|
| otherwise = do
|
|
|
|
resps <- handleMessage handler botConfig msg
|
|
|
|
forM_ resps $ sendMessage msgChannel
|
2014-10-05 15:58:20 +05:30
|
|
|
runHandler botConfig (msgHandlerName, (handler, msgChannel))
|
2014-10-04 21:22:24 +05:30
|
|
|
|
2015-06-29 21:14:14 +05:30
|
|
|
run = bracket (connect botConfigWithCoreHandlers) disconnect $ \ConnectionResource { .. } ->
|
|
|
|
handle handleErrors $ do
|
|
|
|
let Bot { .. } = bot
|
|
|
|
debugM $ "Running with config:\n" ++ show botConfig
|
2014-06-01 23:14:19 +05:30
|
|
|
|
2015-06-29 21:14:14 +05:30
|
|
|
sendMessage mainMsgChannel =<< newMessage NickCmd
|
|
|
|
sendMessage mainMsgChannel =<< newMessage UserCmd
|
2014-05-13 03:02:52 +05:30
|
|
|
|
2015-06-29 21:14:14 +05:30
|
|
|
fork $ sendCommandLoop mainMsgChannel bot
|
|
|
|
`catch` (\(e :: SomeException) -> errorM $ "Error in sendCommandLoop: " ++ show e)
|
|
|
|
fork $ readMessageLoop botStatus inChannel bot oneSec
|
|
|
|
`catch` (\(e :: SomeException) -> errorM $ "Error in readMessageLoop: " ++ show e)
|
|
|
|
forM_ (mapToList . asMap $ mergeMaps msgHandlers handlerMsgChannels) $
|
|
|
|
void . fork . runHandler botConfig
|
|
|
|
runIRC bot Connected $ messageProcessLoop inChannel mainMsgChannel
|
2014-06-01 23:14:19 +05:30
|
|
|
|
2014-06-06 19:58:53 +05:30
|
|
|
-- | Creates and runs an IRC bot for given the config. This IO action runs forever.
|
|
|
|
runBot :: BotConfig -- ^ The bot config used to create the bot.
|
|
|
|
-> IO ()
|
2014-06-01 23:14:19 +05:30
|
|
|
runBot botConfig = do
|
|
|
|
-- setup signal handling
|
2015-06-29 21:14:14 +05:30
|
|
|
mainThreadId <- myThreadId
|
2015-06-26 10:45:02 +05:30
|
|
|
let interruptMainThread = throwTo mainThreadId UserInterrupt
|
|
|
|
installHandler sigINT (Catch interruptMainThread) Nothing
|
|
|
|
installHandler sigTERM (Catch interruptMainThread) Nothing
|
2014-06-01 23:14:19 +05:30
|
|
|
|
|
|
|
-- setup logging
|
|
|
|
hSetBuffering stdout LineBuffering
|
|
|
|
hSetBuffering stderr LineBuffering
|
2015-06-26 10:45:02 +05:30
|
|
|
stderrHandler <- streamHandler stderr DEBUG >>= \logHandler ->
|
|
|
|
return . setFormatter logHandler $
|
|
|
|
tfLogFormatter "%F %T" "[$utcTime] $loggername $prio $msg"
|
2014-06-01 23:14:19 +05:30
|
|
|
updateGlobalLogger rootLoggerName (setHandlers [stderrHandler] . setLevel DEBUG)
|
|
|
|
|
|
|
|
-- run
|
|
|
|
runBotIntenal botConfig
|