diff --git a/Network/IRC/Bot/BotMonad.hs b/Network/IRC/Bot/BotMonad.hs --- a/Network/IRC/Bot/BotMonad.hs +++ b/Network/IRC/Bot/BotMonad.hs @@ -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) diff --git a/Network/IRC/Bot/Core.hs b/Network/IRC/Bot/Core.hs --- a/Network/IRC/Bot/Core.hs +++ b/Network/IRC/Bot/Core.hs @@ -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 () diff --git a/Network/IRC/Bot/ErrorCodes.hs b/Network/IRC/Bot/ErrorCodes.hs new file mode 100644 --- /dev/null +++ b/Network/IRC/Bot/ErrorCodes.hs @@ -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" + diff --git a/Network/IRC/Bot/Parsec.hs b/Network/IRC/Bot/Parsec.hs --- a/Network/IRC/Bot/Parsec.hs +++ b/Network/IRC/Bot/Parsec.hs @@ -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 diff --git a/Network/IRC/Bot/Part/Channels.hs b/Network/IRC/Bot/Part/Channels.hs new file mode 100644 --- /dev/null +++ b/Network/IRC/Bot/Part/Channels.hs @@ -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) + diff --git a/Network/IRC/Bot/Part/Dice.hs b/Network/IRC/Bot/Part/Dice.hs --- a/Network/IRC/Bot/Part/Dice.hs +++ b/Network/IRC/Bot/Part/Dice.hs @@ -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 diff --git a/Network/IRC/Bot/Part/NickUser.hs b/Network/IRC/Bot/Part/NickUser.hs new file mode 100644 --- /dev/null +++ b/Network/IRC/Bot/Part/NickUser.hs @@ -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)) diff --git a/ircbot.cabal b/ircbot.cabal --- a/ircbot.cabal +++ b/ircbot.cabal @@ -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