ircbot-0.5.3/0000755000000000000000000000000012057472536011202 5ustar0000000000000000ircbot-0.5.3/LICENSE0000644000000000000000000000302612057472536012210 0ustar0000000000000000Copyright 2011-2012 Jeremy Shaw, Eric Mertens, SeeReason Partners LLC All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. * Neither the name of Jeremy Shaw nor the names of other contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ircbot-0.5.3/ircbot.cabal0000644000000000000000000000350512057472536013453 0ustar0000000000000000Name: ircbot Version: 0.5.3 Synopsis: A library for writing irc bots Homepage: http://hub.darcs.net/stepcut/ircbot License: BSD3 License-file: LICENSE Author: Jeremy Shaw, Eric Mertens Maintainer: jeremy@seereason.com Copyright: 2012 SeeReason Partners LLC Stability: Experimental Category: Network Build-type: Simple Cabal-version: >=1.6 source-repository head type: darcs location: http://hub.darcs.net/stepcut/ircbot Library Exposed-modules: Network.IRC.Bot Network.IRC.Bot.BotMonad Network.IRC.Bot.Core Network.IRC.Bot.Commands Network.IRC.Bot.ErrorCodes Network.IRC.Bot.Limiter Network.IRC.Bot.Log Network.IRC.Bot.Part.Channels Network.IRC.Bot.Part.Dice Network.IRC.Bot.Part.Hello Network.IRC.Bot.Part.Ping Network.IRC.Bot.Part.NickUser Network.IRC.Bot.Parsec Network.IRC.Bot.PosixLogger Network.IRC.Bot.Types Build-depends: base >= 4 && <5, containers >= 0.4 && < 0.6, directory < 1.3, filepath >= 1.2 && < 1.4, irc == 0.5.*, mtl >= 2.0 && < 2.2, network >= 2.3 && < 2.5, old-locale == 1.0.*, parsec == 3.1.*, time == 1.4.*, unix >= 2.4 && < 2.7, random == 1.0.*, stm >= 2.2 && < 2.5 ircbot-0.5.3/Setup.hs0000644000000000000000000000011012057472536012626 0ustar0000000000000000#!/usr/bin/env runhaskell import Distribution.Simple main = defaultMain ircbot-0.5.3/Network/0000755000000000000000000000000012057472536012633 5ustar0000000000000000ircbot-0.5.3/Network/IRC/0000755000000000000000000000000012057472536013250 5ustar0000000000000000ircbot-0.5.3/Network/IRC/Bot.hs0000644000000000000000000000055412057472536014334 0ustar0000000000000000module Network.IRC.Bot ( module Network.IRC.Bot.BotMonad , module Network.IRC.Bot.Commands , module Network.IRC.Bot.Core , module Network.IRC.Bot.Log , module Network.IRC.Bot.Parsec ) where import Network.IRC.Bot.BotMonad import Network.IRC.Bot.Commands import Network.IRC.Bot.Core import Network.IRC.Bot.Log import Network.IRC.Bot.Parsec ircbot-0.5.3/Network/IRC/Bot/0000755000000000000000000000000012057472536013774 5ustar0000000000000000ircbot-0.5.3/Network/IRC/Bot/Parsec.hs0000644000000000000000000001270412057472536015551 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} module Network.IRC.Bot.Parsec where {- The parsec part is supposed to make it easy to use Parsec to parse the command arguments. We would also like to be able to generate a help menu. But the help menu should not be for only Parsec commands. Or do we? Maybe all interactive commands should be implementing through parsec part. Some commands like @seen (and @tell) are two part. There is the part that collects the data. And there is the command itself. How would that integrate with a parsec command master list? We would like the parsec commands to be non-blocking. Each top-level part is run in a separate thread. But if we only have one thread for all the parsecParts, then blocking could occur. We could run every handler for every message, even though we only expect at most one command to match. That seems bogus. Do we really want to allow to different parts to respond to @foo ? Seems better to have each part register. data Part m = Part { name :: String , description :: String , backgroundParts :: [BotPartT m ()] , command :: Maybe (String, String, BotPartT m ()) -- ^ (name, usage, handler) } 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, isPrefixOf, nub) import Data.Maybe (fromMaybe) import Network.IRC.Bot.Log import Network.IRC.Bot.BotMonad import Network.IRC.Bot.Commands import Text.Parsec import Text.Parsec.Error (errorMessages, messageString) 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 sendMessage = lift . sendMessage logM lvl msg = lift (logM lvl msg) whoami = lift whoami 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 -- | parser that checks for the 'cmdPrefix' (from the 'BotEnv') botPrefix :: (BotMonad m) => ParsecT String () m () botPrefix = do recv <- fromMaybe "" <$> askReceiver pref <- cmdPrefix <$> askBotEnv if "#" `isPrefixOf` recv then (try $ string pref >> return ()) <|> lift mzero else (try $ string pref >> return ()) <|> return () -- | 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) => (ParsecT String () m a) -> m a parsecPart p = do priv <- privMsg logM Debug $ "I got a message: " ++ msg priv ++ " sent to " ++ show (receivers priv) ma <- runParserT p () (msg priv) (msg priv) case ma of (Left e) -> do logM Debug $ "Parse error: " ++ show e target <- maybeZero =<< replyTo reportError target e mzero (Right a) -> return a reportError :: (BotMonad m) => String -> ParseError -> m () reportError target err = let errStrs = showErrorMessages "or" "unknown parse error" "expecting" "unexpected" "end of input" (errorMessages err) errStr = intercalate "; " errStrs in sendCommand (PrivMsg Nothing [target] errStr) showErrorMessages :: String -> String -> String -> String -> String -> [P.Message] -> [String] showErrorMessages msgOr msgUnknown msgExpecting msgUnExpected msgEndOfInput msgs | null msgs = [msgUnknown] | otherwise = clean $ [showSysUnExpect,showUnExpect,showExpect,showMessages] where (sysUnExpect,msgs1) = span ((P.SysUnExpect "") ==) msgs (unExpect,msgs2) = span ((P.UnExpect "") ==) msgs1 (expect,messages) = span ((P.Expect "") ==) msgs2 showExpect = showMany msgExpecting expect showUnExpect = showMany msgUnExpected unExpect showSysUnExpect | not (null unExpect) || null sysUnExpect = "" | null firstMsg = msgUnExpected ++ " " ++ msgEndOfInput | otherwise = msgUnExpected ++ " " ++ firstMsg where firstMsg = messageString (head sysUnExpect) showMessages = showMany "" messages -- helpers showMany pre msgs = case clean (map messageString msgs) of [] -> "" ms | null pre -> commasOr ms | otherwise -> pre ++ " " ++ commasOr ms commasOr [] = "" commasOr [m] = m commasOr ms = commaSep (init ms) ++ " " ++ msgOr ++ " " ++ last ms commaSep = seperate ", " . clean seperate _ [] = "" seperate _ [m] = m seperate sep (m:ms) = m ++ sep ++ seperate sep ms clean = nub . filter (not . null) ircbot-0.5.3/Network/IRC/Bot/Types.hs0000644000000000000000000000322512057472536015436 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable, RecordWildCards #-} module Network.IRC.Bot.Types ( User(..) , nullUser ) where 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.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.Log (Logger, LogLevel(Normal, Debug), stdoutLogger) import Network.IRC.Bot.BotMonad (BotMonad(logM), BotPartT, BotEnv(..), runBotPartT) import Prelude hiding (catch) import System.IO (BufferMode(LineBuffering), Handle, hClose, hGetLine, hPutStrLn, hSetBuffering) 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 = "" } ircbot-0.5.3/Network/IRC/Bot/Core.hs0000644000000000000000000002604412057472536015226 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable, RecordWildCards #-} module Network.IRC.Bot.Core ( simpleBot , simpleBot' , BotConf(..) , nullBotConf , User(..) , nullUser ) where import Control.Concurrent (ThreadId, forkIO, threadDelay) import Control.Concurrent.Chan (Chan, dupChan, newChan, readChan, writeChan) import Control.Concurrent.STM (atomically) import Control.Concurrent.STM.TMVar (TMVar, swapTMVar, newTMVar, readTMVar) 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.Set (Set, empty) import Data.Time (UTCTime, addUTCTime, getCurrentTime) import GHC.IO.Handle (hFlushAll) 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.Limiter (Limiter(..), newLimiter, limit) import Network.IRC.Bot.Log (Logger, LogLevel(Normal, Debug), stdoutLogger) 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(NoBuffering, LineBuffering), Handle, hClose, hGetLine, hPutStrLn, hSetBuffering) -- |Bot configuration data BotConf = BotConf { channelLogger :: (Maybe (Chan Message -> IO ())) -- ^ optional channel logging function , logger :: Logger -- ^ app logging , host :: HostName -- ^ irc server to connect , port :: PortID -- ^ irc port to connect to (usually, 'PortNumber 6667') , nick :: String -- ^ irc nick , commandPrefix :: String -- ^ command prefix , user :: User -- ^ irc user info , channels :: Set String -- ^ channel to join , limits :: Maybe (Int, Int) -- ^ (burst length, delay in microseconds) } nullBotConf :: BotConf nullBotConf = BotConf { channelLogger = Nothing , logger = stdoutLogger Normal , host = "" , port = PortNumber 6667 , nick = "" , commandPrefix = "#" , user = nullUser , channels = empty , limits = Nothing } -- | 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 return h 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 prefix) ircLoop :: Logger -> String -> String -> Chan Message -> Chan Message -> [BotPartT IO ()] -> IO [ThreadId] ircLoop logger botName prefix incomingChan outgoingChan parts = mapM forkPart parts where forkPart botPart = do inChan <- dupChan incomingChan forkIO $ partLoop logger botName prefix 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 -> Maybe (Int, Int) -> TMVar UTCTime -> HostName -> PortID -> String -> User -> Chan Message -> Chan Message -> Maybe (Chan Message) -> QSem -> IO (ThreadId, ThreadId, Maybe ThreadId, IO ()) connectionLoop logger mLimitConf tmv host port nick user outgoingChan incomingChan logChan connQSem = do hTMVar <- atomically $ newTMVar (undefined :: Handle) (limit, limitTid) <- case mLimitConf of Nothing -> return (return (), Nothing) (Just (burst, delay)) -> do limiter <- newLimiter burst delay return (limit limiter, Just $ limitsThreadId limiter) outgoingTid <- forkIO $ forever $ do msg <- readChan outgoingChan writeMaybeChan logChan msg h <- atomically $ readTMVar hTMVar when (msg_command msg `elem` ["PRIVMSG", "NOTICE"]) limit hPutStrLn h (encode msg) `catch` (reconnect logger host port nick user hTMVar connQSem) now <- getCurrentTime atomically $ swapTMVar tmv now incomingTid <- forkIO $ do doConnect logger host port nick user hTMVar connQSem forever $ do h <- atomically $ readTMVar hTMVar msgStr <- (hGetLine h) `catch` (\e -> reconnect logger host port nick user hTMVar connQSem e >> return "") now <- getCurrentTime atomically $ swapTMVar tmv now case decode (msgStr ++ "\n") of Nothing -> logger Normal ("decode failed: " ++ msgStr) (Just msg) -> do logger Debug (show msg) writeMaybeChan logChan msg writeChan incomingChan msg let forceReconnect = do putStrLn "forceReconnect: getting handle" h <- atomically $ readTMVar hTMVar putStrLn "forceReconnect: sending /quit" writeChan outgoingChan (quit $ Just "restarting...") putStrLn "forceReconnect: closing handle" hClose h putStrLn "done." return (outgoingTid, incomingTid, limitTid, forceReconnect) ircConnectLoop :: (LogLevel -> String -> IO a) -- ^ logging -> HostName -> PortID -> String -> User -> IO Handle 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 :: (LogLevel -> String -> IO a) -> String -> PortID -> String -> User -> TMVar Handle -> QSem -> IO () doConnect logger host port nick user hTMVar connQSem = do logger Normal $ showString "Connecting to " . showString host . showString " as " $ nick h <- ircConnectLoop logger host port nick user atomically $ swapTMVar hTMVar h logger Normal $ "Connected." signalQSem connQSem return () reconnect :: Logger -> String -> PortID -> String -> User -> TMVar Handle -> QSem -> IOException -> IO () reconnect logger host port nick user hTMVar connQSem e = do logger Normal $ "IRC Connection died: " ++ show e {- atomically $ do empty <- isEmptyTMVar hTMVar if empty then return () else takeTMVar hTMVar >> return () -} doConnect logger host port nick user hTMVar 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 -- all received and sent messages. This means that the bots output -- will be included in the logs. simpleBot :: BotConf -- ^ Bot configuration -> [BotPartT IO ()] -- ^ bot parts (must include 'pingPart', or equivalent) -> IO ([ThreadId], IO ()) -- ^ 'ThreadId' for all forked handler threads and a function that forces a reconnect simpleBot BotConf{..} parts = simpleBot' channelLogger logger limits host port nick commandPrefix user parts -- |simpleBot' connects to the server and handles messages using the supplied BotPartTs -- -- the 'Chan Message' for the optional logging function will include -- all received and sent messages. This means that the bots output -- will be included in the logs. simpleBot' :: (Maybe (Chan Message -> IO ())) -- ^ optional logging function -> Logger -- ^ application logging -> Maybe (Int, Int) -- ^ rate limiter settings (burst length, delay in microseconds) -> HostName -- ^ irc server to connect -> PortID -- ^ irc port to connect to (usually, 'PortNumber 6667') -> String -- ^ irc nick -> String -- ^ command prefix -> User -- ^ irc user info -> [BotPartT IO ()] -- ^ bot parts (must include 'pingPart', 'channelsPart', and 'nickUserPart)' -> IO ([ThreadId], IO ()) -- ^ 'ThreadId' for all forked handler threads and an IO action that forces a reconnect simpleBot' mChanLogger logger limitConf host port nick prefix user parts = do (mLogTid, mLogChan) <- case mChanLogger of Nothing -> return (Nothing, Nothing) (Just chanLogger) -> do logChan <- newChan :: IO (Chan Message) logTid <- forkIO $ chanLogger logChan return (Just logTid, Just logChan) -- message channels outgoingChan <- newChan :: IO (Chan Message) incomingChan <- newChan :: IO (Chan Message) now <- getCurrentTime tmv <- atomically $ newTMVar now connQSem <- newQSem 0 (outgoingTid, incomingTid, mLimitTid, forceReconnect) <- connectionLoop logger limitConf tmv host port nick user outgoingChan incomingChan mLogChan connQSem watchDogTid <- forkIO $ forever $ do let timeout = 5*60 now <- getCurrentTime lastActivity <- atomically $ readTMVar tmv when (now > addUTCTime (fromIntegral timeout) lastActivity) forceReconnect threadDelay (30*10^6) -- check every 30 seconds ircTids <- ircLoop logger nick prefix incomingChan outgoingChan parts onConnectId <- onConnectLoop logger nick prefix outgoingChan connQSem onConnect return $ (maybe id (:) mLimitTid $ maybe id (:) mLogTid $ (incomingTid : outgoingTid : watchDogTid : ircTids), forceReconnect) where onConnect :: BotPartT IO () onConnect = changeNickUser nick (Just user) -- | call 'writeChan' if 'Just'. Do nothing for Nothing. writeMaybeChan :: Maybe (Chan a) -> a -> IO () writeMaybeChan Nothing _ = return () writeMaybeChan (Just chan) a = writeChan chan a ircbot-0.5.3/Network/IRC/Bot/ErrorCodes.hs0000644000000000000000000000040512057472536016376 0ustar0000000000000000module Network.IRC.Bot.ErrorCodes where -- * Nickname errors noNicknameGiven :: String noNicknameGiven = "431" erroneusNickname :: String erroneusNickname = "432" nicknameInUse :: String nicknameInUse = "433" nickCollision :: String nickCollision = "436" ircbot-0.5.3/Network/IRC/Bot/Limiter.hs0000644000000000000000000000271012057472536015735 0ustar0000000000000000{- | Module : Network.IRC.Bot.Limiter Description : simple rate limiter Copyright : (c) 2012 Eric Mertens License : BSD3 Maintainer : jeremy@seereason.com Stability : stable Portability : portable A simple rate limiter. -} module Network.IRC.Bot.Limiter ( Limiter(..) , newLimiter , limit ) where import Control.Concurrent (ThreadId, forkIO, threadDelay) import Control.Concurrent.QSem (QSem, newQSem, signalQSem, waitQSem) import Control.Monad (forever) data Limiter = Limiter { limitsIn :: QSem , limitsOut :: QSem , limitsDelay :: Int , limitsThreadId :: ThreadId } -- | Construct a new rate limit control newLimiter :: Int -- ^ max burst length -> Int -- ^ delay (in microseconds) -> IO Limiter newLimiter burst delay = do rdy <- newQSem burst sent <- newQSem 0 let l = Limiter { limitsIn = sent , limitsOut = rdy , limitsDelay = delay , limitsThreadId = error "limiter thread not started yet" } tid <- forkIO (limiter l) return $ l { limitsThreadId = tid } -- | Execute this before sending limit :: Limiter -> IO () limit l = do waitQSem (limitsOut l) signalQSem (limitsIn l) -- | Loop which manages the limit timers limiter :: Limiter -> IO b limiter l = forever $ do waitQSem (limitsIn l) threadDelay (limitsDelay l) signalQSem (limitsOut l)ircbot-0.5.3/Network/IRC/Bot/Log.hs0000644000000000000000000000065312057472536015055 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable #-} module Network.IRC.Bot.Log where import Data.Data data LogLevel = Debug | Normal | Important deriving (Eq, Ord, Read, Show, Data, Typeable) type Logger = LogLevel -> String -> IO () stdoutLogger :: LogLevel -> Logger stdoutLogger minLvl msgLvl msg | msgLvl >= minLvl = putStrLn msg | otherwise = return () nullLogger :: Logger nullLogger _ _ = return ()ircbot-0.5.3/Network/IRC/Bot/Commands.hs0000644000000000000000000000523212057472536016073 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable #-} module Network.IRC.Bot.Commands where import Control.Applicative import Control.Monad import Data.Data import Data.List (isPrefixOf) import Network (HostName, PortID(PortNumber)) import Network.IRC import Network.IRC.Bot.BotMonad -- * Commands cmd :: (Functor m, MonadPlus m, BotMonad m) => Command -> m () cmd cmdName = do command <- msg_command <$> askMessage if cmdName == command then return () else mzero data Ping = Ping HostName deriving (Eq, Ord, Read, Show, Data, Typeable) ping :: (Functor m, MonadPlus m, BotMonad m) => m Ping ping = do cmd "PING" params <- msg_params <$> askMessage case params of (hostName:_) -> return $ Ping hostName _ -> mzero data PrivMsg = PrivMsg { prefix :: (Maybe Prefix) , receivers :: [String] , msg :: String } deriving (Eq, Read, Show) privMsg :: (Functor m, MonadPlus m, BotMonad m) => m PrivMsg privMsg = do msg <- askMessage maybe mzero return (toPrivMsg msg) toPrivMsg :: Message -> Maybe PrivMsg toPrivMsg msg = let cmd = msg_command msg params = msg_params msg prefix = msg_prefix msg in case cmd of "PRIVMSG" -> Just $ PrivMsg prefix (init params) (last params) _ -> Nothing class ToMessage a where toMessage :: a -> Message sendCommand :: (ToMessage c, BotMonad m, Functor m) => c -> m () sendCommand c = sendMessage (toMessage c) data Pong = Pong HostName deriving (Eq, Ord, Read, Show, Data, Typeable) instance ToMessage Pong where toMessage (Pong hostName) = Message Nothing "PONG" [hostName] instance ToMessage PrivMsg where toMessage (PrivMsg prefix receivers msg) = Message prefix "PRIVMSG" (receivers ++ [msg]) -- | get the nickname of the user who sent the message askSenderNickName :: (BotMonad m) => m (Maybe String) askSenderNickName = do msg <- askMessage case msg_prefix msg of (Just (NickName nick _ _)) -> return (Just nick) _ -> return Nothing -- | figure out who to reply to for a given `Message` -- -- If message was sent to a #channel reply to the channel. Otherwise reply to the sender. replyTo :: (BotMonad m) => m (Maybe String) replyTo = do priv <- privMsg let receiver = head (receivers priv) if ("#" `isPrefixOf` receiver) then return (Just receiver) else askSenderNickName -- | returns the receiver of a message -- -- if multiple receivers, it returns only the first askReceiver :: (Alternative m, BotMonad m) => m (Maybe String) askReceiver = do priv <- privMsg return (Just (head $ receivers priv)) <|> do return Nothing ircbot-0.5.3/Network/IRC/Bot/PosixLogger.hs0000644000000000000000000000540212057472536016573 0ustar0000000000000000module Network.IRC.Bot.PosixLogger where import Control.Concurrent.Chan import Data.Time.Calendar (Day(..)) import Data.Time.Clock (UTCTime(..), addUTCTime, getCurrentTime) import Data.Time.Format (formatTime) import Network.IRC (Command, Message(Message, msg_prefix, msg_command, msg_params), Prefix(NickName), UserName, encode, decode, joinChan, nick, user) import Network.IRC.Bot.Commands import System.Directory (createDirectoryIfMissing) import System.FilePath (()) import System.Locale (defaultTimeLocale) import System.Posix ( Fd, OpenMode(WriteOnly), OpenFileFlags(append), closeFd, defaultFileFlags , fdWrite, openFd ) -- TODO: This should be modified so that a formatting filter can be applied to the log messages -- TODO: should be updated so that log file name matches channel -- TODO: should support multiple channels posixLogger :: Maybe FilePath -> String -> Chan Message -> IO () posixLogger mLogDir channel logChan = do now <- getCurrentTime let logDay = utctDay now logFd <- openLog now logLoop logDay logFd where openLog :: UTCTime -> IO (Maybe Fd) openLog now = case mLogDir of Nothing -> return Nothing (Just logDir) -> do let logPath = logDir (formatTime defaultTimeLocale ((dropWhile (== '#') channel) ++ "-%Y-%m-%d.txt") now) createDirectoryIfMissing True logDir fd <- openFd logPath WriteOnly (Just 0o0644) (defaultFileFlags { append = True }) return (Just fd) updateLogHandle :: UTCTime -> Day -> Maybe Fd -> IO (Day, Maybe Fd) updateLogHandle now logDay Nothing = return (logDay, Nothing) updateLogHandle now logDay (Just logFd) | logDay == (utctDay now) = return (logDay, Just logFd) | otherwise = do closeFd logFd nowHandle <- openLog now return (utctDay now, nowHandle) logLoop :: Day -> Maybe Fd -> IO () logLoop logDay mLogFd = do msg <- readChan logChan now <- getCurrentTime (logDay', mLogFd') <- updateLogHandle now logDay mLogFd let mPrivMsg = toPrivMsg msg case mPrivMsg of (Just (PrivMsg (Just (NickName nick _user _server)) receivers msg)) | channel `elem` receivers -> do let logMsg = showString (formatTime defaultTimeLocale "%X " now) . showString "<" . showString nick . showString "> " $ msg case mLogFd' of Nothing -> return () (Just logFd') -> fdWrite logFd' (logMsg ++ "\n") >> return () return () -- hPutStrLn logFd logMsg _ -> return () logLoop logDay' mLogFd' ircbot-0.5.3/Network/IRC/Bot/BotMonad.hs0000644000000000000000000000546012057472536016040 0ustar0000000000000000{-# LANGUAGE FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses, StandaloneDeriving, UndecidableInstances #-} module Network.IRC.Bot.BotMonad ( BotPartT(..) , BotMonad(..) , BotEnv(..) , runBotPartT , mapBotPartT , maybeZero ) where import Control.Applicative (Applicative, Alternative, (<$>)) import Control.Arrow (first) import Control.Monad (MonadPlus(mplus, mzero), forever, replicateM, when) import Control.Monad.Cont (MonadCont) import Control.Monad.Error (MonadError) import Control.Monad.Reader (MonadReader(ask, local), MonadTrans, ReaderT(runReaderT), mapReaderT) import Control.Monad.Writer (MonadWriter) import Control.Monad.State (MonadState) import Control.Monad.RWS (MonadRWS) import Control.Concurrent.Chan (Chan, dupChan, newChan, readChan, writeChan) import Control.Monad.Fix (MonadFix) import Control.Monad.Trans 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 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 sendMessage :: Message -> m () logM :: LogLevel -> String -> m () whoami :: m 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) instance (MonadReader r m) => MonadReader r (BotPartT m) where ask = BotPartT (lift ask) local f = BotPartT . mapReaderT (local f) . unBotPartT instance (MonadRWS r w s m) => MonadRWS r w s (BotPartT m) runBotPartT :: BotPartT m a -> BotEnv -> m a runBotPartT botPartT = runReaderT (unBotPartT botPartT) mapBotPartT :: (m a -> n b) -> BotPartT m a -> BotPartT n b 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) sendMessage msg = BotPartT $ do out <- outChan <$> ask liftIO $ writeChan out msg return () logM lvl msg = BotPartT $ do l <- logFn <$> ask liftIO $ l lvl msg whoami = BotPartT $ botName <$> ask maybeZero :: (MonadPlus m) => Maybe a -> m a maybeZero Nothing = mzero maybeZero (Just a) = return aircbot-0.5.3/Network/IRC/Bot/Part/0000755000000000000000000000000012057472536014702 5ustar0000000000000000ircbot-0.5.3/Network/IRC/Bot/Part/Ping.hs0000644000000000000000000000041312057472536016131 0ustar0000000000000000module Network.IRC.Bot.Part.Ping where import Network.IRC.Bot.BotMonad (BotMonad) import Network.IRC.Bot.Commands (Ping(..), Pong(..), ping, sendCommand) pingPart :: (BotMonad m) => m () pingPart = do (Ping hostName) <- ping sendCommand (Pong hostName) ircbot-0.5.3/Network/IRC/Bot/Part/Dice.hs0000644000000000000000000000317212057472536016105 0ustar0000000000000000module Network.IRC.Bot.Part.Dice where import Control.Monad (replicateM) import Control.Monad.Trans (liftIO) import Network.IRC.Bot.Log (LogLevel(Debug)) import Network.IRC.Bot.BotMonad (BotMonad(..), maybeZero) import Network.IRC.Bot.Commands (PrivMsg(..), sendCommand, replyTo) import Network.IRC.Bot.Parsec (botPrefix, nat, parsecPart) import System.Random (randomRIO) import Text.Parsec (ParsecT, (<|>), (), char, skipMany1, space, string, try) dicePart :: (BotMonad m) => m () dicePart = parsecPart diceCommand diceCommand :: (BotMonad m) => ParsecT String () m () diceCommand = do try $ botPrefix >> string "dice" logM Debug "dicePart" target <- maybeZero =<< replyTo (numDice, numSides, modifier) <- (do skipMany1 space nd <- nat <|> return 1 if nd > 100 then fail "You can not roll more than 100 dice." else do char 'd' ns <- (do n <- nat if n > 0 then return n else fail "The dice must have at least 1 side" ) mod <- (do char '+' >> nat) <|> return 0 return (nd, ns, mod)) "dice d[+]" rolls <- liftIO $ replicateM (fromIntegral numDice) $ randomRIO (1, numSides) let results = "You rolled " ++ show numDice ++ " " ++ show numSides ++ "-sided dice with a +" ++ show modifier ++ " modifier: " ++ show rolls ++ " => " ++ show (sum (modifier : rolls)) sendCommand (PrivMsg Nothing [target] results) <|> return () ircbot-0.5.3/Network/IRC/Bot/Part/Channels.hs0000644000000000000000000000243412057472536016774 0ustar0000000000000000module 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) ircbot-0.5.3/Network/IRC/Bot/Part/Hello.hs0000644000000000000000000000205612057472536016304 0ustar0000000000000000module Network.IRC.Bot.Part.Hello where import Control.Monad.Trans (liftIO) import Data.Maybe (fromMaybe) import Network.IRC.Bot.Log (LogLevel(Debug)) import Network.IRC.Bot.BotMonad (BotMonad(..), maybeZero) import Network.IRC.Bot.Commands (PrivMsg(..),askSenderNickName, replyTo, sendCommand) import Network.IRC.Bot.Parsec (botPrefix, parsecPart) import System.Random (randomRIO) import Text.Parsec (ParsecT, (<|>), string, try) helloPart :: (BotMonad m) => m () helloPart = parsecPart helloCommand helloCommand :: (BotMonad m) => ParsecT String () m () helloCommand = do try $ botPrefix >> string "hello" logM Debug "helloPart" target <- maybeZero =<< replyTo logM Debug $ "target: " ++ target mNick <- askSenderNickName let greetings = ["Hello", "Howdy", "Greetings", "Word up"] n <- liftIO $ randomRIO (0, length greetings - 1) let msg = greetings!!n ++ ", " ++ (fromMaybe "stranger" mNick) sendCommand (PrivMsg Nothing [target] msg) <|> return () ircbot-0.5.3/Network/IRC/Bot/Part/NickUser.hs0000644000000000000000000000247512057472536016771 0ustar0000000000000000module 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))