From ff07633fb8f81577ffec409cbf0a3c7361990f6c Mon Sep 17 00:00:00 2001 From: Julien Dessaux Date: Wed, 13 Apr 2011 20:15:55 +0200 Subject: Began a big refactoring/rewriting (again) --- HsbotMaster/Hsbot/.gitignore | 2 - HsbotMaster/Hsbot/Config.hs | 9 ---- HsbotMaster/Hsbot/Core.hs | 91 ---------------------------------------- HsbotMaster/Hsbot/Message.hs | 35 ---------------- HsbotMaster/Hsbot/Plugin.hs | 67 ----------------------------- HsbotMaster/Hsbot/PluginUtils.hs | 15 ------- HsbotMaster/Hsbot/Types.hs | 72 ------------------------------- 7 files changed, 291 deletions(-) delete mode 100644 HsbotMaster/Hsbot/.gitignore delete mode 100644 HsbotMaster/Hsbot/Config.hs delete mode 100644 HsbotMaster/Hsbot/Core.hs delete mode 100644 HsbotMaster/Hsbot/Message.hs delete mode 100644 HsbotMaster/Hsbot/Plugin.hs delete mode 100644 HsbotMaster/Hsbot/PluginUtils.hs delete mode 100644 HsbotMaster/Hsbot/Types.hs (limited to 'HsbotMaster/Hsbot') diff --git a/HsbotMaster/Hsbot/.gitignore b/HsbotMaster/Hsbot/.gitignore deleted file mode 100644 index a5aa1b9..0000000 --- a/HsbotMaster/Hsbot/.gitignore +++ /dev/null @@ -1,2 +0,0 @@ -.*.swp -Session.vim diff --git a/HsbotMaster/Hsbot/Config.hs b/HsbotMaster/Hsbot/Config.hs deleted file mode 100644 index 121cc98..0000000 --- a/HsbotMaster/Hsbot/Config.hs +++ /dev/null @@ -1,9 +0,0 @@ -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 deleted file mode 100644 index d634f10..0000000 --- a/HsbotMaster/Hsbot/Core.hs +++ /dev/null @@ -1,91 +0,0 @@ -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 deleted file mode 100644 index 933394b..0000000 --- a/HsbotMaster/Hsbot/Message.hs +++ /dev/null @@ -1,35 +0,0 @@ -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 deleted file mode 100644 index 1493c73..0000000 --- a/HsbotMaster/Hsbot/Plugin.hs +++ /dev/null @@ -1,67 +0,0 @@ -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 deleted file mode 100644 index d09b3b4..0000000 --- a/HsbotMaster/Hsbot/PluginUtils.hs +++ /dev/null @@ -1,15 +0,0 @@ -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 deleted file mode 100644 index ce1432b..0000000 --- a/HsbotMaster/Hsbot/Types.hs +++ /dev/null @@ -1,72 +0,0 @@ -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 - --- | 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 - , 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) - -- cgit v1.2.3