summaryrefslogtreecommitdiff
path: root/Hsbot
diff options
context:
space:
mode:
authorJulien Dessaux2010-02-04 20:36:58 +0100
committerJulien Dessaux2010-02-04 20:36:58 +0100
commit884c6c9f2e3a03d6666c8dd6c6d6b6513db88ad5 (patch)
treec5941649d7fe1ac23d5ee673c240efb8508b3db2 /Hsbot
parentRewrote the whole architecture. (diff)
downloadhsbot-884c6c9f2e3a03d6666c8dd6c6d6b6513db88ad5.tar.gz
hsbot-884c6c9f2e3a03d6666c8dd6c6d6b6513db88ad5.tar.bz2
hsbot-884c6c9f2e3a03d6666c8dd6c6d6b6513db88ad5.zip
Reorganized code and types, changed slightly the architecture.
Diffstat (limited to 'Hsbot')
-rw-r--r--Hsbot/Core.hs152
-rw-r--r--Hsbot/IRC.hs47
-rw-r--r--Hsbot/IRCParser.hs15
-rw-r--r--Hsbot/Main.hs1
-rw-r--r--Hsbot/Plugin.hs56
-rw-r--r--Hsbot/Types.hs104
-rw-r--r--Hsbot/Utils.hs33
7 files changed, 245 insertions, 163 deletions
diff --git a/Hsbot/Core.hs b/Hsbot/Core.hs
index 41340ba..b0efc03 100644
--- a/Hsbot/Core.hs
+++ b/Hsbot/Core.hs
@@ -1,17 +1,6 @@
module Hsbot.Core
- ( Bot(..)
- , Channel(..)
- , Config(..)
- , IrcServer(..)
- , IrcBot
- , IrcMsg(..)
- , Plugin(..)
- , connectServer
+ ( connectServer
, disconnectServer
- , inColor
- , serializeIrcMsg
- , traceM
- , writeMsg
) where
import Control.Concurrent
@@ -20,82 +9,11 @@ import Control.Monad.State
import Data.List
import Network
import System.IO
-import System.Plugins
-import System.Time (ClockTime, getClockTime)
+import System.Time (getClockTime)
--- | TODO : a monad for a channel, and a monad for a server, all together driven by a Bot?
-
--- | Configuration data type
-data Config = Config {
- commandPrefixes :: String, -- command prefixes, for example @[\'>\',\'@\',\'?\']@
- ircServer :: IrcServer -- list of 'Server's to connect to
-} deriving (Show)
-
--- | An IRC server
-data IrcServer = IrcServer
- { address :: String -- the server's address
- , port :: PortID -- the server's port
- , channels :: [String] -- a list of channels to join
- , nickname :: String -- the hsbot's nickname
- , password :: String -- the hsbot's password, optional
- , realname :: String -- the hsbot's real name, optional
- , administrators :: [String] -- bot admins nicknames
- }
-
-instance Show IrcServer where
- show (IrcServer a p c n pa r ad) = (show a)
- ++ (case p of
- PortNumber num -> show num
- Service s -> show s
- UnixSocket u -> show u)
- ++ (show c) ++ (show n) ++ (show pa) ++ (show r) ++ (show ad)
-
--- instance Show PortID where
--- show (PortNumber n) = show n
--- show (Service s) = show s
--- show (UnixSocket g) = show g
-
--- | The IrcBot monad
-type IrcBot a = StateT Bot IO a
-
--- | An IRC Bot server state
-data Bot = Bot
- { serverConfig :: IrcServer -- original server config we are connected to
- , startTime :: ClockTime -- the bot's uptime
- , botHandle :: Handle -- the socket/handle
- , chans :: [Channel] -- the list of channels we have joined
- , botPlugins :: [Plugin] -- The list of loaded plugins
- , serverChannel :: Chan IrcMsg -- The bot's communication channel
- , serverThreadId :: ThreadId -- The bot's thread ID
- }
-
-instance Show Bot where
- show (Bot _ s h c p _ _) = (show s) ++ (show h) ++ (show c) ++ (show p)
-
--- | A channel connection
-data Channel = Channel
- { channelName :: String -- the channel's name
- , channelNick :: String -- our nickname
- , channelAdmins :: [String] -- the bot administrators
- } deriving (Show)
-
--- |An IRC message.
-data IrcMsg = IrcMsg
- { prefix :: Maybe String -- the message prefix
- , command :: String -- the message command
- , parameters :: [String] -- the message parameters
- } deriving (Show)
-
--- | A plugin definition
-data Plugin = Plugin
- { pluginName :: String -- The plugin's name
- , pluginModule :: Module -- The plugin himself
- , pluginThreadId :: ThreadId -- The plugin thread
- , pluginChannel :: Chan IrcMsg -- The plugin channel
- }
-
-instance Show Plugin where
- show (Plugin name _ _ _) = show name
+import Hsbot.IRCParser
+import Hsbot.Types
+import Hsbot.Utils
-- Connect to the server and return the initial bot state
connectServer :: IrcServer -> IO Bot
@@ -107,57 +25,29 @@ connectServer server = do
hSetBuffering handle NoBuffering
putStrLn "done."
putStr $ "Opening server communication channel... "
- chan <- newChan :: IO (Chan IrcMsg)
- threadId <- forkIO $ botWriter handle chan
+ chan <- newChan :: IO (Chan BotMsg)
+ threadId <- forkIO $ botReader handle chan
putStrLn "done."
return (Bot server starttime handle [] [] chan threadId)
-- | Disconnect from the server
disconnectServer :: Bot -> IO () -- IO Bot ?
disconnectServer bot = do
- killThread $ serverThreadId bot
+ killThread $ readerThreadId bot
+ mapM_ (killThread . pluginThreadId) (botPlugins bot)
hClose $ botHandle bot
return ()
--- | Processing loop
-botWriter :: Handle -> Chan IrcMsg -> IO ()
-botWriter handle chan = forever $ do
- input <- readChan chan :: IO IrcMsg
- sendstr handle (serializeIrcMsg input)
-
--- | Write an IRC message to the bot's writer
-writeMsg :: IrcMsg -> IrcBot ()
-writeMsg msg = do
- chan <- gets serverChannel
- liftIO $ writeChan chan msg
-
--- |Serialize an IRC message to a string.
-serializeIrcMsg :: IrcMsg -> String
-serializeIrcMsg (IrcMsg pfx cmd params) = pfxStr ++ cmd ++ paramStr
- where pfxStr = case pfx of
- Nothing -> ""
- Just pfx' -> ":" ++ pfx' ++ " "
- paramStr = concat (map paramToStr (init params)
- ++ [lastParamToStr (last params)])
- paramToStr p = " " ++ p
- lastParamToStr p = " :" ++ p
-
--- | Send a string over handle
-sendstr :: Handle -> String -> IO ()
-sendstr handle str = do
- trace $ inColor ("--> " ++ str) [33]
- hPutStr handle (str ++ "\r\n")
-
--- | Log a message string
-trace :: String -> IO ()
-trace msg = putStrLn msg
-
--- | Log a message string
-traceM :: String -> IrcBot ()
-traceM msg = liftIO $ putStrLn msg
-
--- |Wrap a string with ANSI escape sequences.
-inColor :: String -> [Int] -> String
-inColor str vals = "\ESC[" ++ valstr ++ "m" ++ str ++ "\ESC[0m"
- where valstr = concat $ intersperse ";" $ map show vals
+-- | Socket reading loop
+botReader :: Handle -> Chan BotMsg -> IO ()
+botReader handle chan = forever $ do
+ -- TODO : detect end of connection!
+ str <- hGetLine handle
+ let msg = parseIrcMsg str
+ case msg of
+ Right msg' -> do
+ trace $ inColor ("<-- " ++ (show msg')) [33]
+ writeChan chan (InputMsg msg')
+ _ -> do
+ return ()
diff --git a/Hsbot/IRC.hs b/Hsbot/IRC.hs
index d3a3114..3fe2181 100644
--- a/Hsbot/IRC.hs
+++ b/Hsbot/IRC.hs
@@ -5,50 +5,38 @@ module Hsbot.IRC
import Control.Concurrent.Chan
import Control.Monad.State
-import System.IO
-import Hsbot.Core
import Hsbot.IRCParser
+import Hsbot.Plugin
+import Hsbot.Types
+import Hsbot.Utils
-- | Setup a newly connected server by sending nick and join stuff
initServer :: IrcBot ()
initServer = do
server <- gets serverConfig
- writeMsg $ IrcMsg Nothing "NICK" [(nickname server)]
- writeMsg $ IrcMsg Nothing "USER" [(nickname server), "0", "*", (realname server)]
+ sendstr $ serializeIrcMsg $ IrcMsg Nothing "NICK" [(nickname server)]
+ sendstr $ serializeIrcMsg $ IrcMsg Nothing "USER" [(nickname server), "0", "*", (realname server)]
when (not . null $ password server) $ do
- writeMsg $ IrcMsg Nothing "PRIVMSG" ["nickserv", "identify", (password server)]
- joinChans
- return ()
+ sendstr $ serializeIrcMsg $ IrcMsg Nothing "PRIVMSG" ["nickserv", "identify", (password server)]
+ mapM_ joinChan (channels server)
-- | Run a server
runServer :: IrcBot ()
runServer = do
- handle <- gets botHandle
+ chan <- gets botChannel
plugins <- gets botPlugins
- str <- liftIO $ hGetLine handle
- traceM $ inColor ("<-- " ++ str) [33]
- let msg = parseIrcMsg str
+ let input = readChan chan
+ msg <- liftIO input
case msg of
- Right msg' -> do
- mapM_ (sendPlugin msg') plugins
- return ()
- _ -> do
- return ()
- traceM $ show msg
+ InputMsg inputMsg ->
+ mapM_ (sendToPlugin $ InputMsg inputMsg) plugins
+ OutputMsg outputMsg ->
+ sendstr (serializeIrcMsg outputMsg)
+ InternalCmd internalCmd ->
+ traceM "TODO"
runServer
-sendPlugin :: IrcMsg -> Plugin -> IrcBot ()
-sendPlugin msg plugin = do
- let chan = pluginChannel plugin
- liftIO $ writeChan chan msg
-
--- | Join chans
-joinChans :: IrcBot ()
-joinChans = do
- server <- gets serverConfig
- mapM_ joinChan (channels server)
-
-- | Joins a chan
joinChan :: String -> IrcBot ()
joinChan name = do
@@ -57,7 +45,6 @@ joinChan name = do
newChannel = Channel name
(nickname $ serverConfig bot)
(administrators $ serverConfig bot)
- traceM $ " Joining " ++ name
- writeMsg $ IrcMsg Nothing "JOIN" [name]
+ sendstr $ serializeIrcMsg $ IrcMsg Nothing "JOIN" [name]
put $ bot { chans = newChannel : oldChannels }
diff --git a/Hsbot/IRCParser.hs b/Hsbot/IRCParser.hs
index 5c1034e..ebf8f71 100644
--- a/Hsbot/IRCParser.hs
+++ b/Hsbot/IRCParser.hs
@@ -1,13 +1,13 @@
module Hsbot.IRCParser
( ParseError
, parseIrcMsg
+ , serializeIrcMsg
) where
import Control.Monad.Identity
--- import Data.List
import Text.Parsec
-import Hsbot.Core
+import Hsbot.Types
-- | Parses an IrcInput
parseIrcMsg :: String -> Either ParseError IrcMsg
@@ -38,3 +38,14 @@ pLongParam = char ':' >> (many1 (noneOf "\r"))
pShortParam :: ParsecT String u Identity [Char]
pShortParam = many1 (noneOf " \r")
+-- |Serialize an IRC message to a string.
+serializeIrcMsg :: IrcMsg -> String
+serializeIrcMsg (IrcMsg pfx cmd params) = pfxStr ++ cmd ++ paramStr
+ where pfxStr = case pfx of
+ Nothing -> ""
+ Just pfx' -> ":" ++ pfx' ++ " "
+ paramStr = concat (map paramToStr (init params)
+ ++ [lastParamToStr (last params)])
+ paramToStr p = " " ++ p
+ lastParamToStr p = " :" ++ p
+
diff --git a/Hsbot/Main.hs b/Hsbot/Main.hs
index 3cb0ce5..c73a2e5 100644
--- a/Hsbot/Main.hs
+++ b/Hsbot/Main.hs
@@ -9,6 +9,7 @@ import Config
import Hsbot.Core
import Hsbot.IRC
import Hsbot.Plugin
+import Hsbot.Types
-- | Bot's main entry point
imain :: IO ()
diff --git a/Hsbot/Plugin.hs b/Hsbot/Plugin.hs
new file mode 100644
index 0000000..662f8e9
--- /dev/null
+++ b/Hsbot/Plugin.hs
@@ -0,0 +1,56 @@
+module Hsbot.Plugin
+ ( loadPlugin
+ , sendToPlugin
+ ) where
+
+import Control.Concurrent
+import Control.Concurrent.Chan
+import Control.Monad.State
+import System.IO
+import System.Plugins
+
+import Hsbot.Types
+import Hsbot.Utils
+
+-- | Loads a plugin into an ircBot
+loadPlugin :: String -> IrcBot ()
+loadPlugin name = do
+ bot <- get
+ plugin <- liftIO $ effectivelyLoadPlugin name (botChannel bot)
+ case plugin of
+ Just plugin' -> do
+ let oldPlugins = botPlugins bot
+ put $ bot { botPlugins = plugin' : oldPlugins } -- TODO : clean with a correct append
+ Nothing -> return ()
+
+-- | Effectively try to load a plugin
+effectivelyLoadPlugin :: String -> Chan BotMsg -> IO (Maybe Plugin)
+effectivelyLoadPlugin name serverChan = do
+ -- TODO : test if Plugins/ ++ name ++ .hs exists
+ -- Just load, do not compile if .o already present
+ m <- liftIO $ makeAll ("Plugins/" ++ name ++ ".hs") []
+ plugin <- case m of
+ MakeSuccess _ _ -> do
+ ldstat <- load_ ("Plugins/" ++ name ++ ".o") [".","Hsbot","Hsbot/Plugins"] ("main" ++ name)
+ case ldstat of
+ LoadSuccess v entryPoint -> do
+ putStrLn $ inColor ("Loaded plugin: " ++ name) [32]
+ chan <- newChan :: IO (Chan BotMsg)
+ threadId <- forkIO $ entryPoint serverChan chan
+ return $ Just (Plugin name v threadId chan)
+ LoadFailure e -> do
+ putStrLn $ inColor ("Couldn't load plugin: " ++ name) [31]
+ mapM_ putStrLn e
+ return Nothing
+ MakeFailure e -> do
+ putStrLn $ inColor ("FATAL: Couldn't compile plugin: " ++ name) [31]
+ mapM_ putStrLn e
+ return Nothing
+ return plugin
+
+-- | Sends a msg to a plugin
+sendToPlugin :: BotMsg -> Plugin -> IrcBot ()
+sendToPlugin msg plugin = do
+ let chan = pluginChannel plugin
+ liftIO $ writeChan chan msg
+
diff --git a/Hsbot/Types.hs b/Hsbot/Types.hs
new file mode 100644
index 0000000..7a37035
--- /dev/null
+++ b/Hsbot/Types.hs
@@ -0,0 +1,104 @@
+module Hsbot.Types
+ ( Bot(..)
+ , BotMsg(..)
+ , Channel(..)
+ , Config(..)
+ , IntCmd(..)
+ , IrcServer(..)
+ , IrcBot
+ , IrcMsg(..)
+ , Plugin(..)
+ ) where
+
+import Control.Concurrent
+import Control.Concurrent.Chan
+import Control.Monad.State
+import qualified Data.Map as M
+import Network
+import System.IO
+import System.Plugins
+import System.Time (ClockTime)
+
+-- | TODO : a monad for a channel, and a monad for a server, all together driven by a Bot?
+
+-- | Configuration data type
+data Config = Config {
+ commandPrefixes :: String, -- command prefixes, for example @[\'>\',\'@\',\'?\']@
+ ircServer :: IrcServer -- list of 'Server's to connect to
+} deriving (Show)
+
+-- | An IRC server
+data IrcServer = IrcServer
+ { address :: String -- the server's address
+ , port :: PortID -- the server's port
+ , channels :: [String] -- a list of channels to join
+ , nickname :: String -- the hsbot's nickname
+ , password :: String -- the hsbot's password, optional
+ , realname :: String -- the hsbot's real name, optional
+ , administrators :: [String] -- bot admins nicknames
+ }
+
+instance Show IrcServer where
+ show (IrcServer a p c n pa r ad) = (show a)
+ ++ (case p of
+ PortNumber num -> show num
+ Service s -> show s
+ UnixSocket u -> show u)
+ ++ (show c) ++ (show n) ++ (show pa) ++ (show r) ++ (show ad)
+
+-- instance Show PortID where
+-- show (PortNumber n) = show n
+-- show (Service s) = show s
+-- show (UnixSocket g) = show g
+
+-- | The IrcBot monad
+type IrcBot a = StateT Bot IO a
+
+-- | An IRC Bot server state
+data Bot = Bot
+ { serverConfig :: IrcServer -- original server config we are connected to
+ , startTime :: ClockTime -- the bot's uptime
+ , botHandle :: Handle -- the socket/handle
+ , chans :: [Channel] -- the list of channels we have joined
+ , botPlugins :: M.Map String Plugin -- Loaded plugins
+ , botChannel :: Chan BotMsg -- The bot's communication channel
+ , readerThreadId :: ThreadId -- The bot's thread ID
+ , botCommands :: M.Map String [String] -- Registered commands ("command", ["pluginName"])
+ }
+
+instance Show Bot where
+ show (Bot _ s h c p _ _ cmds) = (show s) ++ (show h) ++ (show c) ++ (show p) ++ (show cmds)
+
+-- | A channel connection
+data Channel = Channel
+ { channelName :: String -- the channel's name
+ , channelNick :: String -- our nickname
+ , channelAdmins :: [String] -- the bot administrators
+ } deriving (Show)
+
+-- | A Bot command
+data IntCmd = IntCmd
+ { intCmd :: String -- the bot's internal command
+ , intCmdParams :: [String] -- the parameters
+ } deriving (Show)
+
+-- |An IRC message.
+data IrcMsg = IrcMsg
+ { prefix :: Maybe String -- the message prefix
+ , command :: String -- the message command
+ , parameters :: [String] -- the message parameters
+ } deriving (Show)
+
+-- | A plugin definition
+data Plugin = Plugin
+ { pluginName :: String -- The plugin's name
+ , pluginModule :: Module -- The plugin himself
+ , pluginThreadId :: ThreadId -- The plugin thread
+ , pluginChannel :: Chan BotMsg -- The plugin channel
+ }
+
+instance Show Plugin where
+ show (Plugin name _ _ _) = show name
+
+data BotMsg = InputMsg IrcMsg | OutputMsg IrcMsg | InternalCmd IntCmd
+
diff --git a/Hsbot/Utils.hs b/Hsbot/Utils.hs
new file mode 100644
index 0000000..640d16f
--- /dev/null
+++ b/Hsbot/Utils.hs
@@ -0,0 +1,33 @@
+module Hsbot.Utils
+ ( inColor
+ , sendstr
+ , trace
+ , traceM
+ ) where
+
+import Control.Monad.State
+import Data.List
+import System.IO
+
+import Hsbot.Types
+
+-- |Wrap a string with ANSI escape sequences.
+inColor :: String -> [Int] -> String
+inColor str vals = "\ESC[" ++ valstr ++ "m" ++ str ++ "\ESC[0m"
+ where valstr = concat $ intersperse ";" $ map show vals
+
+-- | Sends a string over handle
+sendstr :: String -> IrcBot ()
+sendstr str = do
+ handle <- gets botHandle
+ traceM $ inColor ("--> " ++ str) [33]
+ liftIO $ hPutStr handle (str ++ "\r\n")
+
+-- | Log a message string
+trace :: String -> IO ()
+trace msg = putStrLn msg
+
+-- | Log a message string
+traceM :: String -> IrcBot ()
+traceM msg = liftIO $ putStrLn msg
+