ircbot-0.6.5/0000755000000000000000000000000012725114223011171 5ustar0000000000000000ircbot-0.6.5/ircbot.cabal0000644000000000000000000000402412725114223013437 0ustar0000000000000000Name: ircbot Version: 0.6.5 Synopsis: A library for writing IRC bots Description: A simple library for an IRC bot 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 Homepage: https://github.com/stepcut/ircbot tested-with: GHC == 7.6.3, GHC == 7.8.4, GHC == 7.10.2, GHC==8.0.1 source-repository head type: git location: https://github.com/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, bytestring >= 0.10 && < 0.11, containers >= 0.4 && < 0.6, directory < 1.3, filepath >= 1.2 && < 1.5, irc == 0.6.*, mtl >= 2.0 && < 2.3, network >= 2.3 && < 2.7, parsec == 3.1.*, time >= 1.5 && < 1.7, unix >= 2.4 && < 2.8, random >= 1.0 && < 1.2, stm >= 2.2 && < 2.5, SafeSemaphore >= 0.10 && < 0.11 ircbot-0.6.5/LICENSE0000644000000000000000000000302612725114223012177 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.6.5/Setup.hs0000644000000000000000000000011012725114223012615 0ustar0000000000000000#!/usr/bin/env runhaskell import Distribution.Simple main = defaultMain ircbot-0.6.5/Network/0000755000000000000000000000000012725114223012622 5ustar0000000000000000ircbot-0.6.5/Network/IRC/0000755000000000000000000000000012725114223013237 5ustar0000000000000000ircbot-0.6.5/Network/IRC/Bot.hs0000644000000000000000000000055412725114223014323 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.6.5/Network/IRC/Bot/0000755000000000000000000000000012725114223013763 5ustar0000000000000000ircbot-0.6.5/Network/IRC/Bot/BotMonad.hs0000644000000000000000000000556312725114223016033 0ustar0000000000000000{-# LANGUAGE FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses, StandaloneDeriving, UndecidableInstances, OverloadedStrings #-} 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 Data.ByteString (ByteString) 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 -> ByteString -> m () whoami :: m ByteString data BotEnv = BotEnv { message :: Message , outChan :: Chan Message , logFn :: Logger , botName :: ByteString , 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.6.5/Network/IRC/Bot/Commands.hs0000644000000000000000000000547112725114223016067 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable, OverloadedStrings #-} module Network.IRC.Bot.Commands where import Control.Applicative import Control.Monad import Data.ByteString (ByteString) import qualified Data.ByteString as B import Data.Data import Data.List (isPrefixOf) import Data.Monoid ((<>)) import Network (PortID(PortNumber)) import Network.IRC import Network.IRC.Bot.BotMonad type HostName = ByteString -- * 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 :: [ByteString] , msg :: ByteString } 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 ByteString) 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 ByteString) replyTo = do priv <- privMsg let receiver = head (receivers priv) if ("#" `B.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 ByteString) askReceiver = do priv <- privMsg return (Just (head $ receivers priv)) <|> do return Nothing ircbot-0.6.5/Network/IRC/Bot/Core.hs0000644000000000000000000002664412725114223015223 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable, RecordWildCards, OverloadedStrings #-} 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.Exception (IOException, catch) import Control.Monad (mplus, forever, when) import Control.Monad.Trans (liftIO) import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as C import Data.Data (Data, Typeable) import Data.Monoid ((<>)) 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, showMessage, 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 Control.Concurrent.SSem (SSem) import qualified Control.Concurrent.SSem as SSem import System.IO (BufferMode(NoBuffering, LineBuffering), Handle, hClose, hGetLine, hPutChar, 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 :: ByteString -- ^ irc nick , commandPrefix :: String -- ^ command prefix , user :: User -- ^ irc user info , channels :: Set ByteString -- ^ 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 -> ByteString -> User -> IO Handle ircConnect host port n u = do h <- connectTo host port hSetBuffering h LineBuffering return h partLoop :: Logger -> ByteString -> 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 -> ByteString -> 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 -> ByteString -> User -> Chan Message -> Chan Message -> Maybe (Chan Message) -> SSem -> IO (ThreadId, ThreadId, Maybe ThreadId, IO ()) connectionLoop logger mLimitConf tmv host port nick user outgoingChan incomingChan logChan connSSem = 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 C.hPutStr h (encode msg) `catch` (reconnect logger host port nick user hTMVar connSSem) hPutChar h '\n' now <- getCurrentTime atomically $ swapTMVar tmv now incomingTid <- forkIO $ do doConnect logger host port nick user hTMVar connSSem forever $ do h <- atomically $ readTMVar hTMVar -- FIXME: is C.hGetLine going to do the write thing in the face of unicode? msgStr <- (C.hGetLine h) `catch` (\e -> reconnect logger host port nick user hTMVar connSSem e >> return "") now <- getCurrentTime atomically $ swapTMVar tmv now case decode (msgStr <> "\n") of Nothing -> logger Normal ("decode failed: " <> msgStr) (Just msg) -> do logger Debug (showMessage 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 -> ByteString -> IO a) -- ^ logging -> HostName -> PortID -> ByteString -> 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: " <> (C.pack $ show (e :: IOException)) threadDelay (60 * 10^6) ircConnectLoop logger host port nick user) doConnect :: (LogLevel -> ByteString -> IO a) -> HostName -> PortID -> ByteString -> User -> TMVar Handle -> SSem -> IO () doConnect logger host port nick user hTMVar connSSem = do logger Normal $ "Connecting to " <> (C.pack host) <> " as " <> nick h <- ircConnectLoop logger host port nick user atomically $ swapTMVar hTMVar h logger Normal $ "Connected." SSem.signal connSSem return () reconnect :: Logger -> HostName -> PortID -> ByteString -> User -> TMVar Handle -> SSem -> IOException -> IO () reconnect logger host port nick user hTMVar connSSem e = do logger Normal $ "IRC Connection died: " <> C.pack (show e) {- atomically $ do empty <- isEmptyTMVar hTMVar if empty then return () else takeTMVar hTMVar >> return () -} doConnect logger host port nick user hTMVar connSSem onConnectLoop :: Logger -> ByteString -> String -> Chan Message -> SSem -> BotPartT IO () -> IO ThreadId onConnectLoop logger botName prefix outgoingChan connSSem action = forkIO $ forever $ do SSem.wait connSSem 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') -> ByteString -- ^ 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 connSSem <- SSem.new 0 (outgoingTid, incomingTid, mLimitTid, forceReconnect) <- connectionLoop logger limitConf tmv host port nick user outgoingChan incomingChan mLogChan connSSem 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 connSSem 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.6.5/Network/IRC/Bot/ErrorCodes.hs0000644000000000000000000000053512725114223016371 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} module Network.IRC.Bot.ErrorCodes where import Data.ByteString (ByteString) -- * Nickname errors noNicknameGiven :: ByteString noNicknameGiven = "431" erroneusNickname :: ByteString erroneusNickname = "432" nicknameInUse :: ByteString nicknameInUse = "433" nickCollision :: ByteString nickCollision = "436" ircbot-0.6.5/Network/IRC/Bot/Limiter.hs0000644000000000000000000000275312725114223015733 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.SSem (SSem) import qualified Control.Concurrent.SSem as SSem import Control.Monad (forever) data Limiter = Limiter { limitsIn :: SSem , limitsOut :: SSem , 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 <- SSem.new burst sent <- SSem.new 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 SSem.wait (limitsOut l) SSem.signal (limitsIn l) -- | Loop which manages the limit timers limiter :: Limiter -> IO b limiter l = forever $ do SSem.wait (limitsIn l) threadDelay (limitsDelay l) SSem.signal (limitsOut l)ircbot-0.6.5/Network/IRC/Bot/Log.hs0000644000000000000000000000104512725114223015040 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable #-} module Network.IRC.Bot.Log where import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as C import Data.Data data LogLevel = Debug | Normal | Important deriving (Eq, Ord, Read, Show, Data, Typeable) type Logger = LogLevel -> ByteString -> IO () stdoutLogger :: LogLevel -> Logger stdoutLogger minLvl msgLvl msg | msgLvl >= minLvl = C.putStrLn msg -- assumes ascii, which is wrong(?) | otherwise = return () nullLogger :: Logger nullLogger _ _ = return ()ircbot-0.6.5/Network/IRC/Bot/Parsec.hs0000644000000000000000000001315512725114223015541 0ustar0000000000000000{-# LANGUAGE FlexibleContexts, OverloadedStrings #-} 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.ByteString (ByteString) import qualified Data.ByteString.Char8 as C import Data.Char (digitToInt) import Data.List (intercalate, isPrefixOf, nub) import Data.Maybe (fromMaybe) import Data.Monoid ((<>)) 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 ByteString () 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 ByteString () m () botPrefix = do recv <- fromMaybe "" <$> askReceiver pref <- cmdPrefix <$> askBotEnv if "#" `C.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 ByteString () m a) -> m a parsecPart p = do priv <- privMsg logM Debug $ "I got a message: " <> msg priv <> " sent to " <> (C.intercalate ", " (receivers priv)) ma <- runParserT p () "" (msg priv) case ma of (Left e) -> do logM Debug $ "Parse error: " <> C.pack (show e) target <- maybeZero =<< replyTo reportError target e mzero (Right a) -> return a reportError :: (BotMonad m) => ByteString -> 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] (C.pack 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.6.5/Network/IRC/Bot/PosixLogger.hs0000644000000000000000000000755112725114223016571 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {- Use the 'unix' library to write the log file. Why not 'Handles' you ask? I believe it is because 'Handles' lock the file, and we want to be able to serve the file while it is still being written. -} module Network.IRC.Bot.PosixLogger where import Control.Concurrent.Chan import Data.ByteString (ByteString) import qualified Data.ByteString as B import Data.ByteString.Char8 (pack, unpack) import Data.Time.Calendar (Day(..)) import Data.Time.Clock (UTCTime(..), addUTCTime, getCurrentTime) import Data.Time.Format (defaultTimeLocale, formatTime) import qualified Foreign.C.Error as C import Foreign.Ptr (castPtr) 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.Posix.ByteString ( Fd, OpenMode(WriteOnly), OpenFileFlags(append), closeFd, defaultFileFlags , openFd ) import System.Posix.IO.ByteString (fdWriteBuf) -- 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 -> ByteString -> 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 (== '#') (unpack channel)) ++ "-%Y-%m-%d.txt") now) createDirectoryIfMissing True logDir fd <- openFd (pack 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 = B.concat [ pack (formatTime defaultTimeLocale "%X " now) , "<" , nick , "> " , msg , "\n" ] case mLogFd' of Nothing -> return () (Just logFd') -> fdWrites logFd' logMsg >> return () return () -- hPutStrLn logFd logMsg _ -> return () logLoop logDay' mLogFd' fdWrites :: Fd -> ByteString -> IO () fdWrites fd bs = B.useAsCStringLen bs $ \(cstring, len) -> if len <= 0 then return () else do c <- C.throwErrnoIfMinus1Retry "fdWrites" $ fdWriteBuf fd (castPtr cstring) (fromIntegral len) if (fromIntegral c) == (fromIntegral len) then return () else fdWrites fd (B.drop (fromIntegral c) bs) ircbot-0.6.5/Network/IRC/Bot/Types.hs0000644000000000000000000000146412725114223015430 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable, RecordWildCards, OverloadedStrings #-} module Network.IRC.Bot.Types ( User(..) , nullUser ) where import Data.ByteString (ByteString) import Data.Data (Data, Typeable) import Network.IRC as I import Network (HostName) data User = User { username :: ByteString -- ^ username on client system , hostname :: HostName -- ^ hostname of client system , servername :: HostName -- ^ irc server client is connected to , realname :: ByteString -- ^ client's real name } deriving (Data, Typeable, Eq, Ord, Read, Show) nullUser :: User nullUser = User { username = "" , hostname = "." , servername = "." , realname = "" } ircbot-0.6.5/Network/IRC/Bot/Part/0000755000000000000000000000000012725114223014671 5ustar0000000000000000ircbot-0.6.5/Network/IRC/Bot/Part/Channels.hs0000644000000000000000000000265312725114223016766 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} 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.Monoid ((<>)) import Data.Set (Set, insert, toList) import Data.ByteString (ByteString) import Data.ByteString.Char8(unpack) import Network.IRC (Message(..), joinChan) import Network.IRC.Bot.BotMonad (BotMonad(..)) import Network.IRC.Bot.Log (LogLevel(..)) initChannelsPart :: (BotMonad m) => Set ByteString -> IO (TVar (Set ByteString), m ()) initChannelsPart chans = do channels <- atomically $ newTVar chans return (channels, channelsPart channels) channelsPart :: (BotMonad m) => TVar (Set ByteString) -> 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) => ByteString -> m () doJoin chan = do sendMessage (joinChan chan) logM Normal $ "Joining room " <> chan joinChannel :: (BotMonad m) => ByteString -> TVar (Set ByteString) -> m () joinChannel chan channels = do liftIO $ atomically $ do cs <- readTVar channels writeTVar channels (insert chan cs) sendMessage (joinChan chan) ircbot-0.6.5/Network/IRC/Bot/Part/Dice.hs0000644000000000000000000000344212725114223016074 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} module Network.IRC.Bot.Part.Dice where import Control.Monad (replicateM) import Control.Monad.Trans (liftIO) import Data.ByteString (ByteString) import Data.ByteString.Char8 (pack) import Data.Monoid ((<>)) 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 ByteString () 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] (pack results)) <|> return () ircbot-0.6.5/Network/IRC/Bot/Part/Hello.hs0000644000000000000000000000225112725114223016270 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} module Network.IRC.Bot.Part.Hello where import Control.Monad.Trans (liftIO) import Data.Maybe (fromMaybe) import Data.ByteString (ByteString) import Data.Monoid ((<>)) 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 ByteString () 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.6.5/Network/IRC/Bot/Part/NickUser.hs0000644000000000000000000000300012725114223016741 0ustar0000000000000000module Network.IRC.Bot.Part.NickUser where import Control.Monad.Trans (liftIO) import Data.ByteString (ByteString) import Data.ByteString.Char8 (pack, unpack) import Data.Monoid ((<>)) 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(..), showMessage) 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 (showMessage msg) | cmd == erroneusNickname -> logM Important (showMessage msg) | cmd == nickCollision -> logM Important (showMessage msg) | cmd == nicknameInUse -> do logM Important (showMessage msg) n <- whoami i <- liftIO $ randomRIO (1, 100 :: Int) changeNickUser (n <> pack (show i)) Nothing | otherwise -> return () changeNickUser :: (BotMonad m) => ByteString -> Maybe User -> m () changeNickUser n mUser = do sendMessage (IRC.nick n) case mUser of Nothing -> return () (Just u) -> sendMessage (IRC.user (username u) (pack $ hostname u) (pack $ servername u) (realname u)) ircbot-0.6.5/Network/IRC/Bot/Part/Ping.hs0000644000000000000000000000041312725114223016120 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)