summaryrefslogtreecommitdiff
path: root/Hsbot/Irc/Plugin
diff options
context:
space:
mode:
Diffstat (limited to 'Hsbot/Irc/Plugin')
-rw-r--r--Hsbot/Irc/Plugin/Core.hs63
-rw-r--r--Hsbot/Irc/Plugin/Dummy.hs30
-rw-r--r--Hsbot/Irc/Plugin/Ping.hs36
-rw-r--r--Hsbot/Irc/Plugin/Quote.hs177
4 files changed, 306 insertions, 0 deletions
diff --git a/Hsbot/Irc/Plugin/Core.hs b/Hsbot/Irc/Plugin/Core.hs
new file mode 100644
index 0000000..5d69ca3
--- /dev/null
+++ b/Hsbot/Irc/Plugin/Core.hs
@@ -0,0 +1,63 @@
+module Hsbot.Irc.Plugin.Core
+ ( ircBotPluginCore
+ ) where
+
+import Control.Concurrent (Chan, myThreadId)
+import Control.Exception
+import Control.Monad.State
+import Prelude hiding (catch)
+
+import Hsbot.Irc.Message
+import Hsbot.Irc.PluginCommons
+
+-- | The plugin's main entry point
+ircBotPluginCore :: Chan IrcBotMsg -> Chan IrcBotMsg -> IO ()
+ircBotPluginCore myChan masterChan = do
+ threadId <- myThreadId
+ let plugin = IrcPluginState { ircPluginName = "Core"
+ , ircPluginThreadId = threadId
+ , ircPluginChan = myChan
+ , ircPluginMasterChan = masterChan }
+ evalStateT (mapM_ sendRegisterCommand ["list", "load", "reload", "unload"]) plugin
+ plugin' <- (execStateT run plugin) `catch` (\(_ :: AsyncException) -> return plugin)
+ evalStateT (mapM_ sendUnregisterCommand ["list", "load", "reload", "unload"]) 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
+ _ -> 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
+
diff --git a/Hsbot/Irc/Plugin/Dummy.hs b/Hsbot/Irc/Plugin/Dummy.hs
new file mode 100644
index 0000000..48515ce
--- /dev/null
+++ b/Hsbot/Irc/Plugin/Dummy.hs
@@ -0,0 +1,30 @@
+module Hsbot.Irc.Plugin.Dummy
+ ( ircBotPluginDummy
+ ) where
+
+import Control.Concurrent (myThreadId)
+import Control.Concurrent.Chan
+import Control.Exception
+import Control.Monad.State
+import Prelude hiding (catch)
+
+import Hsbot.Irc.Message
+import Hsbot.Irc.PluginCommons
+
+-- | The plugin's main entry point
+ircBotPluginDummy :: Chan IrcBotMsg -> Chan IrcBotMsg -> IO ()
+ircBotPluginDummy myChan masterChan = do
+ threadId <- myThreadId
+ let plugin = IrcPluginState { ircPluginName = "Dummy"
+ , ircPluginThreadId = threadId
+ , 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
new file mode 100644
index 0000000..6a38f0d
--- /dev/null
+++ b/Hsbot/Irc/Plugin/Ping.hs
@@ -0,0 +1,36 @@
+module Hsbot.Irc.Plugin.Ping
+ ( ircBotPluginPing
+ ) where
+
+import Control.Concurrent (myThreadId)
+import Control.Concurrent.Chan
+import Control.Exception
+import Control.Monad.State
+import Prelude hiding (catch)
+
+import Hsbot.Irc.Message
+import Hsbot.Irc.PluginCommons
+
+-- | The plugin's main entry point
+ircBotPluginPing :: Chan IrcBotMsg -> Chan IrcBotMsg -> IO ()
+ircBotPluginPing myChan masterChan = do
+ threadId <- myThreadId
+ let plugin = IrcPluginState { ircPluginName = "Ping"
+ , ircPluginThreadId = threadId
+ , 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
new file mode 100644
index 0000000..ff037c7
--- /dev/null
+++ b/Hsbot/Irc/Plugin/Quote.hs
@@ -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)
+
generated by cgit v1.2.3 (git 2.25.1) at 2024-07-04 10:36:07 +0000