summaryrefslogtreecommitdiff
path: root/Hsbot/Irc
diff options
context:
space:
mode:
authorJulien Dessaux2010-05-16 00:01:00 +0200
committerJulien Dessaux2010-05-16 00:01:00 +0200
commitc1662ba7b982a8502dc9f32031b7cb518df7f60e (patch)
treef00dbd9cb39bf0fbc20949105ea2b93d9e868070 /Hsbot/Irc
parentAdded the quote module. (diff)
downloadhsbot-0.2.0.tar.gz
hsbot-0.2.0.tar.bz2
hsbot-0.2.0.zip
Rewrote nearly everything!v0.2.0
* 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
Diffstat (limited to '')
-rw-r--r--Hsbot/Irc/Command.hs59
-rw-r--r--Hsbot/Irc/Config.hs34
-rw-r--r--Hsbot/Irc/Core.hs142
-rw-r--r--Hsbot/Irc/Message.hs (renamed from Hsbot/IRCParser.hs)30
-rw-r--r--Hsbot/Irc/Plugin.hs80
-rw-r--r--Hsbot/Irc/Plugin/Core.hs (renamed from Plugins/Core.hs)38
-rw-r--r--Hsbot/Irc/Plugin/Dummy.hs30
-rw-r--r--Hsbot/Irc/Plugin/Ping.hs36
-rw-r--r--Hsbot/Irc/Plugin/Quote.hs (renamed from Plugins/Quote.hs)71
-rw-r--r--Hsbot/Irc/PluginCommons.hs67
-rw-r--r--Hsbot/Irc/Server.hs35
-rw-r--r--Hsbot/Irc/Types.hs48
-rw-r--r--Hsbot/Irc/doc/rfc2812.txt (renamed from doc/rfc2812.txt)0
13 files changed, 622 insertions, 48 deletions
diff --git a/Hsbot/Irc/Command.hs b/Hsbot/Irc/Command.hs
new file mode 100644
index 0000000..3f5c8c1
--- /dev/null
+++ b/Hsbot/Irc/Command.hs
@@ -0,0 +1,59 @@
+module Hsbot.Irc.Command
+ ( processInternalCommand
+ , registerCommand
+ , unregisterCommand
+ ) where
+
+import Control.Monad.State
+import qualified Data.List as L
+import qualified Data.Map as M
+import Data.Maybe
+
+import Hsbot.Irc.Message
+import Hsbot.Irc.Plugin
+import Hsbot.Irc.Types
+
+-- | Registers a plugin's command
+registerCommand :: String -> String -> IrcBot ()
+registerCommand cmd pluginName' = do
+ ircBot <- get
+ let cmds = ircBotCommands ircBot
+ plugins = ircBotPlugins ircBot
+ case M.lookup pluginName' plugins of
+ Just _ -> let pluginNames = pluginName' : fromMaybe [] (M.lookup cmd cmds) -- TODO : remove/check for duplicates ?
+ newCmds = M.insert cmd pluginNames cmds
+ in put $ ircBot { ircBotCommands = newCmds }
+ Nothing -> return ()
+
+-- | Unregisters a plugin's command
+unregisterCommand :: String -> String -> IrcBot ()
+unregisterCommand cmd pluginName' = do
+ ircBot <- get
+ let cmds = ircBotCommands ircBot
+ newCmds = M.adjust (L.delete pluginName') cmd cmds
+ put $ ircBot { ircBotCommands = newCmds }
+
+-- | Processes an internal command
+processInternalCommand :: IrcBotMsg -> IrcBot ()
+processInternalCommand (IntIrcCmd ircCmd)
+ | ircCmdTo ircCmd == "CORE" = processCoreCommand ircCmd
+ | otherwise = do
+ plugins <- gets ircBotPlugins
+ case M.lookup (ircCmdTo ircCmd) plugins of
+ Just plugin -> sendToPlugin (IntIrcCmd ircCmd) plugin
+ Nothing -> return ()
+processInternalCommand _ = return ()
+
+-- | Processes a core command
+processCoreCommand :: IrcCmd -> IrcBot ()
+processCoreCommand ircCmd = do
+ let command' = ircCmdCmd ircCmd
+ originalRequest = ircCmdBotMsg ircCmd
+ case command' of
+ "LIST" -> listPlugins originalRequest (ircCmdFrom ircCmd)
+ "LOAD" -> loadIrcPlugin $ ircCmdMsg ircCmd
+ "UNLOAD" -> unloadPlugin $ ircCmdMsg ircCmd
+ "REGISTER" -> registerCommand (ircCmdMsg ircCmd) (ircCmdFrom ircCmd)
+ "UNREGISTER" -> unregisterCommand (ircCmdMsg ircCmd) (ircCmdFrom ircCmd)
+ _ -> return ()
+
diff --git a/Hsbot/Irc/Config.hs b/Hsbot/Irc/Config.hs
new file mode 100644
index 0000000..5075c36
--- /dev/null
+++ b/Hsbot/Irc/Config.hs
@@ -0,0 +1,34 @@
+module Hsbot.Irc.Config
+ ( IrcConfig(..)
+ , ircDefaultConfig
+ ) where
+
+import Network
+
+-- | Configuration data type
+data IrcConfig = IrcConfig
+ { ircConfigName :: String -- The configuration name
+ , ircConfigAddress :: String -- the server's address
+ , ircConfigPort :: PortID -- the server's port
+ , ircConfigChannels :: [String] -- the Channels to join on start
+ , ircConfigNickname :: String -- the hsbot's nickname
+ , ircConfigPassword :: String -- the hsbot's password, optional
+ , ircConfigRealname :: String -- the hsbot's real name, optional
+ , ircConfigCommandPrefix :: Char -- the prefix the ircbot will recognize as commands
+ , ircConfigPlugins :: [String] -- the ircPlugins to load
+ }
+
+-- | User configuration
+ircDefaultConfig :: IrcConfig
+ircDefaultConfig = IrcConfig
+ { ircConfigName = "localhost"
+ , ircConfigAddress = "localhost"
+ , ircConfigPort = PortNumber 6667
+ , ircConfigChannels = ["#hsbot"]
+ , ircConfigNickname = "hsbot"
+ , ircConfigPassword = ""
+ , ircConfigRealname = "The One True bot, with it's haskell soul."
+ , ircConfigCommandPrefix = '@'
+ , ircConfigPlugins = ["Ping"]
+ }
+
diff --git a/Hsbot/Irc/Core.hs b/Hsbot/Irc/Core.hs
new file mode 100644
index 0000000..ac51419
--- /dev/null
+++ b/Hsbot/Irc/Core.hs
@@ -0,0 +1,142 @@
+module Hsbot.Irc.Core
+ ( ircbot
+ ) where
+
+import Control.Concurrent
+import Control.Exception (IOException, catch)
+import Control.Monad.State
+import qualified Data.Map as M
+import Data.Maybe (fromMaybe)
+import Data.Time
+import Network
+import Prelude hiding (catch)
+import System.IO
+
+import Hsbot.Irc.Command
+import Hsbot.Irc.Config
+import Hsbot.Irc.Message
+import Hsbot.Irc.Plugin
+import Hsbot.Irc.Server
+import Hsbot.Irc.Types
+import Hsbot.Message (BotMsg)
+
+-- | IrcBot's main entry point
+ircbot :: IrcConfig -> Chan BotMsg -> Chan BotMsg -> IO ()
+ircbot config masterChan myChan = do
+ startTime <- getCurrentTime
+ putStrLn "[IrcBot] Opening communication channel... "
+ chan <- newChan :: IO (Chan IrcBotMsg)
+ putStrLn $ concat ["[IrcBot] Connecting to ", ircConfigAddress config, "... "]
+ handle <- connectTo (ircConfigAddress config) (ircConfigPort config)
+ hSetBuffering handle NoBuffering
+ myOwnThreadId <- myThreadId
+ putStrLn "[IrcBot] Spawning reader threads..."
+ readerThreadId <- forkIO $ ircBotReader handle chan myOwnThreadId
+ masterReaderThreadId <- forkIO $ ircBotMasterReader masterChan chan
+ putStrLn "[IrcBot] Initializing server connection..."
+ let ircServerState = IrcServerState { ircServerId = ircConfigAddress config
+ , ircServerChannels = []
+ , ircServerNickname = ircConfigNickname config
+ , ircServerCommandPrefix = ircConfigCommandPrefix config
+ , ircServerChan = chan }
+ ircBotState = IrcBotState { ircBotStartTime = startTime
+ , ircBotPlugins = M.empty
+ , ircBotCommands = M.empty
+ , ircBotChan = chan
+ , ircBotMasterChan = masterChan
+ , ircBotMyChan = myChan
+ , ircBotServerState = ircServerState
+ , ircBotHandle = handle
+ , ircBotConfig = config
+ , ircBotReaderThreadId = readerThreadId
+ , ircBotMasterReaderThreadId = masterReaderThreadId }
+ ircBotState' <- execStateT (initBotServerConnection config) ircBotState
+ putStrLn "[IrcBot] Entering main loop... "
+ _ <- ircBotLoop ircBotState' `catch` (\(_ :: IOException) -> return ())
+ return ()
+
+-- | Runs the IrcBot's reader loop
+ircBotReader :: Handle -> Chan IrcBotMsg -> ThreadId -> IO ()
+ircBotReader handle chan fatherThreadId = forever $ do
+ str <- (hGetLine handle) `catch` handleIOException
+ let msg = parseIrcMsg str
+ case msg of
+ Right msg' -> writeChan chan (InIrcMsg msg')
+ _ -> return ()
+ where
+ handleIOException :: IOException -> IO (String)
+ handleIOException ioException = do
+ throwTo fatherThreadId ioException
+ myId <- myThreadId
+ killThread myId
+ return ""
+
+-- | Reads the Master's chan
+ircBotMasterReader :: Chan BotMsg -> Chan IrcBotMsg -> IO ()
+ircBotMasterReader masterChan _ = forever $ do
+ _ <- readChan masterChan
+ return ()
+ -- TODO : handle botMsg
+
+-- | Initialize the bot's server connection
+initBotServerConnection :: IrcConfig -> IrcBot ()
+initBotServerConnection config = do
+ ircBot <- get
+ let ircServerState = ircBotServerState ircBot
+ ircServerState' <- execStateT (initServerConnection config) ircServerState
+ put $ ircBot { ircBotServerState = ircServerState' }
+
+-- | IrcBot's loop that can catch ircbot's states' updates
+ircBotLoop :: IrcBotState -> IO ()
+ircBotLoop ircBotState = do
+ putStrLn "[IrcBot] Spawning plugins..."
+ ircBotState' <- execStateT spawnIrcPlugins ircBotState
+ -- Todo : throw new ircbotstate to hsbot
+ putStrLn "[IrcBot] Entering Core loop... "
+ _ <- (execStateT ircBotCore ircBotState') -- `catch` (\(_ :: NewBotStateException) -> return ircBotState')
+ return ()
+ -- TODO : loop!
+
+-- | Run the IrcBot's main loop
+ircBotCore :: IrcBot ()
+ircBotCore = forever $ do
+ ircBot <- get
+ let chan = ircBotChan ircBot
+ msg <- liftIO $ readChan chan
+ case msg of
+ InIrcMsg inIrcMsg -> dispatchMessage $ InIrcMsg inIrcMsg
+ OutIrcMsg outIrcMsg -> sendThisMessage outIrcMsg
+ IntIrcCmd intIrcCmd -> do
+ processInternalCommand $ IntIrcCmd intIrcCmd
+ where
+ sendThisMessage :: IrcMsg -> IrcBot ()
+ sendThisMessage outputMsg = do
+ let str = serializeIrcMsg outputMsg
+ handle <- gets ircBotHandle
+ liftIO $ hPutStr handle (str ++ "\r\n")
+
+-- | Dispatches an input message
+dispatchMessage :: IrcBotMsg -> IrcBot ()
+dispatchMessage (InIrcMsg inIrcMsg) = do
+ config <- gets ircBotConfig
+ plugins <- gets ircBotPlugins
+ cmds <- gets ircBotCommands
+ if (isPluginCommand config)
+ then
+ let key = tail . head $ words getMsgContent
+ pluginNames = fromMaybe [] $ M.lookup key cmds
+ plugins' = fromMaybe [] $ mapM (flip M.lookup plugins) pluginNames
+ in mapM_ (sendRunCommand $ tail getMsgContent) plugins'
+ else
+ mapM_ (sendToPlugin $ InIrcMsg inIrcMsg) (M.elems plugins)
+ where
+ isPluginCommand :: IrcConfig -> Bool
+ isPluginCommand config =
+ and [ ircMsgCommand inIrcMsg == "PRIVMSG"
+ , (head getMsgContent) == ircConfigCommandPrefix config ]
+ sendRunCommand :: String -> IrcPluginState -> IrcBot ()
+ sendRunCommand cmd plugin = sendToPlugin (IntIrcCmd $ IrcCmd "RUN" "CORE" (ircPluginName plugin) cmd inIrcMsg) plugin
+ getMsgContent :: String
+ getMsgContent = unwords . tail $ ircMsgParameters inIrcMsg
+dispatchMessage _ = return ()
+
diff --git a/Hsbot/IRCParser.hs b/Hsbot/Irc/Message.hs
index d284377..e92a9d0 100644
--- a/Hsbot/IRCParser.hs
+++ b/Hsbot/Irc/Message.hs
@@ -1,5 +1,8 @@
-module Hsbot.IRCParser
- ( ParseError
+module Hsbot.Irc.Message
+ ( IrcBotMsg (..)
+ , IrcCmd (..)
+ , IrcMsg (..)
+ , emptyIrcMsg
, parseIrcMsg
, serializeIrcMsg
) where
@@ -7,7 +10,26 @@ module Hsbot.IRCParser
import Control.Monad.Identity
import Text.Parsec
-import Hsbot.Types
+-- | An IRC message
+data IrcMsg = IrcMsg
+ { ircMsgPrefix :: Maybe String -- the message prefix
+ , ircMsgCommand :: String -- the message command
+ , ircMsgParameters :: [String] -- the message parameters
+ } deriving (Show)
+
+emptyIrcMsg :: IrcMsg
+emptyIrcMsg = IrcMsg Nothing "" []
+
+-- | An internal command
+data IrcCmd = IrcCmd
+ { ircCmdCmd :: String -- the internal command
+ , ircCmdFrom :: String -- who issues it
+ , ircCmdTo :: String -- who it is destinated to
+ , ircCmdMsg :: String -- the message to be transfered
+ , ircCmdBotMsg :: IrcMsg -- An IrcMsg attached to the command
+ } deriving (Show)
+
+data IrcBotMsg = InIrcMsg IrcMsg | OutIrcMsg IrcMsg | IntIrcCmd IrcCmd deriving (Show)
-- | Parses an IrcInput
parseIrcMsg :: String -> Either ParseError IrcMsg
@@ -38,7 +60,7 @@ pLongParam = char ':' >> (many1 (noneOf "\r"))
pShortParam :: ParsecT String u Identity [Char]
pShortParam = many1 (noneOf " \r")
--- |Serialize an IRC message to a string.
+-- | Serialize an IRC message to a string.
serializeIrcMsg :: IrcMsg -> String
serializeIrcMsg (IrcMsg pfx cmd params) = pfxStr ++ cmd ++ paramStr
where pfxStr = case pfx of
diff --git a/Hsbot/Irc/Plugin.hs b/Hsbot/Irc/Plugin.hs
new file mode 100644
index 0000000..b12d922
--- /dev/null
+++ b/Hsbot/Irc/Plugin.hs
@@ -0,0 +1,80 @@
+module Hsbot.Irc.Plugin
+ ( IrcPlugin
+ , IrcPluginState (..)
+ , listPlugins
+ , loadIrcPlugin
+ , sendToPlugin
+ , spawnIrcPlugins
+ , unloadPlugin
+ ) where
+
+import Control.Concurrent
+import Control.Concurrent.Chan ()
+import Control.Exception
+import Control.Monad.State
+import qualified Data.Map as M
+
+import Hsbot.Irc.Config
+import Hsbot.Irc.Message
+import Hsbot.Irc.PluginCommons
+import Hsbot.Irc.Plugin.Core
+import Hsbot.Irc.Plugin.Dummy
+import Hsbot.Irc.Plugin.Ping
+import Hsbot.Irc.Plugin.Quote
+import Hsbot.Irc.Types
+
+-- | Sends a msg to a plugin
+sendToPlugin :: IrcBotMsg -> IrcPluginState -> IrcBot ()
+sendToPlugin ircBotMsg plugin = do
+ liftIO $ writeChan (ircPluginChan plugin) ircBotMsg
+
+-- | spawns IrcPlugins
+spawnIrcPlugins :: IrcBot ()
+spawnIrcPlugins = do
+ config <- gets ircBotConfig
+ mapM_ (loadIrcPlugin) (ircConfigPlugins config)
+
+-- | loads an ircbot plugin
+loadIrcPlugin :: String -> IrcBot ()
+loadIrcPlugin pluginName = do
+ ircbot <- get
+ let masterChan = ircBotChan ircbot
+ pluginChan <- liftIO (newChan :: IO (Chan IrcBotMsg))
+ let entryPoint = case pluginName of
+ "Core" -> ircBotPluginCore
+ "Ping" -> ircBotPluginPing
+ "Quote" -> ircBotPluginQuote
+ _ -> ircBotPluginDummy
+ let oldPlugins = ircBotPlugins ircbot
+ -- We check for unicity
+ case M.lookup pluginName oldPlugins of
+ Just plugin -> return ()
+ Nothing -> do
+ threadId <- liftIO $ forkIO (entryPoint pluginChan masterChan)
+ let plugin = IrcPluginState { ircPluginName = pluginName
+ , ircPluginThreadId = threadId
+ , ircPluginChan = pluginChan
+ , ircPluginMasterChan = masterChan }
+ put $ ircbot { ircBotPlugins = M.insert pluginName plugin oldPlugins }
+
+-- | Sends a list of loaded plugins
+listPlugins :: IrcMsg -> String -> IrcBot ()
+listPlugins originalRequest dest = do
+ plugins <- gets ircBotPlugins
+ let listing = unwords $ M.keys plugins
+ case M.lookup dest plugins of
+ Just plugin -> sendToPlugin (IntIrcCmd $ IrcCmd "ANSWER" "CORE" dest listing originalRequest) plugin
+ Nothing -> return ()
+
+-- | Unloads a plugin
+unloadPlugin :: String -> IrcBot ()
+unloadPlugin name = do
+ bot <- get
+ let oldPlugins = ircBotPlugins bot
+ case M.lookup name oldPlugins of
+ Just plugin -> do
+ let newPlugins = M.delete name oldPlugins
+ liftIO $ throwTo (ircPluginThreadId plugin) UserInterrupt
+ put $ bot { ircBotPlugins = newPlugins }
+ Nothing -> return ()
+
diff --git a/Plugins/Core.hs b/Hsbot/Irc/Plugin/Core.hs
index f81f4bf..5d69ca3 100644
--- a/Plugins/Core.hs
+++ b/Hsbot/Irc/Plugin/Core.hs
@@ -1,20 +1,23 @@
-module Plugins.Core
- ( mainCore
+module Hsbot.Irc.Plugin.Core
+ ( ircBotPluginCore
) where
-import Control.Concurrent.Chan(Chan)
+import Control.Concurrent (Chan, myThreadId)
import Control.Exception
import Control.Monad.State
import Prelude hiding (catch)
-import Hsbot.IRCPlugin
-import Hsbot.Types
-import Hsbot.Utils
+import Hsbot.Irc.Message
+import Hsbot.Irc.PluginCommons
-- | The plugin's main entry point
-mainCore :: Chan BotMsg -> Chan BotMsg -> IO ()
-mainCore serverChan chan = do
- let plugin = PluginState "Core" serverChan chan
+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'
@@ -25,21 +28,20 @@ run = forever $ do
msg <- readMsg
eval msg
where
- eval :: BotMsg -> IrcPlugin ()
- eval (InternalCmd intCmd) = do
- let request = intCmdBotMsg intCmd
- case intCmdCmd intCmd of
- "RUN" -> let stuff = words $ intCmdMsg intCmd
+ 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
- _ -> lift . trace $ show intCmd -- TODO : help message
- "ANSWER" -> let stuff = intCmdMsg intCmd
+ _ -> return () -- TODO : help message
+ "ANSWER" -> let stuff = ircCmdMsg intCmd
in answerMsg request ("Loaded plugins : " ++ stuff)
- _ -> lift . trace $ show intCmd
- eval (InputMsg _) = return ()
+ _ -> return ()
eval _ = return ()
-- | The list command
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/Plugins/Quote.hs b/Hsbot/Irc/Plugin/Quote.hs
index 61e4558..ff037c7 100644
--- a/Plugins/Quote.hs
+++ b/Hsbot/Irc/Plugin/Quote.hs
@@ -1,7 +1,8 @@
-module Plugins.Quote
- ( mainQuote
+module Hsbot.Irc.Plugin.Quote
+ ( ircBotPluginQuote
) where
+import Control.Concurrent (myThreadId)
import Control.Concurrent.Chan
import Control.Exception
import Control.Monad.State
@@ -10,13 +11,15 @@ 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.IRCPlugin
-import Hsbot.Types
-import Hsbot.Utils
+import Hsbot.Irc.Message
+import Hsbot.Irc.PluginCommons
-- | A quote element
data QuoteElt = QuoteElt
@@ -40,16 +43,29 @@ data QuoteBotState = QuoteBotState
} deriving (Read, Show)
-- | The QuoteBot monad
-type QuoteBot a = StateT QuoteBotState (StateT PluginState IO) a
+type QuoteBot a = StateT QuoteBotState (StateT IrcPluginState IO) a
-- | The plugin's main entry point
-mainQuote :: Chan BotMsg -> Chan BotMsg -> IO ()
-mainQuote serverChan chan = do
+ircBotPluginQuote :: Chan IrcBotMsg -> Chan IrcBotMsg -> IO ()
+ircBotPluginQuote myChan masterChan = do
-- First of all we restore the database
- txtQuoteBot <- TIO.readFile $ "quotedb.txt"
+ 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 = PluginState "Quote" serverChan chan
+ 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
@@ -62,30 +78,31 @@ run quoteBot = do
run quoteBot'
where
-- | evaluate what we just received
- eval :: BotMsg -> IrcPlugin (QuoteBotState)
- eval (InternalCmd intCmd)
- | intCmdCmd intCmd == "RUN" = do
+ eval :: IrcBotMsg -> IrcPlugin (QuoteBotState)
+ eval (IntIrcCmd intCmd)
+ | ircCmdCmd 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)
+ | otherwise = return quoteBot
+ eval (InIrcMsg _) = return (quoteBot)
+ eval (OutIrcMsg _) = return (quoteBot)
-- | run a command we received
-runCommand :: IntCmd -> QuoteBot ()
+runCommand :: IrcCmd -> QuoteBot ()
runCommand intCmd
| theCommand == "quote" = runQuoteCommand
- | otherwise = do
- lift . lift . trace $ show intCmd -- TODO : help message
+ | 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)
- mapM_ (lift . answerMsg request) (formatQuote (M.keys quoteDB !! x) (M.elems quoteDB !! x))
+ 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
@@ -94,7 +111,7 @@ runCommand intCmd
| cmd == "start" = do
quoteBot <- get
now <- liftIO $ getCurrentTime
- let sender = takeWhile (/= '!') $ fromMaybe "ARGH" (prefix request)
+ let sender = takeWhile (/= '!') $ fromMaybe "ARGH" (ircMsgPrefix request)
newQuote = Quote sender [(quoteElt stuff)] now 0
quoteId = nextQuoteId quoteBot
quotesInProgress' = M.insert quoteId newQuote (quotesInProgress quoteBot)
@@ -134,17 +151,19 @@ runCommand intCmd
theQuote = unwords . tail $ msg
QuoteElt budy theQuote
-- | utilities
- params = words . intCmdMsg $ intCmd
+ params = words . ircCmdMsg $ intCmd
theCommand = head params
args = tail params
stuff = tail args
- request = intCmdBotMsg intCmd
+ 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
- file' <- liftIO $ openFile "quotedb.txt" WriteMode
liftIO . hPutStr file' $ show quoteBot
liftIO $ hClose file'
diff --git a/Hsbot/Irc/PluginCommons.hs b/Hsbot/Irc/PluginCommons.hs
new file mode 100644
index 0000000..71f00a4
--- /dev/null
+++ b/Hsbot/Irc/PluginCommons.hs
@@ -0,0 +1,67 @@
+module Hsbot.Irc.PluginCommons
+ ( 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
+ , ircPluginThreadId :: ThreadId -- The plugin thread
+ , 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
+
diff --git a/Hsbot/Irc/Server.hs b/Hsbot/Irc/Server.hs
new file mode 100644
index 0000000..3c20e6d
--- /dev/null
+++ b/Hsbot/Irc/Server.hs
@@ -0,0 +1,35 @@
+module Hsbot.Irc.Server
+ ( initServerConnection
+ , sendIrcMsg
+ ) where
+
+import Control.Concurrent.Chan
+import Control.Monad.State
+
+import Hsbot.Irc.Config
+import Hsbot.Irc.Message
+import Hsbot.Irc.Types
+
+-- | Setup a newly connected server by sending nick and join stuff
+initServerConnection :: IrcConfig -> IrcServer ()
+initServerConnection config = do
+ sendIrcMsg $ IrcMsg Nothing "NICK" [(ircConfigNickname config)]
+ sendIrcMsg $ IrcMsg Nothing "USER" [(ircConfigNickname config), "0", "*", (ircConfigRealname config)]
+ when (not . null $ ircConfigPassword config) $ do
+ sendIrcMsg $ IrcMsg Nothing "PRIVMSG" ["nickserv", "identify", (ircConfigPassword config)]
+ mapM_ joinChan (ircConfigChannels config)
+
+-- | Joins a chan
+joinChan :: String -> IrcServer ()
+joinChan channel = do
+ ircServer <- get
+ let oldChannels = ircServerChannels ircServer
+ sendIrcMsg $ IrcMsg Nothing "JOIN" [channel]
+ put $ ircServer { ircServerChannels = channel : oldChannels }
+
+-- | Sends an IrcMsg
+sendIrcMsg :: IrcMsg -> IrcServer ()
+sendIrcMsg ircMsg = do
+ chan <- gets ircServerChan
+ liftIO $ writeChan chan (OutIrcMsg ircMsg)
+
diff --git a/Hsbot/Irc/Types.hs b/Hsbot/Irc/Types.hs
new file mode 100644
index 0000000..eac58d7
--- /dev/null
+++ b/Hsbot/Irc/Types.hs
@@ -0,0 +1,48 @@
+module Hsbot.Irc.Types
+ ( IrcBot
+ , IrcBotState (..)
+ , IrcServer
+ , IrcServerState (..)
+ ) where
+
+import Control.Concurrent
+import Control.Monad.State
+import qualified Data.Map as M
+import Data.Time
+import System.IO
+
+import Hsbot.Irc.Config
+import Hsbot.Irc.Message
+import Hsbot.Irc.PluginCommons
+import Hsbot.Message
+
+-- | The Ircbot monad
+type IrcBot = StateT IrcBotState IO
+
+-- | An Ircbot state
+data IrcBotState = IrcBotState
+ { ircBotStartTime :: UTCTime -- the bot's uptime
+ , ircBotPlugins :: M.Map String IrcPluginState -- Loaded plugins
+ , ircBotCommands :: M.Map String [String] -- Loaded plugins
+ , ircBotChan :: Chan IrcBotMsg -- The IrcBot's communication channel
+ , ircBotMasterChan :: Chan BotMsg -- The Hsbot communication channel
+ , ircBotMyChan :: Chan BotMsg -- The Hsbot communication channel
+ , ircBotServerState :: IrcServerState -- The state of the IrcServer
+ , ircBotHandle :: Handle -- The server's socket/handle
+ , ircBotConfig :: IrcConfig -- The starting configuration
+ , ircBotReaderThreadId :: ThreadId
+ , ircBotMasterReaderThreadId :: ThreadId
+ }
+
+-- | The IrcServer monad
+type IrcServer = StateT IrcServerState IrcBot
+
+-- | An IRC server
+data IrcServerState = IrcServerState
+ { ircServerId :: String -- the server's address
+ , ircServerChannels :: [String] -- the Channels we are connected to
+ , ircServerNickname :: String -- the hsbot's nickname
+ , ircServerCommandPrefix :: Char -- the prefix the ircbot will recognize as commands
+ , ircServerChan :: Chan IrcBotMsg -- the IrcBot channel
+ }
+
diff --git a/doc/rfc2812.txt b/Hsbot/Irc/doc/rfc2812.txt
index bfa2711..bfa2711 100644
--- a/doc/rfc2812.txt
+++ b/Hsbot/Irc/doc/rfc2812.txt