Moved files around as a preliminary for architectural changes.
This commit is contained in:
Julien Dessaux
parent
d97177ce3b
commit
11c2c16835
29 changed files with 17 additions and 0 deletions
177
HsbotIrcBot/Hsbot/Irc/Core.hs
Normal file
177
HsbotIrcBot/Hsbot/Irc/Core.hs
Normal file
|
|
@ -0,0 +1,177 @@
|
|||
module Hsbot.Irc.Core
|
||||
( startIrcbot
|
||||
) where
|
||||
|
||||
import Control.Concurrent
|
||||
import Control.Exception (AsyncException, Handler (..), IOException, catch, catches)
|
||||
import Control.Monad.State
|
||||
import qualified Data.Map as M
|
||||
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.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... "
|
||||
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..."
|
||||
myOwnThreadId <- myThreadId
|
||||
readerThreadId <- forkIO $ ircBotReader handle chan myOwnThreadId
|
||||
masterReaderThreadId <- forkIO $ ircBotMasterReader myChan chan
|
||||
putStrLn "[IrcBot] Initializing server connection..."
|
||||
let ircServerState = IrcServerState { ircServerId = ircConfigAddress config
|
||||
, ircServerChannels = []
|
||||
, ircServerNickname = ircConfigNickname config
|
||||
, ircServerCommandPrefix = ircConfigCommandPrefix config
|
||||
, 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..."
|
||||
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..."
|
||||
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
|
||||
|
||||
-- | 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' }
|
||||
|
||||
-- | Run the IrcBot's main loop
|
||||
ircBotLoop :: IrcBot ()
|
||||
ircBotLoop = forever $ 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 ()
|
||||
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) . first) plugins'
|
||||
else
|
||||
mapM_ (sendToPlugin (InIrcMsg inIrcMsg) . first) (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 ()
|
||||
|
||||
-- | 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
|
||||
|
||||
Reference in a new issue