Rewrote command handling, added the Quote module and cleaned input handling.

Config.hs

@@ -9,7 +9,7 @@ import Hsbot.Types
 
 -- | Imported plugins goes there
 defaultPlugins :: [String]
-defaultPlugins = [ "Ping" ]
+defaultPlugins = [ "Ping", "Quote" ]
 
 -- | User server
 kro :: IrcServer

Hsbot/Command.hs

@@ -1,5 +1,6 @@
 module Hsbot.Command
-    ( dispatchCommand
+    ( dispatchMessage
+    , processInternalCommand
     , registerCommand
     , unregisterCommand
     ) where
@@ -14,46 +15,20 @@ import Hsbot.Plugin
 import Hsbot.Types
 import Hsbot.Utils
 
--- TODO :  unregister command
-
-dispatchCommand :: BotMsg -> IrcBot ()
-dispatchCommand (InputMsg inputMsg) = do
-    plugins <- gets botPlugins
-    cmds    <- gets botCommands
-    if command inputMsg == "PRIVMSG"
-      then  -- The first word matters as the command
-        let msg = (parameters inputMsg) !! 1
-            pfx = commandPrefix config
-        in if (head msg) == pfx
-             then
-               let key         = tail msg -- all but the cmd prefix
-                   pluginNames = fromMaybe [] $ M.lookup key cmds
-                   plugins'    = fromMaybe [] $ mapM (flip M.lookup plugins) pluginNames
-               in mapM_ (sendToPlugin (InputMsg inputMsg)) plugins'
-             else
-               mapM_ (sendToPlugin (InputMsg inputMsg)) (M.elems plugins)
-      else
-        return ()
-dispatchCommand _ = return ()
-
+-- | Registers a plugin's command
 registerCommand :: String -> String -> IrcBot ()
 registerCommand cmd pluginName' = do
     bot     <- get
     cmds    <- gets botCommands
-    exists <- pluginExists pluginName'
-    -- TODO : improve this crap and remove at least one if!
-    if exists
-      then
-        let cmds' = if cmd `M.member` cmds
-                      then cmds
-                      else M.singleton cmd []
-            -- TODO : remove duplicates ?
-            newCmds = M.adjust (++ [pluginName']) cmd cmds'
-        in put $ bot { botCommands = newCmds }
-      else
-        traceM $ inColor ("Couldn't register command \"" ++ cmd ++ "\" for plugin \""
-                          ++ pluginName' ++ "\" : plugin does not exists") [31]
+    plugins <- gets botPlugins
+    case M.lookup pluginName' plugins of
+        Just _  -> let pluginNames = pluginName' : fromMaybe [] (M.lookup cmd cmds) -- TODO : remove/check for duplicates ?
+                       newCmds     = M.insert cmd pluginNames cmds
+                   in  put $ bot { botCommands = newCmds }
+        Nothing -> traceM $ inColor ("Couldn't register command \"" ++ cmd ++ "\" for plugin \""
+                                     ++ pluginName' ++ "\" : plugin does not exists") [31]
 
+-- | Unregisters a plugin's command
 unregisterCommand :: String -> String -> IrcBot ()
 unregisterCommand cmd pluginName' = do
     bot    <- get
@@ -61,3 +36,37 @@ unregisterCommand cmd pluginName' = do
     let newCmds = M.adjust (L.delete pluginName') cmd cmds
     put $ bot { botCommands = newCmds }
 
+--
+-- TODO Clean this crap
+--
+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 ()
+dispatchMessage _ = return ()
+
+-- | 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]
+processInternalCommand _ = return ()
+

Hsbot/Core.hs

@@ -1,6 +1,7 @@
 module Hsbot.Core
     ( connectServer
     , disconnectServer
+    , emptyMsg
     ) where
 
 import Control.Concurrent
@@ -52,3 +53,6 @@ botReader handle chan = forever $ do
         _ -> do
             return ()
 
+emptyMsg :: IrcMsg
+emptyMsg = IrcMsg Nothing "EMPTY" []
+

Hsbot/IRC.hs

@@ -5,11 +5,9 @@ module Hsbot.IRC
 
 import Control.Concurrent.Chan
 import Control.Monad.State
-import qualified Data.Map as M
 
 import Hsbot.Command
 import Hsbot.IRCParser
-import Hsbot.Plugin
 import Hsbot.Types
 import Hsbot.Utils
 
@@ -27,17 +25,12 @@ initServer = do
 runServer :: IrcBot ()
 runServer = do
     chan    <- gets botChannel
-    plugins <- gets botPlugins
     let input = readChan chan
     msg <- liftIO input
     case msg of
-        InputMsg inputMsg   -> do
-            dispatchCommand $ InputMsg inputMsg
-            mapM_ (sendToPlugin (InputMsg inputMsg) . snd) (M.toList plugins)
-        OutputMsg outputMsg ->
-            sendstr (serializeIrcMsg outputMsg)
-        InternalCmd _       ->
-            traceM "TODO internal command"
+        InputMsg inputMsg       -> dispatchMessage $ InputMsg inputMsg
+        OutputMsg outputMsg     -> sendstr (serializeIrcMsg outputMsg)
+        InternalCmd internalCmd -> processInternalCommand $ InternalCmd internalCmd
     runServer
 
 -- | Joins a chan

Hsbot/Plugin.hs

@@ -1,6 +1,5 @@
 module Hsbot.Plugin
     ( loadPlugin
-    , pluginExists
     , sendToPlugin
     ) where
 
@@ -61,9 +60,3 @@ sendToPlugin msg plugin = do
     let chan = pluginChannel plugin
     liftIO $ writeChan chan msg
 
--- | Tells if a plugin is loaded or not
-pluginExists :: String -> IrcBot Bool
-pluginExists name = do
-    plugins <- gets botPlugins
-    return $ name `M.member` plugins
-

Hsbot/Types.hs

@@ -84,10 +84,11 @@ 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
-    { intCmd :: String -- the internal command
-    , intMsg :: IrcMsg -- the IrcMsg associated with the command
-    }
+    { internalCommand    :: String -- the internal command
+    , internalCommandMsg :: IrcMsg -- the IrcMsg associated with the command
+    } deriving (Show)
 
 -- | A plugin definition
 data Plugin = Plugin

Hsbot/Utils.hs

@@ -31,3 +31,8 @@ trace msg = putStrLn msg
 traceM :: String -> IrcBot ()
 traceM msg = liftIO $ putStrLn msg
 
+-----------------
+-- | Helpers | --
+-----------------
+-- sendRegister
+

Plugins/Quote.hs

@@ -0,0 +1,47 @@
+module Plugins.Quote
+    ( mainQuote
+    ) where
+
+import Control.Concurrent.Chan
+import Control.Monad.State
+import System.Time (ClockTime)
+
+import Hsbot.Core
+import Hsbot.Types
+import Hsbot.Utils
+
+-- | A quote object
+data Quote = Quote
+    { quoter    :: String
+    , quote     :: [String]
+    , quoteTime :: ClockTime
+    , votes     :: Int
+    } deriving (Show)
+
+-- | A QuoteBot state
+type QuoteDB = [Quote]
+
+-- | The QuoteBot monad
+type QuoteBot a = StateT QuoteDB IO a
+
+-- | The main function of the Quote module
+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 ()
+

TODO

@@ -1,7 +1,14 @@
 * 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
 * unload plugin
+* plugin reload
+* list modules command
 * part chan
+* add admin check for cmds
 
 * restore \r in IRCParser