abhin4v/hask-irc
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Added support for new messages and commands

Browse Source 
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
This commit is contained in:
Abhinav Sarkar 2014-05-20 00:05:06 +05:30
parent 8a83053dee
commit 8659c5f755
6 changed files with 145 additions and 109 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

65
Network/IRC/Client.hs
View File

@ -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

33
Network/IRC/Handlers.hs
View File

@ -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

53
Network/IRC/Handlers/MessageLogger.hs
View File

@ -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

44
Network/IRC/Protocol.hs
View File

@ -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

49
Network/IRC/Types.hs
View File

@ -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

10
hask-irc.cabal
View File

@ -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: