From 11c2c16835b3e8368be77ccc5b7ddf949021eccd Mon Sep 17 00:00:00 2001 From: Julien Dessaux Date: Sat, 3 Jul 2010 21:26:00 +0200 Subject: Moved files around as a preliminary for architectural changes. --- Hsbot/Irc/Core.hs | 177 ------------------------------------------------------ 1 file changed, 177 deletions(-) delete mode 100644 Hsbot/Irc/Core.hs (limited to 'Hsbot/Irc/Core.hs') diff --git a/Hsbot/Irc/Core.hs b/Hsbot/Irc/Core.hs deleted file mode 100644 index d65e975..0000000 --- a/Hsbot/Irc/Core.hs +++ /dev/null @@ -1,177 +0,0 @@ -module Hsbot.Irc.Core - ( startIrcbot - ) where - -import Control.Concurrent -import Control.Exception (AsyncException, Handler (..), IOException, catch, catches) -import Control.Monad.State -import qualified Data.Map as M -import Data.Maybe (fromMaybe) -import Network -import Prelude hiding (catch) -import System.IO -import System.Posix.IO (fdToHandle, handleToFd) -import System.Posix.Types (Fd) - -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.Types - --- | IrcBot's main entry point -startIrcbot :: IrcConfig -> Chan BotMsg -> Chan BotMsg -> Maybe String -> IO () -startIrcbot config masterChan myChan txtResumeData = do - let resumeData = case txtResumeData of - Just txtData -> read txtData :: ResumeData -- TODO : catch exception - Nothing -> M.empty :: ResumeData - print resumeData - putStrLn "[IrcBot] Opening communication channel... " - chan <- newChan :: IO (Chan IrcBotMsg) - handle <- case M.lookup "HANDLE" resumeData of - Just txtFd -> do - let fd = read txtFd :: Fd - fdToHandle fd - Nothing -> do - putStrLn $ concat ["[IrcBot] Connecting to ", ircConfigAddress config, "... "] - handle <- connectTo (ircConfigAddress config) (ircConfigPort config) - hSetBuffering handle NoBuffering - hSetEncoding handle utf8 - return handle - fd <- handleToFd handle - putStrLn "[IrcBot] Spawning reader threads..." - myOwnThreadId <- myThreadId - readerThreadId <- forkIO $ ircBotReader handle chan myOwnThreadId - masterReaderThreadId <- forkIO $ ircBotMasterReader myChan chan - putStrLn "[IrcBot] Initializing server connection..." - let ircServerState = IrcServerState { ircServerId = ircConfigAddress config - , ircServerChannels = [] - , ircServerNickname = ircConfigNickname config - , ircServerCommandPrefix = ircConfigCommandPrefix config - , ircServerChan = chan } - ircBotState = IrcBotState { ircBotPlugins = M.empty - , ircBotCommands = M.empty - , ircBotChan = chan - , ircBotMasterChan = masterChan - , ircBotServerState = ircServerState - , ircBotHandle = handle - , ircBotConfig = config - , ircBotResumeData = M.singleton "HANDLE" (show fd) } - ircBotState' <- execStateT (initBotServerConnection config) ircBotState - putStrLn "[IrcBot] Spawning plugins..." - ircBotState'' <- execStateT spawnIrcPlugins ircBotState' - putStrLn "[IrcBot] Entering Core loop... " - ircBotState''' <- (execStateT ircBotLoop ircBotState'') `catches` [ Handler (\ (_ :: IOException) -> return (ircBotState'')) - , Handler (\ (_ :: AsyncException) -> return (ircBotState'')) ] - putStrLn "[IrcBot] Killing reader threads..." - killThread readerThreadId - killThread masterReaderThreadId - putStrLn "[IrcBot] Killing active plugins... " - let resumeData' = ircBotResumeData ircBotState''' - ircPlugins = read (fromMaybe [] (M.lookup "PLUGINS" resumeData')) :: [String] - evalStateT (mapM_ killIrcPlugin ircPlugins) ircBotState''' - return () - ---resumeIrcBot ---resumeIrcBot - --- | 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' } - --- | Run the IrcBot's main loop -ircBotLoop :: IrcBot () -ircBotLoop = forever $ do - chan <- gets ircBotChan - msg <- liftIO $ readChan chan - case msg of - InIrcMsg inIrcMsg -> dispatchMessage $ InIrcMsg inIrcMsg - OutIrcMsg outIrcMsg -> sendThisMessage outIrcMsg - IntIrcCmd intIrcCmd -> do - reboot <- processInternalCommand $ IntIrcCmd intIrcCmd - reportUpdate - if reboot == BotReboot - then processRebootCommand - else return () - 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) . first) plugins' - else - mapM_ (sendToPlugin (InIrcMsg inIrcMsg) . first) (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 () - --- | Reports an update to the master bot -reportUpdate :: IrcBot () -reportUpdate = do - ircbot <- get - let masterChan = ircBotMasterChan ircbot - msg = UpdMsg $ ResMsg { resMsgFrom = ircConfigName $ ircBotConfig ircbot - , resMsgData = ircBotResumeData ircbot } - liftIO $ writeChan masterChan msg - --- | Process a reboot command -processRebootCommand :: IrcBot () -processRebootCommand = do - ircbot <- get - let masterChan = ircBotMasterChan ircbot - msg = IntMsg $ Msg { msgType = "REBOOT" - , msgFrom = ircConfigName $ ircBotConfig ircbot - , msgTo = "CORE" - , msgStuff = show $ ircBotResumeData ircbot - } - liftIO $ writeChan masterChan msg - -- cgit v1.2.3