summaryrefslogtreecommitdiff
path: root/HsbotIrcBot/Hsbot/Irc
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--HsbotIrcBot/Hsbot/Irc/Command.hs11
-rw-r--r--HsbotIrcBot/Hsbot/Irc/Core.hs121
-rw-r--r--HsbotIrcBot/Hsbot/Irc/Message.hs2
-rw-r--r--HsbotIrcBot/Hsbot/Irc/Plugin.hs13
-rw-r--r--HsbotIrcBot/Hsbot/Irc/Types.hs10
5 files changed, 46 insertions, 111 deletions
diff --git a/HsbotIrcBot/Hsbot/Irc/Command.hs b/HsbotIrcBot/Hsbot/Irc/Command.hs
index 51c2187..1b913e2 100644
--- a/HsbotIrcBot/Hsbot/Irc/Command.hs
+++ b/HsbotIrcBot/Hsbot/Irc/Command.hs
@@ -12,7 +12,6 @@ import Data.Maybe
import Hsbot.Irc.Message
import Hsbot.Irc.Plugin
import Hsbot.Irc.Types
-import Hsbot.Types
-- | Registers a plugin's command
registerCommand :: String -> String -> IrcBot ()
@@ -57,18 +56,8 @@ processCoreCommand ircCmd = do
"REGISTER" -> registerCommand (ircCmdMsg ircCmd) (ircCmdFrom ircCmd)
"UNLOAD" -> unloadIrcPlugin $ ircCmdMsg ircCmd
"UNREGISTER" -> unregisterCommand (ircCmdMsg ircCmd) (ircCmdFrom ircCmd)
- "UPDATE" -> processUpdateCommand ircCmd
_ -> return ()
if command' == "REBOOT"
then return BotReboot
else return BotContinue
--- | Process an update command
-processUpdateCommand :: IrcCmd -> IrcBot ()
-processUpdateCommand ircCmd = do
- ircbot <- get
- let oldData = ircBotResumeData ircbot
- from = ircCmdFrom ircCmd
- stuff = ircCmdMsg ircCmd
- put $ ircbot { ircBotResumeData = M.insert from stuff oldData }
-
diff --git a/HsbotIrcBot/Hsbot/Irc/Core.hs b/HsbotIrcBot/Hsbot/Irc/Core.hs
index d65e975..525c3d6 100644
--- a/HsbotIrcBot/Hsbot/Irc/Core.hs
+++ b/HsbotIrcBot/Hsbot/Irc/Core.hs
@@ -10,72 +10,56 @@ import Data.Maybe (fromMaybe)
import Network
import Prelude hiding (catch)
import System.IO
-import System.Posix.IO (fdToHandle, handleToFd)
-import System.Posix.Types (Fd)
+import Hsbot.Irc.CLI
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.Types
-- | IrcBot's main entry point
-startIrcbot :: IrcConfig -> Chan BotMsg -> Chan BotMsg -> Maybe String -> IO ()
-startIrcbot config masterChan myChan txtResumeData = do
- let resumeData = case txtResumeData of
- Just txtData -> read txtData :: ResumeData -- TODO : catch exception
- Nothing -> M.empty :: ResumeData
- print resumeData
- putStrLn "[IrcBot] Opening communication channel... "
+startIrcbot :: Options -> IrcConfig -> IO ()
+startIrcbot opts ircConfig = do
+ when (optDebug opts) $ putStrLn "[IrcBot] Opening communication channel... "
chan <- newChan :: IO (Chan IrcBotMsg)
- handle <- case M.lookup "HANDLE" resumeData of
- Just txtFd -> do
- let fd = read txtFd :: Fd
- fdToHandle fd
- Nothing -> do
- putStrLn $ concat ["[IrcBot] Connecting to ", ircConfigAddress config, "... "]
- handle <- connectTo (ircConfigAddress config) (ircConfigPort config)
- hSetBuffering handle NoBuffering
- hSetEncoding handle utf8
- return handle
- fd <- handleToFd handle
- putStrLn "[IrcBot] Spawning reader threads..."
+ when (optDebug opts) . putStrLn $ concat ["[IrcBot] Connecting to ", ircConfigAddress ircConfig, "... "]
+ handle <- connectTo (ircConfigAddress ircConfig) (ircConfigPort ircConfig)
+ hSetBuffering handle NoBuffering
+ hSetEncoding handle utf8
+ when (optDebug opts) $ putStrLn "[IrcBot] Spawning reader thread..."
myOwnThreadId <- myThreadId
readerThreadId <- forkIO $ ircBotReader handle chan myOwnThreadId
- masterReaderThreadId <- forkIO $ ircBotMasterReader myChan chan
- putStrLn "[IrcBot] Initializing server connection..."
- let ircServerState = IrcServerState { ircServerId = ircConfigAddress config
+ when (optDebug opts) $ putStrLn "[IrcBot] Initializing server connection..."
+ let ircServerState = IrcServerState { ircServerId = ircConfigAddress ircConfig
, ircServerChannels = []
- , ircServerNickname = ircConfigNickname config
- , ircServerCommandPrefix = ircConfigCommandPrefix config
+ , ircServerNickname = ircConfigNickname ircConfig
+ , ircServerCommandPrefix = ircConfigCommandPrefix ircConfig
, ircServerChan = chan }
ircBotState = IrcBotState { ircBotPlugins = M.empty
, ircBotCommands = M.empty
, ircBotChan = chan
- , ircBotMasterChan = masterChan
, ircBotServerState = ircServerState
, ircBotHandle = handle
- , ircBotConfig = config
- , ircBotResumeData = M.singleton "HANDLE" (show fd) }
- ircBotState' <- execStateT (initBotServerConnection config) ircBotState
- putStrLn "[IrcBot] Spawning plugins..."
+ , ircBotConfig = ircConfig }
+ ircBotState' <- execStateT (initBotServerConnection ircConfig) ircBotState
+ when (optDebug opts) $ putStrLn "[IrcBot] Spawning plugins..."
ircBotState'' <- execStateT spawnIrcPlugins ircBotState'
- putStrLn "[IrcBot] Entering Core loop... "
- ircBotState''' <- (execStateT ircBotLoop ircBotState'') `catches` [ Handler (\ (_ :: IOException) -> return (ircBotState''))
- , Handler (\ (_ :: AsyncException) -> return (ircBotState'')) ]
- putStrLn "[IrcBot] Killing reader threads..."
+ when (optDebug opts) $ putStrLn "[IrcBot] Entering Core loop... "
+ (_, ircBotState''') <- runLoop ircBotState''
+ when (optDebug opts) $ putStrLn "[IrcBot] Killing reader thread..."
killThread readerThreadId
- killThread masterReaderThreadId
- putStrLn "[IrcBot] Killing active plugins... "
- let resumeData' = ircBotResumeData ircBotState'''
- ircPlugins = read (fromMaybe [] (M.lookup "PLUGINS" resumeData')) :: [String]
- evalStateT (mapM_ killIrcPlugin ircPlugins) ircBotState'''
- return ()
-
---resumeIrcBot
---resumeIrcBot
+ when (optDebug opts) $ putStrLn "[IrcBot] Killing active plugins... "
+ evalStateT (mapM_ killIrcPlugin . M.keys $ ircBotPlugins ircBotState''') ircBotState'''
+ where
+ runLoop :: IrcBotState -> IO (BotStatus, IrcBotState)
+ runLoop botState = do
+ (status, botState') <- (runStateT ircBotCore botState) `catches` [ Handler (\ (_ :: IOException) -> return (BotExit, botState))
+ , Handler (\ (_ :: AsyncException) -> return (BotExit, botState)) ]
+ case status of
+ BotContinue -> runLoop botState'
+ _ -> return (status, botState')
-- | Runs the IrcBot's reader loop
ircBotReader :: Handle -> Chan IrcBotMsg -> ThreadId -> IO ()
@@ -93,13 +77,6 @@ ircBotReader handle chan fatherThreadId = forever $ do
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
@@ -109,28 +86,24 @@ initBotServerConnection config = do
put $ ircBot { ircBotServerState = ircServerState' }
-- | Run the IrcBot's main loop
-ircBotLoop :: IrcBot ()
-ircBotLoop = forever $ do
+ircBotCore :: IrcBot (BotStatus)
+ircBotCore = do
chan <- gets ircBotChan
msg <- liftIO $ readChan chan
case msg of
InIrcMsg inIrcMsg -> dispatchMessage $ InIrcMsg inIrcMsg
OutIrcMsg outIrcMsg -> sendThisMessage outIrcMsg
- IntIrcCmd intIrcCmd -> do
- reboot <- processInternalCommand $ IntIrcCmd intIrcCmd
- reportUpdate
- if reboot == BotReboot
- then processRebootCommand
- else return ()
+ IntIrcCmd intIrcCmd -> processInternalCommand $ IntIrcCmd intIrcCmd
where
- sendThisMessage :: IrcMsg -> IrcBot ()
+ sendThisMessage :: IrcMsg -> IrcBot (BotStatus)
sendThisMessage outputMsg = do
let str = serializeIrcMsg outputMsg
handle <- gets ircBotHandle
liftIO $ hPutStr handle (str ++ "\r\n")
+ return BotContinue
-- | Dispatches an input message
-dispatchMessage :: IrcBotMsg -> IrcBot ()
+dispatchMessage :: IrcBotMsg -> IrcBot (BotStatus)
dispatchMessage (InIrcMsg inIrcMsg) = do
config <- gets ircBotConfig
plugins <- gets ircBotPlugins
@@ -143,6 +116,7 @@ dispatchMessage (InIrcMsg inIrcMsg) = do
in mapM_ (sendRunCommand (tail getMsgContent) . first) plugins'
else
mapM_ (sendToPlugin (InIrcMsg inIrcMsg) . first) (M.elems plugins)
+ return BotContinue
where
isPluginCommand :: IrcConfig -> Bool
isPluginCommand config =
@@ -152,26 +126,5 @@ dispatchMessage (InIrcMsg inIrcMsg) = do
sendRunCommand cmd plugin = sendToPlugin (IntIrcCmd $ IrcCmd "RUN" "CORE" (ircPluginName plugin) cmd inIrcMsg) plugin
getMsgContent :: String
getMsgContent = unwords . tail $ ircMsgParameters inIrcMsg
-dispatchMessage _ = return ()
-
--- | Reports an update to the master bot
-reportUpdate :: IrcBot ()
-reportUpdate = do
- ircbot <- get
- let masterChan = ircBotMasterChan ircbot
- msg = UpdMsg $ ResMsg { resMsgFrom = ircConfigName $ ircBotConfig ircbot
- , resMsgData = ircBotResumeData ircbot }
- liftIO $ writeChan masterChan msg
-
--- | Process a reboot command
-processRebootCommand :: IrcBot ()
-processRebootCommand = do
- ircbot <- get
- let masterChan = ircBotMasterChan ircbot
- msg = IntMsg $ Msg { msgType = "REBOOT"
- , msgFrom = ircConfigName $ ircBotConfig ircbot
- , msgTo = "CORE"
- , msgStuff = show $ ircBotResumeData ircbot
- }
- liftIO $ writeChan masterChan msg
+dispatchMessage _ = return (BotContinue)
diff --git a/HsbotIrcBot/Hsbot/Irc/Message.hs b/HsbotIrcBot/Hsbot/Irc/Message.hs
index e92a9d0..8ab23d8 100644
--- a/HsbotIrcBot/Hsbot/Irc/Message.hs
+++ b/HsbotIrcBot/Hsbot/Irc/Message.hs
@@ -41,7 +41,7 @@ pMsg = do
cmd <- pCommand
params <- many (char ' ' >> (pLongParam <|> pShortParam))
_ <- char '\r'
- --eof
+ eof
return $ IrcMsg pfx cmd params
pPrefix :: ParsecT String u Identity [Char]
diff --git a/HsbotIrcBot/Hsbot/Irc/Plugin.hs b/HsbotIrcBot/Hsbot/Irc/Plugin.hs
index 2c8e84b..40facbe 100644
--- a/HsbotIrcBot/Hsbot/Irc/Plugin.hs
+++ b/HsbotIrcBot/Hsbot/Irc/Plugin.hs
@@ -47,7 +47,6 @@ loadIrcPlugin pluginName = do
"Quote" -> ircBotPluginQuote
_ -> ircBotPluginDummy
let oldPlugins = ircBotPlugins ircbot
- oldResumeData = ircBotResumeData ircbot
-- We check for unicity
case M.lookup pluginName oldPlugins of
Just _ -> return ()
@@ -58,9 +57,7 @@ loadIrcPlugin pluginName = do
, ircPluginChan = pluginChan
, ircPluginMasterChan = masterChan }
newPlugins = M.insert pluginName (plugin, mvar, threadId) oldPlugins
- newResumeData = M.insert "PLUGINS" (show $ M.keys newPlugins) oldResumeData
- put $ ircbot { ircBotPlugins = newPlugins
- , ircBotResumeData = newResumeData }
+ put $ ircbot { ircBotPlugins = newPlugins }
-- | Sends a list of loaded plugins
listPlugins :: IrcMsg -> String -> IrcBot ()
@@ -73,13 +70,7 @@ listPlugins originalRequest dest = do
-- | Unloads a plugin
unloadIrcPlugin :: String -> IrcBot ()
-unloadIrcPlugin name = do
- killIrcPlugin name
- ircbot <- get
- let oldResumeData = ircBotResumeData ircbot
- newPlugins = M.keys $ ircBotPlugins ircbot
- newResumeData = M.insert "PLUGINS" (show newPlugins) oldResumeData
- put $ ircbot { ircBotResumeData = newResumeData }
+unloadIrcPlugin name = killIrcPlugin name
-- | kills a plugin
killIrcPlugin :: String -> IrcBot ()
diff --git a/HsbotIrcBot/Hsbot/Irc/Types.hs b/HsbotIrcBot/Hsbot/Irc/Types.hs
index 63411df..e7a64ea 100644
--- a/HsbotIrcBot/Hsbot/Irc/Types.hs
+++ b/HsbotIrcBot/Hsbot/Irc/Types.hs
@@ -1,5 +1,6 @@
module Hsbot.Irc.Types
- ( IrcBot
+ ( BotStatus (..)
+ , IrcBot
, IrcBotState (..)
, IrcServer
, IrcServerState (..)
@@ -14,7 +15,6 @@ import System.IO
import Hsbot.Irc.Config
import Hsbot.Irc.Message
import Hsbot.Irc.Plugin.Utils
-import Hsbot.Types
-- | The Ircbot monad
type IrcBot = StateT IrcBotState IO
@@ -24,13 +24,14 @@ data IrcBotState = IrcBotState
{ ircBotPlugins :: M.Map String (IrcPluginState, MVar (), ThreadId) -- Loaded plugins
, ircBotCommands :: M.Map String [String] -- Loaded plugins
, ircBotChan :: Chan IrcBotMsg -- The IrcBot's communication channel
- , ircBotMasterChan :: 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
- , ircBotResumeData :: ResumeData -- the necessary data to resume the bot's operations on reboot
}
+-- | how we exit from the botLoop
+data BotStatus = BotExit | BotReboot | BotContinue deriving (Eq)
+
-- | The IrcServer monad
type IrcServer = StateT IrcServerState IrcBot
@@ -46,3 +47,4 @@ data IrcServerState = IrcServerState
-- | Utilities for triplets
first :: (a, b, c) -> a
first (a, _, _) = a
+