diff options
Diffstat (limited to '')
| -rw-r--r-- | Plugins/Quote.hs | 143 | ||||
| -rw-r--r-- | README | 2 | ||||
| -rw-r--r-- | TODO | 3 |
3 files changed, 127 insertions, 21 deletions
diff --git a/Plugins/Quote.hs b/Plugins/Quote.hs index db473f9..61e4558 100644 --- a/Plugins/Quote.hs +++ b/Plugins/Quote.hs @@ -5,49 +5,154 @@ module Plugins.Quote 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 IO hiding (catch) import Prelude hiding (catch) -import System.Time (ClockTime) +import System.Random(randomRIO) import Hsbot.IRCPlugin import Hsbot.Types import Hsbot.Utils +-- | A quote element +data QuoteElt = QuoteElt + { eltQuoter :: String + , eltQuote :: String + } deriving (Read, Show) + -- | A quote object data Quote = Quote { quoter :: String - , quote :: [String] - , quoteTime :: ClockTime + , quote :: [QuoteElt] + , quoteTime :: UTCTime , votes :: Int - } deriving (Show) + } deriving (Read, Show) -- | A QuoteBot state -type QuoteDB = [Quote] +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 QuoteDB IO a +type QuoteBot a = StateT QuoteBotState (StateT PluginState IO) a -- | The plugin's main entry point mainQuote :: Chan BotMsg -> Chan BotMsg -> IO () mainQuote serverChan chan = do + -- First of all we restore the database + txtQuoteBot <- TIO.readFile $ "quotedb.txt" + let quoteBot = read (T.unpack txtQuoteBot) :: QuoteBotState + -- The plugin main loop let plugin = PluginState "Quote" serverChan chan evalStateT (mapM_ sendRegisterCommand ["quote"]) plugin _ <- (evalStateT (run quoteBot) plugin) `catch` (\(_ :: AsyncException) -> return quoteBot) evalStateT (mapM_ sendUnregisterCommand ["quote"]) plugin -- | The IrcPlugin monad main function -run :: IrcPlugin () -run = forever $ do +run :: QuoteBotState -> IrcPlugin (QuoteBotState) +run quoteBot = do msg <- readMsg - eval msg + quoteBot' <- eval msg + run quoteBot' + where + -- | evaluate what we just received + eval :: BotMsg -> IrcPlugin (QuoteBotState) + eval (InternalCmd intCmd) + | intCmdCmd 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) + +-- | run a command we received +runCommand :: IntCmd -> QuoteBot () +runCommand intCmd + | theCommand == "quote" = runQuoteCommand + | otherwise = do + lift . lift . trace $ show intCmd -- TODO : help message + 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)) + | 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" (prefix 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 . intCmdMsg $ intCmd + theCommand = head params + args = tail params + stuff = tail args + request = intCmdBotMsg intCmd + +-- | The function that sync the quoteDB on disk +syncQuoteBot :: QuoteBot () +syncQuoteBot = do + quoteBot <- get + file' <- liftIO $ openFile "quotedb.txt" WriteMode + 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 - eval :: BotMsg -> IrcPlugin () - eval (InternalCmd intCmd) = do - case intCmdCmd intCmd of - "RUN" -> let stuff = words $ intCmdMsg intCmd - in case head stuff of - "quote" -> lift $ trace $ "Quote module has been invoked for: " ++ (show intCmd) - _ -> lift $ trace $ show intCmd -- TODO : help message - _ -> lift $ trace $ show intCmd - eval (InputMsg msg) = return () - eval _ = return () + formatQuoteElt :: QuoteElt -> String + formatQuoteElt quoteElt = "| <" ++ (eltQuoter quoteElt) ++ "> " ++ (eltQuote quoteElt) @@ -1,5 +1,5 @@ Dependances : ------------- hs-plugin -haskell-irc +text @@ -1,6 +1,5 @@ :julien!~julien@ogu21.corp PRIVMSG #shbot :@quote graou snif -* Write the quote module * 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 @@ -23,4 +22,6 @@ * Make the bot auto-reconnect (/!\ admin plugin!) * discard all trace with a color param and replace those with functions info/warn/error/debug * write a safe reload : try reload before unloading +* remove from Types.hs what can be removed from it + |