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

@@ -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
+    QuitCmd -> latchIt latch
-    Cmd command -> do
+    _       -> sendCommandLoop (commandChan, latch) bot
-      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
 
-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 :: Chan Line -> Chan Command -> Int -> IRC ()
-listenerLoop lineChan commandChan idleFor = do
+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
+          Timeout      -> getCurrentTime >>= dispatchHandlers bot . IdleMsg  >> return Idle
-          EOF          -> return Disconnected
+          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)
+    Idle             -> listenerLoop lineChan commandChan (idleFor + oneSec)
-    Disconnected -> return ()
+    Disconnected     -> return ()
-    _            -> listenerLoop lineChan commandChan 0
+    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
+    Disconnected     -> debug "Restarting .." >> run botConfig
-    Interrupted  -> return ()
+    Interrupted      -> return ()
-    Errored      -> debug "Errored, restarting" >> run botConfig
+    NickNotAvailable -> return ()
-    _            -> error "Unsupported status"
+    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 NickCmd
-          sendCommand commandChan (Cmd UserCmd)
+          sendCommand commandChan UserCmd
 
           fork $ sendCommandLoop (commandChan, sendLatch) bot
           fork $ readLineLoop mvBotStatus (lineChan, readLatch) bot oneSec

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 _ "greeter"    = return . Just $ newMsgHandler { msgHandlerRun = greeter }
-mkMsgHandler _ "welcomer" = return . Just $ newMsgHandler { msgHandlerRun = welcomer }
+mkMsgHandler _ "welcomer"   = return . Just $ newMsgHandler { msgHandlerRun = welcomer }
-mkMsgHandler _ "pingpong" = return . Just $ newMsgHandler { msgHandlerRun = pingPong }
+
-mkMsgHandler botConfig name       =
+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 :: MonadMsgHandler m => IORef UTCTime -> Message -> m (Maybe Command)
-pingPong Ping { .. } = return . Just $ Pong msg
+pingPong state PingMsg { .. } = do
-pingPong _           = return Nothing
+  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

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)
+        mask_ $ do
-        removeFile logFilePath
+          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 ->
+messageLogger message = go message
-  TF.hprint logFile "[{}] {}: {}\n" $ TF.buildParams (fmtTime msgTime, userNick user, msg)
+  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 ->
+    log format args = withLogFile $ \logFile ->
-  TF.hprint logFile "[{}] {}: {} {}\n" $
+      TF.hprint logFile ("[{}] " ++ format ++ "\n") $ TF.buildParams (fmtTime (msgTime message) : args)
-    TF.buildParams (fmtTime msgTime, userNick user, userNick user, msg)
 
-messageLogger KickMsg { .. } = withLogFile $ \logFile ->
+    fmtTime = pack . formatTime defaultTimeLocale "%F %T"
-  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)
 
 --messageLogger IdleMsg = const . liftIO $ do
 --  now <- getCurrentTime
 --  return . Just . MessageCmd $
-
-messageLogger _ = const $ return Nothing

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          = (== ' ')
+    isSpc           = (== ' ')
-    isNotSpc       = not . isSpc
+    isNotSpc        = not . isSpc
-    splits         = split isSpc line
+    splits          = split isSpc line
-    source         = drop 1 . takeWhile isNotSpc $ line
+    source          = drop 1 . takeWhile isNotSpc $ line
-    target         = splits !! 2
+    target          = splits !! 2
-    command        = splits !! 1
+    command         = splits !! 1
-    message        = drop 1 . unwords . drop 3 $ splits
+    message         = drop 1 . unwords . drop 3 $ splits
-    quitMessage    = drop 1 . unwords . drop 2 $ splits
+    quitMessage     = drop 1 . unwords . drop 2 $ splits
-    user           = uncurry User . break (== '!') $ source
+    user            = uncurry User . break (== '!') $ source
-    mode           = splits !! 3
+    mode            = splits !! 3
-    modeArgs       = drop 4 splits
+    modeArgs        = drop 4 splits
-    kicked         = splits !! 3
+    kicked          = splits !! 3
-    kickReason     = drop 1 . unwords . drop 4 $ splits
+    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
+lineFromCommand (BotConfig { .. }) command = case command of
-  Pong { .. }                     -> "PONG :" ++ rmsg
+  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

