diff options
Diffstat (limited to '')
| -rw-r--r-- | Hsbot/Irc/Core.hs | 142 |
1 files changed, 142 insertions, 0 deletions
diff --git a/Hsbot/Irc/Core.hs b/Hsbot/Irc/Core.hs new file mode 100644 index 0000000..ac51419 --- /dev/null +++ b/Hsbot/Irc/Core.hs @@ -0,0 +1,142 @@ +module Hsbot.Irc.Core + ( ircbot + ) where + +import Control.Concurrent +import Control.Exception (IOException, catch) +import Control.Monad.State +import qualified Data.Map as M +import Data.Maybe (fromMaybe) +import Data.Time +import Network +import Prelude hiding (catch) +import System.IO + +import Hsbot.Irc.Command +import Hsbot.Irc.Config +import Hsbot.Irc.Message +import Hsbot.Irc.Plugin +import Hsbot.Irc.Server +import Hsbot.Irc.Types +import Hsbot.Message (BotMsg) + +-- | IrcBot's main entry point +ircbot :: IrcConfig -> Chan BotMsg -> Chan BotMsg -> IO () +ircbot config masterChan myChan = do + startTime <- getCurrentTime + putStrLn "[IrcBot] Opening communication channel... " + chan <- newChan :: IO (Chan IrcBotMsg) + putStrLn $ concat ["[IrcBot] Connecting to ", ircConfigAddress config, "... "] + handle <- connectTo (ircConfigAddress config) (ircConfigPort config) + hSetBuffering handle NoBuffering + myOwnThreadId <- myThreadId + putStrLn "[IrcBot] Spawning reader threads..." + readerThreadId <- forkIO $ ircBotReader handle chan myOwnThreadId + masterReaderThreadId <- forkIO $ ircBotMasterReader masterChan chan + putStrLn "[IrcBot] Initializing server connection..." + let ircServerState = IrcServerState { ircServerId = ircConfigAddress config + , ircServerChannels = [] + , ircServerNickname = ircConfigNickname config + , ircServerCommandPrefix = ircConfigCommandPrefix config + , ircServerChan = chan } + ircBotState = IrcBotState { ircBotStartTime = startTime + , ircBotPlugins = M.empty + , ircBotCommands = M.empty + , ircBotChan = chan + , ircBotMasterChan = masterChan + , ircBotMyChan = myChan + , ircBotServerState = ircServerState + , ircBotHandle = handle + , ircBotConfig = config + , ircBotReaderThreadId = readerThreadId + , ircBotMasterReaderThreadId = masterReaderThreadId } + ircBotState' <- execStateT (initBotServerConnection config) ircBotState + putStrLn "[IrcBot] Entering main loop... " + _ <- ircBotLoop ircBotState' `catch` (\(_ :: IOException) -> return ()) + return () + +-- | Runs the IrcBot's reader loop +ircBotReader :: Handle -> Chan IrcBotMsg -> ThreadId -> IO () +ircBotReader handle chan fatherThreadId = forever $ do + str <- (hGetLine handle) `catch` handleIOException + let msg = parseIrcMsg str + case msg of + Right msg' -> writeChan chan (InIrcMsg msg') + _ -> return () + where + handleIOException :: IOException -> IO (String) + handleIOException ioException = do + throwTo fatherThreadId ioException + myId <- myThreadId + killThread myId + return "" + +-- | Reads the Master's chan +ircBotMasterReader :: Chan BotMsg -> Chan IrcBotMsg -> IO () +ircBotMasterReader masterChan _ = forever $ do + _ <- readChan masterChan + return () + -- TODO : handle botMsg + +-- | Initialize the bot's server connection +initBotServerConnection :: IrcConfig -> IrcBot () +initBotServerConnection config = do + ircBot <- get + let ircServerState = ircBotServerState ircBot + ircServerState' <- execStateT (initServerConnection config) ircServerState + put $ ircBot { ircBotServerState = ircServerState' } + +-- | IrcBot's loop that can catch ircbot's states' updates +ircBotLoop :: IrcBotState -> IO () +ircBotLoop ircBotState = do + putStrLn "[IrcBot] Spawning plugins..." + ircBotState' <- execStateT spawnIrcPlugins ircBotState + -- Todo : throw new ircbotstate to hsbot + putStrLn "[IrcBot] Entering Core loop... " + _ <- (execStateT ircBotCore ircBotState') -- `catch` (\(_ :: NewBotStateException) -> return ircBotState') + return () + -- TODO : loop! + +-- | Run the IrcBot's main loop +ircBotCore :: IrcBot () +ircBotCore = forever $ do + ircBot <- get + let chan = ircBotChan ircBot + msg <- liftIO $ readChan chan + case msg of + InIrcMsg inIrcMsg -> dispatchMessage $ InIrcMsg inIrcMsg + OutIrcMsg outIrcMsg -> sendThisMessage outIrcMsg + IntIrcCmd intIrcCmd -> do + processInternalCommand $ IntIrcCmd intIrcCmd + where + sendThisMessage :: IrcMsg -> IrcBot () + sendThisMessage outputMsg = do + let str = serializeIrcMsg outputMsg + handle <- gets ircBotHandle + liftIO $ hPutStr handle (str ++ "\r\n") + +-- | Dispatches an input message +dispatchMessage :: IrcBotMsg -> IrcBot () +dispatchMessage (InIrcMsg inIrcMsg) = do + config <- gets ircBotConfig + plugins <- gets ircBotPlugins + cmds <- gets ircBotCommands + if (isPluginCommand config) + then + let key = tail . head $ words getMsgContent + pluginNames = fromMaybe [] $ M.lookup key cmds + plugins' = fromMaybe [] $ mapM (flip M.lookup plugins) pluginNames + in mapM_ (sendRunCommand $ tail getMsgContent) plugins' + else + mapM_ (sendToPlugin $ InIrcMsg inIrcMsg) (M.elems plugins) + where + isPluginCommand :: IrcConfig -> Bool + isPluginCommand config = + and [ ircMsgCommand inIrcMsg == "PRIVMSG" + , (head getMsgContent) == ircConfigCommandPrefix config ] + sendRunCommand :: String -> IrcPluginState -> IrcBot () + sendRunCommand cmd plugin = sendToPlugin (IntIrcCmd $ IrcCmd "RUN" "CORE" (ircPluginName plugin) cmd inIrcMsg) plugin + getMsgContent :: String + getMsgContent = unwords . tail $ ircMsgParameters inIrcMsg +dispatchMessage _ = return () + |