From 8659c5f755b82c5f1848580afacb79ededaadfd5 Mon Sep 17 00:00:00 2001 From: Abhinav Sarkar Date: Tue, 20 May 2014 00:05:06 +0530 Subject: [PATCH] Added support for new messages and commands 1. Added support for pong, nick in use and names messages 2. Added support for ping, quit and names commands 3. Refactored message logger 4. Other minor changes --- Network/IRC/Client.hs | 65 ++++++++++++++------------- Network/IRC/Handlers.hs | 33 +++++++++++--- Network/IRC/Handlers/MessageLogger.hs | 53 +++++++++------------- Network/IRC/Protocol.hs | 44 +++++++++++------- Network/IRC/Types.hs | 49 ++++++++++++-------- hask-irc.cabal | 10 +++-- 6 files changed, 145 insertions(+), 109 deletions(-) diff --git a/Network/IRC/Client.hs b/Network/IRC/Client.hs index d3dab70..0b6fc5c 100644 --- a/Network/IRC/Client.hs +++ b/Network/IRC/Client.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} @@ -39,22 +40,20 @@ awaitLatch latch = void $ takeMVar latch type EChannel a = (Chan a, Latch) -data Cmd = CmdQuit | Cmd !Command deriving (Show, Eq) data Line = Timeout | EOF | Line !Message deriving (Show, Eq) -sendCommandLoop :: EChannel Cmd -> Bot -> IO () +sendCommandLoop :: EChannel Command -> Bot -> IO () sendCommandLoop (commandChan, latch) bot@Bot { .. } = do cmd <- readChan commandChan + time <- getCurrentTime + let line = lineFromCommand botConfig cmd + TF.hprint socket "{}\r\n" $ TF.Only line + TF.print "[{}] > {}\n" $ TF.buildParams (formatTime defaultTimeLocale "%F %T" time, line) case cmd of - CmdQuit -> latchIt latch - Cmd command -> do - time <- getCurrentTime - let line = lineFromCommand botConfig command - TF.hprint socket "{}\r\n" $ TF.Only line - TF.print "[{}] > {}\n" $ TF.buildParams (formatTime defaultTimeLocale "%F %T" time, line) - sendCommandLoop (commandChan, latch) bot + QuitCmd -> latchIt latch + _ -> sendCommandLoop (commandChan, latch) bot -sendCommand :: Chan Cmd -> Cmd -> IO () +sendCommand :: Chan Command -> Command -> IO () sendCommand = writeChan readLineLoop :: MVar BotStatus -> EChannel Line -> Bot -> Int -> IO () @@ -85,29 +84,31 @@ readLine = readChan sendMessage :: Chan Line -> Message -> IO () sendMessage = (. Line) . writeChan -listenerLoop :: Chan Line -> Chan Cmd -> Int -> IRC () -listenerLoop lineChan commandChan idleFor = do +listenerLoop :: Chan Line -> Chan Command -> Int -> IRC () +listenerLoop lineChan commandChan !idleFor = do status <- get bot@Bot { .. } <- ask let nick = botNick botConfig - nStatus <- liftIO $ + nStatus <- liftIO . mask_ $ if idleFor >= (oneSec * botTimeout botConfig) - then return Disconnected + then debug "Timeout" >> return Disconnected else do when (status == Kicked) $ - threadDelay (5 * oneSec) >> sendCommand commandChan (Cmd JoinCmd) + threadDelay (5 * oneSec) >> sendCommand commandChan JoinCmd mLine <- readLine lineChan case mLine of - Timeout -> dispatchHandlers bot IdleMsg >> return Idle - EOF -> return Disconnected + Timeout -> getCurrentTime >>= dispatchHandlers bot . IdleMsg >> return Idle + EOF -> debug "Connection closed" >> return Disconnected Line message -> do nStatus <- case message of JoinMsg { .. } | userNick user == nick -> debug "Joined" >> return Joined KickMsg { .. } | kickedNick == nick -> debug "Kicked" >> return Kicked + NickInUseMsg { .. } -> + debug "Nick already in use" >> return NickNotAvailable ModeMsg { user = Self, .. } -> - sendCommand commandChan (Cmd JoinCmd) >> return Connected + sendCommand commandChan JoinCmd >> return Connected _ -> return Connected dispatchHandlers bot message @@ -115,9 +116,10 @@ listenerLoop lineChan commandChan idleFor = do put nStatus case nStatus of - Idle -> listenerLoop lineChan commandChan (idleFor + oneSec) - Disconnected -> return () - _ -> listenerLoop lineChan commandChan 0 + Idle -> listenerLoop lineChan commandChan (idleFor + oneSec) + Disconnected -> return () + NickNotAvailable -> return () + _ -> listenerLoop lineChan commandChan 0 where dispatchHandlers Bot { .. } message = @@ -128,7 +130,7 @@ listenerLoop lineChan commandChan idleFor = do Nothing -> return () Just cmd -> case cmd of MessageCmd msg -> sendMessage lineChan msg - _ -> sendCommand commandChan (Cmd cmd) + _ -> sendCommand commandChan cmd loadMsgHandlers :: BotConfig -> IO (Map MsgHandlerName MsgHandler) loadMsgHandlers botConfig@BotConfig { .. } = @@ -145,7 +147,7 @@ unloadMsgHandlers Bot { .. } = debug $ "Unloading msg handler: " ++ msgHandlerName stopMsgHandler msgHandler botConfig -connect :: BotConfig -> IO (Bot, MVar BotStatus, EChannel Line, EChannel Cmd) +connect :: BotConfig -> IO (Bot, MVar BotStatus, EChannel Line, EChannel Command) connect botConfig@BotConfig { .. } = do debug "Connecting ..." socket <- connectToWithRetry @@ -167,10 +169,10 @@ connect botConfig@BotConfig { .. } = do threadDelay (5 * oneSec) connectToWithRetry) -disconnect :: (Bot, MVar BotStatus, EChannel Line, EChannel Cmd) -> IO () +disconnect :: (Bot, MVar BotStatus, EChannel Line, EChannel Command) -> IO () disconnect (bot@Bot { .. }, mvBotStatus, (_, readLatch), (commandChan, sendLatch)) = do debug "Disconnecting ..." - sendCommand commandChan CmdQuit + sendCommand commandChan QuitCmd awaitLatch sendLatch swapMVar mvBotStatus Disconnected awaitLatch readLatch @@ -190,10 +192,11 @@ run botConfig' = withSocketsDo $ do print botConfig status <- run_ case status of - Disconnected -> debug "Connection timed out" >> run botConfig - Interrupted -> return () - Errored -> debug "Errored, restarting" >> run botConfig - _ -> error "Unsupported status" + Disconnected -> debug "Restarting .." >> run botConfig + Interrupted -> return () + NickNotAvailable -> return () + Errored -> debug "Restarting .." >> run botConfig + _ -> error "Unsupported status" where botConfig = addCoreMsgHandlers botConfig' @@ -205,8 +208,8 @@ run botConfig' = withSocketsDo $ do run_ = bracket (connect botConfig) disconnect $ \(bot, mvBotStatus, (lineChan, readLatch), (commandChan, sendLatch)) -> handle handleErrors $ do - sendCommand commandChan (Cmd NickCmd) - sendCommand commandChan (Cmd UserCmd) + sendCommand commandChan NickCmd + sendCommand commandChan UserCmd fork $ sendCommandLoop (commandChan, sendLatch) bot fork $ readLineLoop mvBotStatus (lineChan, readLatch) bot oneSec diff --git a/Network/IRC/Handlers.hs b/Network/IRC/Handlers.hs index 0f7138a..71f8ab6 100644 --- a/Network/IRC/Handlers.hs +++ b/Network/IRC/Handlers.hs @@ -10,7 +10,9 @@ import qualified Network.IRC.Handlers.SongSearch as SS import ClassyPrelude import Control.Monad.Reader.Class +import Data.Convertible import Data.Text (strip) +import Data.Time (addUTCTime) import Network.IRC.Types @@ -21,18 +23,35 @@ coreMsgHandlerNames :: [Text] coreMsgHandlerNames = ["pingpong", "messagelogger"] mkMsgHandler :: BotConfig -> MsgHandlerName -> IO (Maybe MsgHandler) -mkMsgHandler _ "greeter" = return . Just $ newMsgHandler { msgHandlerRun = greeter } -mkMsgHandler _ "welcomer" = return . Just $ newMsgHandler { msgHandlerRun = welcomer } -mkMsgHandler _ "pingpong" = return . Just $ newMsgHandler { msgHandlerRun = pingPong } -mkMsgHandler botConfig name = +mkMsgHandler _ "greeter" = return . Just $ newMsgHandler { msgHandlerRun = greeter } +mkMsgHandler _ "welcomer" = return . Just $ newMsgHandler { msgHandlerRun = welcomer } + +mkMsgHandler _ "pingpong" = do + state <- getCurrentTime >>= newIORef + return . Just $ newMsgHandler { msgHandlerRun = pingPong state } + +mkMsgHandler botConfig name = flip (`foldM` Nothing) [L.mkMsgHandler, SS.mkMsgHandler] $ \acc h -> case acc of Just _ -> return acc Nothing -> h botConfig name -pingPong :: MonadMsgHandler m => Message -> m (Maybe Command) -pingPong Ping { .. } = return . Just $ Pong msg -pingPong _ = return Nothing +pingPong :: MonadMsgHandler m => IORef UTCTime -> Message -> m (Maybe Command) +pingPong state PingMsg { .. } = do + liftIO $ atomicWriteIORef state msgTime + return . Just $ PongCmd msg +pingPong state PongMsg { .. } = do + liftIO $ atomicWriteIORef state msgTime + return Nothing +pingPong state IdleMsg { .. } | even (convert msgTime :: Int) = do + BotConfig { .. } <- ask + let limit = fromIntegral $ botTimeout `div` 2 + liftIO $ do + lastComm <- readIORef state + if addUTCTime limit lastComm < msgTime + then return . Just . PingCmd . pack . formatTime defaultTimeLocale "%s" $ msgTime + else return Nothing +pingPong _ _ = return Nothing greeter :: MonadMsgHandler m => Message -> m (Maybe Command) greeter ChannelMsg { .. } = case find (== clean msg) greetings of diff --git a/Network/IRC/Handlers/MessageLogger.hs b/Network/IRC/Handlers/MessageLogger.hs index 5ae4b25..7e42ce3 100644 --- a/Network/IRC/Handlers/MessageLogger.hs +++ b/Network/IRC/Handlers/MessageLogger.hs @@ -10,7 +10,8 @@ import qualified Data.Configurator as C import qualified Data.Text.Format as TF import qualified Data.Text.Format.Params as TF -import ClassyPrelude hiding (try, (), (<.>), FilePath) +import ClassyPrelude hiding (try, (), (<.>), FilePath, log) +import Control.Exception.Lifted import Control.Monad.Reader import Data.Time (diffDays) import System.Directory @@ -33,7 +34,7 @@ getLogFilePath :: BotConfig -> IO FilePath getLogFilePath BotConfig { .. } = do logFileDir <- C.require config "messagelogger.logdir" createDirectoryIfMissing True logFileDir - return $ logFileDir unpack botNick <.> "log" + return $ logFileDir unpack (channel ++ "-" ++ botNick) <.> "log" openLogFile :: FilePath -> IO Handle openLogFile logFilePath = do @@ -67,8 +68,9 @@ withLogFile action state = do then do hClose logFileHandle logFilePath <- getLogFilePath botConfig - copyFile logFilePath (logFilePath <.> show prevDay) - removeFile logFilePath + mask_ $ do + copyFile logFilePath (logFilePath <.> show prevDay) + removeFile logFilePath openLogFile logFilePath else return logFileHandle @@ -77,39 +79,24 @@ withLogFile action state = do return Nothing -fmtTime :: UTCTime -> String -fmtTime = formatTime defaultTimeLocale "%F %T" - messageLogger :: MonadMsgHandler m => Message -> IORef LoggerState -> m (Maybe Command) -messageLogger ChannelMsg { .. } = withLogFile $ \logFile -> - TF.hprint logFile "[{}] {}: {}\n" $ TF.buildParams (fmtTime msgTime, userNick user, msg) +messageLogger message = go message + where + go ChannelMsg { .. } = log "<{}> {}" [userNick user, msg] + go ActionMsg { .. } = log "<{}> {} {}" [userNick user, userNick user, msg] + go KickMsg { .. } = log "** {} KICKED {} :{}" [userNick user, kickedNick, msg] + go JoinMsg { .. } = log "** {} JOINED" [userNick user] + go PartMsg { .. } = log "** {} PARTED :{}" [userNick user, msg] + go QuitMsg { .. } = log "** {} QUIT :{}" [userNick user, msg] + go NickMsg { .. } = log "** {} CHANGED NICK TO {}" [userNick user, nick] + go NamesMsg { .. } = log "** USERS {}" [unwords nicks] + go _ = const $ return Nothing -messageLogger ActionMsg { .. } = withLogFile $ \logFile -> - TF.hprint logFile "[{}] {}: {} {}\n" $ - TF.buildParams (fmtTime msgTime, userNick user, userNick user, msg) + log format args = withLogFile $ \logFile -> + TF.hprint logFile ("[{}] " ++ format ++ "\n") $ TF.buildParams (fmtTime (msgTime message) : args) -messageLogger KickMsg { .. } = withLogFile $ \logFile -> - TF.hprint logFile "[{}] ** {} KICKED {} :{}\n" $ - TF.buildParams (fmtTime msgTime, userNick user, kickedNick, msg) - -messageLogger JoinMsg { .. } = withLogFile $ \logFile -> - TF.hprint logFile "[{}] ** {} JOINED\n" $ - TF.buildParams (fmtTime msgTime, userNick user) - -messageLogger PartMsg { .. } = withLogFile $ \logFile -> - TF.hprint logFile "[{}] ** {} PARTED :{}\n" $ - TF.buildParams (fmtTime msgTime, userNick user, msg) - -messageLogger QuitMsg { .. } = withLogFile $ \logFile -> - TF.hprint logFile "[{}] ** {} QUIT :{}\n" $ - TF.buildParams (fmtTime msgTime, userNick user, msg) - -messageLogger NickMsg { .. } = withLogFile $ \logFile -> - TF.hprint logFile "[{}] ** {} CHANGED NICK TO {}\n" $ - TF.buildParams (fmtTime msgTime, userNick user, nick) + fmtTime = pack . formatTime defaultTimeLocale "%F %T" --messageLogger IdleMsg = const . liftIO $ do -- now <- getCurrentTime -- return . Just . MessageCmd $ - -messageLogger _ = const $ return Nothing diff --git a/Network/IRC/Protocol.hs b/Network/IRC/Protocol.hs index ee1ee6d..2afa7e4 100644 --- a/Network/IRC/Protocol.hs +++ b/Network/IRC/Protocol.hs @@ -12,8 +12,9 @@ import Network.IRC.Types msgFromLine :: BotConfig -> UTCTime -> Text -> Message msgFromLine (BotConfig { .. }) time line - | "PING :" `isPrefixOf` line = Ping time (drop 6 line) line + | "PING :" `isPrefixOf` line = PingMsg time (drop 6 line) line | otherwise = case command of + "PONG" -> PongMsg time message line "JOIN" -> JoinMsg time user line "QUIT" -> QuitMsg time user quitMessage line "PART" -> PartMsg time user message line @@ -27,27 +28,38 @@ msgFromLine (BotConfig { .. }) time line then ActionMsg time user (initDef . drop 8 $ message) line else ChannelMsg time user message line else PrivMsg time user message line + "353" -> NamesMsg time namesNicks + "433" -> NickInUseMsg time line _ -> OtherMsg time source command target message line where - isSpc = (== ' ') - isNotSpc = not . isSpc - splits = split isSpc line - source = drop 1 . takeWhile isNotSpc $ line - target = splits !! 2 - command = splits !! 1 - message = drop 1 . unwords . drop 3 $ splits - quitMessage = drop 1 . unwords . drop 2 $ splits - user = uncurry User . break (== '!') $ source - mode = splits !! 3 - modeArgs = drop 4 splits - kicked = splits !! 3 - kickReason = drop 1 . unwords . drop 4 $ splits + isSpc = (== ' ') + isNotSpc = not . isSpc + splits = split isSpc line + source = drop 1 . takeWhile isNotSpc $ line + target = splits !! 2 + command = splits !! 1 + message = drop 1 . unwords . drop 3 $ splits + quitMessage = drop 1 . unwords . drop 2 $ splits + user = uncurry User . break (== '!') $ source + mode = splits !! 3 + modeArgs = drop 4 splits + kicked = splits !! 3 + kickReason = drop 1 . unwords . drop 4 $ splits + + nickPrefixes :: String + nickPrefixes = "~&@%+" + namesNicks = map stripNickPrefix . words . drop 1 . unwords . drop 5 $ splits + stripNickPrefix = pack . dropWhile (`elem` nickPrefixes) . unpack lineFromCommand :: BotConfig -> Command -> Text -lineFromCommand (BotConfig { .. }) reply = case reply of - Pong { .. } -> "PONG :" ++ rmsg +lineFromCommand (BotConfig { .. }) command = case command of + PongCmd { .. } -> "PONG :" ++ rmsg + PingCmd { .. } -> "PING :" ++ rmsg NickCmd -> "NICK " ++ botNick UserCmd -> "USER " ++ botNick ++ " 0 * :" ++ botNick JoinCmd -> "JOIN " ++ channel + QuitCmd -> "QUIT" ChannelMsgReply { .. } -> "PRIVMSG " ++ channel ++ " :" ++ rmsg PrivMsgReply (User { .. }) rmsg -> "PRIVMSG " ++ botNick ++ " :" ++ rmsg + NamesCmd -> "NAMES " ++ channel + _ -> error $ "Unsupported command " ++ show command diff --git a/Network/IRC/Types.hs b/Network/IRC/Types.hs index b42582e..6cd2bdf 100644 --- a/Network/IRC/Types.hs +++ b/Network/IRC/Types.hs @@ -26,30 +26,36 @@ data User = Self | User { userNick :: !Nick, userServer :: !Text } deriving (Show, Eq) data Message = - IdleMsg - | ChannelMsg { msgTime :: !UTCTime, user :: !User, msg :: !Text, msgLine :: !Text } - | PrivMsg { msgTime :: !UTCTime, user :: !User, msg :: !Text, msgLine :: !Text } - | ActionMsg { msgTime :: !UTCTime, user :: !User, msg :: !Text, msgLine :: !Text } - | Ping { msgTime :: !UTCTime, msg :: !Text, msgLine :: !Text } - | JoinMsg { msgTime :: !UTCTime, user :: !User, msgLine :: !Text } - | QuitMsg { msgTime :: !UTCTime, user :: !User, msg :: !Text, msgLine :: !Text } - | PartMsg { msgTime :: !UTCTime, user :: !User, msg :: !Text, msgLine :: !Text } - | ModeMsg { msgTime :: !UTCTime, user :: !User, target :: !Text, mode :: !Text - , modeArgs :: ![Text], msgLine :: !Text } - | NickMsg { msgTime :: !UTCTime, user :: !User, nick :: !Text, msgLine :: !Text } - | KickMsg { msgTime :: !UTCTime, user :: !User, kickedNick :: !Text, msg :: !Text - , msgLine :: !Text } - | OtherMsg { msgTime :: !UTCTime, source :: !Text, command :: !Text, target :: !Text - , msg :: !Text, msgLine :: !Text } + IdleMsg { msgTime :: !UTCTime} + | PingMsg { msgTime :: !UTCTime, msg :: !Text, msgLine :: !Text } + | PongMsg { msgTime :: !UTCTime, msg :: !Text, msgLine :: !Text } + | ChannelMsg { msgTime :: !UTCTime, user :: !User, msg :: !Text, msgLine :: !Text } + | PrivMsg { msgTime :: !UTCTime, user :: !User, msg :: !Text, msgLine :: !Text } + | ActionMsg { msgTime :: !UTCTime, user :: !User, msg :: !Text, msgLine :: !Text } + | JoinMsg { msgTime :: !UTCTime, user :: !User, msgLine :: !Text } + | QuitMsg { msgTime :: !UTCTime, user :: !User, msg :: !Text, msgLine :: !Text } + | PartMsg { msgTime :: !UTCTime, user :: !User, msg :: !Text, msgLine :: !Text } + | NickMsg { msgTime :: !UTCTime, user :: !User, nick :: !Nick, msgLine :: !Text } + | NickInUseMsg { msgTime :: !UTCTime, msgLine :: !Text } + | KickMsg { msgTime :: !UTCTime, user :: !User, kickedNick :: !Nick, msg :: !Text + , msgLine :: !Text } + | ModeMsg { msgTime :: !UTCTime, user :: !User, target :: !Text, mode :: !Text + , modeArgs :: ![Text], msgLine :: !Text } + | NamesMsg { msgTime :: !UTCTime, nicks :: ![Nick] } + | OtherMsg { msgTime :: !UTCTime, source :: !Text, command :: !Text, target :: !Text + , msg :: !Text, msgLine :: !Text } deriving (Show, Eq) data Command = - Pong { rmsg :: !Text } + PingCmd { rmsg :: !Text } + | PongCmd { rmsg :: !Text } | ChannelMsgReply { rmsg :: !Text } | PrivMsgReply { ruser :: !User, rmsg :: !Text } | NickCmd | UserCmd | JoinCmd + | QuitCmd + | NamesCmd | MessageCmd Message deriving (Show, Eq) @@ -73,8 +79,15 @@ data Bot = Bot { botConfig :: !BotConfig , socket :: !Handle , msgHandlers :: !(Map MsgHandlerName MsgHandler) } -data BotStatus = Connected | Disconnected | Joined | Kicked | Errored | Idle | Interrupted - deriving (Show, Eq) +data BotStatus = Connected + | Disconnected + | Joined + | Kicked + | Errored + | Idle + | Interrupted + | NickNotAvailable + deriving (Show, Eq) newtype IRC a = IRC { _runIRC :: StateT BotStatus (ReaderT Bot IO) a } deriving ( Functor diff --git a/hask-irc.cabal b/hask-irc.cabal index d82033d..57627d3 100644 --- a/hask-irc.cabal +++ b/hask-irc.cabal @@ -49,7 +49,7 @@ build-type: Simple cabal-version: >=1.10 library - build-depends: base >=4.5 && <4.7, + build-depends: base >=4.5 && <4.8, text >=0.11 && <0.12, mtl >=2.1 && <2.2, network >=2.3 && <2.5, @@ -64,7 +64,8 @@ library filepath >=1.3, directory >=1.2, lifted-base >=0.2, - unix >=2.7 + unix >=2.7, + convertible >=1.1 exposed-modules: Network.IRC.Types, Network.IRC.Protocol, Network.IRC.Handlers, Network.IRC.Client @@ -85,7 +86,7 @@ executable hask-irc other-extensions: RecordWildCards, OverloadedStrings, ScopedTypeVariables, OverlappingInstances -- Other library packages from which modules are imported. - build-depends: base >=4.5 && <4.7, + build-depends: base >=4.5 && <4.8, text >=0.11 && <0.12, mtl >=2.1 && <2.2, network >=2.3 && <2.5, @@ -100,7 +101,8 @@ executable hask-irc filepath >=1.3, directory >=1.2, lifted-base >=0.2, - unix >=2.7 + unix >=2.7, + convertible >=1.1 -- Directories containing source files. -- hs-source-dirs: