Rewrote nearly everything!
* Rewrote the whole architecture to achieve extreme modularity * Added the ability to build a multiprotocol bot * Added cabal integration * Added configuration handling the XMonad style * Added configuration in ~/.hsbot * Refactored many many named and functions * Refactored data structures * Cleaned a big bunch of stuff
This commit is contained in:
Julien Dessaux
parent
c20cfe88b3
commit
c1662ba7b9
33 changed files with 856 additions and 654 deletions
177
Hsbot/Irc/Plugin/Quote.hs
Normal file
177
Hsbot/Irc/Plugin/Quote.hs
Normal file
|
|
@ -0,0 +1,177 @@
|
|||
module Hsbot.Irc.Plugin.Quote
|
||||
( ircBotPluginQuote
|
||||
) where
|
||||
|
||||
import Control.Concurrent (myThreadId)
|
||||
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.PluginCommons
|
||||
|
||||
-- | 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
|
||||
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
|
||||
|
||||
-- | 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)
|
||||
|
||||
Reference in a new issue