diff options
Diffstat (limited to '')
| -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 |
13 files changed, 622 insertions, 48 deletions
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 |