diff options
| -rw-r--r-- | Hsbot/Core.hs | 50 | ||||
| -rw-r--r-- | Hsbot/Irc/Core.hs | 7 | ||||
| -rw-r--r-- | Hsbot/Irc/Types.hs | 2 | ||||
| -rw-r--r-- | Hsbot/Message.hs | 22 | ||||
| -rw-r--r-- | Hsbot/Types.hs | 21 |
5 files changed, 53 insertions, 49 deletions
diff --git a/Hsbot/Core.hs b/Hsbot/Core.hs index 80846ab..f98fece 100644 --- a/Hsbot/Core.hs +++ b/Hsbot/Core.hs @@ -22,46 +22,48 @@ hsbot config = do startTime <- getCurrentTime putStrLn "[Hsbot] Opening communication channel... " chan <- newChan :: IO (Chan BotMsg) - mvar <- newMVar "" :: IO (MVar String) + mvar <- newMVar M.empty :: IO (MVar BotResumeData) putStrLn "[Hsbot] Spawning IrcBot plugins... " botState <- execStateT spawnIrcPlugins BotState { botStartTime = startTime , botPlugins = M.empty , botChan = chan , botConfig = config - , botMVar = mvar - , botResumeData = M.empty } + , botResumeData = mvar } putStrLn "[Hsbot] Entering main loop... " - (reboot, botState') <- (runStateT botLoop botState) `catch` (\(_ :: IOException) -> return (False, botState)) + (status, botState') <- runLoop botState resumeData <- takeMVar mvar - if reboot + if status == BotReboot then resumeHsbot botState' resumeData else return () + where + runLoop :: BotState -> IO (BotStatus, BotState) + runLoop botState = do + (status, botState') <- (runStateT botCore botState) `catch` (\(_ :: IOException) -> return (BotExit, botState)) + case status of + BotContinue -> runLoop botState' + _ -> return (status, botState') -resumeHsbot :: BotState -> String -> IO () +resumeHsbot :: BotState -> BotResumeData -> IO () resumeHsbot botState resumeData = do print resumeData -- | Run the bot main loop -botLoop :: Bot (Bool) -botLoop = do +botCore :: Bot (BotStatus) +botCore = do chan <- gets botChan msg <- liftIO $ readChan chan case msg of - InMsg _ -> botLoop - OutMsg _ -> botLoop - IntMsg intMsg -> do - reboot <- processInternalMessage $ IntMsg intMsg - reportUpdate - if not reboot - then botLoop - else return (True) + InMsg _ -> return BotContinue + OutMsg _ -> return BotContinue + IntMsg intMsg -> processInternalMessage $ IntMsg intMsg + UpdMsg updMsg -> processUpdateMessage updMsg --- | Reports an update to the master bot -reportUpdate :: Bot () -reportUpdate = do - bot <- get - let mvar = botMVar bot - stuff = show $ botResumeData bot - _ <- liftIO $ swapMVar mvar stuff - return () +-- | 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 diff --git a/Hsbot/Irc/Core.hs b/Hsbot/Irc/Core.hs index b1aee02..2fb8386 100644 --- a/Hsbot/Irc/Core.hs +++ b/Hsbot/Irc/Core.hs @@ -145,11 +145,8 @@ reportUpdate :: IrcBot () reportUpdate = do ircbot <- get let masterChan = ircBotMasterChan ircbot - msg = IntMsg $ Msg { msgType = "UPDATE" - , msgFrom = ircConfigName $ ircBotConfig ircbot - , msgTo = "CORE" - , msgStuff = show $ ircBotResumeData ircbot - } + msg = UpdMsg $ ResMsg { resMsgFrom = ircConfigName $ ircBotConfig ircbot + , resMsgData = ircBotResumeData ircbot } liftIO $ writeChan masterChan msg -- | Process a reboot command diff --git a/Hsbot/Irc/Types.hs b/Hsbot/Irc/Types.hs index 440de64..c9be251 100644 --- a/Hsbot/Irc/Types.hs +++ b/Hsbot/Irc/Types.hs @@ -32,7 +32,7 @@ data IrcBotState = IrcBotState , ircBotConfig :: IrcConfig -- The starting configuration , ircBotReaderThreadId :: ThreadId -- the thread that process inputs from the socket , ircBotMasterReaderThreadId :: ThreadId -- the thread that process inputs from the master bot - , ircBotResumeData :: M.Map String String -- the necessary data to resume the bot's operations on reboot + , ircBotResumeData :: ResumeData -- the necessary data to resume the bot's operations on reboot } -- | The IrcServer monad diff --git a/Hsbot/Message.hs b/Hsbot/Message.hs index c632019..f38438f 100644 --- a/Hsbot/Message.hs +++ b/Hsbot/Message.hs @@ -9,7 +9,7 @@ import Hsbot.PluginUtils import Hsbot.Types -- | Processes an internal message -processInternalMessage :: BotMsg -> Bot (Bool) +processInternalMessage :: BotMsg -> Bot (BotStatus) processInternalMessage (IntMsg msg) | msgTo msg == "CORE" = processCoreMessage msg | otherwise = do @@ -17,22 +17,12 @@ processInternalMessage (IntMsg msg) case M.lookup (msgTo msg) plugins of Just (plugin, _) -> sendToPlugin (IntMsg msg) plugin Nothing -> return () - return False -processInternalMessage _ = return (False) + return BotContinue +processInternalMessage _ = return BotContinue -processCoreMessage :: Msg -> Bot (Bool) +processCoreMessage :: Msg -> Bot (BotStatus) processCoreMessage msg = do case msgType msg of - "UPDATE" -> processUpdateCommand msg - _ -> return () - return $ (msgType msg) == "REBOOT" - --- | Process an update command -processUpdateCommand :: Msg -> Bot () -processUpdateCommand msg = do - bot <- get - let oldData = botResumeData bot - from = msgFrom msg - stuff = msgStuff msg - put $ bot { botResumeData = M.insert from stuff oldData } + "REBOOT" -> return BotReboot + _ -> return BotContinue diff --git a/Hsbot/Types.hs b/Hsbot/Types.hs index 9ea7ff6..49e8e6b 100644 --- a/Hsbot/Types.hs +++ b/Hsbot/Types.hs @@ -1,10 +1,14 @@ module Hsbot.Types ( Bot , BotMsg (..) + , BotResumeData , BotState (..) + , BotStatus (..) , Msg (..) , Plugin , PluginState (..) + , ResumeData + , ResumeMsg (..) ) where import Control.Concurrent @@ -24,10 +28,16 @@ data BotState = BotState , botPlugins :: M.Map String (PluginState, ThreadId) -- Loaded plugins , botChan :: Chan BotMsg -- the bot's communication channel , botConfig :: Config -- the bot's starting config - , botMVar :: MVar String -- the place where to put resume data - , botResumeData :: M.Map String String -- the necessary data to resume the bot's operations on reboot + , 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 @@ -46,5 +56,10 @@ data Msg = Msg , msgStuff :: String -- the message to be transfered } deriving (Show) -data BotMsg = InMsg Msg | OutMsg Msg | IntMsg Msg deriving (Show) +data ResumeMsg = ResMsg + { resMsgFrom :: String + , resMsgData :: ResumeData + } deriving (Show) + +data BotMsg = InMsg Msg | OutMsg Msg | IntMsg Msg | UpdMsg ResumeMsg deriving (Show) |