summaryrefslogtreecommitdiff
path: root/Hsbot
diff options
context:
space:
mode:
authorJulien Dessaux2010-02-04 20:27:22 +0100
committerJulien Dessaux2010-02-04 20:27:22 +0100
commit57f559f3a119b400e4f6288d3b5753185b8f19a7 (patch)
tree76bcd9a7e3980b8a79f64d46e5ae75a362dcd486 /Hsbot
parentRebooting now works great, thanks to the communication channel preservation. (diff)
downloadhsbot-57f559f3a119b400e4f6288d3b5753185b8f19a7.tar.gz
hsbot-57f559f3a119b400e4f6288d3b5753185b8f19a7.tar.bz2
hsbot-57f559f3a119b400e4f6288d3b5753185b8f19a7.zip
Rewrote the whole architecture.
Diffstat (limited to 'Hsbot')
-rw-r--r--Hsbot/Core.hs163
-rw-r--r--Hsbot/IRC.hs121
-rw-r--r--Hsbot/IRCParser.hs26
-rw-r--r--Hsbot/Main.hs75
4 files changed, 216 insertions, 169 deletions
diff --git a/Hsbot/Core.hs b/Hsbot/Core.hs
index fddcb72..41340ba 100644
--- a/Hsbot/Core.hs
+++ b/Hsbot/Core.hs
@@ -1,56 +1,163 @@
module Hsbot.Core
( Bot(..)
+ , Channel(..)
, Config(..)
, IrcServer(..)
- , isConnected
- , newbot
- , sendstr
- , saveServersStates
+ , IrcBot
+ , IrcMsg(..)
+ , Plugin(..)
+ , connectServer
+ , disconnectServer
+ , inColor
+ , serializeIrcMsg
+ , traceM
+ , writeMsg
) where
-import qualified Data.Map as M
-import System.IO (Handle)
-import Text.Printf (hPrintf)
+import Control.Concurrent
+import Control.Concurrent.Chan
+import Control.Monad.State
+import Data.List
+import Network
+import System.IO
+import System.Plugins
+import System.Time (ClockTime, getClockTime)
--- | An IRC Bot server state (socket handles)
-data Bot = Bot
- { joinedServers :: M.Map IrcServer Handle -- servers we are connected to
- } deriving (Eq, Show)
+-- | 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 @[\'>\',\'@\',\'?\']@
- ircServers :: [IrcServer] -- list of 'Server's to connect to
-} deriving (Eq,Show)
+ ircServer :: IrcServer -- list of 'Server's to connect to
+} deriving (Show)
-- | An IRC server
data IrcServer = IrcServer
{ address :: String -- the server's address
- , port :: Int -- the server's port
+ , 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
- } deriving (Eq, Ord, Show)
+ }
+
+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
+
+-- Connect to the server and return the initial bot state
+connectServer :: IrcServer -> IO Bot
+connectServer server = do
+ let name = address server
+ starttime <- getClockTime
+ putStr $ "Connecting to " ++ name ++ "... "
+ handle <- connectTo name $ port server
+ hSetBuffering handle NoBuffering
+ putStrLn "done."
+ putStr $ "Opening server communication channel... "
+ chan <- newChan :: IO (Chan IrcMsg)
+ threadId <- forkIO $ botWriter 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
+ 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
--- | Returns a new, empty bot
-newbot :: Bot
-newbot = Bot (M.empty)
+-- |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 = hPrintf handle "%s\r\n" str
+sendstr handle str = do
+ trace $ inColor ("--> " ++ str) [33]
+ hPutStr handle (str ++ "\r\n")
--- | Are we already connected to this server?
-isConnected :: Bot -> IrcServer -> Bool
-isConnected (Bot bot) ircServer = ircServer `M.member` bot
+-- | Log a message string
+trace :: String -> IO ()
+trace msg = putStrLn msg
-saveServerState :: Handle -> IrcServer -> Bot -> Bot
-saveServerState handle ircServer x@(Bot bot) =
- if ircServer `M.member` bot then x
- else (Bot $ M.insert ircServer handle bot)
+-- | Log a message string
+traceM :: String -> IrcBot ()
+traceM msg = liftIO $ putStrLn msg
-saveServersStates :: [(IrcServer, Handle)] -> Bot -> Bot
-saveServersStates liste bot = foldl (\bot' (ircServer, handle) -> saveServerState handle ircServer bot') bot liste
+-- |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
diff --git a/Hsbot/IRC.hs b/Hsbot/IRC.hs
index 76853e2..d3a3114 100644
--- a/Hsbot/IRC.hs
+++ b/Hsbot/IRC.hs
@@ -1,82 +1,63 @@
module Hsbot.IRC
- ( IrcLine(..)
- , connectServer
- , initServer
- , parseIrcMsg
- , ping
- , pong
- , sendPrivmsg
- )where
+ ( initServer
+ , runServer
+ ) where
-import Control.Monad
-import Data.List(isPrefixOf)
-import Data.Maybe
-import Network
-import qualified Network.IRC as IRC
+import Control.Concurrent.Chan
+import Control.Monad.State
import System.IO
import Hsbot.Core
import Hsbot.IRCParser
-type User = String
-type Channel = String
-type Command = String
-type Args = [String]
-
--- | An IRC line
-data IrcLine = Privmsg (String, [String]) -- statement (chan, sentence...)
- | Quit (IrcServer, Handle) -- a quit message from a server
- | Join (IrcServer, Channel) -- joined a channel
- | Part (IrcServer, Channel) -- parted the channel
- | Ping (String) -- pinged by the server
- | Reboot -- reboot message sent
- | Nil -- signifies thread death, only happens after reboot
- deriving (Eq,Show)
-
--- | Parses an IrcInput
-parseIrcMsg :: String -> IrcLine
-parseIrcMsg str =
- case (ircParser str) of
- Left err -> Nil
- Right x -> eval x
- where
- eval :: IrcMsg -> IrcLine
- eval x@(IrcMsg statement cmd stuff)
- | cmd == "PING" = Ping $ head stuff
- | cmd == "PRIVMSG" =
- case statement of
- Nothing -> Nil
- Just statement' -> if stuff!!1 == "reboot" then Reboot
- else Privmsg $ (statement', stuff)
- | otherwise = Nil
-
--- | Connects to a server
-connectServer :: IrcServer -> IO (IrcServer, Handle)
-connectServer server = do
- let name = address server
- port_number = port server
- handle <- connectTo name (PortNumber $ fromIntegral port_number)
- hSetBuffering handle NoBuffering
- return (server, handle)
-
-- | Setup a newly connected server by sending nick and join stuff
-initServer :: (IrcServer, Handle) -> IO ()
-initServer (server, handle) = do
- sendstr handle (IRC.encode . IRC.nick $ nickname server)
- sendstr handle (IRC.encode $ IRC.user (nickname server) "0" "*" (realname server))
+initServer :: IrcBot ()
+initServer = do
+ server <- gets serverConfig
+ writeMsg $ IrcMsg Nothing "NICK" [(nickname server)]
+ writeMsg $ IrcMsg Nothing "USER" [(nickname server), "0", "*", (realname server)]
when (not . null $ password server) $ do
- sendstr handle (IRC.encode $ IRC.privmsg "nickserv" ("identify" ++ (password server)))
- mapM_ (sendstr handle . IRC.encode . IRC.joinChan) (channels server)
+ writeMsg $ IrcMsg Nothing "PRIVMSG" ["nickserv", "identify", (password server)]
+ joinChans
return ()
--- | Check if a message is a PING
-ping :: String -> Bool
-ping = isPrefixOf "PING :"
-
--- | Send a pong message given a ping message
-pong :: Handle -> String -> IO ()
-pong handle str = sendstr handle $ "PONG " ++ (drop 5 str)
-
-sendPrivmsg :: (IrcServer, Handle) -> [String] -> IO ()
-sendPrivmsg (server, handle) stuff' = sendstr handle (IRC.encode $ IRC.privmsg (head stuff') (unwords . tail $ stuff'))
+-- | Run a server
+runServer :: IrcBot ()
+runServer = do
+ handle <- gets botHandle
+ plugins <- gets botPlugins
+ str <- liftIO $ hGetLine handle
+ traceM $ inColor ("<-- " ++ str) [33]
+ let msg = parseIrcMsg str
+ case msg of
+ Right msg' -> do
+ mapM_ (sendPlugin msg') plugins
+ return ()
+ _ -> do
+ return ()
+ traceM $ show msg
+ 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
+ bot <- get
+ let oldChannels = chans bot
+ newChannel = Channel name
+ (nickname $ serverConfig bot)
+ (administrators $ serverConfig bot)
+ traceM $ " Joining " ++ name
+ writeMsg $ IrcMsg Nothing "JOIN" [name]
+ put $ bot { chans = newChannel : oldChannels }
diff --git a/Hsbot/IRCParser.hs b/Hsbot/IRCParser.hs
index a76e22a..5c1034e 100644
--- a/Hsbot/IRCParser.hs
+++ b/Hsbot/IRCParser.hs
@@ -1,36 +1,40 @@
module Hsbot.IRCParser
- ( IrcMsg (..)
- , ircParser
+ ( ParseError
+ , parseIrcMsg
) where
---import Text.Parsec
-import Text.ParserCombinators.Parsec
+import Control.Monad.Identity
+-- import Data.List
+import Text.Parsec
--- |An IRC message.
-data IrcMsg = IrcMsg (Maybe String) String [String] -- (Maybe first statement) cmd [chan, params/sentence]
- deriving (Show)
+import Hsbot.Core
---ircParser :: String -> IrcInput
-ircParser :: String -> Either ParseError IrcMsg
-ircParser str = parse pMsg "" str
+-- | Parses an IrcInput
+parseIrcMsg :: String -> Either ParseError IrcMsg
+parseIrcMsg line = parse pMsg "" line
+pMsg :: ParsecT String u Identity IrcMsg
pMsg = do
pfx <- optionMaybe pPrefix
cmd <- pCommand
params <- many (char ' ' >> (pLongParam <|> pShortParam))
- char '\r'
+ --char '\r'
eof
return $ IrcMsg pfx cmd params
+pPrefix :: ParsecT String u Identity [Char]
pPrefix = do
char ':'
pfx <- many1 (noneOf " ")
space
return pfx
+pCommand :: ParsecT String u Identity [Char]
pCommand = count 3 digit <|> many1 upper
+pLongParam :: ParsecT String u Identity [Char]
pLongParam = char ':' >> (many1 (noneOf "\r"))
+pShortParam :: ParsecT String u Identity [Char]
pShortParam = many1 (noneOf " \r")
diff --git a/Hsbot/Main.hs b/Hsbot/Main.hs
index 8972022..3cb0ce5 100644
--- a/Hsbot/Main.hs
+++ b/Hsbot/Main.hs
@@ -1,71 +1,26 @@
module Hsbot.Main
( imain
- , imain'
) where
-import Control.Concurrent
-import Control.Concurrent.Chan
-import Control.Monad
-import qualified Data.Map as M
+import Control.Monad.State
import System.IO
-import System.Plugins
-import qualified Config as C
+import Config
import Hsbot.Core
import Hsbot.IRC
-
-type Reboot = (Module -> Bot -> (Chan IrcLine) -> IO ())
-
--- | Bot's first main entry point
-imain :: Module -> Reboot -> IO ()
-imain modul' reboot = do
- chan <- newChan :: IO (Chan IrcLine)
- imain' modul' reboot newbot chan
+import Hsbot.Plugin
-- | Bot's main entry point
-imain' :: Module -> Reboot -> Bot -> (Chan IrcLine) -> IO ()
-imain' modul' reboot bot chan = do
- -- The chan passing to reboot (or another way to keep it) is still missing
- let newServers = filter (not . isConnected bot) (ircServers C.config)
- putStrLn $ "Connecting servers : " ++ show (map address newServers)
- newServers' <- mapM connectServer newServers
- putStrLn $ "Joining channels : " ++ show (map channels newServers)
- mapM_ initServer newServers'
- putStrLn "Spawning threads..."
- let bot' = saveServersStates newServers' bot
- Bot x = bot'
- mapM_ (forkIO . listener chan) newServers' -- (M.toList x)
- bot'' <- monitor chan bot'
- reboot modul' bot'' chan
-
--- | Bot main loop, monitors the threads states and handle reboot
-monitor :: (Chan IrcLine) -> Bot -> IO Bot
-monitor chan bot = do
- loop bot
- where
- loop bot' = do
- input <- readChan chan :: IO IrcLine
- case input of
- Reboot -> do
- putStrLn "Got reboot message, rebooting"
- return bot'
- _ -> loop bot'
-
--- | Thread entry point for socket listeners
-listener :: (Chan IrcLine) -> (IrcServer, Handle) -> IO ()
-listener chan (server, handle) = forever $ do
- str <- hGetLine handle
- let msg = parseIrcMsg str
- writeChan chan msg
- eval msg
- where
- eval :: IrcLine -> IO ()
- eval (Privmsg (statement, stuff')) = sendPrivmsg (server, handle) stuff'
- eval (Quit (ircServer, handle')) = return ()
- eval (Join (ircServer, handle')) = return ()
- eval (Part (ircServer, handle')) = return ()
- eval (Ping (string)) = do pong handle string
- eval stuff' = case stuff' of
- Reboot -> return ()
- Nil -> return ()
+imain :: IO ()
+imain = do
+ bot <- connectServer $ ircServer config
+ (runStateT run bot) `catch` (const $ return ((), bot))
+ disconnectServer bot
+
+-- | The Bot monad main function
+run :: IrcBot ()
+run = do
+ initServer
+ mapM_ loadPlugin defaultPlugins
+ runServer