Added the quote module.

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]
+    , quote     :: [QuoteElt]
-    , quoteTime :: ClockTime
+    , 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 :: QuoteBotState -> IrcPlugin (QuoteBotState)
-run = forever $ do
+run quoteBot = do
     msg <- readMsg
-    eval msg
+    quoteBot' <- eval msg
+    run quoteBot'
   where
-    eval :: BotMsg -> IrcPlugin ()
+    -- | evaluate what we just received
-    eval (InternalCmd intCmd) = do
+    eval :: BotMsg -> IrcPlugin (QuoteBotState)
-        case intCmdCmd intCmd of
+    eval (InternalCmd intCmd)
-            "RUN" -> let stuff = words $ intCmdMsg intCmd
+      | intCmdCmd intCmd == "RUN" = do
-                     in case head stuff of
+          quoteBot' <- execStateT (runCommand intCmd) quoteBot
-                            "quote" -> lift $ trace $ "Quote module has been invoked for: " ++ (show intCmd)
+          return quoteBot'
-                            _       -> lift $ trace $ show intCmd -- TODO : help message
+      | otherwise = do
-            _     -> lift $ trace $ show intCmd
+          lift . trace $ show intCmd
-    eval (InputMsg msg) = return ()
+          return quoteBot
-    eval _ = return ()
+    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
+    formatQuoteElt :: QuoteElt -> String
+    formatQuoteElt quoteElt = "| <" ++ (eltQuoter quoteElt) ++ "> " ++ (eltQuote quoteElt)
 

README

@@ -1,5 +1,5 @@
 Dependances :
 -------------
 hs-plugin
-haskell-irc
+text
 

TODO

@@ -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
+