Added nick tracking handler

Network/IRC/Bot.hs

@@ -55,11 +55,9 @@ sendCommandLoop (commandChan, latch) bot@Bot { .. } = do
   let mline = lineFromCommand botConfig cmd
   handle (\(e :: SomeException) ->
             errorM ("Error while writing to connection: " ++ show e) >> latchIt latch) $ do
-    case mline of
+    whenJust mline $ \line -> do
-      Nothing   -> return ()
+      TF.hprint socket "{}\r\n" $ TF.Only line
-      Just line -> do
+      infoM . unpack $ "> " ++ line
-        TF.hprint socket "{}\r\n" $ TF.Only line
-        infoM . unpack $ "> " ++ line
     case cmd of
       QuitCmd -> latchIt latch
       _       -> sendCommandLoop (commandChan, latch) bot
@@ -132,7 +130,7 @@ messageProcessLoop lineChan commandChan !idleFor = do
         handle (\(e :: SomeException) ->
                   errorM $ "Exception while processing message: " ++ show e) $ do
           mCmd <- handleMessage msgHandler botConfig message
-          maybe (return ()) (sendCommand commandChan) mCmd
+          whenJust mCmd (sendCommand commandChan)
 
 eventProcessLoop :: Channel SomeEvent -> Chan Line -> Chan Command -> Bot -> IO ()
 eventProcessLoop (eventChan, latch) lineChan commandChan bot@Bot {.. } = do

Network/IRC/Handlers.hs

@@ -8,20 +8,17 @@ module Network.IRC.Handlers (coreMsgHandlerNames, mkMsgHandler) where
 import qualified Network.IRC.Handlers.MessageLogger as Logger
 import qualified Network.IRC.Handlers.SongSearch    as SongSearch
 import qualified Network.IRC.Handlers.Auth          as Auth
+import qualified Network.IRC.Handlers.NickTracker   as NickTracker
 
 import ClassyPrelude
 import Control.Concurrent.Lifted  (Chan)
 import Control.Monad.Reader       (ask)
 import Data.Convertible           (convert)
-import Data.Text                  (strip)
 import Data.Time                  (addUTCTime)
 
 import Network.IRC.Types
 import Network.IRC.Util
 
-clean :: Text -> Text
-clean = toLower . strip
-
 coreMsgHandlerNames :: [Text]
 coreMsgHandlerNames = ["pingpong", "messagelogger", "help"]
 
@@ -32,15 +29,19 @@ mkMsgHandler _ _ "pingpong" = do
   state <- getCurrentTime >>= newIORef
   return . Just $ newMsgHandler { onMessage = pingPong state }
 mkMsgHandler _ _ "help"     =
-    return . Just $ newMsgHandler { onMessage = help, onHelp = return $ singletonMap "!help" helpMsg}
+    return . Just $ newMsgHandler { onMessage = help,
+                                    onHelp    = return $ singletonMap "!help" helpMsg }
   where
     helpMsg = "Get help. !help or !help <command>"
 
 mkMsgHandler botConfig eventChan name =
-  flip (`foldM` Nothing) [Logger.mkMsgHandler, SongSearch.mkMsgHandler, Auth.mkMsgHandler] $ \acc h ->
+  flip (`foldM` Nothing) [ Logger.mkMsgHandler
-    case acc of
+                         , SongSearch.mkMsgHandler
-      Just _  -> return acc
+                         , Auth.mkMsgHandler
-      Nothing -> h botConfig eventChan name
+                         , NickTracker.mkMsgHandler ]
+    $ \acc h -> case acc of
+                  Just _  -> return acc
+                  Nothing -> h botConfig eventChan name
 
 pingPong :: MonadMsgHandler m => IORef UTCTime -> Message -> m (Maybe Command)
 pingPong state PingMsg { .. } = do
@@ -60,13 +61,11 @@ pingPong state IdleMsg { .. } | even (convert msgTime :: Int) = do
 pingPong _ _          = return Nothing
 
 greeter ::  MonadMsgHandler m => Message -> m (Maybe Command)
