summaryrefslogtreecommitdiff
path: root/HsbotIrcBot/Hsbot/Irc/Plugin
diff options
context:
space:
mode:
Diffstat (limited to 'HsbotIrcBot/Hsbot/Irc/Plugin')
-rw-r--r--HsbotIrcBot/Hsbot/Irc/Plugin/Core.hs66
-rw-r--r--HsbotIrcBot/Hsbot/Irc/Plugin/Dummy.hs27
-rw-r--r--HsbotIrcBot/Hsbot/Irc/Plugin/Ping.hs33
-rw-r--r--HsbotIrcBot/Hsbot/Irc/Plugin/Quote.hs201
-rw-r--r--HsbotIrcBot/Hsbot/Irc/Plugin/Utils.hs66
5 files changed, 0 insertions, 393 deletions
diff --git a/HsbotIrcBot/Hsbot/Irc/Plugin/Core.hs b/HsbotIrcBot/Hsbot/Irc/Plugin/Core.hs
deleted file mode 100644
index 114ced8..0000000
--- a/HsbotIrcBot/Hsbot/Irc/Plugin/Core.hs
+++ /dev/null
@@ -1,66 +0,0 @@
-module Hsbot.Irc.Plugin.Core
- ( ircBotPluginCore
- ) where
-
-import Control.Concurrent (Chan)
-import Control.Exception
-import Control.Monad.State
-import Prelude hiding (catch)
-
-import Hsbot.Irc.Message
-import Hsbot.Irc.Plugin.Utils
-
--- | The plugin's main entry point
-ircBotPluginCore :: Chan IrcBotMsg -> Chan IrcBotMsg -> IO ()
-ircBotPluginCore myChan masterChan = do
- let plugin = IrcPluginState { ircPluginName = "Core"
- , ircPluginChan = myChan
- , ircPluginMasterChan = masterChan }
- evalStateT (mapM_ sendRegisterCommand ["list", "load", "reload", "unload", "reboot"]) plugin
- plugin' <- (execStateT run plugin) `catch` (\(_ :: AsyncException) -> return plugin)
- evalStateT (mapM_ sendUnregisterCommand ["list", "load", "reload", "unload", "reboot"]) 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
- "reboot" -> rebootBot $ 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
-
--- | The reboot command
-rebootBot :: [String] -> IrcPlugin ()
-rebootBot stuff = sendCommand "REBOOT" "CORE" $ unwords stuff
-
diff --git a/HsbotIrcBot/Hsbot/Irc/Plugin/Dummy.hs b/HsbotIrcBot/Hsbot/Irc/Plugin/Dummy.hs
deleted file mode 100644
index 4e10644..0000000
--- a/HsbotIrcBot/Hsbot/Irc/Plugin/Dummy.hs
+++ /dev/null
@@ -1,27 +0,0 @@
-module Hsbot.Irc.Plugin.Dummy
- ( ircBotPluginDummy
- ) where
-
-import Control.Concurrent.Chan
-import Control.Exception
-import Control.Monad.State
-import Prelude hiding (catch)
-
-import Hsbot.Irc.Message
-import Hsbot.Irc.Plugin.Utils
-
--- | The plugin's main entry point
-ircBotPluginDummy :: Chan IrcBotMsg -> Chan IrcBotMsg -> IO ()
-ircBotPluginDummy myChan masterChan = do
- let plugin = IrcPluginState { ircPluginName = "Dummy"
- , 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/HsbotIrcBot/Hsbot/Irc/Plugin/Ping.hs b/HsbotIrcBot/Hsbot/Irc/Plugin/Ping.hs
deleted file mode 100644
index 57418b3..0000000
--- a/HsbotIrcBot/Hsbot/Irc/Plugin/Ping.hs
+++ /dev/null
@@ -1,33 +0,0 @@
-module Hsbot.Irc.Plugin.Ping
- ( ircBotPluginPing
- ) where
-
-import Control.Concurrent.Chan
-import Control.Exception
-import Control.Monad.State
-import Prelude hiding (catch)
-
-import Hsbot.Irc.Message
-import Hsbot.Irc.Plugin.Utils
-
--- | The plugin's main entry point
-ircBotPluginPing :: Chan IrcBotMsg -> Chan IrcBotMsg -> IO ()
-ircBotPluginPing myChan masterChan = do
- let plugin = IrcPluginState { ircPluginName = "Ping"
- , 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/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)
-
diff --git a/HsbotIrcBot/Hsbot/Irc/Plugin/Utils.hs b/HsbotIrcBot/Hsbot/Irc/Plugin/Utils.hs
deleted file mode 100644
index 1e54d3a..0000000
--- a/HsbotIrcBot/Hsbot/Irc/Plugin/Utils.hs
+++ /dev/null
@@ -1,66 +0,0 @@
-module Hsbot.Irc.Plugin.Utils
- ( IrcPlugin
- , IrcPluginState (..)
- , answerMsg
- , readMsg
- , sendCommand
- , sendCommandWithRequest
- , sendRegisterCommand
- , sendUnregisterCommand
- , writeMsg
- ) where
-
-import Control.Concurrent
-import Control.Concurrent.Chan ()
-import Control.Monad.State
-import Data.Maybe (fromMaybe)
-
-import Hsbot.Irc.Message
-
--- | The IrcPlugin monad
-type IrcPlugin = StateT IrcPluginState IO
-
--- | A plugin state
-data IrcPluginState = IrcPluginState
- { ircPluginName :: String -- The plugin's name
- , ircPluginChan :: Chan IrcBotMsg -- The plugin chan
- , ircPluginMasterChan :: Chan IrcBotMsg -- The master's chan
- }
-
---- | Basic input output for IrcPlugins
-readMsg :: IrcPlugin (IrcBotMsg)
-readMsg = do
- chan <- gets ircPluginChan
- input <- liftIO $ readChan chan
- return input
-
-writeMsg :: IrcBotMsg -> IrcPlugin ()
-writeMsg (OutIrcMsg msg) = do
- chan <- gets ircPluginMasterChan
- liftIO $ writeChan chan (OutIrcMsg msg)
-writeMsg _ = return ()
-
-answerMsg :: IrcMsg -> String -> IrcPlugin ()
-answerMsg request msg = do
- let chanOrigin = head $ ircMsgParameters request
- sender = takeWhile (/= '!') $ fromMaybe "" (ircMsgPrefix request)
- case head chanOrigin of
- '#' -> writeMsg . OutIrcMsg $ IrcMsg Nothing "PRIVMSG" [chanOrigin, msg]
- _ -> writeMsg . OutIrcMsg $ IrcMsg Nothing "PRIVMSG" [sender, msg]
-
--- | Command management
-sendCommand :: String -> String -> String -> IrcPlugin ()
-sendCommand cmd to params = sendCommandWithRequest cmd to params emptyIrcMsg
-
-sendCommandWithRequest :: String -> String -> String -> IrcMsg -> IrcPlugin ()
-sendCommandWithRequest cmd to params originalRequest = do
- masterChan <- gets ircPluginMasterChan
- from <- gets ircPluginName
- liftIO . writeChan masterChan . IntIrcCmd $ IrcCmd cmd from to params originalRequest
-
-sendRegisterCommand :: String -> IrcPlugin ()
-sendRegisterCommand cmd = sendCommand "REGISTER" "CORE" cmd
-
-sendUnregisterCommand :: String -> IrcPlugin ()
-sendUnregisterCommand cmd = sendCommand "UNREGISTER" "CORE" cmd
-
generated by cgit v1.2.3 (git 2.39.1) at 2024-10-05 22:44:29 +0000