Began a complete rewrite of command and plugin management.

Wrote a command routing statement, added an IrcPlugin monad.

Config.hs

@@ -9,12 +9,12 @@ import Hsbot.Types
 
 -- | Imported plugins goes there
 defaultPlugins :: [String]
-defaultPlugins = [ "Ping", "Quote" ]
+defaultPlugins = [ "Ping", "Core" ]
 
 -- | User server
-kro :: IrcServer
-kro = IrcServer
-    { serverAddress  = "perseus"
+localhost :: IrcServer
+localhost = IrcServer
+    { serverAddress  = "localhost"
     , serverPort     = PortNumber 6667
     , joinChannels   = ["#shbot"]
     , nickname       = "hsbot"
@@ -27,6 +27,6 @@ kro = IrcServer
 config :: Config
 config = Config
     { commandPrefix = '@'
-    , ircServer     = kro
+    , ircServer     = localhost
     }
 

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

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]
+

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" []
-

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

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

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
 

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
 

Plugins/Core.hs

@@ -0,0 +1,49 @@
+module Plugins.Core
+    ( mainCore
+    ) where
+
+import Control.Concurrent.Chan
+
+import Hsbot.IRCPlugin
+import Hsbot.Types
+import Hsbot.Utils
+
+-- | The plugin's main entry point
+mainCore :: Chan BotMsg -> Chan BotMsg -> IO ()
+mainCore serverChan chan = do
+    let plugin = PluginInstance "Core" serverChan chan
+    (runStateT run plugin) `catch` (const $ return ((), plugin))
+    return ()
+
+-- | The IrcPlugin monad main function
+run :: IrcPlugin ()
+run = do
+    mapM_ sendRegisterCommand ["load", "unload"]
+    runPlugin
+    mapM_ sendUnregisterCommand ["load", "unload"]
+
+runPlugin :: IrcPlugin ()
+runPlugin = forever $ do
+    msg <- readMsg
+    eval msg
+  where
+    eval :: BotMsg -> IrcPlugin ()
+    eval (InternalCmd intCmd) = do
+        case intCmdCmd intCmd of
+            "RUN" -> let stuff = words $ intCmdMsg intCmd
+                     in case head stuff of
+                            "load"   -> loadPlugin $ tail stuff
+                            "unload" -> unloadPlugin $ tail stuff
+                            _      -> lift $ trace $ show intCmd -- TODO : help message
+            _     -> lift $ trace $ show intCmd
+    eval (InputMsg msg) = return ()
+    eval _ = return ()
+
+-- | The load command
+loadPlugin :: [String] -> IrcPlugin ()
+loadPlugin pluginNames = mapM_ (sendCommand "LOAD" "CORE") pluginNames
+
+-- | The unload command
+unloadPlugin :: [String] -> IrcPlugin ()
+unloadPlugin pluginNames = mapM_ (sendCommand "UNLOAD" "CORE") pluginNames
+

Plugins/Ping.hs

@@ -3,20 +3,27 @@ module Plugins.Ping
     ) where
 
 import Control.Concurrent.Chan
+import Control.Monad.State
 
+import Hsbot.IRCPlugin
 import Hsbot.Types
 
+-- | The plugin's main entry point
 mainPing :: Chan BotMsg -> Chan BotMsg -> IO ()
 mainPing serverChan chan = do
-    loop
-    where
-        loop = do
-            input <- readChan chan
-            eval input
-            loop
-        eval :: BotMsg -> IO ()
-        eval (InputMsg msg)
-            | (command msg) == "PING" = writeChan serverChan $ OutputMsg $ IrcMsg Nothing "PONG" (parameters msg)
-            | otherwise = return ()
-        eval _ = return ()
+    let plugin = PluginInstance "Ping" serverChan chan
+    (runStateT run plugin) `catch` (const $ return ((), plugin))
+    return ()
+
+-- | The IrcPlugin monad main function
+run :: IrcPlugin ()
+run = forever $ do
+    msg <- readMsg
+    eval msg
+  where
+    eval :: BotMsg -> IrcPlugin ()
+    eval (InputMsg msg)
+        | (command msg) == "PING" = writeMsg $ OutputMsg $ IrcMsg Nothing "PONG" (parameters msg)
+        | otherwise = return ()
+    eval _ = return ()
 

Plugins/Quote.hs

@@ -6,7 +6,7 @@ import Control.Concurrent.Chan
 import Control.Monad.State
 import System.Time (ClockTime)
 
-import Hsbot.Core
+import Hsbot.IRCPlugin
 import Hsbot.Types
 import Hsbot.Utils
 
@@ -24,24 +24,35 @@ type QuoteDB = [Quote]
 -- | The QuoteBot monad
 type QuoteBot a = StateT QuoteDB IO a
 
--- | The main function of the Quote module
+-- | The plugin's main entry point
 mainQuote :: Chan BotMsg -> Chan BotMsg -> IO ()
 mainQuote serverChan chan = do
-    writeChan serverChan $ InternalCmd $ IntCmd "REGISTER COMMAND quote Quote" emptyMsg
-    loop
-    where
-        loop = do
-            input <- readChan chan
-            eval input
-            loop
-        eval :: BotMsg -> IO ()
-        eval (InternalCmd intCmd) = do
-            let command' = words $ internalCommand intCmd
-            case command' !! 0 of
-                "runCommand" -> case (command' !! 1) of
-                                    "quote" -> writeChan serverChan $ OutputMsg $ internalCommandMsg intCmd
-                                    _       -> trace $ show command' -- TODO : help message
-                _            -> trace $ show command'
-        eval (InputMsg msg) = return ()
-        eval _ = return ()
+    let plugin = PluginInstance "Quote" serverChan chan
+    (runStateT run plugin) `catch` (const $ return ((), plugin))
+    return ()
+
+-- | The IrcPlugin monad main function
+run :: IrcPlugin ()
+run = do
+    -- TODO : init quote handling (sqlite + structure to handle temporary stuff)
+    sendRegisterCommand "quote"
+    runPlugin
+    sendUnregisterCommand "quote"
+    -- TODO : send cancel messages for all temporary stuff
+
+runPlugin :: IrcPlugin ()
+runPlugin = forever $ do
+    msg <- readMsg
+    eval msg
+  where
+    eval :: BotMsg -> IrcPlugin ()
+    eval (InternalCmd intCmd) = do
+        case intCmdCmd intCmd of
+            "RUN" -> let stuff = words $ intCmdMsg intCmd
+                     in case head stuff of
+                            "quote" -> lift $ trace $ "Quote module has been invoked for: " ++ (show intCmd)
+                            _       -> lift $ trace $ show intCmd -- TODO : help message
+            _     -> lift $ trace $ show intCmd
+    eval (InputMsg msg) = return ()
+    eval _ = return ()
 

TODO

@@ -1,14 +1,17 @@
-* implement InternalCommands "register command" and "unregister command"
-* implement helpers for command parsing in plugins
-  we need a monad "Plugin" in order to manage the from and to message fields.
-* clean command module
-* clean plugin module
-* kill threads
+:julien!~julien@ogu21.corp PRIVMSG #shbot :@quote graou snif
+
+* discard all trace with a color param and replace those with functions info/warn/error/debug
 * unload plugin
+
+* clean the plugin module
+* kill threads
 * plugin reload
 * list modules command
 * part chan
-* add admin check for cmds
+
+* add admin checks for cmds
+* add register for casual conversations for plugins?
+* add a "I have stuff to save so don't kill me too hard" status for plugins
 
 * restore \r in IRCParser