ircbot 0.6.6 → 0.6.6.1
raw patch · 16 files changed
+270/−236 lines, 16 filesdep +ircbotdep +optparse-applicativedep +semigroupsdep ~bytestringdep ~randomdep ~timenew-component:exe:ircbot-demoPVP: minor bump suggested
API additions: PVP suggests at least a minor version bump
Dependencies added: ircbot, optparse-applicative, semigroups
Dependency ranges changed: bytestring, random, time
API changes (from Hackage documentation)
+ Network.IRC.Bot.Options: execBotOptsParser :: Parser extra -> IO (BotConf, extra)
+ Network.IRC.Bot.Options: parseBotConf :: Parser BotConf
+ Network.IRC.Bot.Run: runBotWithParts :: IO [BotPartT IO ()] -> IO ()
Files
- Network/IRC/Bot.hs +2/−0
- Network/IRC/Bot/BotMonad.hs +5/−6
- Network/IRC/Bot/Commands.hs +16/−18
- Network/IRC/Bot/Core.hs +21/−24
- Network/IRC/Bot/Options.hs +95/−0
- Network/IRC/Bot/Parsec.hs +9/−7
- Network/IRC/Bot/Part/Channels.hs +0/−1
- Network/IRC/Bot/Part/Dice.hs +5/−6
- Network/IRC/Bot/Part/Hello.hs +4/−3
- Network/IRC/Bot/Part/NickUser.hs +1/−2
- Network/IRC/Bot/PosixLogger.hs +7/−7
- Network/IRC/Bot/Run.hs +70/−0
- Network/IRC/Bot/Types.hs +0/−1
- app/demo.hs +15/−0
- demo.hs +0/−123
- ircbot.cabal +20/−38
Network/IRC/Bot.hs view
@@ -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
Network/IRC/Bot/BotMonad.hs view
@@ -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
Network/IRC/Bot/Commands.hs view
@@ -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
Network/IRC/Bot/Core.hs view
@@ -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 ()
+ Network/IRC/Bot/Options.hs view
@@ -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")
Network/IRC/Bot/Parsec.hs view
@@ -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
Network/IRC/Bot/Part/Channels.hs view
@@ -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(..))
Network/IRC/Bot/Part/Dice.hs view
@@ -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 <num-dice>d<num-sides>[+<modifier>]"+ modifier <- (do char '+' >> nat) <|> return 0+ return (nd, ns, modifier)) <?> "dice <num-dice>d<num-sides>[+<modifier>]" 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))
Network/IRC/Bot/Part/Hello.hs view
@@ -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 ()
Network/IRC/Bot/Part/NickUser.hs view
@@ -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)
Network/IRC/Bot/PosixLogger.hs view
@@ -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)
+ Network/IRC/Bot/Run.hs view
@@ -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
Network/IRC/Bot/Types.hs view
@@ -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
+ app/demo.hs view
@@ -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+ ]
− demo.hs
@@ -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- ]
ircbot.cabal view
@@ -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