Cleaned that ugly update message handling and added a reboot command to the ircbot.

Hsbot/Core.hs

@@ -2,8 +2,8 @@ module Hsbot.Core
     ( hsbot
     ) where
 
-import Control.Concurrent
+import Control.Concurrent.Chan
-import Control.Concurrent.Chan ()
+import Control.Concurrent.MVar
 import Control.Exception
 import Control.Monad.State
 import qualified Data.Map as M
@@ -22,54 +22,46 @@ hsbot config = do
     startTime <- getCurrentTime
     putStrLn "[Hsbot] Opening communication channel... "
     chan <- newChan :: IO (Chan BotMsg)
-    putStrLn "[Hsbot] Spawning bot state manager... "
+    mvar <- newMVar "" :: IO (MVar String)
-    processUpdateChan <- newChan :: IO (Chan String)
-    reportUpdateChan  <- newChan :: IO (Chan String)
-    updaterThreadId <- forkIO $ readUpdates processUpdateChan reportUpdateChan ""
     putStrLn "[Hsbot] Spawning IrcBot plugins... "
     botState <- execStateT spawnIrcPlugins BotState { botStartTime  = startTime
                                                     , botPlugins    = M.empty
                                                     , botChan       = chan
                                                     , botConfig     = config
-                                                    , botUpdateChan = processUpdateChan
+                                                    , botMVar       = mvar
                                                     , botResumeData = M.empty }
     putStrLn "[Hsbot] Entering main loop... "
