adyxax/hsbot
Archived
1
0
Fork 0
Code Issues Activity

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

Browse source
This commit is contained in:
Julien Dessaux 2010-05-25 21:54:33 +02:00
parent 8b33600f38
commit 451564ef5b
7 changed files with 75 additions and 58 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

56
Hsbot/Core.hs
View file

@ -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... "
processUpdateChan <- newChan :: IO (Chan String)
reportUpdateChan <- newChan :: IO (Chan String)
updaterThreadId <- forkIO $ readUpdates processUpdateChan reportUpdateChan ""
mvar <- newMVar "" :: IO (MVar String)
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)
killThread updaterThreadId
resumeData <- readChan reportUpdateChan
(reboot, botState') <- (runStateT botLoop botState) `catch` (\(_ :: IOException) -> return (False, botState))
resumeData <- takeMVar mvar
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 = forever $ do
botLoop :: Bot (Bool)
botLoop = do
chan <- gets botChan
msg <- liftIO $ readChan chan
case msg of
InMsg _ -> return ()
OutMsg _ -> return ()
InMsg _ -> botLoop
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
stuff = show $ botResumeData bot
liftIO $ writeChan updateChan stuff
-- | 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 ""
let mvar = botMVar bot
stuff = show $ botResumeData bot
_ <- liftIO $ swapMVar mvar stuff
return ()

12
Hsbot/Irc/Command.hs
View file

@ -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 ()

29
Hsbot/Irc/Core.hs
View file

@ -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"
, msgFrom = ircConfigName $ ircBotConfig ircbot
, msgTo = "CORE"
, msgCmd = show $ ircBotResumeData ircbot
}
msg = IntMsg $ Msg { msgType = "UPDATE"
, msgFrom = ircConfigName $ ircBotConfig ircbot
, msgTo = "CORE"
, 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

9
Hsbot/Irc/Plugin/Core.hs
View file

@ -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

16
Hsbot/Message.hs
View file

@ -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
"UPDATE" -> processUpdateCommand msg
_ -> return ()
case msgType msg of
"UPDATE" -> processUpdateCommand msg
_ -> 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 }

10
Hsbot/Types.hs
View file

@ -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
, msgFrom :: String -- who issues it
, msgTo :: String -- who it is destinated to
, msgCmd :: String -- the message to be transfered
{ 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 BotMsg = InMsg Msg | OutMsg Msg | IntMsg Msg deriving (Show)

1
TODO
View file

@ -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)