summaryrefslogtreecommitdiff
path: root/Hsbot
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--Hsbot.hs30
-rw-r--r--Hsbot/Command.hs87
-rw-r--r--Hsbot/Config.hs18
-rw-r--r--Hsbot/Core.hs110
-rw-r--r--Hsbot/IRC.hs45
-rw-r--r--Hsbot/IRCPlugin.hs66
-rw-r--r--Hsbot/Irc/Command.hs59
-rw-r--r--Hsbot/Irc/Config.hs34
-rw-r--r--Hsbot/Irc/Core.hs142
-rw-r--r--Hsbot/Irc/Message.hs (renamed from Hsbot/IRCParser.hs)30
-rw-r--r--Hsbot/Irc/Plugin.hs80
-rw-r--r--Hsbot/Irc/Plugin/Core.hs (renamed from Plugins/Core.hs)38
-rw-r--r--Hsbot/Irc/Plugin/Dummy.hs30
-rw-r--r--Hsbot/Irc/Plugin/Ping.hs36
-rw-r--r--Hsbot/Irc/Plugin/Quote.hs (renamed from Plugins/Quote.hs)71
-rw-r--r--Hsbot/Irc/PluginCommons.hs67
-rw-r--r--Hsbot/Irc/Server.hs35
-rw-r--r--Hsbot/Irc/Types.hs48
-rw-r--r--Hsbot/Irc/doc/rfc2812.txt (renamed from doc/rfc2812.txt)0
-rw-r--r--Hsbot/Main.hs36
-rw-r--r--Hsbot/Message.hs15
-rw-r--r--Hsbot/Plugin.hs65
-rw-r--r--Hsbot/Types.hs108
-rw-r--r--Hsbot/Utils.hs42
24 files changed, 723 insertions, 569 deletions
diff --git a/Hsbot.hs b/Hsbot.hs
deleted file mode 100644
index a504784..0000000
--- a/Hsbot.hs
+++ /dev/null
@@ -1,30 +0,0 @@
-module Hsbot
- ( module Config
- , module Hsbot.Command
- , module Hsbot.Core
- , module Hsbot.IRC
- , module Hsbot.IRCParser
- , module Hsbot.IRCPlugin
- , module Hsbot.Main
- , module Hsbot.Plugin
- , module Hsbot.Types
- , module Hsbot.Utils
- , module Plugins.Core
- , module Plugins.Ping
- , module Plugins.Quote
- ) where
-
-import Config
-import Hsbot.Command
-import Hsbot.Core
-import Hsbot.IRC
-import Hsbot.IRCParser
-import Hsbot.IRCPlugin
-import Hsbot.Main
-import Hsbot.Plugin
-import Hsbot.Types
-import Hsbot.Utils
-import Plugins.Core
-import Plugins.Ping
-import Plugins.Quote
-
diff --git a/Hsbot/Command.hs b/Hsbot/Command.hs
deleted file mode 100644
index 4653618..0000000
--- a/Hsbot/Command.hs
+++ /dev/null
@@ -1,87 +0,0 @@
-module Hsbot.Command
- ( dispatchMessage
- , processInternalCommand
- , registerCommand
- , unregisterCommand
- ) where
-
-import Control.Monad.State
-import qualified Data.List as L
-import qualified Data.Map as M
-import Data.Maybe
-
-import Config
-import Hsbot.Plugin
-import Hsbot.Types
-import Hsbot.Utils
-
--- | Registers a plugin's command
-registerCommand :: String -> String -> IrcBot ()
-registerCommand cmd pluginName' = do
- bot <- get
- cmds <- gets botCommands
- 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
- cmds <- gets botCommands
- let newCmds = M.adjust (L.delete pluginName') cmd cmds
- put $ bot { botCommands = newCmds }
-
--- | Dispatches an input message
-dispatchMessage :: BotMsg -> IrcBot ()
-dispatchMessage (InputMsg inputMsg)
- | isPluginCommand = do
- plugins <- gets botPlugins
- cmds <- gets botCommands
- let key = tail . head $ words getMsgContent
- pluginNames = fromMaybe [] $ M.lookup key cmds
- plugins' = fromMaybe [] $ mapM (flip M.lookup plugins) pluginNames
- mapM_ (sendRunCommand $ tail getMsgContent) plugins'
- | otherwise = do
- plugins <- gets botPlugins
- 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 inputMsg) plugin
- getMsgContent :: String
- getMsgContent = unwords . tail $ parameters inputMsg
-dispatchMessage _ = return ()
-
--- | Processes an internal command
-processInternalCommand :: BotMsg -> IrcBot ()
-processInternalCommand (InternalCmd intCmd) = do
- plugins <- gets botPlugins
- if intCmdTo intCmd == "CORE"
- then processCoreCommand intCmd
- else case M.lookup (intCmdTo intCmd) plugins of
- Just plugin -> sendToPlugin (InternalCmd intCmd) plugin
- Nothing -> errorM $ "Invalid destination in message : " ++ (show intCmd)
-processInternalCommand _ = return ()
-
--- | Processes a core command
-processCoreCommand :: IntCmd -> IrcBot ()
-processCoreCommand intCmd = do
- let command' = intCmdCmd intCmd
- originalRequest = intCmdBotMsg intCmd
- case command' of
- "LIST" -> listPlugins originalRequest (intCmdFrom intCmd)
- "LOAD" -> traceM $ inColor "hsbot has been compiled in static mode." [31]
- "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/Config.hs b/Hsbot/Config.hs
new file mode 100644
index 0000000..9ce62c5
--- /dev/null
+++ b/Hsbot/Config.hs
@@ -0,0 +1,18 @@
+module Hsbot.Config
+ ( Config(..)
+ , defaultConfig
+ ) where
+
+import Hsbot.Irc.Config (IrcConfig)
+
+-- | Configuration data type
+data Config = Config
+ { ircConfigs :: [IrcConfig]
+ }
+
+-- | User configuration
+defaultConfig :: Config
+defaultConfig = Config
+ { ircConfigs = []
+ }
+
diff --git a/Hsbot/Core.hs b/Hsbot/Core.hs
index ab2989a..cae873b 100644
--- a/Hsbot/Core.hs
+++ b/Hsbot/Core.hs
@@ -1,71 +1,69 @@
module Hsbot.Core
- ( connectServer
- , disconnectServer
+ ( hsbot
) where
import Control.Concurrent
-import Control.Concurrent.Chan()
-import Control.Exception(IOException, catch)
+import Control.Concurrent.Chan ()
+import Control.Exception
import Control.Monad.State
-import Data.List()
import qualified Data.Map as M
-import Network
+import Data.Time
import Prelude hiding (catch)
-import System.IO
-import System.Time (getClockTime)
+import System.IO()
-import Hsbot.IRCParser
+import Hsbot.Config
+import Hsbot.Irc.Config
+import Hsbot.Irc.Core (ircbot)
+import Hsbot.Message
import Hsbot.Plugin
-import Hsbot.Types
-import Hsbot.Utils
--- Connect to the server and return the initial bot state
-connectServer :: IrcServer -> IO Bot
-connectServer server = do
- let name = serverAddress server
- starttime <- getClockTime
- putStr $ "Connecting to " ++ name ++ "... "
- handle <- connectTo name $ serverPort server
- hSetBuffering handle NoBuffering
- putStrLn "done."
- putStr "Opening server communication channel... "
+-- | The Bot monad
+type Bot = StateT BotState IO
+
+-- | An Hsbot state
+data BotState = BotState
+ { botStartTime :: UTCTime -- the bot's uptime
+ , botPlugins :: M.Map String PluginState -- Loaded plugins
+ , botChan :: Chan BotMsg -- The bot's communication channel
+ , botConfig :: Config -- the bot's starting config
+ }
+
+-- | Bot's main entry point
+hsbot :: Config -> IO ()
+hsbot config = do
+ startTime <- getCurrentTime
+ putStrLn "[Hsbot] Opening communication channel... "
chan <- newChan :: IO (Chan BotMsg)
- myFatherThreadId <- myThreadId
- threadId <- forkIO $ botReader handle chan myFatherThreadId
- putStrLn "done."
- return $ Bot server starttime handle [] M.empty chan threadId M.empty
+ putStrLn "[Hsbot] Spawning IrcBot plugins... "
+ botState <- execStateT spawnIrcPlugins BotState { botStartTime = startTime
+ , botPlugins = M.empty
+ , botChan = chan
+ , botConfig = config }
+ putStrLn "[Hsbot] Entering main loop... "
+ botState' <- (execStateT botLoop botState) `catch` (\(_ :: IOException) -> return botState)
+ return ()
--- | Disconnect from the server
-disconnectServer :: IrcBot ()
-disconnectServer = do
- bot <- get
- let name = serverAddress $ serverConfig bot
- liftIO $ putStr "Shutting down plugins..."
- mapM_ unloadPlugin (M.keys $ botPlugins bot)
- liftIO $ putStrLn"done."
- liftIO $ putStr "Closing server communication channel... "
- liftIO . killThread $ readerThreadId bot
- liftIO $ putStrLn "done."
- liftIO . putStr $ "Disconnecting from " ++ name ++ "... "
- liftIO . hClose $ botHandle bot
- liftIO $ putStrLn "done."
+-- | Run the bot main loop
+botLoop :: Bot ()
+botLoop = forever $ do
+ chan <- gets botChan
+ msg <- liftIO $ readChan chan
+ -- process messages
+ return ()
--- | Socket reading loop
-botReader :: Handle -> Chan BotMsg -> ThreadId -> IO ()
-botReader handle chan fatherThreadId = forever $ do
- str <- (hGetLine handle) `catch` handleIOException
- let msg = parseIrcMsg str
- case msg of
- Right msg' -> do
- trace $ inColor ("<-- " ++ (show msg')) [33]
- writeChan chan (InputMsg msg')
- _ -> do
- return ()
+-- | spawns IrcPlugins
+spawnIrcPlugins :: Bot ()
+spawnIrcPlugins = do
+ config <- gets botConfig
+ mapM_ (spawnIrcPlugin) (ircConfigs config)
where
- handleIOException :: IOException -> IO (String)
- handleIOException ioException = do
- throwTo fatherThreadId ioException
- myId <- myThreadId
- killThread myId
- return ""
+ spawnIrcPlugin :: IrcConfig -> Bot ()
+ spawnIrcPlugin config = do
+ bot <- get
+ let chan = botChan bot
+ pchan <- liftIO (newChan :: IO (Chan BotMsg))
+ threadId <- liftIO $ forkIO (ircbot config chan pchan)
+ let plugin = PluginState (ircConfigName config) threadId pchan M.empty
+ plugins = botPlugins bot
+ put $ bot { botPlugins = M.insert (pluginName plugin) plugin plugins }
diff --git a/Hsbot/IRC.hs b/Hsbot/IRC.hs
deleted file mode 100644
index 4a0e5f8..0000000
--- a/Hsbot/IRC.hs
+++ /dev/null
@@ -1,45 +0,0 @@
-module Hsbot.IRC
- ( initServer
- , runServer
- ) where
-
-import Control.Concurrent.Chan
-import Control.Monad.State
-
-import Hsbot.Command
-import Hsbot.IRCParser
-import Hsbot.Types
-import Hsbot.Utils
-
--- | Setup a newly connected server by sending nick and join stuff
-initServer :: IrcBot ()
-initServer = do
- server <- gets serverConfig
- sendstr . serializeIrcMsg $ IrcMsg Nothing "NICK" [(nickname server)]
- sendstr . serializeIrcMsg $ IrcMsg Nothing "USER" [(nickname server), "0", "*", (realname server)]
- when (not . null $ password server) $ do
- sendstr . serializeIrcMsg $ IrcMsg Nothing "PRIVMSG" ["nickserv", "identify", (password server)]
- mapM_ joinChan (joinChannels server)
-
--- | Run a server
-runServer :: IrcBot ()
-runServer = forever $ do
- chan <- gets botChannel
- let input = readChan chan
- msg <- liftIO input
- case msg of
- InputMsg inputMsg -> dispatchMessage $ InputMsg inputMsg
- OutputMsg outputMsg -> sendstr (serializeIrcMsg outputMsg)
- InternalCmd internalCmd -> processInternalCommand $ InternalCmd internalCmd
-
--- | Joins a chan
-joinChan :: String -> IrcBot ()
-joinChan name = do
- bot <- get
- let oldChannels = chans bot
- newChannel = Channel name
- (nickname $ serverConfig bot)
- (administrators $ serverConfig bot)
- sendstr . serializeIrcMsg $ IrcMsg Nothing "JOIN" [name]
- put $ bot { chans = newChannel : oldChannels }
-
diff --git a/Hsbot/IRCPlugin.hs b/Hsbot/IRCPlugin.hs
deleted file mode 100644
index e0299fc..0000000
--- a/Hsbot/IRCPlugin.hs
+++ /dev/null
@@ -1,66 +0,0 @@
-module Hsbot.IRCPlugin
- ( IrcPlugin
- , PluginState(..)
- , answerMsg
- , readMsg
- , sendCommand
- , sendCommandWithRequest
- , sendRegisterCommand
- , sendUnregisterCommand
- , writeMsg
- ) where
-
-import Control.Concurrent.Chan
-import Control.Monad.State
-import Data.Maybe(fromMaybe)
-
-import Hsbot.Types
-
--- | The IrcPlugin monad
-type IrcPlugin a = StateT PluginState IO a
-
--- | An IRCPlugin state
-data PluginState = PluginState
- { instanceName :: String -- The plugin's name
- , instanceServerChan :: Chan BotMsg -- The server channel
- , instanceChan :: Chan BotMsg -- The plugin channel
- }
-
--- | 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
-
-answerMsg :: IrcMsg -> String -> IrcPlugin ()
-answerMsg request msg = do
- let chanOrigin = head $ parameters request
- sender = takeWhile (/= '!') $ fromMaybe "" (prefix request)
- case head chanOrigin of
- '#' -> writeMsg . OutputMsg $ IrcMsg Nothing "PRIVMSG" [chanOrigin, msg]
- _ -> writeMsg . OutputMsg $ IrcMsg Nothing "PRIVMSG" [sender, msg]
-
--- | Commands management
-sendCommand :: String -> String -> String -> IrcPlugin ()
-sendCommand cmd to params = sendCommandWithRequest cmd to params emptyIrcMsg
-
-sendCommandWithRequest :: String -> String -> String -> IrcMsg -> IrcPlugin ()
-sendCommandWithRequest cmd to params originalRequest = do
- serverChan <- gets instanceServerChan
- from <- gets instanceName
- liftIO . writeChan serverChan . InternalCmd $ IntCmd cmd from to params originalRequest
-
-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/Irc/Command.hs b/Hsbot/Irc/Command.hs
new file mode 100644
index 0000000..3f5c8c1
--- /dev/null
+++ b/Hsbot/Irc/Command.hs
@@ -0,0 +1,59 @@
+module Hsbot.Irc.Command
+ ( processInternalCommand
+ , registerCommand
+ , unregisterCommand
+ ) where
+
+import Control.Monad.State
+import qualified Data.List as L
+import qualified Data.Map as M
+import Data.Maybe
+
+import Hsbot.Irc.Message
+import Hsbot.Irc.Plugin
+import Hsbot.Irc.Types
+
+-- | Registers a plugin's command
+registerCommand :: String -> String -> IrcBot ()
+registerCommand cmd pluginName' = do
+ ircBot <- get
+ let cmds = ircBotCommands ircBot
+ plugins = ircBotPlugins ircBot
+ 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 $ ircBot { ircBotCommands = newCmds }
+ Nothing -> return ()
+
+-- | Unregisters a plugin's command
+unregisterCommand :: String -> String -> IrcBot ()
+unregisterCommand cmd pluginName' = do
+ ircBot <- get
+ let cmds = ircBotCommands ircBot
+ newCmds = M.adjust (L.delete pluginName') cmd cmds
+ put $ ircBot { ircBotCommands = newCmds }
+
+-- | Processes an internal command
+processInternalCommand :: IrcBotMsg -> IrcBot ()
+processInternalCommand (IntIrcCmd ircCmd)
+ | ircCmdTo ircCmd == "CORE" = processCoreCommand ircCmd
+ | otherwise = do
+ plugins <- gets ircBotPlugins
+ case M.lookup (ircCmdTo ircCmd) plugins of
+ Just plugin -> sendToPlugin (IntIrcCmd ircCmd) plugin
+ Nothing -> return ()
+processInternalCommand _ = return ()
+
+-- | Processes a core command
+processCoreCommand :: IrcCmd -> IrcBot ()
+processCoreCommand ircCmd = do
+ let command' = ircCmdCmd ircCmd
+ originalRequest = ircCmdBotMsg ircCmd
+ case command' of
+ "LIST" -> listPlugins originalRequest (ircCmdFrom ircCmd)
+ "LOAD" -> loadIrcPlugin $ ircCmdMsg ircCmd
+ "UNLOAD" -> unloadPlugin $ ircCmdMsg ircCmd
+ "REGISTER" -> registerCommand (ircCmdMsg ircCmd) (ircCmdFrom ircCmd)
+ "UNREGISTER" -> unregisterCommand (ircCmdMsg ircCmd) (ircCmdFrom ircCmd)
+ _ -> return ()
+
diff --git a/Hsbot/Irc/Config.hs b/Hsbot/Irc/Config.hs
new file mode 100644
index 0000000..5075c36
--- /dev/null
+++ b/Hsbot/Irc/Config.hs
@@ -0,0 +1,34 @@
+module Hsbot.Irc.Config
+ ( IrcConfig(..)
+ , ircDefaultConfig
+ ) where
+
+import Network
+
+-- | Configuration data type
+data IrcConfig = IrcConfig
+ { ircConfigName :: String -- The configuration name
+ , ircConfigAddress :: String -- the server's address
+ , ircConfigPort :: PortID -- the server's port
+ , ircConfigChannels :: [String] -- the Channels to join on start
+ , ircConfigNickname :: String -- the hsbot's nickname
+ , ircConfigPassword :: String -- the hsbot's password, optional
+ , ircConfigRealname :: String -- the hsbot's real name, optional
+ , ircConfigCommandPrefix :: Char -- the prefix the ircbot will recognize as commands
+ , ircConfigPlugins :: [String] -- the ircPlugins to load
+ }
+
+-- | User configuration
+ircDefaultConfig :: IrcConfig
+ircDefaultConfig = IrcConfig
+ { ircConfigName = "localhost"
+ , ircConfigAddress = "localhost"
+ , ircConfigPort = PortNumber 6667
+ , ircConfigChannels = ["#hsbot"]
+ , ircConfigNickname = "hsbot"
+ , ircConfigPassword = ""
+ , ircConfigRealname = "The One True bot, with it's haskell soul."
+ , ircConfigCommandPrefix = '@'
+ , ircConfigPlugins = ["Ping"]
+ }
+
diff --git a/Hsbot/Irc/Core.hs b/Hsbot/Irc/Core.hs
new file mode 100644
index 0000000..ac51419
--- /dev/null
+++ b/Hsbot/Irc/Core.hs
@@ -0,0 +1,142 @@
+module Hsbot.Irc.Core
+ ( ircbot
+ ) where
+
+import Control.Concurrent
+import Control.Exception (IOException, catch)
+import Control.Monad.State
+import qualified Data.Map as M
+import Data.Maybe (fromMaybe)
+import Data.Time
+import Network
+import Prelude hiding (catch)
+import System.IO
+
+import Hsbot.Irc.Command
+import Hsbot.Irc.Config
+import Hsbot.Irc.Message
+import Hsbot.Irc.Plugin
+import Hsbot.Irc.Server
+import Hsbot.Irc.Types
+import Hsbot.Message (BotMsg)
+
+-- | IrcBot's main entry point
+ircbot :: IrcConfig -> Chan BotMsg -> Chan BotMsg -> IO ()
+ircbot config masterChan myChan = do
+ startTime <- getCurrentTime
+ putStrLn "[IrcBot] Opening communication channel... "
+ chan <- newChan :: IO (Chan IrcBotMsg)
+ putStrLn $ concat ["[IrcBot] Connecting to ", ircConfigAddress config, "... "]
+ handle <- connectTo (ircConfigAddress config) (ircConfigPort config)
+ hSetBuffering handle NoBuffering
+ myOwnThreadId <- myThreadId
+ putStrLn "[IrcBot] Spawning reader threads..."
+ readerThreadId <- forkIO $ ircBotReader handle chan myOwnThreadId
+ masterReaderThreadId <- forkIO $ ircBotMasterReader masterChan chan
+ putStrLn "[IrcBot] Initializing server connection..."
+ let ircServerState = IrcServerState { ircServerId = ircConfigAddress config
+ , ircServerChannels = []
+ , ircServerNickname = ircConfigNickname config
+ , ircServerCommandPrefix = ircConfigCommandPrefix config
+ , ircServerChan = chan }
+ ircBotState = IrcBotState { ircBotStartTime = startTime
+ , ircBotPlugins = M.empty
+ , ircBotCommands = M.empty
+ , ircBotChan = chan
+ , ircBotMasterChan = masterChan
+ , ircBotMyChan = myChan
+ , ircBotServerState = ircServerState
+ , ircBotHandle = handle
+ , ircBotConfig = config
+ , ircBotReaderThreadId = readerThreadId
+ , ircBotMasterReaderThreadId = masterReaderThreadId }
+ ircBotState' <- execStateT (initBotServerConnection config) ircBotState
+ putStrLn "[IrcBot] Entering main loop... "
+ _ <- ircBotLoop ircBotState' `catch` (\(_ :: IOException) -> return ())
+ return ()
+
+-- | Runs the IrcBot's reader loop
+ircBotReader :: Handle -> Chan IrcBotMsg -> ThreadId -> IO ()
+ircBotReader handle chan fatherThreadId = forever $ do
+ str <- (hGetLine handle) `catch` handleIOException
+ let msg = parseIrcMsg str
+ case msg of
+ Right msg' -> writeChan chan (InIrcMsg msg')
+ _ -> return ()
+ where
+ handleIOException :: IOException -> IO (String)
+ handleIOException ioException = do
+ throwTo fatherThreadId ioException
+ myId <- myThreadId
+ killThread myId
+ return ""
+
+-- | Reads the Master's chan
+ircBotMasterReader :: Chan BotMsg -> Chan IrcBotMsg -> IO ()
+ircBotMasterReader masterChan _ = forever $ do
+ _ <- readChan masterChan
+ return ()
+ -- TODO : handle botMsg
+
+-- | Initialize the bot's server connection
+initBotServerConnection :: IrcConfig -> IrcBot ()
+initBotServerConnection config = do
+ ircBot <- get
+ let ircServerState = ircBotServerState ircBot
+ ircServerState' <- execStateT (initServerConnection config) ircServerState
+ put $ ircBot { ircBotServerState = ircServerState' }
+
+-- | IrcBot's loop that can catch ircbot's states' updates
+ircBotLoop :: IrcBotState -> IO ()
+ircBotLoop ircBotState = do
+ putStrLn "[IrcBot] Spawning plugins..."
+ ircBotState' <- execStateT spawnIrcPlugins ircBotState
+ -- Todo : throw new ircbotstate to hsbot
+ putStrLn "[IrcBot] Entering Core loop... "
+ _ <- (execStateT ircBotCore ircBotState') -- `catch` (\(_ :: NewBotStateException) -> return ircBotState')
+ return ()
+ -- TODO : loop!
+
+-- | Run the IrcBot's main loop
+ircBotCore :: IrcBot ()
+ircBotCore = forever $ do
+ ircBot <- get
+ let chan = ircBotChan ircBot
+ msg <- liftIO $ readChan chan
+ case msg of
+ InIrcMsg inIrcMsg -> dispatchMessage $ InIrcMsg inIrcMsg
+ OutIrcMsg outIrcMsg -> sendThisMessage outIrcMsg
+ IntIrcCmd intIrcCmd -> do
+ processInternalCommand $ IntIrcCmd intIrcCmd
+ where
+ sendThisMessage :: IrcMsg -> IrcBot ()
+ sendThisMessage outputMsg = do
+ let str = serializeIrcMsg outputMsg
+ handle <- gets ircBotHandle
+ liftIO $ hPutStr handle (str ++ "\r\n")
+
+-- | Dispatches an input message
+dispatchMessage :: IrcBotMsg -> IrcBot ()
+dispatchMessage (InIrcMsg inIrcMsg) = do
+ config <- gets ircBotConfig
+ plugins <- gets ircBotPlugins
+ cmds <- gets ircBotCommands
+ if (isPluginCommand config)
+ 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 $ InIrcMsg inIrcMsg) (M.elems plugins)
+ where
+ isPluginCommand :: IrcConfig -> Bool
+ isPluginCommand config =
+ and [ ircMsgCommand inIrcMsg == "PRIVMSG"
+ , (head getMsgContent) == ircConfigCommandPrefix config ]
+ sendRunCommand :: String -> IrcPluginState -> IrcBot ()
+ sendRunCommand cmd plugin = sendToPlugin (IntIrcCmd $ IrcCmd "RUN" "CORE" (ircPluginName plugin) cmd inIrcMsg) plugin
+ getMsgContent :: String
+ getMsgContent = unwords . tail $ ircMsgParameters inIrcMsg
+dispatchMessage _ = return ()
+
diff --git a/Hsbot/IRCParser.hs b/Hsbot/Irc/Message.hs
index d284377..e92a9d0 100644
--- a/Hsbot/IRCParser.hs
+++ b/Hsbot/Irc/Message.hs
@@ -1,5 +1,8 @@
-module Hsbot.IRCParser
- ( ParseError
+module Hsbot.Irc.Message
+ ( IrcBotMsg (..)
+ , IrcCmd (..)
+ , IrcMsg (..)
+ , emptyIrcMsg
, parseIrcMsg
, serializeIrcMsg
) where
@@ -7,7 +10,26 @@ module Hsbot.IRCParser
import Control.Monad.Identity
import Text.Parsec
-import Hsbot.Types
+-- | An IRC message
+data IrcMsg = IrcMsg
+ { ircMsgPrefix :: Maybe String -- the message prefix
+ , ircMsgCommand :: String -- the message command
+ , ircMsgParameters :: [String] -- the message parameters
+ } deriving (Show)
+
+emptyIrcMsg :: IrcMsg
+emptyIrcMsg = IrcMsg Nothing "" []
+
+-- | An internal command
+data IrcCmd = IrcCmd
+ { ircCmdCmd :: String -- the internal command
+ , ircCmdFrom :: String -- who issues it
+ , ircCmdTo :: String -- who it is destinated to
+ , ircCmdMsg :: String -- the message to be transfered
+ , ircCmdBotMsg :: IrcMsg -- An IrcMsg attached to the command
+ } deriving (Show)
+
+data IrcBotMsg = InIrcMsg IrcMsg | OutIrcMsg IrcMsg | IntIrcCmd IrcCmd deriving (Show)
-- | Parses an IrcInput
parseIrcMsg :: String -> Either ParseError IrcMsg
@@ -38,7 +60,7 @@ pLongParam = char ':' >> (many1 (noneOf "\r"))
pShortParam :: ParsecT String u Identity [Char]
pShortParam = many1 (noneOf " \r")
--- |Serialize an IRC message to a string.
+-- | Serialize an IRC message to a string.
serializeIrcMsg :: IrcMsg -> String
serializeIrcMsg (IrcMsg pfx cmd params) = pfxStr ++ cmd ++ paramStr
where pfxStr = case pfx of
diff --git a/Hsbot/Irc/Plugin.hs b/Hsbot/Irc/Plugin.hs
new file mode 100644
index 0000000..b12d922
--- /dev/null
+++ b/Hsbot/Irc/Plugin.hs
@@ -0,0 +1,80 @@
+module Hsbot.Irc.Plugin
+ ( IrcPlugin
+ , IrcPluginState (..)
+ , listPlugins
+ , loadIrcPlugin
+ , sendToPlugin
+ , spawnIrcPlugins
+ , unloadPlugin
+ ) where
+
+import Control.Concurrent
+import Control.Concurrent.Chan ()
+import Control.Exception
+import Control.Monad.State
+import qualified Data.Map as M
+
+import Hsbot.Irc.Config
+import Hsbot.Irc.Message
+import Hsbot.Irc.PluginCommons
+import Hsbot.Irc.Plugin.Core
+import Hsbot.Irc.Plugin.Dummy
+import Hsbot.Irc.Plugin.Ping
+import Hsbot.Irc.Plugin.Quote
+import Hsbot.Irc.Types
+
+-- | Sends a msg to a plugin
+sendToPlugin :: IrcBotMsg -> IrcPluginState -> IrcBot ()
+sendToPlugin ircBotMsg plugin = do
+ liftIO $ writeChan (ircPluginChan plugin) ircBotMsg
+
+-- | spawns IrcPlugins
+spawnIrcPlugins :: IrcBot ()
+spawnIrcPlugins = do
+ config <- gets ircBotConfig
+ mapM_ (loadIrcPlugin) (ircConfigPlugins config)
+
+-- | loads an ircbot plugin
+loadIrcPlugin :: String -> IrcBot ()
+loadIrcPlugin pluginName = do
+ ircbot <- get
+ let masterChan = ircBotChan ircbot
+ pluginChan <- liftIO (newChan :: IO (Chan IrcBotMsg))
+ let entryPoint = case pluginName of
+ "Core" -> ircBotPluginCore
+ "Ping" -> ircBotPluginPing
+ "Quote" -> ircBotPluginQuote
+ _ -> ircBotPluginDummy
+ let oldPlugins = ircBotPlugins ircbot
+ -- We check for unicity
+ case M.lookup pluginName oldPlugins of
+ Just plugin -> return ()
+ Nothing -> do
+ threadId <- liftIO $ forkIO (entryPoint pluginChan masterChan)
+ let plugin = IrcPluginState { ircPluginName = pluginName
+ , ircPluginThreadId = threadId
+ , ircPluginChan = pluginChan
+ , ircPluginMasterChan = masterChan }
+ put $ ircbot { ircBotPlugins = M.insert pluginName plugin oldPlugins }
+
+-- | Sends a list of loaded plugins
+listPlugins :: IrcMsg -> String -> IrcBot ()
+listPlugins originalRequest dest = do
+ plugins <- gets ircBotPlugins
+ let listing = unwords $ M.keys plugins
+ case M.lookup dest plugins of
+ Just plugin -> sendToPlugin (IntIrcCmd $ IrcCmd "ANSWER" "CORE" dest listing originalRequest) plugin
+ Nothing -> return ()
+
+-- | Unloads a plugin
+unloadPlugin :: String -> IrcBot ()
+unloadPlugin name = do
+ bot <- get
+ let oldPlugins = ircBotPlugins bot
+ case M.lookup name oldPlugins of
+ Just plugin -> do
+ let newPlugins = M.delete name oldPlugins
+ liftIO $ throwTo (ircPluginThreadId plugin) UserInterrupt
+ put $ bot { ircBotPlugins = newPlugins }
+ Nothing -> return ()
+
diff --git a/Plugins/Core.hs b/Hsbot/Irc/Plugin/Core.hs
index f81f4bf..5d69ca3 100644
--- a/Plugins/Core.hs
+++ b/Hsbot/Irc/Plugin/Core.hs
@@ -1,20 +1,23 @@
-module Plugins.Core
- ( mainCore
+module Hsbot.Irc.Plugin.Core
+ ( ircBotPluginCore
) where
-import Control.Concurrent.Chan(Chan)
+import Control.Concurrent (Chan, myThreadId)
import Control.Exception
import Control.Monad.State
import Prelude hiding (catch)
-import Hsbot.IRCPlugin
-import Hsbot.Types
-import Hsbot.Utils
+import Hsbot.Irc.Message
+import Hsbot.Irc.PluginCommons
-- | The plugin's main entry point
-mainCore :: Chan BotMsg -> Chan BotMsg -> IO ()
-mainCore serverChan chan = do
- let plugin = PluginState "Core" serverChan chan
+ircBotPluginCore :: Chan IrcBotMsg -> Chan IrcBotMsg -> IO ()
+ircBotPluginCore myChan masterChan = do
+ threadId <- myThreadId
+ let plugin = IrcPluginState { ircPluginName = "Core"
+ , ircPluginThreadId = threadId
+ , ircPluginChan = myChan
+ , ircPluginMasterChan = masterChan }
evalStateT (mapM_ sendRegisterCommand ["list", "load", "reload", "unload"]) plugin
plugin' <- (execStateT run plugin) `catch` (\(_ :: AsyncException) -> return plugin)
evalStateT (mapM_ sendUnregisterCommand ["list", "load", "reload", "unload"]) plugin'
@@ -25,21 +28,20 @@ run = forever $ do
msg <- readMsg
eval msg
where
- eval :: BotMsg -> IrcPlugin ()
- eval (InternalCmd intCmd) = do
- let request = intCmdBotMsg intCmd
- case intCmdCmd intCmd of
- "RUN" -> let stuff = words $ intCmdMsg intCmd
+ eval :: IrcBotMsg -> IrcPlugin ()
+ eval (IntIrcCmd intCmd) = do
+ let request = ircCmdBotMsg intCmd
+ case ircCmdCmd intCmd of
+ "RUN" -> let stuff = words $ ircCmdMsg intCmd
in case head stuff of
"list" -> listPlugins request
"load" -> loadPlugin $ tail stuff
"reload" -> reloadPlugin $ tail stuff
"unload" -> unloadPlugin $ tail stuff
- _ -> lift . trace $ show intCmd -- TODO : help message
- "ANSWER" -> let stuff = intCmdMsg intCmd
+ _ -> return () -- TODO : help message
+ "ANSWER" -> let stuff = ircCmdMsg intCmd
in answerMsg request ("Loaded plugins : " ++ stuff)
- _ -> lift . trace $ show intCmd
- eval (InputMsg _) = return ()
+ _ -> return ()
eval _ = return ()
-- | The list command
diff --git a/Hsbot/Irc/Plugin/Dummy.hs b/Hsbot/Irc/Plugin/Dummy.hs
new file mode 100644
index 0000000..48515ce
--- /dev/null
+++ b/Hsbot/Irc/Plugin/Dummy.hs
@@ -0,0 +1,30 @@
+module Hsbot.Irc.Plugin.Dummy
+ ( ircBotPluginDummy
+ ) where
+
+import Control.Concurrent (myThreadId)
+import Control.Concurrent.Chan
+import Control.Exception
+import Control.Monad.State
+import Prelude hiding (catch)
+
+import Hsbot.Irc.Message
+import Hsbot.Irc.PluginCommons
+
+-- | The plugin's main entry point
+ircBotPluginDummy :: Chan IrcBotMsg -> Chan IrcBotMsg -> IO ()
+ircBotPluginDummy myChan masterChan = do
+ threadId <- myThreadId
+ let plugin = IrcPluginState { ircPluginName = "Dummy"
+ , ircPluginThreadId = threadId
+ , ircPluginChan = myChan
+ , ircPluginMasterChan = masterChan }
+ _ <- (execStateT run plugin) `catch` (\(_ :: AsyncException) -> return plugin)
+ return ()
+
+-- | The IrcPlugin monad main function
+run :: IrcPlugin ()
+run = forever $ do
+ _ <- readMsg
+ return ()
+
diff --git a/Hsbot/Irc/Plugin/Ping.hs b/Hsbot/Irc/Plugin/Ping.hs
new file mode 100644
index 0000000..6a38f0d
--- /dev/null
+++ b/Hsbot/Irc/Plugin/Ping.hs
@@ -0,0 +1,36 @@
+module Hsbot.Irc.Plugin.Ping
+ ( ircBotPluginPing
+ ) where
+
+import Control.Concurrent (myThreadId)
+import Control.Concurrent.Chan
+import Control.Exception
+import Control.Monad.State
+import Prelude hiding (catch)
+
+import Hsbot.Irc.Message
+import Hsbot.Irc.PluginCommons
+
+-- | The plugin's main entry point
+ircBotPluginPing :: Chan IrcBotMsg -> Chan IrcBotMsg -> IO ()
+ircBotPluginPing myChan masterChan = do
+ threadId <- myThreadId
+ let plugin = IrcPluginState { ircPluginName = "Ping"
+ , ircPluginThreadId = threadId
+ , ircPluginChan = myChan
+ , ircPluginMasterChan = masterChan }
+ _ <- (execStateT run plugin) `catch` (\(_ :: AsyncException) -> return plugin)
+ return ()
+
+-- | The IrcPlugin monad main function
+run :: IrcPlugin ()
+run = forever $ do
+ msg <- readMsg
+ eval msg
+ where
+ eval :: IrcBotMsg -> IrcPlugin ()
+ eval (InIrcMsg msg)
+ | (ircMsgCommand msg) == "PING" = writeMsg . OutIrcMsg $ IrcMsg Nothing "PONG" (ircMsgParameters msg)
+ | otherwise = return ()
+ eval _ = return ()
+
diff --git a/Plugins/Quote.hs b/Hsbot/Irc/Plugin/Quote.hs
index 61e4558..ff037c7 100644
--- a/Plugins/Quote.hs
+++ b/Hsbot/Irc/Plugin/Quote.hs
@@ -1,7 +1,8 @@
-module Plugins.Quote
- ( mainQuote
+module Hsbot.Irc.Plugin.Quote
+ ( ircBotPluginQuote
) where
+import Control.Concurrent (myThreadId)
import Control.Concurrent.Chan
import Control.Exception
import Control.Monad.State
@@ -10,13 +11,15 @@ import Data.Maybe(fromMaybe)
import qualified Data.Text as T
import qualified Data.Text.IO as TIO
import Data.Time
+import System.Directory
import IO hiding (catch)
import Prelude hiding (catch)
+import System.FilePath
+import System.Posix.Files
import System.Random(randomRIO)
-import Hsbot.IRCPlugin
-import Hsbot.Types
-import Hsbot.Utils
+import Hsbot.Irc.Message
+import Hsbot.Irc.PluginCommons
-- | A quote element
data QuoteElt = QuoteElt
@@ -40,16 +43,29 @@ data QuoteBotState = QuoteBotState
} deriving (Read, Show)
-- | The QuoteBot monad
-type QuoteBot a = StateT QuoteBotState (StateT PluginState IO) a
+type QuoteBot a = StateT QuoteBotState (StateT IrcPluginState IO) a
-- | The plugin's main entry point
-mainQuote :: Chan BotMsg -> Chan BotMsg -> IO ()
-mainQuote serverChan chan = do
+ircBotPluginQuote :: Chan IrcBotMsg -> Chan IrcBotMsg -> IO ()
+ircBotPluginQuote myChan masterChan = do
-- First of all we restore the database
- txtQuoteBot <- TIO.readFile $ "quotedb.txt"
+ dir <- getAppUserDataDirectory "hsbot"
+ let dbfile = dir </> "quotedb.txt"
+ dbfileExists <- fileExist dbfile
+ if not dbfileExists
+ then
+ let quoteBot = QuoteBotState 0 M.empty M.empty
+ in TIO.writeFile dbfile (T.pack $ show quoteBot)
+ else
+ return ()
+ txtQuoteBot <- TIO.readFile $ dbfile
let quoteBot = read (T.unpack txtQuoteBot) :: QuoteBotState
-- The plugin main loop
- let plugin = PluginState "Quote" serverChan chan
+ threadId <- myThreadId
+ let plugin = IrcPluginState { ircPluginName = "Quote"
+ , ircPluginThreadId = threadId
+ , ircPluginChan = myChan
+ , ircPluginMasterChan = masterChan }
evalStateT (mapM_ sendRegisterCommand ["quote"]) plugin
_ <- (evalStateT (run quoteBot) plugin) `catch` (\(_ :: AsyncException) -> return quoteBot)
evalStateT (mapM_ sendUnregisterCommand ["quote"]) plugin
@@ -62,30 +78,31 @@ run quoteBot = do
run quoteBot'
where
-- | evaluate what we just received
- eval :: BotMsg -> IrcPlugin (QuoteBotState)
- eval (InternalCmd intCmd)
- | intCmdCmd intCmd == "RUN" = do
+ eval :: IrcBotMsg -> IrcPlugin (QuoteBotState)
+ eval (IntIrcCmd intCmd)
+ | ircCmdCmd intCmd == "RUN" = do
quoteBot' <- execStateT (runCommand intCmd) quoteBot
return quoteBot'
- | otherwise = do
- lift . trace $ show intCmd
- return quoteBot
- eval (InputMsg _) = return (quoteBot)
- eval _ = return (quoteBot)
+ | otherwise = return quoteBot
+ eval (InIrcMsg _) = return (quoteBot)
+ eval (OutIrcMsg _) = return (quoteBot)
-- | run a command we received
-runCommand :: IntCmd -> QuoteBot ()
+runCommand :: IrcCmd -> QuoteBot ()
runCommand intCmd
| theCommand == "quote" = runQuoteCommand
- | otherwise = do
- lift . lift . trace $ show intCmd -- TODO : help message
+ | otherwise = return ()
where
-- | the message is a quote command
runQuoteCommand :: QuoteBot ()
| length args == 0 = do
quoteDB <- gets quoteBotDB
x <- liftIO $ randomRIO (0, (length $ M.keys quoteDB) - 1)
- mapM_ (lift . answerMsg request) (formatQuote (M.keys quoteDB !! x) (M.elems quoteDB !! x))
+ if (length $ M.keys quoteDB) > 0
+ then
+ mapM_ (lift . answerMsg request) (formatQuote (M.keys quoteDB !! x) (M.elems quoteDB !! x))
+ else
+ lift $ answerMsg request "The quote database is empty."
| otherwise = do
dispatchQuoteCmd $ head args
-- | quote command dispatcher
@@ -94,7 +111,7 @@ runCommand intCmd
| cmd == "start" = do
quoteBot <- get
now <- liftIO $ getCurrentTime
- let sender = takeWhile (/= '!') $ fromMaybe "ARGH" (prefix request)
+ let sender = takeWhile (/= '!') $ fromMaybe "ARGH" (ircMsgPrefix request)
newQuote = Quote sender [(quoteElt stuff)] now 0
quoteId = nextQuoteId quoteBot
quotesInProgress' = M.insert quoteId newQuote (quotesInProgress quoteBot)
@@ -134,17 +151,19 @@ runCommand intCmd
theQuote = unwords . tail $ msg
QuoteElt budy theQuote
-- | utilities
- params = words . intCmdMsg $ intCmd
+ params = words . ircCmdMsg $ intCmd
theCommand = head params
args = tail params
stuff = tail args
- request = intCmdBotMsg intCmd
+ request = ircCmdBotMsg intCmd
-- | The function that sync the quoteDB on disk
syncQuoteBot :: QuoteBot ()
syncQuoteBot = do
+ dir <- liftIO $ getAppUserDataDirectory "hsbot"
+ let dbfile = dir </> "quotedb.txt"
+ file' <- liftIO $ openFile dbfile WriteMode
quoteBot <- get
- file' <- liftIO $ openFile "quotedb.txt" WriteMode
liftIO . hPutStr file' $ show quoteBot
liftIO $ hClose file'
diff --git a/Hsbot/Irc/PluginCommons.hs b/Hsbot/Irc/PluginCommons.hs
new file mode 100644
index 0000000..71f00a4
--- /dev/null
+++ b/Hsbot/Irc/PluginCommons.hs
@@ -0,0 +1,67 @@
+module Hsbot.Irc.PluginCommons
+ ( IrcPlugin
+ , IrcPluginState (..)
+ , answerMsg
+ , readMsg
+ , sendCommand
+ , sendCommandWithRequest
+ , sendRegisterCommand
+ , sendUnregisterCommand
+ , writeMsg
+ ) where
+
+import Control.Concurrent
+import Control.Concurrent.Chan ()
+import Control.Monad.State
+import Data.Maybe (fromMaybe)
+
+import Hsbot.Irc.Message
+
+-- | The IrcPlugin monad
+type IrcPlugin = StateT IrcPluginState IO
+
+-- | A plugin state
+data IrcPluginState = IrcPluginState
+ { ircPluginName :: String -- The plugin's name
+ , ircPluginThreadId :: ThreadId -- The plugin thread
+ , ircPluginChan :: Chan IrcBotMsg -- The plugin chan
+ , ircPluginMasterChan :: Chan IrcBotMsg -- The master's chan
+ }
+
+--- | Basic input output for IrcPlugins
+readMsg :: IrcPlugin (IrcBotMsg)
+readMsg = do
+ chan <- gets ircPluginChan
+ input <- liftIO $ readChan chan
+ return input
+
+writeMsg :: IrcBotMsg -> IrcPlugin ()
+writeMsg (OutIrcMsg msg) = do
+ chan <- gets ircPluginMasterChan
+ liftIO $ writeChan chan (OutIrcMsg msg)
+writeMsg _ = return ()
+
+answerMsg :: IrcMsg -> String -> IrcPlugin ()
+answerMsg request msg = do
+ let chanOrigin = head $ ircMsgParameters request
+ sender = takeWhile (/= '!') $ fromMaybe "" (ircMsgPrefix request)
+ case head chanOrigin of
+ '#' -> writeMsg . OutIrcMsg $ IrcMsg Nothing "PRIVMSG" [chanOrigin, msg]
+ _ -> writeMsg . OutIrcMsg $ IrcMsg Nothing "PRIVMSG" [sender, msg]
+
+-- | Command management
+sendCommand :: String -> String -> String -> IrcPlugin ()
+sendCommand cmd to params = sendCommandWithRequest cmd to params emptyIrcMsg
+
+sendCommandWithRequest :: String -> String -> String -> IrcMsg -> IrcPlugin ()
+sendCommandWithRequest cmd to params originalRequest = do
+ masterChan <- gets ircPluginMasterChan
+ from <- gets ircPluginName
+ liftIO . writeChan masterChan . IntIrcCmd $ IrcCmd cmd from to params originalRequest
+
+sendRegisterCommand :: String -> IrcPlugin ()
+sendRegisterCommand cmd = sendCommand "REGISTER" "CORE" cmd
+
+sendUnregisterCommand :: String -> IrcPlugin ()
+sendUnregisterCommand cmd = sendCommand "UNREGISTER" "CORE" cmd
+
diff --git a/Hsbot/Irc/Server.hs b/Hsbot/Irc/Server.hs
new file mode 100644
index 0000000..3c20e6d
--- /dev/null
+++ b/Hsbot/Irc/Server.hs
@@ -0,0 +1,35 @@
+module Hsbot.Irc.Server
+ ( initServerConnection
+ , sendIrcMsg
+ ) where
+
+import Control.Concurrent.Chan
+import Control.Monad.State
+
+import Hsbot.Irc.Config
+import Hsbot.Irc.Message
+import Hsbot.Irc.Types
+
+-- | Setup a newly connected server by sending nick and join stuff
+initServerConnection :: IrcConfig -> IrcServer ()
+initServerConnection config = do
+ sendIrcMsg $ IrcMsg Nothing "NICK" [(ircConfigNickname config)]
+ sendIrcMsg $ IrcMsg Nothing "USER" [(ircConfigNickname config), "0", "*", (ircConfigRealname config)]
+ when (not . null $ ircConfigPassword config) $ do
+ sendIrcMsg $ IrcMsg Nothing "PRIVMSG" ["nickserv", "identify", (ircConfigPassword config)]
+ mapM_ joinChan (ircConfigChannels config)
+
+-- | Joins a chan
+joinChan :: String -> IrcServer ()
+joinChan channel = do
+ ircServer <- get
+ let oldChannels = ircServerChannels ircServer
+ sendIrcMsg $ IrcMsg Nothing "JOIN" [channel]
+ put $ ircServer { ircServerChannels = channel : oldChannels }
+
+-- | Sends an IrcMsg
+sendIrcMsg :: IrcMsg -> IrcServer ()
+sendIrcMsg ircMsg = do
+ chan <- gets ircServerChan
+ liftIO $ writeChan chan (OutIrcMsg ircMsg)
+
diff --git a/Hsbot/Irc/Types.hs b/Hsbot/Irc/Types.hs
new file mode 100644
index 0000000..eac58d7
--- /dev/null
+++ b/Hsbot/Irc/Types.hs
@@ -0,0 +1,48 @@
+module Hsbot.Irc.Types
+ ( IrcBot
+ , IrcBotState (..)
+ , IrcServer
+ , IrcServerState (..)
+ ) where
+
+import Control.Concurrent
+import Control.Monad.State
+import qualified Data.Map as M
+import Data.Time
+import System.IO
+
+import Hsbot.Irc.Config
+import Hsbot.Irc.Message
+import Hsbot.Irc.PluginCommons
+import Hsbot.Message
+
+-- | The Ircbot monad
+type IrcBot = StateT IrcBotState IO
+
+-- | An Ircbot state
+data IrcBotState = IrcBotState
+ { ircBotStartTime :: UTCTime -- the bot's uptime
+ , ircBotPlugins :: M.Map String IrcPluginState -- Loaded plugins
+ , ircBotCommands :: M.Map String [String] -- Loaded plugins
+ , ircBotChan :: Chan IrcBotMsg -- The IrcBot's communication channel
+ , ircBotMasterChan :: Chan BotMsg -- The Hsbot communication channel
+ , ircBotMyChan :: Chan BotMsg -- The Hsbot communication channel
+ , ircBotServerState :: IrcServerState -- The state of the IrcServer
+ , ircBotHandle :: Handle -- The server's socket/handle
+ , ircBotConfig :: IrcConfig -- The starting configuration
+ , ircBotReaderThreadId :: ThreadId
+ , ircBotMasterReaderThreadId :: ThreadId
+ }
+
+-- | The IrcServer monad
+type IrcServer = StateT IrcServerState IrcBot
+
+-- | An IRC server
+data IrcServerState = IrcServerState
+ { ircServerId :: String -- the server's address
+ , ircServerChannels :: [String] -- the Channels we are connected to
+ , ircServerNickname :: String -- the hsbot's nickname
+ , ircServerCommandPrefix :: Char -- the prefix the ircbot will recognize as commands
+ , ircServerChan :: Chan IrcBotMsg -- the IrcBot channel
+ }
+
diff --git a/doc/rfc2812.txt b/Hsbot/Irc/doc/rfc2812.txt
index bfa2711..bfa2711 100644
--- a/doc/rfc2812.txt
+++ b/Hsbot/Irc/doc/rfc2812.txt
diff --git a/Hsbot/Main.hs b/Hsbot/Main.hs
deleted file mode 100644
index 767722b..0000000
--- a/Hsbot/Main.hs
+++ /dev/null
@@ -1,36 +0,0 @@
-module Hsbot.Main
- ( imain
- ) where
-
-import Control.Exception
-import Control.Monad.State
-import Prelude hiding (catch)
-import System.IO()
-
-import Config
-import Hsbot.Core
-import Hsbot.IRC
-import Hsbot.Plugin
-import Hsbot.Types
-
-import Plugins.Core(mainCore)
-import Plugins.Ping(mainPing)
-import Plugins.Quote(mainQuote)
-
--- | Bot's main entry point
-imain :: IO ()
-imain = do
- bot <- connectServer $ ircServer config
- bot' <- (execStateT run bot) `catch` (\(_ :: IOException) -> return bot)
- evalStateT disconnectServer bot'
-
--- | The Bot monad main function
-run :: IrcBot ()
-run = do
- initServer
- liftIO $ putStrLn "Starting plugins..."
- loadPlugin "Ping" mainPing
- loadPlugin "Core" mainCore
- loadPlugin "Quote" mainQuote
- runServer
-
diff --git a/Hsbot/Message.hs b/Hsbot/Message.hs
new file mode 100644
index 0000000..7532211
--- /dev/null
+++ b/Hsbot/Message.hs
@@ -0,0 +1,15 @@
+module Hsbot.Message
+ ( BotMsg (..)
+ , Msg (..)
+ ) where
+
+-- | A hsbot message
+data Msg = Msg
+ { msgType :: String -- the message type
+ , msgFrom :: String -- who issues it
+ , msgTo :: String -- who it is destinated to
+ , msgCmd :: String -- the message to be transfered
+ } deriving (Show)
+
+data BotMsg = InMsg Msg | OutMsg Msg | IntMsg Msg deriving (Show)
+
diff --git a/Hsbot/Plugin.hs b/Hsbot/Plugin.hs
index 13d0efc..9e34d92 100644
--- a/Hsbot/Plugin.hs
+++ b/Hsbot/Plugin.hs
@@ -1,61 +1,24 @@
module Hsbot.Plugin
- ( listPlugins
- , loadPlugin
- , sendToPlugin
- , unloadPlugin
+ ( Plugin
+ , PluginState (..)
) where
import Control.Concurrent
-import Control.Concurrent.Chan()
-import Control.Exception
+import Control.Concurrent.Chan ()
import Control.Monad.State
import qualified Data.Map as M
-import Data.Maybe()
-import System.IO()
+import IO (Handle)
-import Hsbot.Types
-import Hsbot.Utils
+import Hsbot.Message
--- | Loads a plugin into an ircBot
-loadPlugin :: String -> (Chan BotMsg -> Chan BotMsg -> IO ()) -> IrcBot ()
-loadPlugin name entryPoint = do
- bot <- get
- let oldPlugins = botPlugins bot
- plugin <- liftIO $ effectivelyLoadPlugin name entryPoint (botChannel bot)
- put $ bot { botPlugins = M.insert name plugin oldPlugins}
+-- | The Plugin monad
+type Plugin = StateT PluginState IO
--- | Effectively try to load a plugin
-effectivelyLoadPlugin :: String -> (Chan BotMsg -> Chan BotMsg -> IO ()) -> Chan BotMsg -> IO (Plugin)
-effectivelyLoadPlugin name entryPoint serverChan = do
- putStrLn $ inColor ("Loaded (static) plugin: " ++ name) [32]
- chan <- newChan :: IO (Chan BotMsg)
- threadId <- forkIO $ entryPoint serverChan chan
- return $ Plugin name threadId chan
-
--- | Sends a list of loaded plugins
-listPlugins :: IrcMsg -> String -> IrcBot ()
-listPlugins originalRequest dest = do
- plugins <- gets botPlugins
- let listing = unwords $ M.keys plugins
- case M.lookup dest plugins of
- Just plugin -> sendToPlugin (InternalCmd $ IntCmd "ANSWER" "CORE" dest listing originalRequest) plugin
- Nothing -> return ()
-
--- | 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 $ throwTo (pluginThreadId plugin) UserInterrupt
- put $ bot { botPlugins = newPlugins }
- Nothing -> return ()
-
--- | Sends a msg to a plugin
-sendToPlugin :: BotMsg -> Plugin -> IrcBot ()
-sendToPlugin msg plugin = do
- let chan = pluginChannel plugin
- liftIO $ writeChan chan msg
+-- | A plugin state
+data PluginState = PluginState
+ { pluginName :: String -- The plugin's name
+ , pluginThreadId :: ThreadId -- The plugin thread
+ , pluginChan :: Chan BotMsg -- The plugin chan
+ , pluginHandles :: M.Map String Handle -- the plugins's handles
+ }
diff --git a/Hsbot/Types.hs b/Hsbot/Types.hs
deleted file mode 100644
index aa45f8b..0000000
--- a/Hsbot/Types.hs
+++ /dev/null
@@ -1,108 +0,0 @@
-module Hsbot.Types
- ( Bot(..)
- , BotMsg(..)
- , Channel(..)
- , Config(..)
- , IntCmd(..)
- , IrcServer(..)
- , IrcBot
- , IrcMsg(..)
- , Plugin(..)
- , emptyIrcMsg
- ) where
-
-import Control.Concurrent
-import Control.Concurrent.Chan()
-import Control.Monad.State
-import qualified Data.Map as M
-import Network
-import System.IO
-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
- { commandPrefix :: Char -- command prefixe, for example @[\'>\',\'@\',\'?\']@
- , ircServer :: IrcServer -- list of 'Server's to connect to
- } deriving (Show)
-
--- | An IRC server
-data IrcServer = IrcServer
- { serverAddress :: String -- the server's address
- , serverPort :: PortID -- the server's port
- , joinChannels :: [String] -- a list of channels to join
- , nickname :: String -- the hsbot's nickname
- , password :: String -- the hsbot's password, optional
- , realname :: String -- the hsbot's real name, optional
- , administrators :: [String] -- bot admins nicknames
- }
-
-instance Show IrcServer where
- show (IrcServer a p c n pa r ad) = (show a)
- ++ (case p of
- PortNumber num -> show num
- Service s -> show s
- UnixSocket u -> show u)
- ++ (show c) ++ (show n) ++ (show pa) ++ (show r) ++ (show ad)
-
--- | The IrcBot monad
-type IrcBot a = StateT Bot IO a
-
--- | An IRC Bot server state
-data Bot = Bot
- { serverConfig :: IrcServer -- original server config we are connected to
- , startTime :: ClockTime -- the bot's uptime
- , botHandle :: Handle -- the socket/handle
- , chans :: [Channel] -- the list of channels we have joined
- , botPlugins :: M.Map String Plugin -- Loaded plugins
- , botChannel :: Chan BotMsg -- The bot's communication channel
- , readerThreadId :: ThreadId -- The bot's thread ID
- , botCommands :: M.Map String [String] -- Registered commands ("command", ["pluginName"])
- }
-
-instance Show Bot where
- show (Bot _ s h c p _ _ cmds) = unlines [ "Start time : " ++ (show s)
- , "Handle : " ++ (show h)
- , "Channels : " ++ (show c)
- , "Plugins : " ++ (show p)
- , "Commands : " ++ (show cmds)]
-
--- | A channel connection
-data Channel = Channel
- { channelName :: String -- the channel's name
- , channelNick :: String -- our nickname
- , channelAdmins :: [String] -- the bot administrators
- } deriving (Show)
-
--- | An IRC message
-data IrcMsg = IrcMsg
- { prefix :: Maybe String -- the message prefix
- , command :: String -- the message command
- , parameters :: [String] -- the message parameters
- } deriving (Show)
-
-emptyIrcMsg :: IrcMsg
-emptyIrcMsg = IrcMsg Nothing "" []
-
--- | An internal command
-data IntCmd = IntCmd
- { intCmdCmd :: String -- the internal command
- , intCmdFrom :: String -- who issues it
- , intCmdTo :: String -- who it is destinated to
- , intCmdMsg :: String -- the message to be transfered
- , intCmdBotMsg :: IrcMsg -- An IrcMsg attached to the command
- } deriving (Show)
-
-data BotMsg = InputMsg IrcMsg | OutputMsg IrcMsg | InternalCmd IntCmd deriving (Show)
-
--- | A plugin (core side)
-data Plugin = Plugin
- { pluginName :: String -- The plugin's name
- , pluginThreadId :: ThreadId -- The plugin thread
- , pluginChannel :: Chan BotMsg -- The plugin channel
- }
-
-instance Show Plugin where
- show (Plugin name _ _) = show name
-
diff --git a/Hsbot/Utils.hs b/Hsbot/Utils.hs
deleted file mode 100644
index 247a65c..0000000
--- a/Hsbot/Utils.hs
+++ /dev/null
@@ -1,42 +0,0 @@
-module Hsbot.Utils
- ( error
- , errorM
- , inColor
- , sendstr
- , trace
- , traceM
- ) where
-
-import Control.Monad.State
-import Data.List
-import System.IO
-
-import Hsbot.Types
-
--- |Wrap a string with ANSI escape sequences.
-inColor :: String -> [Int] -> String
-inColor str vals = "\ESC[" ++ valstr ++ "m" ++ str ++ "\ESC[0m"
- where valstr = concat . intersperse ";" $ map show vals
-
--- | Sends a string over handle
-sendstr :: String -> IrcBot ()
-sendstr str = do
- handle <- gets botHandle
- traceM $ inColor ("--> " ++ str) [33]
- liftIO $ hPutStr handle (str ++ "\r\n")
-
--- | Log a message string
-trace :: String -> IO ()
-trace msg = putStrLn msg
-
--- | Log a message string
-traceM :: String -> IrcBot ()
-traceM msg = liftIO $ trace msg
-
--- | Logs an error message
-traceRed :: String -> IO ()
-traceRed msg = trace $ inColor msg [31]
-
-errorM :: String -> IrcBot ()
-errorM msg = liftIO $ traceRed msg
-
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-15 05:03:50 +0000