diff options
| -rw-r--r-- | Config.hs | 32 | ||||
| -rw-r--r-- | Hsbot.hs | 30 | ||||
| -rw-r--r-- | Hsbot/Command.hs | 87 | ||||
| -rw-r--r-- | Hsbot/Config.hs | 18 | ||||
| -rw-r--r-- | Hsbot/Core.hs | 110 | ||||
| -rw-r--r-- | Hsbot/IRC.hs | 45 | ||||
| -rw-r--r-- | Hsbot/IRCPlugin.hs | 66 | ||||
| -rw-r--r-- | Hsbot/Irc/Command.hs | 59 | ||||
| -rw-r--r-- | Hsbot/Irc/Config.hs | 34 | ||||
| -rw-r--r-- | Hsbot/Irc/Core.hs | 142 | ||||
| -rw-r--r-- | Hsbot/Irc/Message.hs (renamed from Hsbot/IRCParser.hs) | 30 | ||||
| -rw-r--r-- | Hsbot/Irc/Plugin.hs | 80 | ||||
| -rw-r--r-- | Hsbot/Irc/Plugin/Core.hs (renamed from Plugins/Core.hs) | 38 | ||||
| -rw-r--r-- | Hsbot/Irc/Plugin/Dummy.hs | 30 | ||||
| -rw-r--r-- | Hsbot/Irc/Plugin/Ping.hs | 36 | ||||
| -rw-r--r-- | Hsbot/Irc/Plugin/Quote.hs (renamed from Plugins/Quote.hs) | 71 | ||||
| -rw-r--r-- | Hsbot/Irc/PluginCommons.hs | 67 | ||||
| -rw-r--r-- | Hsbot/Irc/Server.hs | 35 | ||||
| -rw-r--r-- | Hsbot/Irc/Types.hs | 48 | ||||
| -rw-r--r-- | Hsbot/Irc/doc/rfc2812.txt (renamed from doc/rfc2812.txt) | 0 | ||||
| -rw-r--r-- | Hsbot/Main.hs | 36 | ||||
| -rw-r--r-- | Hsbot/Message.hs | 15 | ||||
| -rw-r--r-- | Hsbot/Plugin.hs | 65 | ||||
| -rw-r--r-- | Hsbot/Types.hs | 108 | ||||
| -rw-r--r-- | Hsbot/Utils.hs | 42 | ||||
| -rw-r--r-- | LICENSE (renamed from LICENCE) | 0 | ||||
| -rw-r--r-- | Main.hs | 55 | ||||
| -rw-r--r-- | Makefile | 14 | ||||
| -rw-r--r-- | Plugins/Ping.hs | 31 | ||||
| -rw-r--r-- | README | 5 | ||||
| -rw-r--r-- | Setup.hs | 5 | ||||
| -rw-r--r-- | TODO | 3 | ||||
| -rw-r--r-- | hsbot.cabal | 73 |
33 files changed, 856 insertions, 654 deletions
diff --git a/Config.hs b/Config.hs deleted file mode 100644 index fbf98b1..0000000 --- a/Config.hs +++ /dev/null @@ -1,32 +0,0 @@ -module Config - ( config - , defaultPlugins - ) where - -import Network - -import Hsbot.Types - --- | Imported plugins goes there -defaultPlugins :: [String] -defaultPlugins = [] - --- | User server -localhost :: IrcServer -localhost = IrcServer - { serverAddress = "localhost" - , serverPort = PortNumber 6667 - , joinChannels = ["#shbot", "#geek"] - , nickname = "hsbot" - , password = "" - , realname = "The One True bot, with it's haskell soul." - , administrators = ["julien"] - } - --- | User configuration -config :: Config -config = Config - { commandPrefix = '@' - , ircServer = localhost - } - 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 - @@ -1,9 +1,58 @@ -module Main where +module Main (main) where -import Hsbot +import Control.Monad (when) +import Prelude hiding (catch) +import System.Directory +import System.Environment +import System.Exit +import System.FilePath +import System.Info +import System.IO +import System.Posix.Process (executeFile) +import System.Process -- | Dynamic launching function main :: IO () main = do - imain + args <- getArgs + case args of + [] -> buildLaunch + ["--help"] -> usage + _ -> fail "unrecognized flags" + +usage :: IO () +usage = do + self <- getProgName + putStr . unlines $ + concat ["Usage: ", self, " [OPTION]"] : + "Options:" : + " --help : Print this message" : + [] + +buildLaunch :: IO () +buildLaunch = do + _ <- recompile + dir <- getAppUserDataDirectory "hsbot" + args <- getArgs + _ <- executeFile (dir ++ "/hsbot-" ++ arch ++ "-" ++ os) False args Nothing + return () + +recompile :: IO (Bool) +recompile = do + dir <- getAppUserDataDirectory "hsbot" + let binn = "hsbot-"++arch++"-"++os + base = dir </> "hsbot" + err = base ++ ".errors" + src = base ++ ".hs" + errorHandle <- openFile err WriteMode + exitCode <- waitForProcess =<< runProcess "ghc" ["--make", "hsbot.hs", "-fforce-recomp", "-XScopedTypeVariables", "-o", binn] (Just dir) + Nothing Nothing Nothing (Just errorHandle) + hClose errorHandle + when (exitCode /= ExitSuccess) $ do + ghcErr <- readFile err + let msg = unlines $ + ["Error detected while loading hsbot configuration file: " ++ src] + ++ lines ghcErr ++ ["","Please check the file for errors."] + hPutStrLn stderr msg + return (exitCode == ExitSuccess) diff --git a/Makefile b/Makefile deleted file mode 100644 index abd30ba..0000000 --- a/Makefile +++ /dev/null @@ -1,14 +0,0 @@ -all: - ghc --make -Wall -O2 Main.hs -o hsbot -XScopedTypeVariables - -listen: - nc -l 127.0.0.1 6667 - -run: - runghc -XScopedTypeVariables Main - -clean: - - rm hsbot - - find ./ -name \*.o -exec rm {} \; - - find ./ -name \*.hi -exec rm {} \; - diff --git a/Plugins/Ping.hs b/Plugins/Ping.hs deleted file mode 100644 index 5da3f2f..0000000 --- a/Plugins/Ping.hs +++ /dev/null @@ -1,31 +0,0 @@ -module Plugins.Ping - ( mainPing - ) where - -import Control.Concurrent.Chan -import Control.Exception -import Control.Monad.State -import Prelude hiding (catch) - -import Hsbot.IRCPlugin -import Hsbot.Types - --- | The plugin's main entry point -mainPing :: Chan BotMsg -> Chan BotMsg -> IO () -mainPing serverChan chan = do - let plugin = PluginState "Ping" serverChan chan - _ <- (execStateT run plugin) `catch` (\(_ :: AsyncException) -> 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 () - @@ -1,5 +0,0 @@ -Dependances : -------------- -hs-plugin -text - diff --git a/Setup.hs b/Setup.hs new file mode 100644 index 0000000..14a7f90 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,5 @@ +#!/usr/bin/env runhaskell + +import Distribution.Simple + +main = defaultMain @@ -1,5 +1,8 @@ :julien!~julien@ogu21.corp PRIVMSG #shbot :@quote graou snif +* Handle bot/Plugin state updates threw the masters' Chans +* Find a way to handle bot reloading threw exec + * write the vote system for the quote module * only the quote reporter should be able to edit it * detect too identical quoting in a raw, or implement quote abort diff --git a/hsbot.cabal b/hsbot.cabal new file mode 100644 index 0000000..ca1cd98 --- /dev/null +++ b/hsbot.cabal @@ -0,0 +1,73 @@ +name: hsbot +version: 0.1.0 +cabal-version: >= 1.8 +build-type: Simple +license: BSD3 +license-file: LICENSE +copyright: Copyright (c) 2010 Julien Dessaux +author: Julien Dessaux +maintainer: judessaux@gmail.com +homepage: http://code.adyxax.org/hsbot +bug-reports: http://code.adyxax.org/hsbot/tracker +category: Hsbot +synopsis: An multi-purpose bot, mainly an IRC bot +description: + hsbot is a multi-purpose bot, written slowly, as long as I learned more + haskell. It features IRC integration and some plugins. I tried to design + a bot architecture as modular and as flexible as possible. + +Executable hsbot + Main-Is: Main.hs + ghc-options: -Wall + extensions: DeriveDataTypeable ScopedTypeVariables + build-depends: base >= 4.1, + containers >= 0.3, + directory >= 1.0, + filepath >= 1.1, + ghc >= 6.12, + haskell98 >= 1.0, + mtl >= 1.1, + network >= 2.2, + old-time >= 1.0, + parsec >= 3.1, + process >= 1.0, + random >= 1.0, + text >= 0.7, + time >= 1.1, + unix >= 2.4 + +Library + exposed-modules: + Hsbot.Config + Hsbot.Core + Hsbot.Irc.Command + Hsbot.Irc.Config + Hsbot.Irc.Core + Hsbot.Irc.Message + Hsbot.Irc.Plugin + Hsbot.Irc.PluginCommons + Hsbot.Irc.Plugin.Core + Hsbot.Irc.Plugin.Dummy + Hsbot.Irc.Plugin.Ping + Hsbot.Irc.Plugin.Quote + Hsbot.Irc.Server + Hsbot.Irc.Types + Hsbot.Message + Hsbot.Plugin + ghc-options: -Wall + extensions: DeriveDataTypeable ScopedTypeVariables + build-depends: base >= 4.1, + containers >= 0.3, + directory >= 1.0, + filepath >= 1.1, + ghc >= 6.12, + haskell98 >= 1.0, + mtl >= 1.1, + network >= 2.2, + old-time >= 1.0, + parsec >= 3.1, + random >= 1.0, + text >= 0.7, + time >= 1.1, + unix >= 2.4 + |