adyxax/hsbot
Archived
1
0
Fork 0
Code Issues Activity

Got a working hsbot-irc back online!

Browse source
This commit is contained in:
Julien Dessaux 2010-08-01 23:29:48 +02:00
parent 03795ac2f7
commit 8c59b45dc7
7 changed files with 59 additions and 111 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

11
HsbotIrcBot/Hsbot/Irc/Command.hs
View file

@ -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 }

121
HsbotIrcBot/Hsbot/Irc/Core.hs
View file

@ -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)

2
HsbotIrcBot/Hsbot/Irc/Message.hs
View file

@ -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]

13
HsbotIrcBot/Hsbot/Irc/Plugin.hs
View file

@ -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 ()

10
HsbotIrcBot/Hsbot/Irc/Types.hs
View file

@ -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

5
HsbotIrcBot/Main.hs
View file

@ -8,6 +8,7 @@ import System.IO
import Hsbot.Irc.CLI
import Hsbot.Irc.Config
import Hsbot.Irc.Core
-- | Main function
main :: IO ()
@ -26,4 +27,8 @@ main = do
-- We find and parse the config file
ircConfig <- getIrcConfig $ optConfigFile opts
when (optDebug opts) . putStrLn $ "[hsbot-irc] Compiled config :\n" ++ (show ircConfig)
-- Finally we get into the ircbot stuff
case optDebug opts of
True -> startIrcbot opts ircConfig
False -> startIrcbot opts ircConfig -- TODO : fork process in background

8
HsbotIrcBot/hsbot-irc.cabal
View file

@ -22,8 +22,16 @@ Executable hsbot-irc
Extensions: DeriveDataTypeable ScopedTypeVariables
Build-depends: base >= 4.1 && < 5,
ConfigFile,
containers,
directory,
filepath,
haskell98,
MissingH,
mtl,
network,
parsec >= 3,
random,
text,
time,
unix