Began a complete rewrite of command and plugin management.

Wrote a command routing statement, added an IrcPlugin monad.

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