summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--Config.hs10
-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
-rw-r--r--Plugins/Core.hs49
-rw-r--r--Plugins/Ping.hs29
-rw-r--r--Plugins/Quote.hs49
-rw-r--r--TODO17
12 files changed, 244 insertions, 87 deletions
diff --git a/Config.hs b/Config.hs
index 0af7b81..fd5619e 100644
--- a/Config.hs
+++ b/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
}
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
diff --git a/Plugins/Core.hs b/Plugins/Core.hs
new file mode 100644
index 0000000..a15cc62
--- /dev/null
+++ b/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
+
diff --git a/Plugins/Ping.hs b/Plugins/Ping.hs
index 46351aa..6102fe4 100644
--- a/Plugins/Ping.hs
+++ b/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 ()
diff --git a/Plugins/Quote.hs b/Plugins/Quote.hs
index 6547cd1..4c6e22c 100644
--- a/Plugins/Quote.hs
+++ b/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 ()
diff --git a/TODO b/TODO
index 451ee77..ebe4450 100644
--- a/TODO
+++ b/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
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-14 17:31:35 +0000