From cf68de02be3e9695c95b0d1fafdab5ab2c0fc5f7 Mon Sep 17 00:00:00 2001
From: Julien Dessaux
Date: Thu, 4 Feb 2010 20:40:16 +0100
Subject: Added command registering and dispatching for plugins.

---
 Config.hs        |  4 ++--
 Hsbot.hs         |  2 ++
 Hsbot/Command.hs | 52 ++++++++++++++++++++++++++++++++++++++++++++++++++++
 Hsbot/IRC.hs     |  8 +++++---
 Hsbot/Types.hs   | 22 +++++++++++-----------
 TODO             |  7 +++++++
 6 files changed, 79 insertions(+), 16 deletions(-)
 create mode 100644 Hsbot/Command.hs
 create mode 100644 TODO

diff --git a/Config.hs b/Config.hs
index 50ddcfc..5bbb992 100644
--- a/Config.hs
+++ b/Config.hs
@@ -26,7 +26,7 @@ kro = IrcServer
 -- | User configuration
 config :: Config
 config = Config
-    { commandPrefixes = ['@']
-    , ircServer       = kro
+    { commandPrefix = '@'
+    , ircServer     = kro
     }
 
diff --git a/Hsbot.hs b/Hsbot.hs
index 7275b81..d4c1769 100644
--- a/Hsbot.hs
+++ b/Hsbot.hs
@@ -1,5 +1,6 @@
 module Hsbot
     ( module Config
+    , module Hsbot.Command
     , module Hsbot.Core
     , module Hsbot.IRC
     , module Hsbot.IRCParser
@@ -10,6 +11,7 @@ module Hsbot
     ) where
 
 import Config
+import Hsbot.Command
 import Hsbot.Core
 import Hsbot.IRC
 import Hsbot.IRCParser
diff --git a/Hsbot/Command.hs b/Hsbot/Command.hs
new file mode 100644
index 0000000..20e5525
--- /dev/null
+++ b/Hsbot/Command.hs
@@ -0,0 +1,52 @@
+module Hsbot.Command
+    ( dispatchCommand
+    , registerCommand
+    ) where
+
+import Control.Monad.State
+import qualified Data.Map as M
+import Data.Maybe
+
+import Config
+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 ()
+
+registerCommand :: String -> String -> IrcBot ()
+registerCommand cmd pluginName' = do
+    bot     <- get
+    cmds    <- gets botCommands
+    exists <- pluginExists pluginName'
+    if exists
+      then
+        let cmds' = if cmd `M.member` cmds
+                      then cmds
+                      else M.singleton cmd []
+            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]
+
diff --git a/Hsbot/IRC.hs b/Hsbot/IRC.hs
index a8f3fcb..c10467e 100644
--- a/Hsbot/IRC.hs
+++ b/Hsbot/IRC.hs
@@ -7,6 +7,7 @@ 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
@@ -30,12 +31,13 @@ runServer = do
     let input = readChan chan
     msg <- liftIO input
     case msg of
-        InputMsg inputMsg ->
+        InputMsg inputMsg   -> do
+            dispatchCommand $ InputMsg inputMsg
             mapM_ (sendToPlugin (InputMsg inputMsg) . snd) (M.toList plugins)
         OutputMsg outputMsg ->
             sendstr (serializeIrcMsg outputMsg)
-        InternalCmd internalCmd ->
-            traceM "TODO"
+        InternalCmd _       ->
+            traceM "TODO internal command"
     runServer
 
 -- | Joins a chan
diff --git a/Hsbot/Types.hs b/Hsbot/Types.hs
index 7a37035..5522404 100644
--- a/Hsbot/Types.hs
+++ b/Hsbot/Types.hs
@@ -22,10 +22,10 @@ import System.Time (ClockTime)
 -- | TODO : a monad for a channel, and a monad for a server, all together driven by a Bot?
 
 -- | Configuration data type
-data Config = Config {
-   commandPrefixes :: String,   -- command prefixes, for example @[\'>\',\'@\',\'?\']@
-   ircServer       :: IrcServer -- list of 'Server's to connect to
-} deriving (Show)
+data Config = Config
+    { commandPrefix :: Char      -- command prefixes, for example @[\'>\',\'@\',\'?\']@
+    , ircServer     :: IrcServer -- list of 'Server's to connect to
+    } deriving (Show)
 
 -- | An IRC server
 data IrcServer = IrcServer
@@ -76,19 +76,19 @@ data Channel = Channel
     , channelAdmins :: [String] -- the bot administrators
     } deriving (Show)
 
--- | A Bot command
-data IntCmd = IntCmd
-    { intCmd       :: String   -- the bot's internal command
-    , intCmdParams :: [String] -- the parameters
-    } deriving (Show)
-
--- |An IRC message.
+-- | An IRC message
 data IrcMsg = IrcMsg
     { prefix     :: Maybe String -- the message prefix
     , command    :: String       -- the message command
     , parameters :: [String]     -- the message parameters
     } deriving (Show)
 
+-- | An internal command
+data IntCmd = IntCmd
+    { intCmd :: String -- the internal command
+    , intMsg :: IrcMsg -- the IrcMsg associated with the command
+    }
+
 -- | A plugin definition
 data Plugin = Plugin
     { pluginName     :: String      -- The plugin's name
diff --git a/TODO b/TODO
new file mode 100644
index 0000000..6b06f7a
--- /dev/null
+++ b/TODO
@@ -0,0 +1,7 @@
+* implement InternalCommands "register command"
+* unregister command, add it to internal commands
+* kill threads
+* unload plugin
+
+* restore \r in IRCParser
+
-- 
cgit v1.2.3