-greeter ChannelMsg { .. } = case find (== clean msg) greetings of
+greeter ChannelMsg { .. } =
-    Nothing       -> return Nothing
+  return . map (ChannelMsgReply . (++ " ") . (++ userNick user)) . find (== clean msg) $ greetings
-    Just greeting -> return . Just . ChannelMsgReply $ greeting ++ " " ++ userNick user
   where
-    greetings = ["hi", "hello", "hey", "sup", "bye"
+    greetings = [ "hi", "hello", "hey", "sup", "bye"
-                , "good morning", "good evening", "good night"
+                , "good morning", "good evening", "good night" ]
-                , "ohayo", "oyasumi"]
 greeter _ = return Nothing
 
 welcomer :: MonadMsgHandler m => Message -> m (Maybe Command)
@@ -91,4 +90,3 @@ help ChannelMsg { .. }
       return . Just . ChannelMsgReply $ maybe ("No such command found: " ++ command) snd mHelp
 
 help _ = return Nothing
-

Network/IRC/Handlers/Auth.hs

@@ -18,15 +18,12 @@ import Control.Monad.State       (get, put)
 import Data.Acid                 (AcidState, Query, Update, makeAcidic, query, update,
                                   openLocalState, createArchive)
 import Data.Acid.Local           (createCheckpointAndClose)
-import Data.SafeCopy             (base, deriveSafeCopy)
 
 import Network.IRC.Handlers.Auth.Types
 import Network.IRC.Types
 
 -- database
 