Network/IRC/Types.hs

@@ -26,30 +26,36 @@ data User = Self | User { userNick :: !Nick, userServer :: !Text }
             deriving (Show, Eq)
 
 data Message =
-    IdleMsg
+    IdleMsg      { msgTime  :: !UTCTime}
-  | ChannelMsg { msgTime  :: !UTCTime, user   :: !User, msg         :: !Text, msgLine :: !Text }
+  | PingMsg      { msgTime  :: !UTCTime, msg     :: !Text, msgLine     :: !Text }
-  | PrivMsg    { msgTime  :: !UTCTime, user   :: !User, msg         :: !Text, msgLine :: !Text }
+  | PongMsg      { msgTime  :: !UTCTime, msg     :: !Text, msgLine     :: !Text }
-  | ActionMsg  { msgTime  :: !UTCTime, user   :: !User, msg         :: !Text, msgLine :: !Text }
+  | ChannelMsg   { msgTime  :: !UTCTime, user    :: !User, msg         :: !Text, msgLine :: !Text }
-  | Ping       { msgTime  :: !UTCTime, msg    :: !Text, msgLine     :: !Text }
+  | PrivMsg      { msgTime  :: !UTCTime, user    :: !User, msg         :: !Text, msgLine :: !Text }
-  | JoinMsg    { msgTime  :: !UTCTime, user   :: !User, msgLine     :: !Text }
+  | ActionMsg    { msgTime  :: !UTCTime, user    :: !User, msg         :: !Text, msgLine :: !Text }
-  | QuitMsg    { msgTime  :: !UTCTime, user   :: !User, msg         :: !Text, msgLine :: !Text }
+  | JoinMsg      { msgTime  :: !UTCTime, user    :: !User, msgLine     :: !Text }
-  | PartMsg    { msgTime  :: !UTCTime, user   :: !User, msg         :: !Text, msgLine :: !Text }
+  | QuitMsg      { msgTime  :: !UTCTime, user    :: !User, msg         :: !Text, msgLine :: !Text }
-  | ModeMsg    { msgTime  :: !UTCTime, user   :: !User, target      :: !Text, mode    :: !Text
+  | PartMsg      { msgTime  :: !UTCTime, user    :: !User, msg         :: !Text, msgLine :: !Text }
-               , modeArgs :: ![Text], msgLine :: !Text }
+  | NickMsg      { msgTime  :: !UTCTime, user    :: !User, nick        :: !Nick, msgLine :: !Text }
-  | NickMsg    { msgTime  :: !UTCTime, user   :: !User, nick        :: !Text, msgLine :: !Text }
+  | NickInUseMsg { msgTime  :: !UTCTime, msgLine :: !Text }
-  | KickMsg    { msgTime  :: !UTCTime, user   :: !User, kickedNick  :: !Text, msg     :: !Text
+  | KickMsg      { msgTime  :: !UTCTime, user    :: !User, kickedNick  :: !Nick, msg     :: !Text
-               , msgLine  :: !Text }
+                 , msgLine  :: !Text }
-  | OtherMsg   { msgTime  :: !UTCTime, source :: !Text, command     :: !Text, target  :: !Text
+  | ModeMsg      { msgTime  :: !UTCTime, user    :: !User, target      :: !Text, mode    :: !Text
-               , msg      :: !Text,   msgLine :: !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
+data BotStatus = Connected
-                 deriving (Show, Eq)
+               | Disconnected
+               | Joined
+               | Kicked
+               | Errored
+               | Idle
+               | Interrupted
+               | NickNotAvailable
+               deriving (Show, Eq)
 
 newtype IRC a = IRC { _runIRC :: StateT BotStatus (ReaderT Bot IO) a }
                 deriving ( Functor

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: