summaryrefslogtreecommitdiff
path: root/Hsbot
diff options
context:
space:
mode:
authorJulien Dessaux2010-02-04 21:05:37 +0100
committerJulien Dessaux2010-02-04 21:05:37 +0100
commitfd8d5faf5f4ab085b01316e15403779ca30cf3f9 (patch)
tree83dfae790dcb184d651567f06929fc69338733a9 /Hsbot
parentFixed some types' functions. (diff)
downloadhsbot-fd8d5faf5f4ab085b01316e15403779ca30cf3f9.tar.gz
hsbot-fd8d5faf5f4ab085b01316e15403779ca30cf3f9.tar.bz2
hsbot-fd8d5faf5f4ab085b01316e15403779ca30cf3f9.zip
Began a complete rewrite of command and plugin management.
Wrote a command routing statement, added an IrcPlugin monad.
Diffstat (limited to '')
-rw-r--r--Hsbot.hs2
-rw-r--r--Hsbot/Command.hs59
-rw-r--r--Hsbot/Core.hs6
-rw-r--r--Hsbot/IRCPlugin.hs39
-rw-r--r--Hsbot/Plugin.hs24
-rw-r--r--Hsbot/Types.hs31
-rw-r--r--Hsbot/Utils.hs16
7 files changed, 132 insertions, 45 deletions
diff --git a/Hsbot.hs b/Hsbot.hs
index d4c1769..48b3224 100644
--- a/Hsbot.hs
+++ b/Hsbot.hs
@@ -4,6 +4,7 @@ module Hsbot
, module Hsbot.Core
, module Hsbot.IRC
, module Hsbot.IRCParser
+ , module Hsbot.IRCPlugin
, module Hsbot.Main
, module Hsbot.Plugin
, module Hsbot.Types
@@ -15,6 +16,7 @@ import Hsbot.Command
import Hsbot.Core
import Hsbot.IRC
import Hsbot.IRCParser
+import Hsbot.IRCPlugin
import Hsbot.Main
import Hsbot.Plugin
import Hsbot.Types
diff --git a/Hsbot/Command.hs b/Hsbot/Command.hs
index bab592e..054653d 100644
--- a/Hsbot/Command.hs
+++ b/Hsbot/Command.hs
@@ -36,37 +36,48 @@ unregisterCommand cmd pluginName' = do
let newCmds = M.adjust (L.delete pluginName') cmd cmds
put $ bot { botCommands = newCmds }
---
--- TODO Clean this crap
---
+-- | Dispatches an input message
dispatchMessage :: BotMsg -> IrcBot ()
dispatchMessage (InputMsg inputMsg) = do
plugins <- gets botPlugins
cmds <- gets botCommands
- case command inputMsg of
- "PRIVMSG" -> -- The first word matters as the command
- let msg = (parameters inputMsg) !! 1
- pfx = commandPrefix config
- in if (head msg) == pfx
- then
- let msg' = tail msg -- all but the cmd prefix
- key = head $ words msg'
- pluginNames = fromMaybe [] $ M.lookup key cmds
- plugins' = fromMaybe [] $ mapM (flip M.lookup plugins) pluginNames
- in mapM_ (sendToPlugin $ InternalCmd $ IntCmd ("runCommand " ++ key) inputMsg) plugins'
- else
- mapM_ (sendToPlugin (InputMsg inputMsg)) (M.elems plugins)
- _ -> return ()
+ if isPluginCommand --TODO : how to get rid of this if?
+ then
+ let key = tail $ head $ words getMsgContent
+ pluginNames = fromMaybe [] $ M.lookup key cmds
+ plugins' = fromMaybe [] $ mapM (flip M.lookup plugins) pluginNames
+ in mapM_ (sendRunCommand $ tail getMsgContent) plugins'
+ else
+ mapM_ (sendToPlugin (InputMsg inputMsg)) (M.elems plugins)
+ where
+ isPluginCommand :: Bool
+ isPluginCommand =
+ and [ command inputMsg == "PRIVMSG"
+ , (head getMsgContent) == (commandPrefix config) ]
+ sendRunCommand :: String -> Plugin -> IrcBot ()
+ sendRunCommand cmd plugin = do
+ sendToPlugin (InternalCmd $ IntCmd "RUN" "CORE" (pluginName plugin) cmd) plugin
+ getMsgContent :: String
+ getMsgContent = (parameters inputMsg) !! 1
dispatchMessage _ = return ()
--- | Processes an internal command
+-- | Processes an internal command
processInternalCommand :: BotMsg -> IrcBot ()
processInternalCommand (InternalCmd intCmd) = do
- let command' = words $ internalCommand intCmd
- case command' !! 0 of
- "REGISTER" -> case command' !! 1 of
- "COMMAND" -> registerCommand (command' !! 2) (command' !! 3)
- _ -> traceM $ inColor ("Invalid argument for the REGISTER command : " ++ (command' !! 2)) [31]
- _ -> traceM $ inColor ("Invalid command : " ++ (command' !! 1)) [31]
+ plugins <- gets botPlugins
+ if intCmdTo intCmd == "CORE"
+ then processCoreCommand intCmd
+ else sendToPlugin (InternalCmd intCmd) $ fromMaybe [] (M.lookup plugins (intCmdTo intCmd))
processInternalCommand _ = return ()
+-- | Processes a core command
+processCoreCommand :: IntCmd -> IrcBot ()
+processCoreCommand intCmd = do
+ let command' = intCmdCmd intCmd
+ case command' of
+ "LOAD" -> loadPlugin $ intCmdMsg intCmd
+ "UNLOAD" -> unloadPlugin $ intCmdMsg intCmd
+ "REGISTER" -> registerCommand (intCmdMsg intCmd) (intCmdFrom intCmd)
+ "UNREGISTER" -> unregisterCommand (intCmdMsg intCmd) (intCmdFrom intCmd)
+ _ -> traceM $ inColor ("Invalid command : " ++ (show intCmd)) [31]
+
diff --git a/Hsbot/Core.hs b/Hsbot/Core.hs
index 40e8e59..2de1507 100644
--- a/Hsbot/Core.hs
+++ b/Hsbot/Core.hs
@@ -1,7 +1,6 @@
module Hsbot.Core
( connectServer
, disconnectServer
- , emptyMsg
) where
import Control.Concurrent
@@ -30,7 +29,7 @@ connectServer server = do
chan <- newChan :: IO (Chan BotMsg)
threadId <- forkIO $ botReader handle chan
putStrLn "done."
- return (Bot server starttime handle [] M.empty chan threadId M.empty)
+ return $ Bot server starttime handle [] M.empty chan threadId M.empty
-- | Disconnect from the server
disconnectServer :: Bot -> IO () -- IO Bot ?
@@ -53,6 +52,3 @@ botReader handle chan = forever $ do
_ -> do
return ()
-emptyMsg :: IrcMsg
-emptyMsg = IrcMsg Nothing "EMPTY" []
-
diff --git a/Hsbot/IRCPlugin.hs b/Hsbot/IRCPlugin.hs
new file mode 100644
index 0000000..8c5eb86
--- /dev/null
+++ b/Hsbot/IRCPlugin.hs
@@ -0,0 +1,39 @@
+module Hsbot.IRCPlugin
+ ( readMsg
+ , sendRegisterCommand
+ , sendUnregisterCommand
+ , writeMsg
+ ) where
+
+import Control.Concurrent.Chan
+import Control.Monad.State
+
+import Hsbot.Types
+
+-- | Basic input output for IrcPlugins
+readMsg :: IrcPlugin (BotMsg)
+readMsg = do
+ chan <- gets instanceChan
+ input <- liftIO $ readChan chan
+ return input
+
+writeMsg :: BotMsg -> IrcPlugin ()
+writeMsg botMsg = do
+ serverChan <- gets instanceServerChan
+ liftIO $ writeChan serverChan $ botMsg
+
+-- | Commands management
+sendCommand :: String -> String -> String -> IrcPlugin ()
+sendCommand cmd to params = do
+ serverChan <- gets instanceServerChan
+ from <- gets instanceName
+ liftIO $ writeChan serverChan $ InternalCmd $ IntCmd cmd from to params
+
+sendRegisterCommand :: String -> IrcPlugin ()
+sendRegisterCommand cmd = sendCommand "REGISTER" "CORE" cmd
+
+sendUnregisterCommand :: String -> IrcPlugin ()
+sendUnregisterCommand cmd = sendCommand "UNREGISTER" "CORE" cmd
+
+-- | a isAdmin helper : I need an admin plugin (to track admins' status around chans)
+
diff --git a/Hsbot/Plugin.hs b/Hsbot/Plugin.hs
index 7d4f0ca..e6f425a 100644
--- a/Hsbot/Plugin.hs
+++ b/Hsbot/Plugin.hs
@@ -13,7 +13,7 @@ import System.Plugins
import Hsbot.Types
import Hsbot.Utils
--- TODO : unload plugin, reload plugin, list plugins, etc
+-- TODO : reload plugin, list plugins, etc
-- | Loads a plugin into an ircBot
loadPlugin :: String -> IrcBot ()
@@ -21,7 +21,7 @@ loadPlugin name = do
bot <- get
let oldPlugins = botPlugins bot
if name `M.member` oldPlugins
- then traceM $ inColor ("Can't load plugin \"" ++ name ++ "\", this identifier has already been registered.") [31]
+ then traceM $ inColor ("Can't load plugin \"" ++ name ++ "\", this identifier has already been registered.") [31] -- or a wait, smthg like that?
else do
plugin <- liftIO $ effectivelyLoadPlugin name (botChannel bot)
case plugin of
@@ -33,7 +33,6 @@ loadPlugin name = do
effectivelyLoadPlugin :: String -> Chan BotMsg -> IO (Maybe Plugin)
effectivelyLoadPlugin name serverChan = do
-- TODO : test if Plugins/ ++ name ++ .hs exists
- -- Just load, do not compile if .o already present
m <- liftIO $ makeAll ("Plugins/" ++ name ++ ".hs") []
plugin <- case m of
MakeSuccess _ _ -> do
@@ -54,6 +53,25 @@ effectivelyLoadPlugin name serverChan = do
return Nothing
return plugin
+-- | Unloads a plugin
+unloadPlugin :: String -> IrcBot ()
+unloadPlugin name = do
+ bot <- get
+ let oldPlugins = botPlugins bot
+ case M.lookup name oldPlugins of
+ Just plugin -> do
+ let newPlugins = M.delete name oldPlugins
+ liftIO $ killPlugin plugin -- TODO : forkIO to get this asynchronous and non blocking
+ -- or let's see if closing one's chan kills him.
+ unloadAll $ pluginModule $ M.lookup name oldPlugins
+ put $ bot { botPlugins = newPlugins }
+ Nothing -> return ()
+
+-- | stop a plugin
+killPlugin :: Plugin -> IO ()
+killPlugin plugin = do
+ -- TODO : send stop, sleep and kill thread (if necessary) and remove its commands
+
-- | Sends a msg to a plugin
sendToPlugin :: BotMsg -> Plugin -> IrcBot ()
sendToPlugin msg plugin = do
diff --git a/Hsbot/Types.hs b/Hsbot/Types.hs
index 4e002db..99619ee 100644
--- a/Hsbot/Types.hs
+++ b/Hsbot/Types.hs
@@ -7,7 +7,9 @@ module Hsbot.Types
, IrcServer(..)
, IrcBot
, IrcMsg(..)
+ , IrcPlugin
, Plugin(..)
+ , PluginInstance(..)
) where
import Control.Concurrent
@@ -23,7 +25,7 @@ import System.Time (ClockTime)
-- | Configuration data type
data Config = Config
- { commandPrefix :: Char -- command prefixes, for example @[\'>\',\'@\',\'?\']@
+ { commandPrefix :: Char -- command prefixe, for example @[\'>\',\'@\',\'?\']@
, ircServer :: IrcServer -- list of 'Server's to connect to
} deriving (Show)
@@ -67,7 +69,11 @@ data Bot = Bot
}
instance Show Bot where
- show (Bot _ s h c p _ _ cmds) = (show s) ++ (show h) ++ (show c) ++ (show p) ++ (show cmds)
+ show (Bot _ s h c p _ _ cmds) = "Start time : " ++ (show s) ++ "\n"
+ ++ "Handle : " ++ (show h) ++ "\n"
+ ++ "Channels : " ++ (show c) ++ "\n"
+ ++ "Plugins : " ++ (show p) ++ "\n"
+ ++ "Commands : " ++ (show cmds) ++ "\n"
-- | A channel connection
data Channel = Channel
@@ -84,13 +90,16 @@ data IrcMsg = IrcMsg
} deriving (Show)
-- | An internal command
--- TODO : make it with a FROM and a TO for plugins handling, and make it usefull threw the helpers.
data IntCmd = IntCmd
- { internalCommand :: String -- the internal command
- , internalCommandMsg :: IrcMsg -- the IrcMsg associated with the command
+ { intCmdCmd :: String -- the internal command
+ , intCmdFrom :: String -- who issues it
+ , intCmdTo :: String -- who it is destinated to
+ , intCmdMsg :: String -- the IrcMsg associated with the command
} deriving (Show)
--- | A plugin definition
+data BotMsg = InputMsg IrcMsg | OutputMsg IrcMsg | InternalCmd IntCmd
+
+-- | A plugin (core side)
data Plugin = Plugin
{ pluginName :: String -- The plugin's name
, pluginModule :: Module -- The plugin himself
@@ -101,5 +110,13 @@ data Plugin = Plugin
instance Show Plugin where
show (Plugin name _ _ _) = show name
-data BotMsg = InputMsg IrcMsg | OutputMsg IrcMsg | InternalCmd IntCmd
+-- | A IrcPlugin ("user" side)
+data PluginInstance = PluginInstance
+ { instanceName :: String -- The plugin's name
+ , instanceServerChan :: Chan BotMsg -- The server channel
+ , instanceChan :: Chan BotMsg -- The plugin channel
+ }
+
+-- | The IrcPlugin monad
+type IrcPlugin a = StateT PluginInstance IO a
diff --git a/Hsbot/Utils.hs b/Hsbot/Utils.hs
index 1c40362..b84b028 100644
--- a/Hsbot/Utils.hs
+++ b/Hsbot/Utils.hs
@@ -1,5 +1,7 @@
module Hsbot.Utils
- ( inColor
+ ( error
+ , errorM
+ , inColor
, sendstr
, trace
, traceM
@@ -29,10 +31,12 @@ trace msg = putStrLn msg
-- | Log a message string
traceM :: String -> IrcBot ()
-traceM msg = liftIO $ putStrLn msg
+traceM msg = liftIO $ trace msg
------------------
--- | Helpers | --
------------------
--- sendRegister
+-- | Logs an error message
+error :: String -> IO ()
+error msg = trace $ inColor msg [31]
+
+errorM :: String -> a ()
+error msg = liftIO $ error msg