From ff07633fb8f81577ffec409cbf0a3c7361990f6c Mon Sep 17 00:00:00 2001 From: Julien Dessaux Date: Wed, 13 Apr 2011 20:15:55 +0200 Subject: Began a big refactoring/rewriting (again) --- HsbotIrcBot/Hsbot/Irc/Plugin/Quote.hs | 201 ---------------------------------- 1 file changed, 201 deletions(-) delete mode 100644 HsbotIrcBot/Hsbot/Irc/Plugin/Quote.hs (limited to 'HsbotIrcBot/Hsbot/Irc/Plugin/Quote.hs') diff --git a/HsbotIrcBot/Hsbot/Irc/Plugin/Quote.hs b/HsbotIrcBot/Hsbot/Irc/Plugin/Quote.hs deleted file mode 100644 index ab4734a..0000000 --- a/HsbotIrcBot/Hsbot/Irc/Plugin/Quote.hs +++ /dev/null @@ -1,201 +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 == "help" = - case length stuff of - 0 -> lift $ answerMsg request ("Usage: quote [append|commit|help|quick|start] {quoteId} {nickname} {quote}") - _ -> case head stuff of - "quick" -> do - lift $ answerMsg request ("quote quick [nickname] [quote]") - lift $ answerMsg request (" Performs a single line quote.") - "start" -> do - lift $ answerMsg request ("quote start [nickname] [quote]") - lift $ answerMsg request (" Begins a multi lines quote. Use either append to append new lines, or commit to terminate the quoting process.") - "append" -> do - lift $ answerMsg request ("quote append [quoteId] [nickname] [quote]") - lift $ answerMsg request (" Continue a multi line quote by appending to it.") - "commit" -> do - lift $ answerMsg request ("quote commit [quoteId]") - lift $ answerMsg request (" Terminates a multi lines quote.") - _ -> lift $ answerMsg request ("Usage: quote [append|commit|help|quick|start] {quoteId} {nickname} {quote}") - | cmd == "quick" = do - quoteBot <- get - now <- liftIO $ getCurrentTime - let sender = takeWhile (/= '!') $ fromMaybe "ARGH" (ircMsgPrefix request) - newQuote = Quote sender [(quoteElt stuff)] now 0 - quoteId = nextQuoteId quoteBot - quoteBotDB' = M.insert quoteId newQuote (quoteBotDB quoteBot) - put $ quoteBot { nextQuoteId = quoteId + 1, quoteBotDB = quoteBotDB' } - lift $ answerMsg request ("New quoteId : " ++ show quoteId) - syncQuoteBot - | 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) - -- cgit v1.2.3