diff --git a/Network/IRC/Bot.hs b/Network/IRC/Bot.hs --- a/Network/IRC/Bot.hs +++ b/Network/IRC/Bot.hs @@ -4,6 +4,7 @@ , module Network.IRC.Bot.Core , module Network.IRC.Bot.Log , module Network.IRC.Bot.Parsec + , module Network.IRC.Bot.Run ) where import Network.IRC.Bot.BotMonad @@ -11,3 +12,4 @@ import Network.IRC.Bot.Core import Network.IRC.Bot.Log import Network.IRC.Bot.Parsec +import Network.IRC.Bot.Run 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 @@ -8,20 +8,19 @@ , maybeZero ) where -import Control.Applicative (Applicative, Alternative, (<$>)) -import Control.Arrow (first) -import Control.Monad (MonadPlus(mplus, mzero), forever, replicateM, when) +import Control.Applicative (Alternative) +import Control.Monad (MonadPlus(mzero)) import Control.Monad.Cont (MonadCont) import Control.Monad.Except (MonadError) -import Control.Monad.Reader (MonadReader(ask, local), MonadTrans, ReaderT(runReaderT), mapReaderT) +import Control.Monad.Reader (MonadReader(ask, local), 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.Concurrent.Chan (Chan, 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 (Message) import Network.IRC.Bot.Log class (Functor m, MonadPlus m, MonadIO m) => BotMonad m where diff --git a/Network/IRC/Bot/Commands.hs b/Network/IRC/Bot/Commands.hs --- a/Network/IRC/Bot/Commands.hs +++ b/Network/IRC/Bot/Commands.hs @@ -6,11 +6,9 @@ import Data.ByteString (ByteString) import qualified Data.ByteString as B import Data.Data -import Data.List (isPrefixOf) import Data.Monoid ((<>)) -import Network.Socket (PortNumber) -import Network.IRC -import Network.IRC.Bot.BotMonad +import Network.IRC (Message(Message, msg_prefix, msg_command, msg_params), Command, Prefix(NickName)) +import Network.IRC.Bot.BotMonad (BotMonad, askMessage, sendMessage) type HostName = ByteString @@ -18,8 +16,8 @@ cmd :: (Functor m, MonadPlus m, BotMonad m) => Command -> m () cmd cmdName = - do command <- msg_command <$> askMessage - if cmdName == command + do command' <- msg_command <$> askMessage + if cmdName == command' then return () else mzero @@ -45,16 +43,16 @@ privMsg :: (Functor m, MonadPlus m, BotMonad m) => m PrivMsg privMsg = - do msg <- askMessage - maybe mzero return (toPrivMsg msg) + 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) +toPrivMsg m = + let cmd' = msg_command m + params = msg_params m + prefix' = msg_prefix m + in case cmd' of + "PRIVMSG" -> Just $ PrivMsg prefix' (init params) (last params) _ -> Nothing class ToMessage a where @@ -71,7 +69,7 @@ toMessage (Pong hostName) = Message Nothing "PONG" [hostName] instance ToMessage PrivMsg where - toMessage (PrivMsg prefix receivers msg) = Message prefix "PRIVMSG" (receivers <> [msg]) + toMessage (PrivMsg prefix' receivers' msg') = Message prefix' "PRIVMSG" (receivers' <> [msg']) data Notice = Notice { noticePrefix :: (Maybe Prefix) @@ -81,13 +79,13 @@ deriving (Eq, Read, Show) instance ToMessage Notice where - toMessage (Notice prefix receivers msg) = Message prefix "NOTICE" (receivers <> [msg]) + toMessage (Notice prefix' receivers' msg') = Message prefix' "NOTICE" (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 + do msg' <- askMessage + case msg_prefix msg' of (Just (NickName nick _ _)) -> return (Just nick) _ -> return Nothing 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,4 +1,4 @@ -{-# LANGUAGE DeriveDataTypeable, RecordWildCards, OverloadedStrings #-} +{-# LANGUAGE RecordWildCards, OverloadedStrings #-} module Network.IRC.Bot.Core ( simpleBot , simpleBot' @@ -13,27 +13,23 @@ 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 Control.Monad (mplus, forever, void, when) 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.Socket hiding (Debug) -import Network.IRC (Message, decode, encode, joinChan, nick, showMessage, user) -import Network.IRC as I +import Network.IRC (Message, decode, encode, showMessage, msg_command, quit) 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.BotMonad (BotPartT, BotEnv(..), runBotPartT) import Network.IRC.Bot.Part.NickUser (changeNickUser) -import Prelude hiding (catch) +--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, IOMode(..)) +import System.IO (BufferMode(LineBuffering), Handle, hClose, hPutChar, hSetBuffering, IOMode(..)) -- |Bot configuration data BotConf = @@ -68,7 +64,7 @@ -> ByteString -> User -> IO Handle -ircConnect host port n u = do +ircConnect host port _n _u = do addr <- head <$> getAddrInfo Nothing (Just host) (Just $ show port) print addr sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr) @@ -97,7 +93,7 @@ connectionLoop :: Logger -> Maybe (Int, Int) -> TMVar UTCTime -> HostName -> PortNumber -> 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) <- + (limit', limitTid) <- case mLimitConf of Nothing -> return (return (), Nothing) (Just (burst, delay)) -> @@ -107,7 +103,7 @@ do msg <- readChan outgoingChan writeMaybeChan logChan msg h <- atomically $ readTMVar hTMVar - when (msg_command msg `elem` ["PRIVMSG", "NOTICE"]) limit + 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 @@ -119,7 +115,7 @@ -- 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 + void $ atomically $ swapTMVar tmv now case decode (msgStr <> "\n") of Nothing -> logger Normal ("decode failed: " <> msgStr) (Just msg) -> @@ -136,7 +132,7 @@ putStrLn "done." return (outgoingTid, incomingTid, limitTid, forceReconnect) -ircConnectLoop :: (LogLevel -> ByteString -> IO a) -- ^ logging +ircConnectLoop :: (LogLevel -> ByteString -> IO ()) -- ^ logging -> HostName -> PortNumber -> ByteString @@ -146,15 +142,15 @@ (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) + threadDelay (60 * 10^(6 :: Int)) ircConnectLoop logger host port nick user) -doConnect :: (LogLevel -> ByteString -> IO a) -> HostName -> PortNumber -> ByteString -> User -> TMVar Handle -> SSem -> IO () +doConnect :: (LogLevel -> ByteString -> IO ()) -> HostName -> PortNumber -> 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." + void $ atomically $ swapTMVar hTMVar h + void $ logger Normal $ "Connected." SSem.signal connSSem return () @@ -217,13 +213,14 @@ 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 + do let timeout :: Int + timeout = 5*60 + now' <- getCurrentTime lastActivity <- atomically $ readTMVar tmv - when (now > addUTCTime (fromIntegral timeout) lastActivity) forceReconnect - threadDelay (30*10^6) -- check every 30 seconds + when (now' > addUTCTime (fromIntegral timeout) lastActivity) forceReconnect + threadDelay (30*10^(6 :: Int)) -- check every 30 seconds ircTids <- ircLoop logger nick prefix incomingChan outgoingChan parts - onConnectId <- onConnectLoop logger nick prefix outgoingChan connSSem onConnect + _onConnectId <- onConnectLoop logger nick prefix outgoingChan connSSem onConnect return $ (maybe id (:) mLimitTid $ maybe id (:) mLogTid $ (incomingTid : outgoingTid : watchDogTid : ircTids), forceReconnect) where onConnect :: BotPartT IO () diff --git a/Network/IRC/Bot/Options.hs b/Network/IRC/Bot/Options.hs new file mode 100644 --- /dev/null +++ b/Network/IRC/Bot/Options.hs @@ -0,0 +1,95 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Network.IRC.Bot.Options + ( execBotOptsParser + , parseBotConf + ) where + +import Data.ByteString (ByteString) + +import qualified Data.ByteString.Char8 +import qualified Data.Set + +import Options.Applicative +import Data.Semigroup ((<>)) + +import Network.IRC.Bot.Core (BotConf(..), User(..)) +import Network.IRC.Bot.Log (Logger, LogLevel(..), stdoutLogger) + +execBotOptsParser :: Parser extra -> IO (BotConf, extra) +execBotOptsParser parseExtra = execParser + $ info (((,) <$> parseBotConf <*> parseExtra) <**> helper) + ( fullDesc + <> progDesc "ircbot" + <> header "ircbot - Haskell IRC bot" ) + +parseBotConf :: Parser BotConf +parseBotConf = BotConf + <$> pure Nothing + <*> parseLogger + <*> strOption + (long "server" + <> short 's' + <> metavar "HOST_OR_IP" + <> value "localhost" + <> help "IRC server to connect to") + <*> option auto + (long "port" + <> short 'p' + <> metavar "PORT" + <> value 6667 + <> help "Port of the IRC server to use") + <*> strOption + (long "nick" + <> short 'n' + <> help "IRC nick") + <*> strOption + (long "cmd-prefix" + <> short 'c' + <> value "#" + <> help "Bot command prefix") + <*> parseUser + <*> (Data.Set.fromList . map coercePrefixes <$> + some (argument str + (metavar "CHANNEL [CHANNEL]" + <> help "IRC channels to join to, channel prefix # not required") + )) + <*> parseLimits + +-- | Prefix channel name with '#' if needed +coercePrefixes :: ByteString -> ByteString +coercePrefixes x | "#" `Data.ByteString.Char8.isPrefixOf` x = x +coercePrefixes x | otherwise = Data.ByteString.Char8.cons '#' x + +parseLogger :: Parser Logger +parseLogger = stdoutLogger + <$> flag Normal Debug + (long "debug" + <> short 'd' + <> help "Enable debug output") + +parseUser :: Parser User +parseUser = User + <$> strOption + (long "username" + <> help "Ident username") + <*> strOption + (long "hostname" + <> help "Hostname of the client system") + <*> pure "." + <*> strOption + (long "realname" + <> help "Clients real name") + +parseLimits :: Parser (Maybe (Int, Int)) +parseLimits = optional $ (,) + <$> option auto + (long "burst-length" + <> metavar "BURST" + <> value 2 + <> help "Rate limit after a BURST limit of messages is reached") + <*> option auto + (long "delay-ms" + <> metavar "MS" + <> value 2 + <> help "Delay in microseconds for rate limiting") 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,4 +1,8 @@ {-# LANGUAGE FlexibleContexts, OverloadedStrings #-} +-- Enable when GHC7.10 support is not needed +-- where this fails with 'unknown flag' +-- {-# OPTIONS_GHC -Wno-orphans #-} + module Network.IRC.Bot.Parsec where {- @@ -30,14 +34,12 @@ 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.List (intercalate, nub) import Data.Maybe (fromMaybe) import Data.Monoid ((<>)) import Network.IRC.Bot.Log @@ -53,7 +55,7 @@ askOutChan = lift askOutChan localMessage f m = mapParsecT (localMessage f) m sendMessage = lift . sendMessage - logM lvl msg = lift (logM lvl msg) + 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 @@ -106,12 +108,12 @@ showErrorMessages :: String -> String -> String -> String -> String -> [P.Message] -> [String] -showErrorMessages msgOr msgUnknown msgExpecting msgUnExpected msgEndOfInput msgs - | null msgs = [msgUnknown] +showErrorMessages msgOr msgUnknown msgExpecting msgUnExpected msgEndOfInput msgs' + | null msgs' = [msgUnknown] | otherwise = clean $ [showSysUnExpect,showUnExpect,showExpect,showMessages] where - (sysUnExpect,msgs1) = span ((P.SysUnExpect "") ==) msgs + (sysUnExpect,msgs1) = span ((P.SysUnExpect "") ==) msgs' (unExpect,msgs2) = span ((P.UnExpect "") ==) msgs1 (expect,messages) = span ((P.Expect "") ==) msgs2 diff --git a/Network/IRC/Bot/Part/Channels.hs b/Network/IRC/Bot/Part/Channels.hs --- a/Network/IRC/Bot/Part/Channels.hs +++ b/Network/IRC/Bot/Part/Channels.hs @@ -7,7 +7,6 @@ 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(..)) 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 @@ -1,11 +1,10 @@ {-# LANGUAGE OverloadedStrings #-} module Network.IRC.Bot.Part.Dice where -import Control.Monad (replicateM) +import Control.Monad (replicateM, void) 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) @@ -18,7 +17,7 @@ diceCommand :: (BotMonad m) => ParsecT ByteString () m () diceCommand = - do try $ botPrefix >> string "dice" + do void $ try $ botPrefix >> string "dice" logM Debug "dicePart" target <- maybeZero =<< replyTo (numDice, numSides, modifier) <- (do @@ -27,14 +26,14 @@ if nd > 100 then fail "You can not roll more than 100 dice." else do - char 'd' + _ <- 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[+]" + modifier <- (do char '+' >> nat) <|> return 0 + return (nd, ns, modifier)) "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)) diff --git a/Network/IRC/Bot/Part/Hello.hs b/Network/IRC/Bot/Part/Hello.hs --- a/Network/IRC/Bot/Part/Hello.hs +++ b/Network/IRC/Bot/Part/Hello.hs @@ -1,6 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} module Network.IRC.Bot.Part.Hello where +import Control.Monad (void) import Control.Monad.Trans (liftIO) import Data.Maybe (fromMaybe) import Data.ByteString (ByteString) @@ -17,13 +18,13 @@ helloCommand :: (BotMonad m) => ParsecT ByteString () m () helloCommand = - do try $ botPrefix >> string "hello" + do void $ 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) + let message = greetings!!n <> ", " <> (fromMaybe "stranger" mNick) + sendCommand (PrivMsg Nothing [target] message) <|> return () diff --git a/Network/IRC/Bot/Part/NickUser.hs b/Network/IRC/Bot/Part/NickUser.hs --- a/Network/IRC/Bot/Part/NickUser.hs +++ b/Network/IRC/Bot/Part/NickUser.hs @@ -2,13 +2,12 @@ import Control.Monad.Trans (liftIO) import Data.ByteString (ByteString) -import Data.ByteString.Char8 (pack, unpack) +import Data.ByteString.Char8 (pack) 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) diff --git a/Network/IRC/Bot/PosixLogger.hs b/Network/IRC/Bot/PosixLogger.hs --- a/Network/IRC/Bot/PosixLogger.hs +++ b/Network/IRC/Bot/PosixLogger.hs @@ -13,12 +13,12 @@ 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.Clock (UTCTime(..), 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 Network.IRC (Message, Prefix(NickName)) +import Network.IRC.Bot.Commands (PrivMsg(PrivMsg), toPrivMsg) import System.Directory (createDirectoryIfMissing) import System.FilePath (()) import System.Posix.ByteString ( Fd, OpenMode(WriteOnly), OpenFileFlags(append), closeFd, defaultFileFlags @@ -46,7 +46,7 @@ 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 Nothing = return (logDay, Nothing) updateLogHandle now logDay (Just logFd) | logDay == (utctDay now) = return (logDay, Just logFd) | otherwise = do closeFd logFd @@ -60,11 +60,11 @@ (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 -> + (Just (PrivMsg (Just (NickName nick _user _server)) receivers msg')) | channel `elem` receivers -> do let logMsg = B.concat [ pack (formatTime defaultTimeLocale "%X " now) , "<" , nick , "> " - , msg + , msg' , "\n" ] case mLogFd' of @@ -83,6 +83,6 @@ if len <= 0 then return () else do c <- C.throwErrnoIfMinus1Retry "fdWrites" $ fdWriteBuf fd (castPtr cstring) (fromIntegral len) - if (fromIntegral c) == (fromIntegral len) + if (fromIntegral c :: Int) == (fromIntegral len) then return () else fdWrites fd (B.drop (fromIntegral c) bs) diff --git a/Network/IRC/Bot/Run.hs b/Network/IRC/Bot/Run.hs new file mode 100644 --- /dev/null +++ b/Network/IRC/Bot/Run.hs @@ -0,0 +1,70 @@ +-- {-# LANGUAGE OverloadedStrings #-} + +-- | Simple wrapper on top of simpleBot +-- adding applicative parser +-- and `runBotWithParts` shorthand. +-- +-- `runBotWithParts` allows passing +-- initialization function that inits +-- all bot parts and returns them as list. + +module Network.IRC.Bot.Run ( + runBotWithParts + ) where + +import Data.ByteString (ByteString) +import Data.Set (Set) +import Options.Applicative (Parser) + +import qualified Control.Concurrent +import qualified Control.Monad +import qualified Data.List +import qualified System.IO + +import Network.IRC.Bot.BotMonad (BotMonad(..), BotPartT) +import Network.IRC.Bot.Core (BotConf(..), simpleBot) +import Network.IRC.Bot.Options (execBotOptsParser) +import Network.IRC.Bot.Part.Channels (initChannelsPart) +import Network.IRC.Bot.Part.Ping (pingPart) + + +-- | Run bot with user provided initialization +-- function returning bot parts. +runBotWithParts :: IO [BotPartT IO ()] -> IO () +runBotWithParts parts = runBotWithParts' (pure ()) (const parts) + +-- | Run bot with user provided initialization +-- function returning bot parts. +-- +-- Accepts another `optparse-applicative` `Parser` for extending +-- built-in one. +runBotWithParts' :: Parser extra + -> (extra -> IO [BotPartT IO ()]) + -> IO () +runBotWithParts' extrasParser initUserParts = do + (botOptions, extras) <- execBotOptsParser extrasParser + + ircParts <- initParts (initUserParts extras) (channels botOptions) + (tids, reconnect) <- simpleBot botOptions ircParts + hasStdin <- System.IO.isEOF + case hasStdin of + True -> Control.Monad.forever $ Control.Concurrent.threadDelay 1000000000 + False -> do + let loop = do + l <- getLine + Control.Monad.unless ("quit" `Data.List.isPrefixOf` l) $ do + reconnect + loop + + loop + mapM_ Control.Concurrent.killThread tids + +-- Init channels part and all user parts +initParts :: (BotMonad m) + => (IO [m ()]) -- ^ User provided parts + -> Set ByteString -- ^ Set of channels to join + -> IO [m ()] +initParts initUser chans = do + (_, channelsPart) <- initChannelsPart chans + userParts <- initUser + return $ channelsPart:pingPart:userParts diff --git a/Network/IRC/Bot/Types.hs b/Network/IRC/Bot/Types.hs --- a/Network/IRC/Bot/Types.hs +++ b/Network/IRC/Bot/Types.hs @@ -6,7 +6,6 @@ import Data.ByteString (ByteString) import Data.Data (Data, Typeable) -import Network.IRC as I import Network.Socket (HostName) data User = User diff --git a/app/demo.hs b/app/demo.hs new file mode 100644 --- /dev/null +++ b/app/demo.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE DeriveDataTypeable, FlexibleContexts, GeneralizedNewtypeDeriving, RankNTypes, RecordWildCards, OverloadedStrings #-} +module Main where + +import Network.IRC.Bot (runBotWithParts) +import Network.IRC.Bot.Part.Dice (dicePart) +import Network.IRC.Bot.Part.Hello (helloPart) +import Network.IRC.Bot.Part.NickUser (nickUserPart) +import Network.IRC.Bot.Part.Channels (initChannelsPart) + +main :: IO () +main = runBotWithParts $ pure + [ nickUserPart + , dicePart + , helloPart + ] diff --git a/demo.hs b/demo.hs deleted file mode 100644 --- a/demo.hs +++ /dev/null @@ -1,123 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable, FlexibleContexts, GeneralizedNewtypeDeriving, RankNTypes, RecordWildCards, OverloadedStrings #-} -module Main where - -import Control.Concurrent (killThread) -import Control.Concurrent.Chan (Chan) -import Data.ByteString (ByteString) -import qualified Data.ByteString.Char8 as C -import Data.Set (Set, insert) -import Network.Socket hiding (Debug) -import Network.IRC (Message) -import Network.IRC.Bot.BotMonad (BotMonad(..)) -import Network.IRC.Bot.Core (BotConf(..), User(..), nullBotConf, simpleBot) -import Network.IRC.Bot.Log (LogLevel(..), nullLogger, stdoutLogger) -import Network.IRC.Bot.Part.Dice (dicePart) -import Network.IRC.Bot.Part.Hello (helloPart) -import Network.IRC.Bot.Part.Ping (pingPart) -import Network.IRC.Bot.Part.NickUser (nickUserPart) -import Network.IRC.Bot.Part.Channels (initChannelsPart) -import System.Console.GetOpt -import System.Environment (getArgs, getProgName) -import System.Exit (exitFailure) -import System.IO (stdout) - -data Flag - = BotConfOpt { unBotConfOpt :: (BotConf -> BotConf) } - -botOpts :: [OptDescr Flag] -botOpts = - [ Option [] ["irc-server"] (ReqArg setIrcServer "hostname or IP") "irc server to connect to" - , Option [] ["port"] (ReqArg setPort "port") "port to connect to on server" - , Option [] ["nick"] (ReqArg setNick "name") "irc nick" - , Option [] ["username"] (ReqArg setUsername "username") "ident username" - , Option [] ["hostname"] (ReqArg setHostname "hostname") "hostname of machine bot is connecting from" - , Option [] ["realname"] (ReqArg setRealname "name") "bot's real name" - , Option [] ["cmd-prefix"] (ReqArg setCmdPrefix "prefix") "prefix to bot commands (e.g., ?, @, bot: )" - , Option [] ["channel"] (ReqArg addChannel "channel name") "channel to join after connecting. (can be specified more than once to join multiple channels)" - , Option [] ["log-level"] (ReqArg setLogLevel "debug, normal, important, quiet") "set the logging level" - , Option [] ["limit"] (ReqArg setLimit "int,int") "enable rate limiter. burst length, delay in microseconds" - ] - where - setIrcServer n = BotConfOpt $ \c -> c { host = n, user = (user c) { servername = n } } - setPort str = BotConfOpt $ \c -> c { port = (fromIntegral $ read str) } - setNick n = BotConfOpt $ \c -> c { nick = C.pack n } - setUsername n = BotConfOpt $ \c -> c { user = (user c) { username = C.pack n } } - setHostname n = BotConfOpt $ \c -> c { user = (user c) { hostname = n } } - setRealname n = BotConfOpt $ \c -> c { user = (user c) { realname = (C.pack n) } } - setCmdPrefix p = BotConfOpt $ \c -> c { commandPrefix = p } - addChannel ch = BotConfOpt $ \c -> c { channels = insert (C.pack ch) (channels c) } - setLogLevel l = BotConfOpt $ \c -> - case l of - "debug" -> c { logger = stdoutLogger Debug } - "normal" -> c { logger = stdoutLogger Normal } - "important" -> c { logger = stdoutLogger Important } - "quiet" -> c { logger = nullLogger } - _ -> error $ "unknown log-level: " ++ l - setLimit s = BotConfOpt $ \c -> - case break (== ',') s of - (burstStr, delayStr) -> - case reads burstStr of - [(burstLen,[])] -> - case reads (drop 1 $ delayStr) of - [(delay,[])] -> - c { limits = Just (burstLen, delay) } - _ -> error $ "unabled to parse delay: " ++ delayStr - _ -> error $ "unabled to parse burst length: " ++ burstStr - -getBotConf :: Maybe (Chan Message -> IO ()) -> IO BotConf -getBotConf mLogger = - do args <- getArgs - case getOpt Permute botOpts args of - (f,_,[]) -> - do let conf = (foldr ($) nullBotConf (map unBotConfOpt f)) { channelLogger = mLogger } - checkConf conf - return conf - (_,_,errs) -> - do progName <- getProgName - putStr (helpMessage progName) - exitFailure - -exitHelp msg = - do progName <- getProgName - putStrLn msg - putStr (helpMessage progName) - exitFailure - -checkConf :: BotConf -> IO () -checkConf BotConf{..} - | null host = exitHelp "must specify --irc-server" - | C.null nick = exitHelp "must specify --nick" - | C.null (username user) = exitHelp "must specify --username" - | null (hostname user) = exitHelp "must specify --hostname" - | C.null (realname user) = exitHelp "must specify --realname" - | otherwise = return () - -helpMessage progName = usageInfo header botOpts - where - header = "Usage: "++progName++" [OPTION...]\n" ++ "e.g.\n" ++ - progName ++ " --irc-server irc.freenode.net --nick stepbot --username stepbot --hostname happstack.com --realname \"happstack bot\" --channel \"#stepbot\"" - -main :: IO () -main = - do botConf <- getBotConf Nothing - ircParts <- initParts (channels botConf) - (tids, reconnect) <- simpleBot botConf ircParts - (logger botConf) Important "Press enter to force reconnect." - getLine - reconnect - (logger botConf) Important "Press enter to quit." - getLine - - mapM_ killThread tids - -initParts :: (BotMonad m) => - Set ByteString -- ^ set of channels to join - -> IO [m ()] -initParts chans = - do (_, channelsPart) <- initChannelsPart chans - return [ pingPart - , nickUserPart - , channelsPart - , dicePart - , helloPart - ] diff --git a/ircbot.cabal b/ircbot.cabal --- a/ircbot.cabal +++ b/ircbot.cabal @@ -1,5 +1,5 @@ Name: ircbot -Version: 0.6.6 +Version: 0.6.6.1 Synopsis: A library for writing IRC bots Description: A simple library for an IRC bot License: BSD3 @@ -28,17 +28,23 @@ Network.IRC.Bot.ErrorCodes Network.IRC.Bot.Limiter Network.IRC.Bot.Log + Network.IRC.Bot.Options 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.Run Network.IRC.Bot.PosixLogger Network.IRC.Bot.Types + if impl(ghc >= 8.10) + ghc-options: -Wall -Wunused-packages + else + ghc-options: -Wall Build-depends: base >= 4 && <5, - bytestring >= 0.10 && < 0.11, + bytestring >= 0.10 && < 0.12, containers >= 0.4 && < 0.7, directory < 1.4, filepath >= 1.2 && < 1.5, @@ -46,44 +52,20 @@ mtl >= 2.0 && < 2.3, network >= 3.1 && < 3.2, parsec == 3.1.*, - time >= 1.5 && < 1.10, + time >= 1.5 && < 1.12, unix >= 2.4 && < 2.8, - random >= 1.0 && < 1.2, + random >= 1.0 && < 1.3, stm >= 2.2 && < 2.6, - SafeSemaphore >= 0.10 && < 0.11 + SafeSemaphore >= 0.10 && < 0.11, + optparse-applicative >= 0.14 && < 0.17 -Executable demo - main-is: demo.hs - ghc-options: -threaded -rtsopts -with-rtsopts=-N - build-depends: base >= 4 && <5, - bytestring >= 0.10 && < 0.11, - containers >= 0.4 && < 0.7, - directory < 1.4, - filepath >= 1.2 && < 1.5, - irc == 0.6.*, - mtl >= 2.0 && < 2.3, - network >= 3.1 && < 3.2, - parsec == 3.1.*, - time >= 1.5 && < 1.10, - unix >= 2.4 && < 2.8, - random >= 1.0 && < 1.2, - stm >= 2.2 && < 2.6, - SafeSemaphore >= 0.10 && < 0.11 - other-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 + if !impl(ghc >= 8.0) + build-depends: semigroups >= 0.18 +Executable ircbot-demo + main-is: demo.hs + hs-source-dirs: app + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-depends: base >= 4 && <5, + ircbot default-language: Haskell2010