diff options
author | Julien Dessaux | 2010-07-03 21:26:00 +0200 |
---|---|---|
committer | Julien Dessaux | 2010-07-03 22:40:17 +0200 |
commit | 11c2c16835b3e8368be77ccc5b7ddf949021eccd (patch) | |
tree | 7733132ee370335156219ff6eb4f0ef2dbd1c8ff /HsbotMaster/Hsbot | |
parent | Wrote most of the resume code for the core and the irc plugin. (diff) | |
download | hsbot-11c2c16835b3e8368be77ccc5b7ddf949021eccd.tar.gz hsbot-11c2c16835b3e8368be77ccc5b7ddf949021eccd.tar.bz2 hsbot-11c2c16835b3e8368be77ccc5b7ddf949021eccd.zip |
Moved files around as a preliminary for architectural changes.
Diffstat (limited to 'HsbotMaster/Hsbot')
-rw-r--r-- | HsbotMaster/Hsbot/.gitignore | 2 | ||||
-rw-r--r-- | HsbotMaster/Hsbot/Config.hs | 9 | ||||
-rw-r--r-- | HsbotMaster/Hsbot/Core.hs | 91 | ||||
-rw-r--r-- | HsbotMaster/Hsbot/Message.hs | 35 | ||||
-rw-r--r-- | HsbotMaster/Hsbot/Plugin.hs | 67 | ||||
-rw-r--r-- | HsbotMaster/Hsbot/PluginUtils.hs | 15 | ||||
-rw-r--r-- | HsbotMaster/Hsbot/Types.hs | 75 |
7 files changed, 294 insertions, 0 deletions
diff --git a/HsbotMaster/Hsbot/.gitignore b/HsbotMaster/Hsbot/.gitignore new file mode 100644 index 0000000..a5aa1b9 --- /dev/null +++ b/HsbotMaster/Hsbot/.gitignore @@ -0,0 +1,2 @@ +.*.swp +Session.vim diff --git a/HsbotMaster/Hsbot/Config.hs b/HsbotMaster/Hsbot/Config.hs new file mode 100644 index 0000000..121cc98 --- /dev/null +++ b/HsbotMaster/Hsbot/Config.hs @@ -0,0 +1,9 @@ +module Hsbot.Config + ( BotConfig (..) + ) where + +import Hsbot.Irc.Config + +-- | Configuration data type +data BotConfig = IrcBotConfig IrcConfig + diff --git a/HsbotMaster/Hsbot/Core.hs b/HsbotMaster/Hsbot/Core.hs new file mode 100644 index 0000000..dad965d --- /dev/null +++ b/HsbotMaster/Hsbot/Core.hs @@ -0,0 +1,91 @@ +module Hsbot.Core + ( hsbot + ) where + +import Control.Concurrent.Chan +import Control.Concurrent.MVar +import Control.Exception +import Control.Monad.State +import qualified Data.Map as M +import Data.Time +import Prelude hiding (catch) +import System.IO() +import System.Posix.Signals + +import Hsbot.Config +import Hsbot.Message +import Hsbot.Plugin +import Hsbot.Types + +-- | Bot's main entry point +hsbot :: [BotConfig] -> Maybe String -> IO () +hsbot config txtResumeData= do + let resumeData = case txtResumeData of + Just txtData -> read txtData :: BotResumeData -- TODO : catch exception + Nothing -> M.empty :: BotResumeData + startTime <- case M.lookup "HSBOT" resumeData of + Just hsbotData -> do + case M.lookup "STARTTIME" hsbotData of + Just txtStartTime -> do + let gotStartTime = read txtStartTime :: UTCTime + return gotStartTime + Nothing -> getCurrentTime + Nothing -> getCurrentTime + let resumeData' = M.insert "HSBOT" (M.singleton "STARTTIME" $ show startTime) resumeData + putStrLn "[Hsbot] Opening communication channel... " + chan <- newChan :: IO (Chan BotMsg) + mvar <- newMVar resumeData' :: IO (MVar BotResumeData) + putStrLn "[Hsbot] Installing signal handlers... " + _ <- installHandler sigHUP (Catch $ sigHupHandler chan) Nothing + _ <- installHandler sigTERM (Catch $ sigTermHandler chan) Nothing + putStrLn "[Hsbot] Spawning IrcBot plugins... " + botState <- execStateT spawnPlugins BotState { botStartTime = startTime + , botPlugins = M.empty + , botChan = chan + , botConfig = config + , botResumeData = mvar } + putStrLn "[Hsbot] Entering main loop... " + (status, botState') <- runLoop botState + putStrLn "[Hsbot] Killing active plugins... " + newResumeData <- takeMVar mvar + evalStateT (mapM_ killPlugin $ M.keys newResumeData) botState' + if status == BotReboot + then hsbot config (Just $ show newResumeData) -- TODO : exec on the hsbot launcher with the reload string + else return () + where + runLoop :: BotState -> IO (BotStatus, BotState) + runLoop botState = do + (status, botState') <- (runStateT botCore botState) `catches` [ Handler (\ (_ :: IOException) -> return (BotExit, botState)) + , Handler (\ (_ :: AsyncException) -> return (BotExit, botState)) ] + case status of + BotContinue -> runLoop botState' + _ -> return (status, botState') + +-- | Run the bot main loop +botCore :: Bot (BotStatus) +botCore = do + chan <- gets botChan + msg <- liftIO $ readChan chan + case msg of + IntMsg intMsg -> processInternalMessage intMsg + UpdMsg updMsg -> processUpdateMessage updMsg + RebMsg rebMsg -> processRebootMessage rebMsg + ExiMsg exiMsg -> processExitMessage exiMsg + +-- | Process an update command +processUpdateMessage :: ResumeMsg -> Bot (BotStatus) +processUpdateMessage msg = do + resumeData <- gets botResumeData + let from = resMsgFrom msg + stuff = resMsgData msg + liftIO $ modifyMVar_ resumeData (\oldData -> return $ M.insert from stuff oldData) + return BotContinue + +-- | signals handlers +sigHupHandler :: Chan BotMsg -> IO () +sigHupHandler chan = writeChan chan $ RebMsg RebootMsg { rebMsgFrom = "HUP handler" } + +-- | signals handlers +sigTermHandler :: Chan BotMsg -> IO () +sigTermHandler chan = writeChan chan $ ExiMsg ExitMsg { exiMsgFrom = "TERM handler" } + diff --git a/HsbotMaster/Hsbot/Message.hs b/HsbotMaster/Hsbot/Message.hs new file mode 100644 index 0000000..933394b --- /dev/null +++ b/HsbotMaster/Hsbot/Message.hs @@ -0,0 +1,35 @@ +module Hsbot.Message + ( processInternalMessage + , processRebootMessage + , processExitMessage + ) where + +import Control.Monad.State +import qualified Data.Map as M + +import Hsbot.PluginUtils +import Hsbot.Types + +-- | Processes an internal message +processInternalMessage :: Msg -> Bot (BotStatus) +processInternalMessage msg + | msgTo msg == "CORE" = processCoreMessage msg + | otherwise = do + plugins <- gets botPlugins + case M.lookup (msgTo msg) plugins of + Just (plugin, _, _) -> sendToPlugin (IntMsg msg) plugin + Nothing -> return () + return BotContinue + +processCoreMessage :: Msg -> Bot (BotStatus) +processCoreMessage msg = do + case msgType msg of + "REBOOT" -> return BotReboot + _ -> return BotContinue + +processRebootMessage :: RebootMsg -> Bot (BotStatus) +processRebootMessage _ = return BotReboot -- TODO : check who is sending that to us + +processExitMessage :: ExitMsg -> Bot (BotStatus) +processExitMessage _ = return BotExit -- TODO : check who is sending that to us + diff --git a/HsbotMaster/Hsbot/Plugin.hs b/HsbotMaster/Hsbot/Plugin.hs new file mode 100644 index 0000000..1493c73 --- /dev/null +++ b/HsbotMaster/Hsbot/Plugin.hs @@ -0,0 +1,67 @@ +module Hsbot.Plugin + ( killPlugin + , spawnPlugins + , spawnPlugin + , unloadPlugin + ) where + +import Control.Concurrent (forkIO) +import Control.Concurrent.Chan +import Control.Concurrent.MVar +import Control.Exception +import Control.Monad.State +import qualified Data.Map as M +import Data.Maybe (fromMaybe) +import Prelude hiding (catch) + +import Hsbot.Config +import Hsbot.Irc.Config +import Hsbot.Irc.Core +import Hsbot.Types + +-- | spawns plugins +spawnPlugins :: Bot () +spawnPlugins = do + config <- gets botConfig + mapM_ (spawnPlugin) config + +-- | spawns a single plugin +spawnPlugin :: BotConfig -> Bot () +spawnPlugin (IrcBotConfig ircConfig) = do + bot <- get + let mvar = botResumeData bot + name = ircConfigName ircConfig + resumeData <- liftIO $ takeMVar mvar + let pluginResumeData = fromMaybe M.empty $ M.lookup name resumeData + chan = botChan bot + pchan <- liftIO (newChan :: IO (Chan BotMsg)) + pluginMVar <- liftIO newEmptyMVar + threadId <- liftIO . forkIO $ finally (startIrcbot ircConfig chan pchan (Just $ show pluginResumeData)) (putMVar pluginMVar ()) + let plugin = PluginState { pluginName = name + , pluginChan = pchan + , pluginHandles = M.empty } + plugins = botPlugins bot + put $ bot { botPlugins = M.insert (pluginName plugin) (plugin, pluginMVar, threadId) plugins } + liftIO . putMVar mvar $ M.insert name pluginResumeData resumeData + +-- | Unloads a plugin +unloadPlugin :: String -> Bot () +unloadPlugin name = do + killPlugin name + resumeData <- gets botResumeData + liftIO $ modifyMVar_ resumeData (\oldData -> return $ M.delete name oldData) + +-- | kills a plugin +killPlugin :: String -> Bot () +killPlugin name = do + bot <- get + let oldPlugins = botPlugins bot + -- We check if the plugin exists + case M.lookup name oldPlugins of + Just (_, mvar, threadId) -> do + let newPlugins = M.delete name oldPlugins + liftIO $ throwTo threadId UserInterrupt + put $ bot { botPlugins = newPlugins } + liftIO $ takeMVar mvar + Nothing -> return () + diff --git a/HsbotMaster/Hsbot/PluginUtils.hs b/HsbotMaster/Hsbot/PluginUtils.hs new file mode 100644 index 0000000..d09b3b4 --- /dev/null +++ b/HsbotMaster/Hsbot/PluginUtils.hs @@ -0,0 +1,15 @@ +module Hsbot.PluginUtils + ( sendToPlugin + ) where + +import Control.Concurrent +import Control.Concurrent.Chan () +import Control.Monad.State + +import Hsbot.Types + +-- | Sends a msg to a plugin +sendToPlugin :: BotMsg -> PluginState -> Bot () +sendToPlugin botMsg plugin = do + liftIO $ writeChan (pluginChan plugin) botMsg + diff --git a/HsbotMaster/Hsbot/Types.hs b/HsbotMaster/Hsbot/Types.hs new file mode 100644 index 0000000..66b4d6b --- /dev/null +++ b/HsbotMaster/Hsbot/Types.hs @@ -0,0 +1,75 @@ +module Hsbot.Types + ( Bot + , BotMsg (..) + , BotResumeData + , BotState (..) + , BotStatus (..) + , ExitMsg (..) + , Msg (..) + , Plugin + , PluginState (..) + , RebootMsg (..) + , ResumeData + , ResumeMsg (..) + ) where + +import Control.Concurrent +import Control.Monad.State +import qualified Data.Map as M +import Data.Time +import System.IO + +import Hsbot.Config + +-- | The Bot monad +type Bot = StateT BotState IO + +-- | An Hsbot state +data BotState = BotState + { botStartTime :: UTCTime -- the bot's uptime + , botPlugins :: M.Map String (PluginState, MVar (), ThreadId) -- Loaded plugins + , botChan :: Chan BotMsg -- the bot's communication channel + , botConfig :: [BotConfig] -- the bot's starting config + , botResumeData :: MVar BotResumeData -- the necessary data to resume the bot's operations on reboot + } + +-- | how we exit from the botLoop +data BotStatus = BotExit | BotReboot | BotContinue deriving (Eq) + +-- | Types to factorise resume data +type ResumeData = M.Map String String +type BotResumeData = M.Map String ResumeData + +-- | The Plugin monad +type Plugin = StateT PluginState IO + +-- | A plugin state +data PluginState = PluginState + { pluginName :: String -- The plugin's name + , pluginChan :: Chan BotMsg -- The plugin chan + , pluginHandles :: M.Map String Handle -- the plugins's handles + } + +-- | A hsbot message +data Msg = Msg + { msgType :: String -- the message type + , msgFrom :: String -- who issues it + , msgTo :: String -- who it is destinated to + , msgStuff :: String -- the message to be transfered + } deriving (Show) + +data ResumeMsg = ResMsg + { resMsgFrom :: String + , resMsgData :: ResumeData + } deriving (Show) + +data RebootMsg = RebootMsg + { rebMsgFrom :: String + } deriving (Show) + +data ExitMsg = ExitMsg + { exiMsgFrom :: String + } deriving (Show) + +data BotMsg = IntMsg Msg | UpdMsg ResumeMsg | RebMsg RebootMsg | ExiMsg ExitMsg deriving (Show) + |