diff options
Diffstat (limited to '')
| -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 |
6 files changed, 278 insertions, 44 deletions
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 + |