-$(deriveSafeCopy 0 'base ''Auth)
-
 getToken :: Nick -> Query Auth (Maybe Token)
 getToken user = lookup user <$> asks auth
 

Network/IRC/Handlers/Auth/Types.hs

@@ -1,10 +1,12 @@
 {-# LANGUAGE DeriveDataTypeable #-}
 {-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE TemplateHaskell #-}
 
 module Network.IRC.Handlers.Auth.Types where
 
 import ClassyPrelude
 import Data.Data (Data)
+import Data.SafeCopy             (base, deriveSafeCopy)
 
 import Network.IRC.Types hiding (user)
 
@@ -14,6 +16,8 @@ newtype Auth = Auth { auth :: Map Nick Token } deriving (Eq, Show, Data, Typeabl
 emptyAuth :: Auth
 emptyAuth = Auth mempty
 
+$(deriveSafeCopy 0 'base ''Auth)
+
 data AuthEvent = AuthEvent Nick Token (MVar Bool) deriving (Typeable)
 
 instance Event AuthEvent

Network/IRC/Handlers/MessageLogger.hs

@@ -20,6 +20,7 @@ import System.FilePath           (FilePath, (</>), (<.>))
 import System.IO                 (openFile, IOMode(..), hSetBuffering, BufferMode(..))
 
 import Network.IRC.Types
+import Network.IRC.Util
 
 type LoggerState = Maybe (Handle, Day)
 
@@ -51,7 +52,7 @@ initMessageLogger botConfig state = do
   atomicWriteIORef state $ Just (logFileHandle, utctDay time)
 
 exitMessageLogger :: MonadMsgHandler m => IORef LoggerState -> m ()
-exitMessageLogger state = liftIO $ readIORef state >>= maybe (return ()) (hClose . fst)
+exitMessageLogger state = liftIO $ readIORef state >>= flip whenJust (hClose . fst)
 
 withLogFile :: MonadMsgHandler m => (Handle -> IO ()) -> IORef LoggerState -> m (Maybe Command)
 withLogFile action state = do
@@ -83,7 +84,7 @@ messageLogger message = case message of
   JoinMsg { .. }    -> log "** {} JOINED"             [userNick user]
   PartMsg { .. }    -> log "** {} PARTED :{}"         [userNick user, msg]
   QuitMsg { .. }    -> log "** {} QUIT :{}"           [userNick user, msg]
-  NickMsg { .. }    -> log "** {} CHANGED NICK TO {}" [userNick user, nick]
+  NickMsg { .. }    -> log "** {} CHANGED NICK TO {}" [userNick user, newNick]
   NamesMsg { .. }   -> log "** USERS {}"              [unwords nicks]
   _                 -> const $ return Nothing
   where

Network/IRC/Handlers/NickTracker.hs

@@ -0,0 +1,125 @@
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeFamilies #-}
+
+module Network.IRC.Handlers.NickTracker (mkMsgHandler) where
+
+import qualified Data.IxSet as IS
+import qualified Data.UUID as U
+import qualified Data.UUID.V4 as U
+
+import ClassyPrelude
+import Control.Concurrent.Lifted (Chan)
+import Control.Monad.Reader      (ask)
+import Control.Monad.State       (get, put)
+import Data.Acid                 (AcidState, Query, Update, makeAcidic, query, update,
+                                  openLocalState, createArchive)
+import Data.Acid.Local           (createCheckpointAndClose)
+import Data.IxSet                (getOne, (@=))
+
+import Network.IRC.Handlers.NickTracker.Types
+import Network.IRC.Types hiding (Nick)
+import Network.IRC.Util
+
+getByNick :: Nick -> Query NickTracking (Maybe NickTrack)
+getByNick nick = do
+  NickTracking { .. } <- ask
+  return . getOne $ nickTracking @= nick
+
+getByCanonicalNick :: CanonicalNick -> Query NickTracking [NickTrack]
+getByCanonicalNick canonicalNick = do
+  NickTracking { .. } <- ask
+  return . IS.toList $ nickTracking @= canonicalNick
+
+--getLastSeenOn :: CanonicalNick -> Query NickTracking LastSeenOn
+--getLastSeenOn = liftM (minimumEx . map lastSeenOn) . getByCanonicalNick
+
+saveNickTrack :: NickTrack -> Update NickTracking ()
+saveNickTrack nt = do
+  NickTracking { .. } <- get
+  put . NickTracking $ IS.updateIx (nick nt) nt nickTracking
+
+$(makeAcidic ''NickTracking ['getByNick, 'getByCanonicalNick, 'saveNickTrack])
+
+nickTrackerMsg :: MonadMsgHandler m => IORef (AcidState NickTracking) -> Message ->  m (Maybe Command)
+nickTrackerMsg state = go
+  where
+    go ChannelMsg { .. } = updateNickTrack user msg msgTime True  >> handleCommands msg
+    go ActionMsg { .. }  = updateNickTrack user msg msgTime True  >> return Nothing
+    go JoinMsg { .. }    = updateNickTrack user "" msgTime False  >> return Nothing
+    go PartMsg { .. }    = updateNickTrack user msg msgTime False >> return Nothing
+    go QuitMsg { .. }    = updateNickTrack user msg msgTime False >> return Nothing
+    go NickMsg { .. }    = handleNickChange user newNick msgTime  >> return Nothing
+    go _                 = return Nothing
+
+    updateNickTrack user message msgTime isChat = liftIO $ do
+      acid <- readIORef state
+      let nck = userNick user
+      mnt <- query acid . GetByNick $ Nick nck
+      (message', cn) <- case (message, mnt) of
+        ("", Just (NickTrack { .. })) -> return (lastMessage, canonicalNick)
+        (_, Just (NickTrack { .. }))  -> return (message, canonicalNick)
+        _                             -> do
+         cn <- map (CanonicalNick . pack . U.toString) U.nextRandom
+         return (message, cn)
+      let lastMessageOn' = case (isChat, mnt) of
+                             (True, _)                        -> msgTime
+                             (False, Just (NickTrack { .. })) -> lastMessageOn
+                             (False, Nothing)                 -> msgTime
+
+      update acid . SaveNickTrack $
+        NickTrack (Nick nck) cn (LastSeenOn msgTime) lastMessageOn' message'
+
+    handleNickChange user newNick msgTime = liftIO $ do
+      acid <- readIORef state
+      let prevNick = userNick user
+      mpnt <- query acid . GetByNick $ Nick prevNick
+      mnt  <- query acid . GetByNick $ Nick newNick
+      mInfo <- case (mpnt, mnt) of
+        (Nothing, _)       -> do
+          cn <- map (CanonicalNick . pack . U.toString) U.nextRandom
+          return $ Just ("", cn, msgTime)
+        (Just nt, Nothing) -> return $ Just (lastMessage nt, canonicalNick nt, lastMessageOn nt)
+        _                  -> return Nothing
+      whenJust mInfo $ \(message, cn, lastMessageOn') ->
+        update acid . SaveNickTrack $
+          NickTrack (Nick newNick) cn (LastSeenOn msgTime) lastMessageOn' message
+
+    handleCommands message =
+      if "!nick" `isPrefixOf` message
+        then handleNickCommand state message
+        else return Nothing
+
+handleNickCommand :: MonadMsgHandler m => IORef(AcidState NickTracking) -> Text -> m (Maybe Command)
+handleNickCommand state msg = liftIO $ do
+  acid <- readIORef state
+  let nck = clean . unwords . drop 1 . words $ msg
+  mcn <- liftM (map canonicalNick) . query acid . GetByNick $ Nick nck
+  resp <- case mcn of
+    Nothing -> return $ "Unknown nick: " ++ nck
+    Just cn -> liftIO $ do
+      nicks <- liftM (map ((\(Nick n) -> n) . nick)) . query acid . GetByCanonicalNick $ cn
+      if length nicks == 1
+        then return $ nck ++ " has only one nick"
+        else return $ nck ++ "'s other nicks are: " ++ intercalate ", " (filter (/= nck) nicks)
+  return . Just . ChannelMsgReply $ resp
+
+stopNickTracker :: MonadMsgHandler m => IORef (AcidState NickTracking) -> m ()
+stopNickTracker state = liftIO $ do
+  acid <- readIORef state
+  createArchive acid
+  createCheckpointAndClose acid
+
+mkMsgHandler :: BotConfig -> Chan SomeEvent -> MsgHandlerName -> IO (Maybe MsgHandler)
+mkMsgHandler BotConfig { .. } _ "nicktracker" = do
+  state <- liftIO (openLocalState emptyNickTracking >>= newIORef)
+  return . Just $ newMsgHandler { onMessage = nickTrackerMsg state
+                                , onStop    = stopNickTracker state
+                                , onHelp    = return $ singletonMap "!nick" helpMsg }
+  where
+    helpMsg = "Shows the user's other nicks. !nick <user nick>"
+mkMsgHandler _ _ _                     = return Nothing

Network/IRC/Handlers/NickTracker/Types.hs

@@ -0,0 +1,40 @@
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE TemplateHaskell #-}
+
+module Network.IRC.Handlers.NickTracker.Types where
+
+import ClassyPrelude
+import Data.Data (Data)
+import Data.IxSet (IxSet, Indexable (..), ixSet, ixFun)
+import Data.SafeCopy             (base, deriveSafeCopy)
+
+newtype Nick = Nick Text deriving (Eq, Ord, Show, Data, Typeable)
+newtype CanonicalNick = CanonicalNick Text deriving (Eq, Ord, Show, Data, Typeable)
+newtype LastSeenOn = LastSeenOn UTCTime deriving (Eq, Ord, Show, Data, Typeable)
+
+data NickTrack = NickTrack {
+  nick :: Nick,
+  canonicalNick :: CanonicalNick,
+  lastSeenOn    :: LastSeenOn,
+  lastMessageOn :: UTCTime,
+  lastMessage   :: Text
+} deriving (Eq, Ord, Show, Data, Typeable)
+
+instance Indexable NickTrack where
+  empty = ixSet [ ixFun $ (: []) . nick
+                , ixFun $ (: []) . canonicalNick
+                , ixFun $ (: []) . lastSeenOn ]
+
+$(deriveSafeCopy 0 'base ''Nick)
+$(deriveSafeCopy 0 'base ''CanonicalNick)
+$(deriveSafeCopy 0 'base ''LastSeenOn)
+$(deriveSafeCopy 0 'base ''NickTrack)
+
+newtype NickTracking = NickTracking { nickTracking :: IxSet NickTrack }
+                       deriving (Eq, Ord, Show, Data, Typeable)
+
+$(deriveSafeCopy 0 'base ''NickTracking)
+
+emptyNickTracking :: NickTracking
+emptyNickTracking = NickTracking empty

Network/IRC/Protocol.hs

@@ -6,7 +6,7 @@ module Network.IRC.Protocol (msgFromLine, lineFromCommand) where
 
 import ClassyPrelude
 import Data.List ((!!))
-import Data.Text (split)
+import Data.Text (split, strip)
 
 import Network.IRC.Types
 
@@ -36,8 +36,8 @@ msgFromLine (BotConfig { .. }) time line
     source          = drop 1 . takeWhile isNotSpc $ line
     target          = splits !! 2
     command         = splits !! 1
-    message         = drop 1 . unwords . drop 3 $ splits
+    message         = strip . drop 1 . unwords . drop 3 $ splits
-    quitMessage     = drop 1 . unwords . drop 2 $ splits
+    quitMessage     = strip . drop 1 . unwords . drop 2 $ splits
     user            = uncurry User . break (== '!') $ source
     mode            = splits !! 3
     modeArgs        = drop 4 splits

Network/IRC/Types.hs

@@ -58,7 +58,7 @@ data Message =
   | 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 }
+  | NickMsg      { msgTime  :: !UTCTime, user    :: !User, newNick     :: !Nick, msgLine :: !Text }
   | NickInUseMsg { msgTime  :: !UTCTime, msgLine :: !Text }
   | KickMsg      { msgTime  :: !UTCTime, user    :: !User, kickedNick  :: !Nick, msg     :: !Text
                  , msgLine  :: !Text }

Network/IRC/Util.hs

@@ -9,6 +9,7 @@ module Network.IRC.Util where
 
 import ClassyPrelude
 import Control.Concurrent.Lifted (Chan)
+import Data.Text                 (strip)
 
 oneSec :: Int
 oneSec = 1000000
@@ -28,3 +29,9 @@ mapKeys   = map fst . mapToList
 
 mapValues :: IsMap map => map -> [MapValue map]
 mapValues = map snd . mapToList
+
+whenJust :: Monad m => Maybe t -> (t -> m ()) -> m ()
+whenJust m f = maybe (return ()) f m
+
+clean :: Text -> Text
+clean = toLower . strip

hask-irc.cabal

@@ -55,14 +55,14 @@ library
                        text              >=0.11 && <0.12,
                        mtl               >=2.1 && <2.2,
                        network           >=2.3 && <2.5,
-                       configurator      >= 0.2,
+                       configurator      >=0.2,
                        time              >=1.4.0,
                        curl-aeson        ==0.0.3,
                        aeson             >=0.6.0.0,
                        HTTP              >=4000,
                        transformers      >=0.3,
                        classy-prelude    ==0.9.1,
-                       text-format       >= 0.3.1,
+                       text-format       >=0.3.1,
                        filepath          >=1.3,
                        directory         >=1.2,
                        lifted-base       >=0.2,
@@ -98,14 +98,14 @@ executable hask-irc
                        text              >=0.11 && <0.12,
                        mtl               >=2.1 && <2.2,
                        network           >=2.3 && <2.5,
-                       configurator      >= 0.2,
+                       configurator      >=0.2,
                        time              >=1.4.0,
                        curl-aeson        ==0.0.3,
                        aeson             >=0.6.0.0,
                        HTTP              >=4000,
                        transformers      >=0.3,
                        classy-prelude    ==0.9.1,
-                       text-format       >= 0.3.1,
+                       text-format       >=0.3.1,
                        filepath          >=1.3,
                        directory         >=1.2,
                        lifted-base       >=0.2,