diff options
Diffstat (limited to 'HsbotIrcBot/Hsbot/Irc')
| -rw-r--r-- | HsbotIrcBot/Hsbot/Irc/Command.hs | 11 | ||||
| -rw-r--r-- | HsbotIrcBot/Hsbot/Irc/Core.hs | 121 | ||||
| -rw-r--r-- | HsbotIrcBot/Hsbot/Irc/Message.hs | 2 | ||||
| -rw-r--r-- | HsbotIrcBot/Hsbot/Irc/Plugin.hs | 13 | ||||
| -rw-r--r-- | HsbotIrcBot/Hsbot/Irc/Types.hs | 10 |
5 files changed, 46 insertions, 111 deletions
diff --git a/HsbotIrcBot/Hsbot/Irc/Command.hs b/HsbotIrcBot/Hsbot/Irc/Command.hs index 51c2187..1b913e2 100644 --- a/HsbotIrcBot/Hsbot/Irc/Command.hs +++ b/HsbotIrcBot/Hsbot/Irc/Command.hs @@ -12,7 +12,6 @@ import Data.Maybe import Hsbot.Irc.Message import Hsbot.Irc.Plugin import Hsbot.Irc.Types -import Hsbot.Types -- | Registers a plugin's command registerCommand :: String -> String -> IrcBot () @@ -57,18 +56,8 @@ processCoreCommand ircCmd = do "REGISTER" -> registerCommand (ircCmdMsg ircCmd) (ircCmdFrom ircCmd) "UNLOAD" -> unloadIrcPlugin $ ircCmdMsg ircCmd "UNREGISTER" -> unregisterCommand (ircCmdMsg ircCmd) (ircCmdFrom ircCmd) - "UPDATE" -> processUpdateCommand ircCmd _ -> return () if command' == "REBOOT" then return BotReboot else return BotContinue --- | Process an update command -processUpdateCommand :: IrcCmd -> IrcBot () -processUpdateCommand ircCmd = do - ircbot <- get - let oldData = ircBotResumeData ircbot - from = ircCmdFrom ircCmd - stuff = ircCmdMsg ircCmd - put $ ircbot { ircBotResumeData = M.insert from stuff oldData } - diff --git a/HsbotIrcBot/Hsbot/Irc/Core.hs b/HsbotIrcBot/Hsbot/Irc/Core.hs index d65e975..525c3d6 100644 --- a/HsbotIrcBot/Hsbot/Irc/Core.hs +++ b/HsbotIrcBot/Hsbot/Irc/Core.hs @@ -10,72 +10,56 @@ 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.CLI 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... " +startIrcbot :: Options -> IrcConfig -> IO () +startIrcbot opts ircConfig = do + when (optDebug opts) $ 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..." + when (optDebug opts) . putStrLn $ concat ["[IrcBot] Connecting to ", ircConfigAddress ircConfig, "... "] + handle <- connectTo (ircConfigAddress ircConfig) (ircConfigPort ircConfig) + hSetBuffering handle NoBuffering + hSetEncoding handle utf8 + when (optDebug opts) $ putStrLn "[IrcBot] Spawning reader thread..." myOwnThreadId <- myThreadId readerThreadId <- forkIO $ ircBotReader handle chan myOwnThreadId - masterReaderThreadId <- forkIO $ ircBotMasterReader myChan chan - putStrLn "[IrcBot] Initializing server connection..." - let ircServerState = IrcServerState { ircServerId = ircConfigAddress config + when (optDebug opts) $ putStrLn "[IrcBot] Initializing server connection..." + let ircServerState = IrcServerState { ircServerId = ircConfigAddress ircConfig , ircServerChannels = [] - , ircServerNickname = ircConfigNickname config - , ircServerCommandPrefix = ircConfigCommandPrefix config + , ircServerNickname = ircConfigNickname ircConfig + , ircServerCommandPrefix = ircConfigCommandPrefix ircConfig , 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..." + , ircBotConfig = ircConfig } + ircBotState' <- execStateT (initBotServerConnection ircConfig) ircBotState + when (optDebug opts) $ 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..." + when (optDebug opts) $ putStrLn "[IrcBot] Entering Core loop... " + (_, ircBotState''') <- runLoop ircBotState'' + when (optDebug opts) $ putStrLn "[IrcBot] Killing reader thread..." 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 + when (optDebug opts) $ putStrLn "[IrcBot] Killing active plugins... " + evalStateT (mapM_ killIrcPlugin . M.keys $ ircBotPlugins ircBotState''') ircBotState''' + where + runLoop :: IrcBotState -> IO (BotStatus, IrcBotState) + runLoop botState = do + (status, botState') <- (runStateT ircBotCore botState) `catches` [ Handler (\ (_ :: IOException) -> return (BotExit, botState)) + , Handler (\ (_ :: AsyncException) -> return (BotExit, botState)) ] + case status of + BotContinue -> runLoop botState' + _ -> return (status, botState') -- | Runs the IrcBot's reader loop ircBotReader :: Handle -> Chan IrcBotMsg -> ThreadId -> IO () @@ -93,13 +77,6 @@ ircBotReader handle chan fatherThreadId = forever $ do 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 @@ -109,28 +86,24 @@ initBotServerConnection config = do put $ ircBot { ircBotServerState = ircServerState' } -- | Run the IrcBot's main loop -ircBotLoop :: IrcBot () -ircBotLoop = forever $ do +ircBotCore :: IrcBot (BotStatus) +ircBotCore = 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 () + IntIrcCmd intIrcCmd -> processInternalCommand $ IntIrcCmd intIrcCmd where - sendThisMessage :: IrcMsg -> IrcBot () + sendThisMessage :: IrcMsg -> IrcBot (BotStatus) sendThisMessage outputMsg = do let str = serializeIrcMsg outputMsg handle <- gets ircBotHandle liftIO $ hPutStr handle (str ++ "\r\n") + return BotContinue -- | Dispatches an input message -dispatchMessage :: IrcBotMsg -> IrcBot () +dispatchMessage :: IrcBotMsg -> IrcBot (BotStatus) dispatchMessage (InIrcMsg inIrcMsg) = do config <- gets ircBotConfig plugins <- gets ircBotPlugins @@ -143,6 +116,7 @@ dispatchMessage (InIrcMsg inIrcMsg) = do in mapM_ (sendRunCommand (tail getMsgContent) . first) plugins' else mapM_ (sendToPlugin (InIrcMsg inIrcMsg) . first) (M.elems plugins) + return BotContinue where isPluginCommand :: IrcConfig -> Bool isPluginCommand config = @@ -152,26 +126,5 @@ dispatchMessage (InIrcMsg inIrcMsg) = do 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 +dispatchMessage _ = return (BotContinue) diff --git a/HsbotIrcBot/Hsbot/Irc/Message.hs b/HsbotIrcBot/Hsbot/Irc/Message.hs index e92a9d0..8ab23d8 100644 --- a/HsbotIrcBot/Hsbot/Irc/Message.hs +++ b/HsbotIrcBot/Hsbot/Irc/Message.hs @@ -41,7 +41,7 @@ pMsg = do cmd <- pCommand params <- many (char ' ' >> (pLongParam <|> pShortParam)) _ <- char '\r' - --eof + eof return $ IrcMsg pfx cmd params pPrefix :: ParsecT String u Identity [Char] diff --git a/HsbotIrcBot/Hsbot/Irc/Plugin.hs b/HsbotIrcBot/Hsbot/Irc/Plugin.hs index 2c8e84b..40facbe 100644 --- a/HsbotIrcBot/Hsbot/Irc/Plugin.hs +++ b/HsbotIrcBot/Hsbot/Irc/Plugin.hs @@ -47,7 +47,6 @@ loadIrcPlugin pluginName = do "Quote" -> ircBotPluginQuote _ -> ircBotPluginDummy let oldPlugins = ircBotPlugins ircbot - oldResumeData = ircBotResumeData ircbot -- We check for unicity case M.lookup pluginName oldPlugins of Just _ -> return () @@ -58,9 +57,7 @@ loadIrcPlugin pluginName = do , ircPluginChan = pluginChan , ircPluginMasterChan = masterChan } newPlugins = M.insert pluginName (plugin, mvar, threadId) oldPlugins - newResumeData = M.insert "PLUGINS" (show $ M.keys newPlugins) oldResumeData - put $ ircbot { ircBotPlugins = newPlugins - , ircBotResumeData = newResumeData } + put $ ircbot { ircBotPlugins = newPlugins } -- | Sends a list of loaded plugins listPlugins :: IrcMsg -> String -> IrcBot () @@ -73,13 +70,7 @@ listPlugins originalRequest dest = do -- | Unloads a plugin unloadIrcPlugin :: String -> IrcBot () -unloadIrcPlugin name = do - killIrcPlugin name - ircbot <- get - let oldResumeData = ircBotResumeData ircbot - newPlugins = M.keys $ ircBotPlugins ircbot - newResumeData = M.insert "PLUGINS" (show newPlugins) oldResumeData - put $ ircbot { ircBotResumeData = newResumeData } +unloadIrcPlugin name = killIrcPlugin name -- | kills a plugin killIrcPlugin :: String -> IrcBot () diff --git a/HsbotIrcBot/Hsbot/Irc/Types.hs b/HsbotIrcBot/Hsbot/Irc/Types.hs index 63411df..e7a64ea 100644 --- a/HsbotIrcBot/Hsbot/Irc/Types.hs +++ b/HsbotIrcBot/Hsbot/Irc/Types.hs @@ -1,5 +1,6 @@ module Hsbot.Irc.Types - ( IrcBot + ( BotStatus (..) + , IrcBot , IrcBotState (..) , IrcServer , IrcServerState (..) @@ -14,7 +15,6 @@ import System.IO import Hsbot.Irc.Config import Hsbot.Irc.Message import Hsbot.Irc.Plugin.Utils -import Hsbot.Types -- | The Ircbot monad type IrcBot = StateT IrcBotState IO @@ -24,13 +24,14 @@ data IrcBotState = IrcBotState { ircBotPlugins :: M.Map String (IrcPluginState, MVar (), ThreadId) -- Loaded plugins , ircBotCommands :: M.Map String [String] -- Loaded plugins , ircBotChan :: Chan IrcBotMsg -- The IrcBot's communication channel - , ircBotMasterChan :: Chan BotMsg -- The Hsbot communication channel , ircBotServerState :: IrcServerState -- The state of the IrcServer , ircBotHandle :: Handle -- The server's socket/handle , ircBotConfig :: IrcConfig -- The starting configuration - , ircBotResumeData :: ResumeData -- the necessary data to resume the bot's operations on reboot } +-- | how we exit from the botLoop +data BotStatus = BotExit | BotReboot | BotContinue deriving (Eq) + -- | The IrcServer monad type IrcServer = StateT IrcServerState IrcBot @@ -46,3 +47,4 @@ data IrcServerState = IrcServerState -- | Utilities for triplets first :: (a, b, c) -> a first (a, _, _) = a + |