Rewrote nearly everything!
* 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
This commit is contained in:
Julien Dessaux
parent
c20cfe88b3
commit
c1662ba7b9
33 changed files with 856 additions and 654 deletions
110
Hsbot/Core.hs
110
Hsbot/Core.hs
|
|
@ -1,71 +1,69 @@
|
|||
module Hsbot.Core
|
||||
( connectServer
|
||||
, disconnectServer
|
||||
( hsbot
|
||||
) where
|
||||
|
||||
import Control.Concurrent
|
||||
import Control.Concurrent.Chan()
|
||||
import Control.Exception(IOException, catch)
|
||||
import Control.Concurrent.Chan ()
|
||||
import Control.Exception
|
||||
import Control.Monad.State
|
||||
import Data.List()
|
||||
import qualified Data.Map as M
|
||||
import Network
|
||||
import Data.Time
|
||||
import Prelude hiding (catch)
|
||||
import System.IO
|
||||
import System.Time (getClockTime)
|
||||
import System.IO()
|
||||
|
||||
import Hsbot.IRCParser
|
||||
import Hsbot.Config
|
||||
import Hsbot.Irc.Config
|
||||
import Hsbot.Irc.Core (ircbot)
|
||||
import Hsbot.Message
|
||||
import Hsbot.Plugin
|
||||
import Hsbot.Types
|
||||
import Hsbot.Utils
|
||||
|
||||
-- Connect to the server and return the initial bot state
|
||||
connectServer :: IrcServer -> IO Bot
|
||||
connectServer server = do
|
||||
let name = serverAddress server
|
||||
starttime <- getClockTime
|
||||
putStr $ "Connecting to " ++ name ++ "... "
|
||||
handle <- connectTo name $ serverPort server
|
||||
hSetBuffering handle NoBuffering
|
||||
putStrLn "done."
|
||||
putStr "Opening server communication channel... "
|
||||
-- | The Bot monad
|
||||
type Bot = StateT BotState IO
|
||||
|
||||
-- | An Hsbot state
|
||||
data BotState = BotState
|
||||
{ botStartTime :: UTCTime -- the bot's uptime
|
||||
, botPlugins :: M.Map String PluginState -- Loaded plugins
|
||||
, botChan :: Chan BotMsg -- The bot's communication channel
|
||||
, botConfig :: Config -- the bot's starting config
|
||||
}
|
||||
|
||||
-- | Bot's main entry point
|
||||
hsbot :: Config -> IO ()
|
||||
hsbot config = do
|
||||
startTime <- getCurrentTime
|
||||
putStrLn "[Hsbot] Opening communication channel... "
|
||||
chan <- newChan :: IO (Chan BotMsg)
|
||||
myFatherThreadId <- myThreadId
|
||||
threadId <- forkIO $ botReader handle chan myFatherThreadId
|
||||
putStrLn "done."
|
||||
return $ Bot server starttime handle [] M.empty chan threadId M.empty
|
||||
putStrLn "[Hsbot] Spawning IrcBot plugins... "
|
||||
botState <- execStateT spawnIrcPlugins BotState { botStartTime = startTime
|
||||
, botPlugins = M.empty
|
||||
, botChan = chan
|
||||
, botConfig = config }
|
||||
putStrLn "[Hsbot] Entering main loop... "
|
||||
botState' <- (execStateT botLoop botState) `catch` (\(_ :: IOException) -> return botState)
|
||||
return ()
|
||||
|
||||
-- | Disconnect from the server
|
||||
disconnectServer :: IrcBot ()
|
||||
disconnectServer = do
|
||||
bot <- get
|
||||
let name = serverAddress $ serverConfig bot
|
||||
liftIO $ putStr "Shutting down plugins..."
|
||||
mapM_ unloadPlugin (M.keys $ botPlugins bot)
|
||||
liftIO $ putStrLn"done."
|
||||
liftIO $ putStr "Closing server communication channel... "
|
||||
liftIO . killThread $ readerThreadId bot
|
||||
liftIO $ putStrLn "done."
|
||||
liftIO . putStr $ "Disconnecting from " ++ name ++ "... "
|
||||
liftIO . hClose $ botHandle bot
|
||||
liftIO $ putStrLn "done."
|
||||
-- | Run the bot main loop
|
||||
botLoop :: Bot ()
|
||||
botLoop = forever $ do
|
||||
chan <- gets botChan
|
||||
msg <- liftIO $ readChan chan
|
||||
-- process messages
|
||||
return ()
|
||||
|
||||
-- | Socket reading loop
|
||||
botReader :: Handle -> Chan BotMsg -> ThreadId -> IO ()
|
||||
botReader handle chan fatherThreadId = forever $ do
|
||||
str <- (hGetLine handle) `catch` handleIOException
|
||||
let msg = parseIrcMsg str
|
||||
case msg of
|
||||
Right msg' -> do
|
||||
trace $ inColor ("<-- " ++ (show msg')) [33]
|
||||
writeChan chan (InputMsg msg')
|
||||
_ -> do
|
||||
return ()
|
||||
-- | spawns IrcPlugins
|
||||
spawnIrcPlugins :: Bot ()
|
||||
spawnIrcPlugins = do
|
||||
config <- gets botConfig
|
||||
mapM_ (spawnIrcPlugin) (ircConfigs config)
|
||||
where
|
||||
handleIOException :: IOException -> IO (String)
|
||||
handleIOException ioException = do
|
||||
throwTo fatherThreadId ioException
|
||||
myId <- myThreadId
|
||||
killThread myId
|
||||
return ""
|
||||
spawnIrcPlugin :: IrcConfig -> Bot ()
|
||||
spawnIrcPlugin config = do
|
||||
bot <- get
|
||||
let chan = botChan bot
|
||||
pchan <- liftIO (newChan :: IO (Chan BotMsg))
|
||||
threadId <- liftIO $ forkIO (ircbot config chan pchan)
|
||||
let plugin = PluginState (ircConfigName config) threadId pchan M.empty
|
||||
plugins = botPlugins bot
|
||||
put $ bot { botPlugins = M.insert (pluginName plugin) plugin plugins }
|
||||
|
||||
|
|
|
|||
Reference in a new issue