ircbot 0.1.5 → 0.2.0
raw patch · 8 files changed
+184/−78 lines, 8 files
Files
- Network/IRC/Bot/BotMonad.hs +11/−8
- Network/IRC/Bot/Core.hs +57/−60
- Network/IRC/Bot/ErrorCodes.hs +16/−0
- Network/IRC/Bot/Parsec.hs +24/−8
- Network/IRC/Bot/Part/Channels.hs +36/−0
- Network/IRC/Bot/Part/Dice.hs +2/−1
- Network/IRC/Bot/Part/NickUser.hs +34/−0
- ircbot.cabal +4/−1
Network/IRC/Bot/BotMonad.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses, StandaloneDeriving, UndecidableInstances #-}+{-# LANGUAGE FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses, StandaloneDeriving, UndecidableInstances #-} module Network.IRC.Bot.BotMonad ( BotPartT(..) , BotMonad(..)@@ -22,8 +22,8 @@ import Network.IRC (Command, Message(Message, msg_prefix, msg_command, msg_params), Prefix(NickName), UserName, encode, decode, joinChan, nick, user) import Network.IRC.Bot.Log --- FIXME: add whoami? class (Functor m, MonadPlus m, MonadIO m) => BotMonad m where+ askBotEnv :: m BotEnv askMessage :: m Message askOutChan :: m (Chan Message) localMessage :: (Message -> Message) -> m a -> m a@@ -31,14 +31,16 @@ logM :: LogLevel -> String -> m () whoami :: m String -data BotEnv = BotEnv { message :: Message- , outChan :: Chan Message- , logFn :: Logger- , botName :: String- }+data BotEnv = BotEnv+ { message :: Message+ , outChan :: Chan Message+ , logFn :: Logger+ , botName :: String+ , cmdPrefix :: String+ } newtype BotPartT m a = BotPartT { unBotPartT :: ReaderT BotEnv m a }- deriving (Applicative, Alternative, Functor, Monad, MonadFix, MonadPlus, MonadTrans, MonadIO, MonadWriter w, MonadState s, MonadError e, MonadCont)+ deriving (Applicative, Alternative, Functor, Monad, MonadFix, MonadPlus, MonadTrans, MonadIO, MonadWriter w, MonadState s, MonadError e, MonadCont) instance (MonadReader r m) => MonadReader r (BotPartT m) where ask = BotPartT (lift ask)@@ -53,6 +55,7 @@ mapBotPartT f (BotPartT r) = BotPartT $ mapReaderT f r instance (Functor m, MonadIO m, MonadPlus m) => BotMonad (BotPartT m) where+ askBotEnv = BotPartT ask askMessage = BotPartT (message <$> ask) askOutChan = BotPartT (outChan <$> ask) localMessage f (BotPartT r) = BotPartT (local (\e -> e { message = f (message e) }) r)
Network/IRC/Bot/Core.hs view
@@ -1,5 +1,5 @@ {-# LANGUAGE DeriveDataTypeable, RecordWildCards #-}-module Network.IRC.Bot.Core +module Network.IRC.Bot.Core ( simpleBot , simpleBot' , BotConf(..)@@ -11,16 +11,20 @@ import Control.Concurrent (ThreadId, forkIO, threadDelay) import Control.Concurrent.Chan (Chan, dupChan, newChan, readChan, writeChan) import Control.Concurrent.MVar (MVar, modifyMVar_, newMVar, readMVar)+import Control.Concurrent.QSem (QSem, newQSem, waitQSem, signalQSem) import Control.Exception (IOException, catch) import Control.Monad (mplus, forever, when)+import Control.Monad.Trans (liftIO) import Data.Data (Data, Typeable)-import Data.Maybe (fromMaybe)+import Data.Set (Set, empty) import Data.Time (UTCTime, addUTCTime, getCurrentTime) import Network (HostName, PortID(PortNumber), connectTo) import Network.IRC (Message, decode, encode, joinChan, nick, user) import Network.IRC as I+import Network.IRC.Bot.Types (User(..), nullUser) import Network.IRC.Bot.Log (Logger, LogLevel(Normal, Debug), stdoutLogger)-import Network.IRC.Bot.BotMonad (BotMonad(logM), BotPartT, BotEnv(..), runBotPartT)+import Network.IRC.Bot.BotMonad (BotMonad(logM, sendMessage), BotPartT, BotEnv(..), runBotPartT)+import Network.IRC.Bot.Part.NickUser (changeNickUser) import Prelude hiding (catch) import System.IO (BufferMode(LineBuffering), Handle, hClose, hGetLine, hPutStrLn, hSetBuffering) @@ -30,75 +34,61 @@ { channelLogger :: (Maybe (Chan Message -> IO ())) -- ^ optional channel logging function , logger :: Logger -- ^ app logging , host :: HostName -- ^ irc server to connect - , port :: Maybe PortID -- ^ irc port to connect to (usually, 'PortNumber 6667')+ , port :: PortID -- ^ irc port to connect to (usually, 'PortNumber 6667') , nick :: String -- ^ irc nick+ , prefix :: String -- ^ command prefix , user :: User -- ^ irc user info- , channel :: String -- ^ channel to join+ , channels :: Set String -- ^ channel to join } nullBotConf :: BotConf nullBotConf = BotConf { channelLogger = Nothing- , logger = stdoutLogger Normal- , host = ""- , port = Nothing- , nick = ""- , user = nullUser- , channel = ""+ , logger = stdoutLogger Normal+ , host = ""+ , port = PortNumber 6667+ , nick = ""+ , prefix = "#"+ , user = nullUser+ , channels = empty } -data User = User- { username :: String -- ^ username on client system- , hostname :: HostName -- ^ hostname of client system- , servername :: HostName -- ^ irc server client is connected to- , realname :: String -- ^ client's real name- }- deriving (Data, Typeable, Eq, Ord, Read, Show)--nullUser :: User-nullUser = User { username = ""- , hostname = ""- , servername = ""- , realname = ""- }- -- | connect to irc server and send NICK and USER commands ircConnect :: HostName -> PortID -> String -> User -> IO Handle ircConnect host port n u = do h <- connectTo host port hSetBuffering h LineBuffering- hPutStrLn h (encode (I.nick n))- hPutStrLn h (encode (I.user (username u) (hostname u) (servername u) (realname u))) return h- -partLoop :: Logger -> String -> Chan Message -> Chan Message -> (BotPartT IO ()) -> IO ()-partLoop logger botName incomingChan outgoingChan botPart =++partLoop :: Logger -> String -> String -> Chan Message -> Chan Message -> (BotPartT IO ()) -> IO ()+partLoop logger botName prefix incomingChan outgoingChan botPart = forever $ do msg <- readChan incomingChan- runBotPartT botPart (BotEnv msg outgoingChan logger botName)- -ircLoop :: Logger -> String -> Chan Message -> Chan Message -> [BotPartT IO ()] -> IO [ThreadId]-ircLoop logger botName incomingChan outgoingChan parts = mapM forkPart parts+ runBotPartT botPart (BotEnv msg outgoingChan logger botName prefix)++ircLoop :: Logger -> String -> String -> Chan Message -> Chan Message -> [BotPartT IO ()] -> IO [ThreadId]+ircLoop logger botName cmdPrefix incomingChan outgoingChan parts = + mapM forkPart parts where forkPart botPart = do inChan <- dupChan incomingChan- forkIO $ partLoop logger botName inChan outgoingChan (botPart `mplus` return ())- + forkIO $ partLoop logger botName cmdPrefix inChan outgoingChan (botPart `mplus` return ())+ -- reconnect loop is still a bit buggy -- if you try to write multiple lines, and the all fail, reconnect will be called multiple times.. -- something should be done so that this does not happen-connectionLoop :: Logger -> MVar UTCTime -> HostName -> PortID -> String -> User -> Chan Message -> Chan Message -> Maybe (Chan Message) -> IO () -> IO (ThreadId, ThreadId, IO ())-connectionLoop logger mv host port nick user outgoingChan incomingChan logChan onConnect =+connectionLoop :: Logger -> MVar UTCTime -> HostName -> PortID -> String -> User -> Chan Message -> Chan Message -> Maybe (Chan Message) -> QSem -> IO (ThreadId, ThreadId, IO ())+connectionLoop logger mv host port nick user outgoingChan incomingChan logChan connQSem = do hMVar <- newMVar (undefined :: Handle)- doConnect logger host port nick user onConnect hMVar+ doConnect logger host port nick user hMVar connQSem outgoingTid <- forkIO $ forever $ do msg <- readChan outgoingChan writeMaybeChan logChan msg h <- readMVar hMVar- hPutStrLn h (encode msg) `catch` (reconnect logger host port nick user onConnect hMVar)+ hPutStrLn h (encode msg) `catch` (reconnect logger host port nick user hMVar connQSem) modifyMVar_ mv (const getCurrentTime) incomingTid <- forkIO $ forever $ do h <- readMVar hMVar- msgStr <- (hGetLine h) `catch` (\e -> reconnect logger host port nick user onConnect hMVar e >> return "")+ msgStr <- (hGetLine h) `catch` (\e -> reconnect logger host port nick user hMVar connQSem e >> return "") modifyMVar_ mv (const getCurrentTime) case decode (msgStr ++ "\n") of Nothing -> logger Normal ("decode failed: " ++ msgStr)@@ -111,27 +101,33 @@ hClose h return (outgoingTid, incomingTid, forceReconnect) - ircConnectLoop logger host port nick user = (ircConnect host port nick user) `catch` (\e -> do logger Normal $ "irc connect failed ... retry in 60 seconds: " ++ show (e :: IOException) threadDelay (60 * 10^6) ircConnectLoop logger host port nick user)- -doConnect logger host port nick user onConnect hMVar =++doConnect :: (LogLevel -> String -> IO a) -> String -> PortID -> String -> User -> MVar Handle -> QSem -> IO ()+doConnect logger host port nick user hMVar connQSem = do logger Normal $ showString "Connecting to " . showString host . showString " as " $ nick h <- ircConnectLoop logger host port nick user modifyMVar_ hMVar (const $ return h) logger Normal $ "Connected."- onConnect+ signalQSem connQSem return () -reconnect :: Logger -> String -> PortID -> String -> User -> IO a -> MVar Handle -> IOException -> IO ()-reconnect logger host port nick user onConnect hMVar e = +reconnect :: Logger -> String -> PortID -> String -> User -> MVar Handle -> QSem -> IOException -> IO ()+reconnect logger host port nick user hMVar connQSem e = do logger Normal $ "IRC Connection died: " ++ show e- doConnect logger host port nick user onConnect hMVar+ doConnect logger host port nick user hMVar connQSem +onConnectLoop :: Logger -> String -> String -> Chan Message -> QSem -> BotPartT IO () -> IO ThreadId+onConnectLoop logger botName prefix outgoingChan connQSem action =+ forkIO $ forever $ + do waitQSem connQSem+ runBotPartT action (BotEnv undefined outgoingChan logger botName prefix)+ -- |simpleBot connects to the server and handles messages using the supplied BotPartTs -- -- the 'Chan Message' for the optional logging function will include@@ -141,7 +137,7 @@ -> [BotPartT IO ()] -- ^ bot parts (must include 'pingPart', or equivalent) -> IO [ThreadId] -- ^ 'ThreadId' for all forked handler threads simpleBot BotConf{..} parts =- simpleBot' channelLogger logger host port nick user channel parts+ simpleBot' channelLogger logger host port nick prefix user parts -- |simpleBot' connects to the server and handles messages using the supplied BotPartTs --@@ -151,13 +147,13 @@ simpleBot' :: (Maybe (Chan Message -> IO ())) -- ^ optional logging function -> Logger -- ^ application logging -> HostName -- ^ irc server to connect - -> Maybe PortID -- ^ irc port to connect to (usually, 'PortNumber 6667')+ -> PortID -- ^ irc port to connect to (usually, 'PortNumber 6667') -> String -- ^ irc nick+ -> String -- ^ command prefix -> User -- ^ irc user info- -> String -- ^ channel to join- -> [BotPartT IO ()] -- ^ bot parts (must include 'pingPart', or equivalent)+ -> [BotPartT IO ()] -- ^ bot parts (must include 'pingPart', 'channelsPart', and 'nickUserPart') -> IO [ThreadId] -- ^ 'ThreadId' for all forked handler threads-simpleBot' mChanLogger logger host mPort nick user channel parts = +simpleBot' mChanLogger logger host port nick prefix user parts = do (mLogTid, mLogChan) <- case mChanLogger of Nothing -> return (Nothing, Nothing)@@ -169,20 +165,21 @@ outgoingChan <- newChan :: IO (Chan Message) incomingChan <- newChan :: IO (Chan Message) mv <- newMVar =<< getCurrentTime- (outgoingTid, incomingTid, forceReconnect) <- connectionLoop logger mv host (fromMaybe (PortNumber 6667) mPort) nick user outgoingChan incomingChan mLogChan (onConnect outgoingChan)+ connQSem <- newQSem 0+ (outgoingTid, incomingTid, forceReconnect) <- connectionLoop logger mv host port nick user outgoingChan incomingChan mLogChan connQSem watchDogTid <- forkIO $ forever $ do let timeout = 5*60 now <- getCurrentTime lastActivity <- readMVar mv when (now > addUTCTime (fromIntegral timeout) lastActivity) forceReconnect threadDelay (30*10^6) -- check every 30 seconds- ircTids <- ircLoop logger nick incomingChan outgoingChan parts+ ircTids <- ircLoop logger nick prefix incomingChan outgoingChan parts+ onConnectId <- onConnectLoop logger nick prefix outgoingChan connQSem onConnect return $ maybe id (:) mLogTid $ (incomingTid : outgoingTid : watchDogTid : ircTids) where- onConnect outgoingChan = - do logger Normal $ "joining channel " ++ channel- writeChan outgoingChan (joinChan channel)-+ onConnect :: BotPartT IO ()+ onConnect = + changeNickUser nick (Just user) -- | call 'writeChan' if 'Just'. Do nothing for Nothing. writeMaybeChan :: Maybe (Chan a) -> a -> IO ()
+ Network/IRC/Bot/ErrorCodes.hs view
@@ -0,0 +1,16 @@+module Network.IRC.Bot.ErrorCodes where++-- * Nickname errors++noNicknameGiven :: String+noNicknameGiven = "431"++erroneusNickname :: String+erroneusNickname = "432"++nicknameInUse :: String+nicknameInUse = "433"++nickCollision :: String+nickCollision = "436"+
Network/IRC/Bot/Parsec.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE FlexibleContexts #-} module Network.IRC.Bot.Parsec where {-@@ -29,7 +30,9 @@ This is good, unless multiple plugins wanted to depend on some common backgroundParts -} +import Control.Applicative ((<$>)) import Control.Monad+import Control.Monad.Reader (MonadReader, ask) import Control.Monad.Trans import Data.Char (digitToInt) import Data.List (intercalate, nub)@@ -41,6 +44,7 @@ import qualified Text.Parsec.Error as P instance (BotMonad m, Monad m) => BotMonad (ParsecT s u m) where+ askBotEnv = lift askBotEnv askMessage = lift askMessage askOutChan = lift askOutChan localMessage f m = mapParsecT (localMessage f) m@@ -51,25 +55,37 @@ mapParsecT :: (Monad m, Monad n) => (m (Consumed (m (Reply s u a))) -> n (Consumed (n (Reply s u b)))) -> ParsecT s u m a -> ParsecT s u n b mapParsecT f p = mkPT $ \s -> f (runParsecT p s) +-- | parse a positive integer nat :: (Monad m) => ParsecT String () m Integer nat = do digits <- many1 digit return $ foldl (\x d -> x * 10 + fromIntegral (digitToInt d)) 0 digits -botPrefix :: (MonadPlus m) => String -> ParsecT String () m ()-botPrefix name = - (try $ do string name- string ": "+-- | parser that checks for the 'cmdPrefix' (from the 'BotEnv')+botPrefix :: (BotMonad m) => ParsecT String () m ()+botPrefix =+ (try $ do str <- cmdPrefix <$> askBotEnv+ string str return ()) <|> lift mzero --- parsecPart :: (Monad m, MonadPlus m, BotMonad m) => String -> ParsecT String () m a -> m a+-- | create a bot part by using Parsec to parse the command+--+-- The argument to 'parsecPart' is a parser function.+--+-- The argument to that parsec function is the 'target' that the response should be sent to.+--+-- The parser will receive the 'msg' from the 'PrivMsg'.+--+-- see 'dicePart' for an example usage.+parsecPart :: (BotMonad m) =>+ (String -> ParsecT String () m a) + -> m a parsecPart p = - do name <- whoami- priv <- privMsg + do priv <- privMsg logM Debug $ "I got a message: " ++ msg priv ++ " sent to " ++ show (receivers priv)- ma <- runParserT (botPrefix name >> p (head (receivers priv))) () (msg priv) (msg priv)+ ma <- runParserT (p $ head (receivers priv)) () (msg priv) (msg priv) case ma of (Left e) -> do logM Debug $ "Parse error: " ++ show e
+ Network/IRC/Bot/Part/Channels.hs view
@@ -0,0 +1,36 @@+module Network.IRC.Bot.Part.Channels where++import Control.Concurrent.STM (atomically)+import Control.Concurrent.STM.TVar (TVar, newTVar, readTVar, writeTVar)+import Control.Monad.Trans (MonadIO(liftIO))+import Data.Set (Set, insert, toList)+import Network.IRC (Message(..), joinChan)+import Network.IRC.Bot.BotMonad (BotMonad(..))+import Network.IRC.Bot.Log (LogLevel(..))++initChannelsPart :: (BotMonad m) => Set String -> IO (TVar (Set String), m ())+initChannelsPart chans =+ do channels <- atomically $ newTVar chans+ return (channels, channelsPart channels)++channelsPart :: (BotMonad m) => TVar (Set String) -> m ()+channelsPart channels =+ do msg <- askMessage+ let cmd = msg_command msg+ case cmd of+ "005" -> do chans <- liftIO $ atomically $ readTVar channels+ mapM_ doJoin (toList chans)+ _ -> return ()+ where+ doJoin :: (BotMonad m) => String -> m ()+ doJoin chan = + do sendMessage (joinChan chan)+ logM Normal $ "Joining room " ++ chan++joinChannel :: (BotMonad m) => String -> TVar (Set String) -> m ()+joinChannel chan channels =+ do liftIO $ atomically $+ do cs <- readTVar channels+ writeTVar channels (insert chan cs)+ sendMessage (joinChan chan)+
Network/IRC/Bot/Part/Dice.hs view
@@ -16,7 +16,8 @@ diceCommand :: (BotMonad m) => String -> ParsecT String () m () diceCommand target =- do try $ string "dice"+ do botPrefix+ try $ string "dice" (numDice, numSides, modifier) <- (do skipMany1 space nd <- nat <|> return 1
+ Network/IRC/Bot/Part/NickUser.hs view
@@ -0,0 +1,34 @@+module Network.IRC.Bot.Part.NickUser where++import Control.Monad.Trans (liftIO)+import Network.IRC.Bot.BotMonad (BotMonad(..) )+import Network.IRC.Bot.Types (User(..))+import Network.IRC.Bot.ErrorCodes +import Network.IRC.Bot.Log (LogLevel(..))+-- import Network.IRC.Bot.Commands (Ping(..), Pong(..), ping, sendCommand)+import Network.IRC (Message(..))+import qualified Network.IRC as IRC+import System.Random (randomRIO)++nickUserPart :: (BotMonad m) => m () +nickUserPart =+ do msg <- askMessage + let cmd = msg_command msg+ case () of+ () | cmd == noNicknameGiven -> logM Important (show msg)+ | cmd == erroneusNickname -> logM Important (show msg)+ | cmd == nickCollision -> logM Important (show msg)+ | cmd == nicknameInUse -> + do logM Important (show msg)+ n <- whoami+ i <- liftIO $ randomRIO (1, 100 :: Int)+ changeNickUser (n ++ show i) Nothing+ | otherwise -> return ()++changeNickUser :: (BotMonad m) => String -> Maybe User -> m ()+changeNickUser n mUser =+ do sendMessage (IRC.nick n)+ case mUser of+ Nothing -> return ()+ (Just u) ->+ sendMessage (IRC.user (username u) (hostname u) (servername u) (realname u))
ircbot.cabal view
@@ -1,5 +1,5 @@ Name: ircbot-Version: 0.1.5+Version: 0.2.0 Synopsis: A library for writing irc bots Homepage: http://patch-tag.com/r/stepcut/ircbot License: BSD3@@ -18,9 +18,12 @@ Network.IRC.Bot.BotMonad Network.IRC.Bot.Core Network.IRC.Bot.Commands+ Network.IRC.Bot.ErrorCodes Network.IRC.Bot.Log+ Network.IRC.Bot.Part.Channels Network.IRC.Bot.Part.Dice Network.IRC.Bot.Part.Ping+ Network.IRC.Bot.Part.NickUser Network.IRC.Bot.Parsec Network.IRC.Bot.PosixLogger