-    _ <- (execStateT botLoop botState) `catch` (\(_ :: IOException) -> return botState)
+    (reboot, botState') <- (runStateT botLoop botState) `catch` (\(_ :: IOException) -> return (False, botState))
-    killThread updaterThreadId
+    resumeData <- takeMVar mvar
-    resumeData <- readChan reportUpdateChan
+    if reboot
+      then resumeHsbot botState' resumeData
+      else return ()
+
+resumeHsbot :: BotState -> String -> IO ()
+resumeHsbot botState resumeData = do
     print resumeData
-    return ()
 
 -- | Run the bot main loop
-botLoop :: Bot ()
+botLoop :: Bot (Bool)
-botLoop = forever $ do
+botLoop = do
     chan <- gets botChan
     msg  <- liftIO $ readChan chan
     case msg of
-        InMsg  _      -> return ()
+        InMsg  _      -> botLoop
-        OutMsg _      -> return ()
+        OutMsg _      -> botLoop
         IntMsg intMsg -> do
-            processInternalMessage $ IntMsg intMsg
+            reboot <- processInternalMessage $ IntMsg intMsg
             reportUpdate
+            if not reboot
+              then botLoop
+              else return (True)
 
 -- | Reports an update to the master bot
 reportUpdate :: Bot ()
 reportUpdate = do
     bot <- get
-    let updateChan = botUpdateChan bot
+    let mvar  = botMVar bot
-        stuff      = show $ botResumeData bot
+        stuff = show $ botResumeData bot
-    liftIO $ writeChan updateChan stuff
+    _ <- liftIO $ swapMVar mvar stuff
-
+    return ()
--- | Runs bot updates' manager thread
-readUpdates :: Chan String -> Chan String -> String -> IO ()
-readUpdates processChan reportChan resumeData = do
-    resumeData' <- (readChan processChan) `catch` handleException
-    readUpdates processChan reportChan resumeData'
-  where
-    handleException :: AsyncException -> IO (String)
-    handleException _ = do
-        writeChan reportChan resumeData
-        myId <- myThreadId
-        killThread myId
-        return ""
 

Hsbot/Irc/Command.hs

@@ -34,7 +34,7 @@ unregisterCommand cmd pluginName' = do
     put $ ircBot { ircBotCommands = newCmds }
 
 -- | Processes an internal command
-processInternalCommand :: IrcBotMsg -> IrcBot ()
+processInternalCommand :: IrcBotMsg -> IrcBot (Bool)
 processInternalCommand (IntIrcCmd ircCmd)
   | ircCmdTo ircCmd == "CORE"   = processCoreCommand ircCmd
   | otherwise = do
@@ -42,21 +42,23 @@ processInternalCommand (IntIrcCmd ircCmd)
       case M.lookup (ircCmdTo ircCmd) plugins of
           Just (plugin, _) -> sendToPlugin (IntIrcCmd ircCmd) plugin
           Nothing          -> return ()
-processInternalCommand _ = return ()
+      return False
+processInternalCommand _ = return (False)
 
 -- | Processes a core command
-processCoreCommand :: IrcCmd -> IrcBot ()
+processCoreCommand :: IrcCmd -> IrcBot (Bool)
 processCoreCommand ircCmd = do
     let command' = ircCmdCmd ircCmd
         originalRequest = ircCmdBotMsg ircCmd
     case command' of
         "LIST"       -> listPlugins originalRequest (ircCmdFrom ircCmd)
         "LOAD"       -> loadIrcPlugin $ ircCmdMsg ircCmd
-        "UNLOAD"     -> unloadIrcPlugin $ ircCmdMsg ircCmd
-        "UPDATE"     -> processUpdateCommand ircCmd
         "REGISTER"   -> registerCommand (ircCmdMsg ircCmd) (ircCmdFrom ircCmd)
+        "UNLOAD"     -> unloadIrcPlugin $ ircCmdMsg ircCmd
         "UNREGISTER" -> unregisterCommand (ircCmdMsg ircCmd) (ircCmdFrom ircCmd)
+        "UPDATE"     -> processUpdateCommand ircCmd
         _            -> return ()
+    return $ command' == "REBOOT"
 
 -- | Process an update command
 processUpdateCommand :: IrcCmd -> IrcBot ()

Hsbot/Irc/Core.hs

@@ -57,7 +57,7 @@ startIrcbot config masterChan myChan = do
     putStrLn "[IrcBot] Spawning plugins..."
     ircBotState'' <- execStateT spawnIrcPlugins ircBotState'
     putStrLn "[IrcBot] Entering Core loop... "
-    _ <- (execStateT ircBotLoop ircBotState'') `catch` (\(_ :: IOException) -> return (ircBotState''))
+    (evalStateT ircBotLoop ircBotState'') `catch` (\(_ :: IOException) -> return ())
     return ()
 
 --resumeIrcBot
@@ -103,8 +103,11 @@ ircBotLoop = forever $ do
         InIrcMsg inIrcMsg   -> dispatchMessage $ InIrcMsg inIrcMsg
         OutIrcMsg outIrcMsg -> sendThisMessage outIrcMsg
         IntIrcCmd intIrcCmd -> do
-            processInternalCommand $ IntIrcCmd intIrcCmd
+            reboot <- processInternalCommand $ IntIrcCmd intIrcCmd
             reportUpdate
+            if reboot
+              then processRebootCommand
+              else return ()
   where
     sendThisMessage :: IrcMsg -> IrcBot ()
     sendThisMessage outputMsg = do
@@ -142,10 +145,22 @@ reportUpdate :: IrcBot ()
 reportUpdate = do
     ircbot <- get
     let masterChan = ircBotMasterChan ircbot
-        msg        = IntMsg $ Msg { msgType = "UPDATE"
+        msg = IntMsg $ Msg { msgType  = "UPDATE"
-                                  , msgFrom = ircConfigName $ ircBotConfig ircbot
+                           , msgFrom  = ircConfigName $ ircBotConfig ircbot
-                                  , msgTo   = "CORE"
+                           , msgTo    = "CORE"
-                                  , msgCmd  = show $ ircBotResumeData ircbot
+                           , msgStuff = show $ 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
 

Hsbot/Irc/Plugin/Core.hs

@@ -16,9 +16,9 @@ ircBotPluginCore myChan masterChan = do
     let plugin = IrcPluginState { ircPluginName       = "Core"
                                 , ircPluginChan       = myChan
                                 , ircPluginMasterChan = masterChan }
-    evalStateT (mapM_ sendRegisterCommand ["list", "load", "reload", "unload"]) plugin
+    evalStateT (mapM_ sendRegisterCommand ["list", "load", "reload", "unload", "reboot"]) plugin
     plugin' <- (execStateT run plugin) `catch` (\(_ :: AsyncException) -> return plugin)
-    evalStateT (mapM_ sendUnregisterCommand ["list", "load", "reload", "unload"]) plugin'
+    evalStateT (mapM_ sendUnregisterCommand ["list", "load", "reload", "unload", "reboot"]) plugin'
 
 -- | The IrcPlugin monad main function
 run :: IrcPlugin ()
@@ -36,6 +36,7 @@ run = forever $ do
                             "load"   -> loadPlugin $ tail stuff
                             "reload" -> reloadPlugin $ tail stuff
                             "unload" -> unloadPlugin $ tail stuff
+                            "reboot" -> rebootBot $ tail stuff
                             _        -> return () -- TODO : help message
             "ANSWER" -> let stuff = ircCmdMsg intCmd
                         in answerMsg request ("Loaded plugins : " ++ stuff)
@@ -59,3 +60,7 @@ reloadPlugin pluginNames = mapM_ (sendCommand "RELOAD" "CORE") pluginNames
 unloadPlugin :: [String] -> IrcPlugin ()
 unloadPlugin pluginNames = mapM_ (sendCommand "UNLOAD" "CORE") pluginNames
 
+-- | The reboot command
+rebootBot :: [String] -> IrcPlugin ()
+rebootBot stuff = sendCommand "REBOOT" "CORE" $ unwords stuff
+

Hsbot/Message.hs

@@ -9,7 +9,7 @@ import Hsbot.PluginUtils
 import Hsbot.Types
 
 -- | Processes an internal message
-processInternalMessage :: BotMsg -> Bot ()
+processInternalMessage :: BotMsg -> Bot (Bool)
 processInternalMessage (IntMsg msg)
   | msgTo msg == "CORE" = processCoreMessage msg
   | otherwise = do
@@ -17,13 +17,15 @@ processInternalMessage (IntMsg msg)
       case M.lookup (msgTo msg) plugins of
           Just (plugin, _) -> sendToPlugin (IntMsg msg) plugin
           Nothing          -> return ()
-processInternalMessage _ = return ()
+      return False
+processInternalMessage _ = return (False)
 
-processCoreMessage :: Msg -> Bot ()
+processCoreMessage :: Msg -> Bot (Bool)
 processCoreMessage msg = do
-    case msgCmd msg of
+    case msgType msg of
-        "UPDATE"     -> processUpdateCommand msg
+        "UPDATE" -> processUpdateCommand msg
-        _            -> return ()
+        _        -> return ()
+    return $ (msgType msg) == "REBOOT"
 
 -- | Process an update command
 processUpdateCommand :: Msg -> Bot ()
@@ -31,6 +33,6 @@ processUpdateCommand msg = do
     bot <- get
     let oldData = botResumeData bot
         from    = msgFrom msg
-        stuff   = msgCmd msg
+        stuff   = msgStuff msg
     put $ bot { botResumeData = M.insert from stuff oldData }
 

Hsbot/Types.hs

@@ -24,7 +24,7 @@ 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
-    , botUpdateChan :: Chan String  -- the bot's chan to report updates on
+    , 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
     }
 
@@ -40,10 +40,10 @@ data PluginState = PluginState
 
 -- | A hsbot message
 data Msg = Msg
-    { msgType :: String -- the message type
+    { msgType  :: String -- the message type
-    , msgFrom :: String -- who issues it
+    , msgFrom  :: String -- who issues it
-    , msgTo   :: String -- who it is destinated to
+    , msgTo    :: String -- who it is destinated to
-    , msgCmd  :: String -- the message to be transfered
+    , msgStuff :: String -- the message to be transfered
     } deriving (Show)
 
 data BotMsg = InMsg Msg | OutMsg Msg | IntMsg Msg deriving (Show)

TODO

@@ -1,5 +1,6 @@
 :julien!~julien@ogu21.corp PRIVMSG #shbot :@quote graou snif
 
+* Handle clean termination of all thread on reboot
 * Find a way to handle bot reloading threw exec
 * Find a way to cleanly handle termination/reboot requests (signals, IOExceptions, plugins' requests)