From 11c2c16835b3e8368be77ccc5b7ddf949021eccd Mon Sep 17 00:00:00 2001 From: Julien Dessaux Date: Sat, 3 Jul 2010 21:26:00 +0200 Subject: Moved files around as a preliminary for architectural changes. --- Hsbot/Irc/Plugin/Core.hs | 66 ------------------ Hsbot/Irc/Plugin/Dummy.hs | 27 ------- Hsbot/Irc/Plugin/Ping.hs | 33 --------- Hsbot/Irc/Plugin/Quote.hs | 174 ---------------------------------------------- Hsbot/Irc/Plugin/Utils.hs | 66 ------------------ 5 files changed, 366 deletions(-) delete mode 100644 Hsbot/Irc/Plugin/Core.hs delete mode 100644 Hsbot/Irc/Plugin/Dummy.hs delete mode 100644 Hsbot/Irc/Plugin/Ping.hs delete mode 100644 Hsbot/Irc/Plugin/Quote.hs delete mode 100644 Hsbot/Irc/Plugin/Utils.hs (limited to 'Hsbot/Irc/Plugin') diff --git a/Hsbot/Irc/Plugin/Core.hs b/Hsbot/Irc/Plugin/Core.hs deleted file mode 100644 index 114ced8..0000000 --- a/Hsbot/Irc/Plugin/Core.hs +++ /dev/null @@ -1,66 +0,0 @@ -module Hsbot.Irc.Plugin.Core - ( ircBotPluginCore - ) where - -import Control.Concurrent (Chan) -import Control.Exception -import Control.Monad.State -import Prelude hiding (catch) - -import Hsbot.Irc.Message -import Hsbot.Irc.Plugin.Utils - --- | The plugin's main entry point -ircBotPluginCore :: Chan IrcBotMsg -> Chan IrcBotMsg -> IO () -ircBotPluginCore myChan masterChan = do - let plugin = IrcPluginState { ircPluginName = "Core" - , ircPluginChan = myChan - , ircPluginMasterChan = masterChan } - evalStateT (mapM_ sendRegisterCommand ["list", "load", "reload", "unload", "reboot"]) plugin - plugin' <- (execStateT run plugin) `catch` (\(_ :: AsyncException) -> return plugin) - evalStateT (mapM_ sendUnregisterCommand ["list", "load", "reload", "unload", "reboot"]) plugin' - --- | The IrcPlugin monad main function -run :: IrcPlugin () -run = forever $ do - msg <- readMsg - eval msg - where - 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 - "reboot" -> rebootBot $ tail stuff - _ -> return () -- TODO : help message - "ANSWER" -> let stuff = ircCmdMsg intCmd - in answerMsg request ("Loaded plugins : " ++ stuff) - _ -> return () - eval _ = return () - --- | The list command -listPlugins :: IrcMsg -> IrcPlugin () -listPlugins request = do - sendCommandWithRequest "LIST" "CORE" (unwords []) request - --- | The load command -loadPlugin :: [String] -> IrcPlugin () -loadPlugin pluginNames = mapM_ (sendCommand "LOAD" "CORE") pluginNames - --- | The reload command -reloadPlugin :: [String] -> IrcPlugin () -reloadPlugin pluginNames = mapM_ (sendCommand "RELOAD" "CORE") pluginNames - --- | The unload command -unloadPlugin :: [String] -> IrcPlugin () -unloadPlugin pluginNames = mapM_ (sendCommand "UNLOAD" "CORE") pluginNames - --- | The reboot command -rebootBot :: [String] -> IrcPlugin () -rebootBot stuff = sendCommand "REBOOT" "CORE" $ unwords stuff - diff --git a/Hsbot/Irc/Plugin/Dummy.hs b/Hsbot/Irc/Plugin/Dummy.hs deleted file mode 100644 index 4e10644..0000000 --- a/Hsbot/Irc/Plugin/Dummy.hs +++ /dev/null @@ -1,27 +0,0 @@ -module Hsbot.Irc.Plugin.Dummy - ( ircBotPluginDummy - ) where - -import Control.Concurrent.Chan -import Control.Exception -import Control.Monad.State -import Prelude hiding (catch) - -import Hsbot.Irc.Message -import Hsbot.Irc.Plugin.Utils - --- | The plugin's main entry point -ircBotPluginDummy :: Chan IrcBotMsg -> Chan IrcBotMsg -> IO () -ircBotPluginDummy myChan masterChan = do - let plugin = IrcPluginState { ircPluginName = "Dummy" - , 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 deleted file mode 100644 index 57418b3..0000000 --- a/Hsbot/Irc/Plugin/Ping.hs +++ /dev/null @@ -1,33 +0,0 @@ -module Hsbot.Irc.Plugin.Ping - ( ircBotPluginPing - ) where - -import Control.Concurrent.Chan -import Control.Exception -import Control.Monad.State -import Prelude hiding (catch) - -import Hsbot.Irc.Message -import Hsbot.Irc.Plugin.Utils - --- | The plugin's main entry point -ircBotPluginPing :: Chan IrcBotMsg -> Chan IrcBotMsg -> IO () -ircBotPluginPing myChan masterChan = do - let plugin = IrcPluginState { ircPluginName = "Ping" - , 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/Hsbot/Irc/Plugin/Quote.hs b/Hsbot/Irc/Plugin/Quote.hs deleted file mode 100644 index 0335d8b..0000000 --- a/Hsbot/Irc/Plugin/Quote.hs +++ /dev/null @@ -1,174 +0,0 @@ -module Hsbot.Irc.Plugin.Quote - ( ircBotPluginQuote - ) where - -import Control.Concurrent.Chan -import Control.Exception -import Control.Monad.State -import qualified Data.Map as M -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.Irc.Message -import Hsbot.Irc.Plugin.Utils - --- | A quote element -data QuoteElt = QuoteElt - { eltQuoter :: String - , eltQuote :: String - } deriving (Read, Show) - --- | A quote object -data Quote = Quote - { quoter :: String - , quote :: [QuoteElt] - , quoteTime :: UTCTime - , votes :: Int - } deriving (Read, Show) - --- | A QuoteBot state -data QuoteBotState = QuoteBotState - { nextQuoteId :: Integer - , quoteBotDB :: M.Map Integer Quote - , quotesInProgress :: M.Map Integer Quote - } deriving (Read, Show) - --- | The QuoteBot monad -type QuoteBot a = StateT QuoteBotState (StateT IrcPluginState IO) a - --- | The plugin's main entry point -ircBotPluginQuote :: Chan IrcBotMsg -> Chan IrcBotMsg -> IO () -ircBotPluginQuote myChan masterChan = do - -- First of all we restore the database - 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 = IrcPluginState { ircPluginName = "Quote" - , ircPluginChan = myChan - , ircPluginMasterChan = masterChan } - evalStateT (mapM_ sendRegisterCommand ["quote"]) plugin - _ <- (evalStateT (run quoteBot) plugin) `catch` (\(_ :: AsyncException) -> return quoteBot) - evalStateT (mapM_ sendUnregisterCommand ["quote"]) plugin - --- | The IrcPlugin monad main function -run :: QuoteBotState -> IrcPlugin (QuoteBotState) -run quoteBot = do - msg <- readMsg - quoteBot' <- eval msg - run quoteBot' - where - -- | evaluate what we just received - eval :: IrcBotMsg -> IrcPlugin (QuoteBotState) - eval (IntIrcCmd intCmd) - | ircCmdCmd intCmd == "RUN" = do - quoteBot' <- execStateT (runCommand intCmd) quoteBot - return quoteBot' - | otherwise = return quoteBot - eval (InIrcMsg _) = return (quoteBot) - eval (OutIrcMsg _) = return (quoteBot) - --- | run a command we received -runCommand :: IrcCmd -> QuoteBot () -runCommand intCmd - | theCommand == "quote" = runQuoteCommand - | 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) - 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 - dispatchQuoteCmd :: String -> QuoteBot () - dispatchQuoteCmd cmd - | cmd == "start" = do - quoteBot <- get - now <- liftIO $ getCurrentTime - let sender = takeWhile (/= '!') $ fromMaybe "ARGH" (ircMsgPrefix request) - newQuote = Quote sender [(quoteElt stuff)] now 0 - quoteId = nextQuoteId quoteBot - quotesInProgress' = M.insert quoteId newQuote (quotesInProgress quoteBot) - put $ quoteBot { nextQuoteId = quoteId + 1, quotesInProgress = quotesInProgress' } - lift $ answerMsg request ("New quoteId : " ++ show quoteId) - syncQuoteBot - | cmd == "append" = do - quoteBot <- get - case reads (head stuff) of - [(quoteId :: Integer,"")] -> do - case M.lookup quoteId (quotesInProgress quoteBot) of - Just theQuote -> do - let newQuote = theQuote { quote = (quoteElt $ tail stuff) : (quote theQuote) } - quotesInProgress' = M.insert quoteId newQuote (quotesInProgress quoteBot) - put $ quoteBot { quotesInProgress = quotesInProgress' } - syncQuoteBot - Nothing -> lift $ answerMsg request ("quoteId not found : " ++ (show quoteId)) - _ -> lift $ answerMsg request ("Invalid quoteId : " ++ (head stuff)) - | cmd == "commit" = do - quoteBot <- get - case reads (head stuff) of - [(quoteId :: Integer,"")] -> do - case M.lookup quoteId (quotesInProgress quoteBot) of - Just theQuote -> do - let quoteBotDB' = M.insert quoteId theQuote (quoteBotDB quoteBot) - quotesInProgress' = M.delete quoteId (quotesInProgress quoteBot) - put $ quoteBot { quoteBotDB = quoteBotDB', quotesInProgress = quotesInProgress' } - syncQuoteBot - Nothing -> lift $ answerMsg request ("quoteId not found : " ++ (show quoteId)) - _ -> lift $ answerMsg request ("Invalid quoteId : " ++ (head stuff)) - -- | cmd == "abort" = - | otherwise = lift $ answerMsg request ("Invalid command : " ++ cmd) - -- | Gets the new QuoteElt - quoteElt :: [String] -> QuoteElt - quoteElt msg = do - let budy = head $ msg - theQuote = unwords . tail $ msg - QuoteElt budy theQuote - -- | utilities - params = words . ircCmdMsg $ intCmd - theCommand = head params - args = tail params - stuff = tail args - 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 - liftIO . hPutStr file' $ show quoteBot - liftIO $ hClose file' - -formatQuote :: Integer -> Quote -> [String] -formatQuote quoteId theQuote = - ("+---| " ++ (show quoteId) ++ " |-- Reported by " ++ (quoter theQuote) ++ " on " ++ (show $ quoteTime theQuote)) : - foldl (\acc x -> formatQuoteElt x : acc) ["`------------------------------------------"] (quote theQuote) - where - formatQuoteElt :: QuoteElt -> String - formatQuoteElt quoteElt = "| <" ++ (eltQuoter quoteElt) ++ "> " ++ (eltQuote quoteElt) - diff --git a/Hsbot/Irc/Plugin/Utils.hs b/Hsbot/Irc/Plugin/Utils.hs deleted file mode 100644 index 1e54d3a..0000000 --- a/Hsbot/Irc/Plugin/Utils.hs +++ /dev/null @@ -1,66 +0,0 @@ -module Hsbot.Irc.Plugin.Utils - ( 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 - , 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 - -- cgit v1.2.3