diff --git a/Network/IRC/Bot/BotMonad.hs b/Network/IRC/Bot/BotMonad.hs --- a/Network/IRC/Bot/BotMonad.hs +++ b/Network/IRC/Bot/BotMonad.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses, StandaloneDeriving, UndecidableInstances #-} +{-# LANGUAGE FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses, StandaloneDeriving, UndecidableInstances, OverloadedStrings #-} module Network.IRC.Bot.BotMonad ( BotPartT(..) , BotMonad(..) @@ -20,6 +20,7 @@ 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 @@ -29,14 +30,14 @@ askOutChan :: m (Chan Message) localMessage :: (Message -> Message) -> m a -> m a sendMessage :: Message -> m () - logM :: LogLevel -> String -> m () - whoami :: m String + logM :: LogLevel -> ByteString -> m () + whoami :: m ByteString data BotEnv = BotEnv { message :: Message , outChan :: Chan Message , logFn :: Logger - , botName :: String + , botName :: ByteString , cmdPrefix :: String } 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 @@ -1,14 +1,19 @@ -{-# LANGUAGE DeriveDataTypeable #-} +{-# 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 Network (HostName, PortID(PortNumber)) +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 () @@ -33,8 +38,8 @@ data PrivMsg = PrivMsg { prefix :: (Maybe Prefix) - , receivers :: [String] - , msg :: String + , receivers :: [ByteString] + , msg :: ByteString } deriving (Eq, Read, Show) @@ -66,11 +71,11 @@ 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]) -- | get the nickname of the user who sent the message -askSenderNickName :: (BotMonad m) => m (Maybe String) +askSenderNickName :: (BotMonad m) => m (Maybe ByteString) askSenderNickName = do msg <- askMessage case msg_prefix msg of @@ -80,18 +85,18 @@ -- | figure out who to reply to for a given `Message` -- -- If message was sent to a #channel reply to the channel. Otherwise reply to the sender. -replyTo :: (BotMonad m) => m (Maybe String) +replyTo :: (BotMonad m) => m (Maybe ByteString) replyTo = do priv <- privMsg let receiver = head (receivers priv) - if ("#" `isPrefixOf` receiver) + 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 String) +askReceiver :: (Alternative m, BotMonad m) => m (Maybe ByteString) askReceiver = do priv <- privMsg return (Just (head $ receivers priv)) 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 #-} +{-# LANGUAGE DeriveDataTypeable, RecordWildCards, OverloadedStrings #-} module Network.IRC.Bot.Core ( simpleBot , simpleBot' @@ -12,16 +12,18 @@ import Control.Concurrent.Chan (Chan, dupChan, newChan, readChan, writeChan) import Control.Concurrent.STM (atomically) import Control.Concurrent.STM.TMVar (TMVar, swapTMVar, newTMVar, readTMVar) -import Control.Concurrent.QSem (QSem, newQSem, waitQSem, signalQSem) import Control.Exception (IOException, catch) import Control.Monad (mplus, forever, when) import Control.Monad.Trans (liftIO) +import Data.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, user) +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) @@ -29,7 +31,9 @@ import Network.IRC.Bot.BotMonad (BotMonad(logM, sendMessage), BotPartT, BotEnv(..), runBotPartT) import Network.IRC.Bot.Part.NickUser (changeNickUser) import Prelude hiding (catch) -import System.IO (BufferMode(NoBuffering, LineBuffering), Handle, hClose, hGetLine, hPutStrLn, hSetBuffering) +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 = @@ -38,10 +42,10 @@ , logger :: Logger -- ^ app logging , host :: HostName -- ^ irc server to connect , port :: PortID -- ^ irc port to connect to (usually, 'PortNumber 6667') - , nick :: String -- ^ irc nick + , nick :: ByteString -- ^ irc nick , commandPrefix :: String -- ^ command prefix , user :: User -- ^ irc user info - , channels :: Set String -- ^ channel to join + , channels :: Set ByteString -- ^ channel to join , limits :: Maybe (Int, Int) -- ^ (burst length, delay in microseconds) } @@ -61,7 +65,7 @@ -- | connect to irc server and send NICK and USER commands ircConnect :: HostName -> PortID - -> String + -> ByteString -> User -> IO Handle ircConnect host port n u = @@ -69,12 +73,12 @@ hSetBuffering h LineBuffering return h -partLoop :: Logger -> String -> String -> Chan Message -> Chan Message -> (BotPartT IO ()) -> IO () +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 -> String -> String -> Chan Message -> Chan Message -> [BotPartT IO ()] -> IO [ThreadId] +ircLoop :: Logger -> ByteString -> String -> Chan Message -> Chan Message -> [BotPartT IO ()] -> IO [ThreadId] ircLoop logger botName prefix incomingChan outgoingChan parts = mapM forkPart parts where @@ -85,8 +89,8 @@ -- reconnect loop is still a bit buggy -- if you try to write multiple lines, and the all fail, reconnect will be called multiple times.. -- something should be done so that this does not happen -connectionLoop :: Logger -> Maybe (Int, Int) -> TMVar UTCTime -> HostName -> PortID -> String -> User -> Chan Message -> Chan Message -> Maybe (Chan Message) -> QSem -> IO (ThreadId, ThreadId, Maybe ThreadId, IO ()) -connectionLoop logger mLimitConf tmv host port nick user outgoingChan incomingChan logChan connQSem = +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 @@ -99,20 +103,22 @@ writeMaybeChan logChan msg h <- atomically $ readTMVar hTMVar when (msg_command msg `elem` ["PRIVMSG", "NOTICE"]) limit - hPutStrLn h (encode msg) `catch` (reconnect logger host port nick user hTMVar connQSem) + 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 connQSem + doConnect logger host port nick user hTMVar connSSem forever $ do h <- atomically $ readTMVar hTMVar - msgStr <- (hGetLine h) `catch` (\e -> reconnect logger host port nick user hTMVar connQSem e >> return "") + -- 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) + case decode (msgStr <> "\n") of + Nothing -> logger Normal ("decode failed: " <> msgStr) (Just msg) -> - do logger Debug (show msg) + do logger Debug (showMessage msg) writeMaybeChan logChan msg writeChan incomingChan msg let forceReconnect = @@ -125,43 +131,43 @@ putStrLn "done." return (outgoingTid, incomingTid, limitTid, forceReconnect) -ircConnectLoop :: (LogLevel -> String -> IO a) -- ^ logging +ircConnectLoop :: (LogLevel -> ByteString -> IO a) -- ^ logging -> HostName -> PortID - -> String + -> 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: " ++ show (e :: IOException) + 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 -> String -> IO a) -> String -> PortID -> String -> User -> TMVar Handle -> QSem -> IO () -doConnect logger host port nick user hTMVar connQSem = - do logger Normal $ showString "Connecting to " . showString host . showString " as " $ nick +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." - signalQSem connQSem + SSem.signal connSSem return () -reconnect :: Logger -> String -> PortID -> String -> User -> TMVar Handle -> QSem -> IOException -> IO () -reconnect logger host port nick user hTMVar connQSem e = - do logger Normal $ "IRC Connection died: " ++ show e +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 connQSem + doConnect logger host port nick user hTMVar connSSem -onConnectLoop :: Logger -> String -> String -> Chan Message -> QSem -> BotPartT IO () -> IO ThreadId -onConnectLoop logger botName prefix outgoingChan connQSem action = +onConnectLoop :: Logger -> ByteString -> String -> Chan Message -> SSem -> BotPartT IO () -> IO ThreadId +onConnectLoop logger botName prefix outgoingChan connSSem action = forkIO $ forever $ - do waitQSem connQSem + do SSem.wait connSSem runBotPartT action (BotEnv undefined outgoingChan logger botName prefix) -- |simpleBot connects to the server and handles messages using the supplied BotPartTs @@ -185,7 +191,7 @@ -> Maybe (Int, Int) -- ^ rate limiter settings (burst length, delay in microseconds) -> HostName -- ^ irc server to connect -> PortID -- ^ irc port to connect to (usually, 'PortNumber 6667') - -> String -- ^ irc nick + -> ByteString -- ^ irc nick -> String -- ^ command prefix -> User -- ^ irc user info -> [BotPartT IO ()] -- ^ bot parts (must include 'pingPart', 'channelsPart', and 'nickUserPart)' @@ -203,8 +209,8 @@ incomingChan <- newChan :: IO (Chan Message) now <- getCurrentTime tmv <- atomically $ newTMVar now - connQSem <- newQSem 0 - (outgoingTid, incomingTid, mLimitTid, forceReconnect) <- connectionLoop logger limitConf tmv host port nick user outgoingChan incomingChan mLogChan connQSem + 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 @@ -212,7 +218,7 @@ when (now > addUTCTime (fromIntegral timeout) lastActivity) forceReconnect threadDelay (30*10^6) -- check every 30 seconds ircTids <- ircLoop logger nick prefix incomingChan outgoingChan parts - onConnectId <- onConnectLoop logger nick prefix outgoingChan connQSem onConnect + 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/ErrorCodes.hs b/Network/IRC/Bot/ErrorCodes.hs --- a/Network/IRC/Bot/ErrorCodes.hs +++ b/Network/IRC/Bot/ErrorCodes.hs @@ -1,16 +1,19 @@ +{-# LANGUAGE OverloadedStrings #-} module Network.IRC.Bot.ErrorCodes where +import Data.ByteString (ByteString) + -- * Nickname errors -noNicknameGiven :: String +noNicknameGiven :: ByteString noNicknameGiven = "431" -erroneusNickname :: String +erroneusNickname :: ByteString erroneusNickname = "432" -nicknameInUse :: String +nicknameInUse :: ByteString nicknameInUse = "433" -nickCollision :: String +nickCollision :: ByteString nickCollision = "436" diff --git a/Network/IRC/Bot/Limiter.hs b/Network/IRC/Bot/Limiter.hs --- a/Network/IRC/Bot/Limiter.hs +++ b/Network/IRC/Bot/Limiter.hs @@ -18,12 +18,13 @@ where import Control.Concurrent (ThreadId, forkIO, threadDelay) -import Control.Concurrent.QSem (QSem, newQSem, signalQSem, waitQSem) +import Control.Concurrent.SSem (SSem) +import qualified Control.Concurrent.SSem as SSem import Control.Monad (forever) data Limiter = Limiter - { limitsIn :: QSem - , limitsOut :: QSem + { limitsIn :: SSem + , limitsOut :: SSem , limitsDelay :: Int , limitsThreadId :: ThreadId } @@ -33,8 +34,8 @@ -> Int -- ^ delay (in microseconds) -> IO Limiter newLimiter burst delay = do - rdy <- newQSem burst - sent <- newQSem 0 + rdy <- SSem.new burst + sent <- SSem.new 0 let l = Limiter { limitsIn = sent , limitsOut = rdy , limitsDelay = delay @@ -46,12 +47,12 @@ -- | Execute this before sending limit :: Limiter -> IO () limit l = do - waitQSem (limitsOut l) - signalQSem (limitsIn l) + SSem.wait (limitsOut l) + SSem.signal (limitsIn l) -- | Loop which manages the limit timers limiter :: Limiter -> IO b limiter l = forever $ do - waitQSem (limitsIn l) - threadDelay (limitsDelay l) - signalQSem (limitsOut l) + SSem.wait (limitsIn l) + threadDelay (limitsDelay l) + SSem.signal (limitsOut l) diff --git a/Network/IRC/Bot/Log.hs b/Network/IRC/Bot/Log.hs --- a/Network/IRC/Bot/Log.hs +++ b/Network/IRC/Bot/Log.hs @@ -1,6 +1,8 @@ {-# LANGUAGE DeriveDataTypeable #-} module Network.IRC.Bot.Log where +import Data.ByteString (ByteString) +import qualified Data.ByteString.Char8 as C import Data.Data data LogLevel @@ -9,11 +11,11 @@ | Important deriving (Eq, Ord, Read, Show, Data, Typeable) -type Logger = LogLevel -> String -> IO () +type Logger = LogLevel -> ByteString -> IO () stdoutLogger :: LogLevel -> Logger stdoutLogger minLvl msgLvl msg - | msgLvl >= minLvl = putStrLn msg + | msgLvl >= minLvl = C.putStrLn msg -- assumes ascii, which is wrong(?) | otherwise = return () nullLogger :: Logger 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,4 @@ -{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleContexts, OverloadedStrings #-} module Network.IRC.Bot.Parsec where {- @@ -34,9 +34,12 @@ 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 @@ -57,17 +60,17 @@ mapParsecT f p = mkPT $ \s -> f (runParsecT p s) -- | parse a positive integer -nat :: (Monad m) => ParsecT String () m 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 String () m () +botPrefix :: (BotMonad m) => ParsecT ByteString () m () botPrefix = do recv <- fromMaybe "" <$> askReceiver pref <- cmdPrefix <$> askBotEnv - if "#" `isPrefixOf` recv + if "#" `C.isPrefixOf` recv then (try $ string pref >> return ()) <|> lift mzero else (try $ string pref >> return ()) <|> return () @@ -81,25 +84,25 @@ -- -- see 'dicePart' for an example usage. parsecPart :: (BotMonad m) => - (ParsecT String () m a) + (ParsecT ByteString () m a) -> m a parsecPart p = do priv <- privMsg - logM Debug $ "I got a message: " ++ msg priv ++ " sent to " ++ show (receivers priv) - ma <- runParserT p () (msg priv) (msg priv) + 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: " ++ show e + do logM Debug $ "Parse error: " <> C.pack (show e) target <- maybeZero =<< replyTo reportError target e mzero (Right a) -> return a -reportError :: (BotMonad m) => String -> ParseError -> m () +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] errStr) + in sendCommand (PrivMsg Nothing [target] (C.pack errStr)) showErrorMessages :: String -> String -> String -> String -> String -> [P.Message] -> [String] @@ -116,8 +119,8 @@ showUnExpect = showMany msgUnExpected unExpect showSysUnExpect | not (null unExpect) || null sysUnExpect = "" - | null firstMsg = msgUnExpected ++ " " ++ msgEndOfInput - | otherwise = msgUnExpected ++ " " ++ firstMsg + | null firstMsg = msgUnExpected <> " " <> msgEndOfInput + | otherwise = msgUnExpected <> " " <> firstMsg where firstMsg = messageString (head sysUnExpect) @@ -127,16 +130,16 @@ showMany pre msgs = case clean (map messageString msgs) of [] -> "" ms | null pre -> commasOr ms - | otherwise -> pre ++ " " ++ commasOr ms + | otherwise -> pre <> " " <> commasOr ms commasOr [] = "" commasOr [m] = m - commasOr ms = commaSep (init ms) ++ " " ++ msgOr ++ " " ++ last ms + commasOr ms = commaSep (init ms) <> " " <> msgOr <> " " <> last ms commaSep = seperate ", " . clean seperate _ [] = "" seperate _ [m] = m - seperate sep (m:ms) = m ++ sep ++ seperate sep ms + seperate sep (m:ms) = m <> sep <> seperate sep ms clean = nub . filter (not . null) 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 @@ -1,19 +1,23 @@ +{-# 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 String -> IO (TVar (Set String), m ()) +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 String) -> m () +channelsPart :: (BotMonad m) => TVar (Set ByteString) -> m () channelsPart channels = do msg <- askMessage let cmd = msg_command msg @@ -22,15 +26,14 @@ mapM_ doJoin (toList chans) _ -> return () where - doJoin :: (BotMonad m) => String -> m () - doJoin chan = + doJoin :: (BotMonad m) => ByteString -> m () + doJoin chan = do sendMessage (joinChan chan) - logM Normal $ "Joining room " ++ chan + logM Normal $ "Joining room " <> chan -joinChannel :: (BotMonad m) => String -> TVar (Set String) -> m () +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) - 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,7 +1,11 @@ +{-# 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) @@ -12,7 +16,7 @@ dicePart :: (BotMonad m) => m () dicePart = parsecPart diceCommand -diceCommand :: (BotMonad m) => ParsecT String () m () +diceCommand :: (BotMonad m) => ParsecT ByteString () m () diceCommand = do try $ botPrefix >> string "dice" logM Debug "dicePart" @@ -33,5 +37,5 @@ return (nd, ns, mod)) "dice d[+]" rolls <- liftIO $ replicateM (fromIntegral numDice) $ randomRIO (1, numSides) let results = "You rolled " ++ show numDice ++ " " ++ show numSides ++ "-sided dice with a +" ++ show modifier ++ " modifier: " ++ show rolls ++ " => " ++ show (sum (modifier : rolls)) - sendCommand (PrivMsg Nothing [target] results) + sendCommand (PrivMsg Nothing [target] (pack results)) <|> return () 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,7 +1,10 @@ +{-# 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) @@ -12,15 +15,15 @@ helloPart :: (BotMonad m) => m () helloPart = parsecPart helloCommand -helloCommand :: (BotMonad m) => ParsecT String () m () +helloCommand :: (BotMonad m) => ParsecT ByteString () m () helloCommand = do try $ botPrefix >> string "hello" logM Debug "helloPart" target <- maybeZero =<< replyTo - logM Debug $ "target: " ++ target + 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) + let msg = greetings!!n <> ", " <> (fromMaybe "stranger" mNick) sendCommand (PrivMsg Nothing [target] msg) <|> 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 @@ -1,34 +1,37 @@ module 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.ErrorCodes import Network.IRC.Bot.Log (LogLevel(..)) -- import Network.IRC.Bot.Commands (Ping(..), Pong(..), ping, sendCommand) -import Network.IRC (Message(..)) +import Network.IRC (Message(..), showMessage) import qualified Network.IRC as IRC import System.Random (randomRIO) -nickUserPart :: (BotMonad m) => m () +nickUserPart :: (BotMonad m) => m () nickUserPart = - do msg <- askMessage + do msg <- askMessage let cmd = msg_command msg case () of - () | cmd == noNicknameGiven -> logM Important (show msg) - | cmd == erroneusNickname -> logM Important (show msg) - | cmd == nickCollision -> logM Important (show msg) - | cmd == nicknameInUse -> - do logM Important (show msg) + () | 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 ++ show i) Nothing + changeNickUser (n <> pack (show i)) Nothing | otherwise -> return () -changeNickUser :: (BotMonad m) => String -> Maybe User -> m () +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) (hostname u) (servername u) (realname u)) + sendMessage (IRC.user (username u) (pack $ hostname u) (pack $ servername u) (realname u)) 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 @@ -1,22 +1,36 @@ +{-# 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.Time.Calendar (Day(..)) -import Data.Time.Clock (UTCTime(..), addUTCTime, getCurrentTime) -import Data.Time.Format (formatTime) -import Network.IRC (Command, Message(Message, msg_prefix, msg_command, msg_params), Prefix(NickName), UserName, encode, decode, joinChan, nick, user) +import 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 (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.Locale (defaultTimeLocale) -import System.Posix ( Fd, OpenMode(WriteOnly), OpenFileFlags(append), closeFd, defaultFileFlags - , fdWrite, openFd - ) +import System.Directory (createDirectoryIfMissing) +import System.FilePath (()) +import System.Locale (defaultTimeLocale) +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 -> String -> Chan Message -> IO () +posixLogger :: Maybe FilePath -> ByteString -> Chan Message -> IO () posixLogger mLogDir channel logChan = do now <- getCurrentTime let logDay = utctDay now @@ -28,9 +42,9 @@ case mLogDir of Nothing -> return Nothing (Just logDir) -> - do let logPath = logDir (formatTime defaultTimeLocale ((dropWhile (== '#') channel) ++ "-%Y-%m-%d.txt") now) + do let logPath = logDir (formatTime defaultTimeLocale ((dropWhile (== '#') (unpack channel)) ++ "-%Y-%m-%d.txt") now) createDirectoryIfMissing True logDir - fd <- openFd logPath WriteOnly (Just 0o0644) (defaultFileFlags { append = True }) + 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) @@ -48,11 +62,28 @@ let mPrivMsg = toPrivMsg msg case mPrivMsg of (Just (PrivMsg (Just (NickName nick _user _server)) receivers msg)) | channel `elem` receivers -> - do let logMsg = showString (formatTime defaultTimeLocale "%X " now) . showString "<" . showString nick . showString "> " $ msg + do let logMsg = + B.concat [ pack (formatTime defaultTimeLocale "%X " now) + , "<" , nick , "> " + , msg + , "\n" + ] case mLogFd' of Nothing -> return () - (Just logFd') -> fdWrite logFd' (logMsg ++ "\n") >> 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) 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 @@ -1,32 +1,19 @@ -{-# LANGUAGE DeriveDataTypeable, RecordWildCards #-} +{-# LANGUAGE DeriveDataTypeable, RecordWildCards, OverloadedStrings #-} module Network.IRC.Bot.Types ( User(..) , nullUser ) where -import Control.Concurrent (ThreadId, forkIO, threadDelay) -import Control.Concurrent.Chan (Chan, dupChan, newChan, readChan, writeChan) -import Control.Concurrent.MVar (MVar, modifyMVar_, newMVar, readMVar) -import Control.Concurrent.QSem (QSem, newQSem, waitQSem, signalQSem) -import Control.Exception (IOException, catch) -import Control.Monad (mplus, forever, when) -import Control.Monad.Trans (liftIO) +import Data.ByteString (ByteString) import Data.Data (Data, Typeable) -import Data.Time (UTCTime, addUTCTime, getCurrentTime) -import Network (HostName, PortID(PortNumber), connectTo) -import Network.IRC (Message, decode, encode, joinChan, nick, user) import Network.IRC as I -import Network.IRC.Bot.Log (Logger, LogLevel(Normal, Debug), stdoutLogger) -import Network.IRC.Bot.BotMonad (BotMonad(logM), BotPartT, BotEnv(..), runBotPartT) -import Prelude hiding (catch) -import System.IO (BufferMode(LineBuffering), Handle, hClose, hGetLine, hPutStrLn, hSetBuffering) - +import Network (HostName) data User = User - { username :: String -- ^ username on client system + { username :: ByteString -- ^ username on client system , hostname :: HostName -- ^ hostname of client system , servername :: HostName -- ^ irc server client is connected to - , realname :: String -- ^ client's real name + , realname :: ByteString -- ^ client's real name } deriving (Data, Typeable, Eq, Ord, Read, Show) diff --git a/ircbot.cabal b/ircbot.cabal --- a/ircbot.cabal +++ b/ircbot.cabal @@ -1,5 +1,5 @@ Name: ircbot -Version: 0.5.4 +Version: 0.6.0 Synopsis: A library for writing irc bots Homepage: http://hub.darcs.net/stepcut/ircbot License: BSD3 @@ -34,16 +34,18 @@ Network.IRC.Bot.PosixLogger Network.IRC.Bot.Types - Build-depends: base >= 4 && <5, - containers >= 0.4 && < 0.6, + Build-depends: base >= 4 && <5, + bytestring >= 0.10 && < 0.11, + containers >= 0.4 && < 0.6, directory < 1.3, - filepath >= 1.2 && < 1.4, - irc == 0.5.*, - mtl >= 2.0 && < 2.2, - network >= 2.3 && < 2.5, + filepath >= 1.2 && < 1.4, + irc == 0.6.*, + mtl >= 2.0 && < 2.2, + network >= 2.3 && < 2.5, old-locale == 1.0.*, parsec == 3.1.*, time == 1.4.*, - unix >= 2.4 && < 2.8, + unix >= 2.4 && < 2.8, random == 1.0.*, - stm >= 2.2 && < 2.5 + stm >= 2.2 && < 2.5, + SafeSemaphore >= 0.10 && < 0.11