From 02d1b7ab989b638a0db1b927fd2382887906e3b3 Mon Sep 17 00:00:00 2001 From: Abhinav Sarkar Date: Fri, 23 May 2014 02:45:45 +0530 Subject: [PATCH] Added nick tracking handler --- Network/IRC/Bot.hs | 10 +- Network/IRC/Handlers.hs | 30 +++--- Network/IRC/Handlers/Auth.hs | 3 - Network/IRC/Handlers/Auth/Types.hs | 4 + Network/IRC/Handlers/MessageLogger.hs | 5 +- Network/IRC/Handlers/NickTracker.hs | 125 ++++++++++++++++++++++ Network/IRC/Handlers/NickTracker/Types.hs | 40 +++++++ Network/IRC/Protocol.hs | 6 +- Network/IRC/Types.hs | 2 +- Network/IRC/Util.hs | 7 ++ hask-irc.cabal | 8 +- 11 files changed, 205 insertions(+), 35 deletions(-) create mode 100644 Network/IRC/Handlers/NickTracker.hs create mode 100644 Network/IRC/Handlers/NickTracker/Types.hs diff --git a/Network/IRC/Bot.hs b/Network/IRC/Bot.hs index 4613072..3654fa3 100644 --- a/Network/IRC/Bot.hs +++ b/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 - Nothing -> return () - Just line -> do - TF.hprint socket "{}\r\n" $ TF.Only line - infoM . unpack $ "> " ++ line + whenJust mline $ \line -> do + 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 diff --git a/Network/IRC/Handlers.hs b/Network/IRC/Handlers.hs index 2e572c0..9552e99 100644 --- a/Network/IRC/Handlers.hs +++ b/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 " mkMsgHandler botConfig eventChan name = - flip (`foldM` Nothing) [Logger.mkMsgHandler, SongSearch.mkMsgHandler, Auth.mkMsgHandler] $ \acc h -> - case acc of - Just _ -> return acc - Nothing -> h botConfig eventChan name + flip (`foldM` Nothing) [ Logger.mkMsgHandler + , SongSearch.mkMsgHandler + , Auth.mkMsgHandler + , 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 - Nothing -> return Nothing - Just greeting -> return . Just . ChannelMsgReply $ greeting ++ " " ++ userNick user +greeter ChannelMsg { .. } = + return . map (ChannelMsgReply . (++ " ") . (++ userNick user)) . find (== clean msg) $ greetings where - greetings = ["hi", "hello", "hey", "sup", "bye" - , "good morning", "good evening", "good night" - , "ohayo", "oyasumi"] + greetings = [ "hi", "hello", "hey", "sup", "bye" + , "good morning", "good evening", "good night" ] 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 - diff --git a/Network/IRC/Handlers/Auth.hs b/Network/IRC/Handlers/Auth.hs index acc0024..e02138e 100644 --- a/Network/IRC/Handlers/Auth.hs +++ b/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 diff --git a/Network/IRC/Handlers/Auth/Types.hs b/Network/IRC/Handlers/Auth/Types.hs index daa3ecd..e7cb23a 100644 --- a/Network/IRC/Handlers/Auth/Types.hs +++ b/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 diff --git a/Network/IRC/Handlers/MessageLogger.hs b/Network/IRC/Handlers/MessageLogger.hs index 5971c72..87148f9 100644 --- a/Network/IRC/Handlers/MessageLogger.hs +++ b/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 diff --git a/Network/IRC/Handlers/NickTracker.hs b/Network/IRC/Handlers/NickTracker.hs new file mode 100644 index 0000000..4f0436d --- /dev/null +++ b/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 " +mkMsgHandler _ _ _ = return Nothing diff --git a/Network/IRC/Handlers/NickTracker/Types.hs b/Network/IRC/Handlers/NickTracker/Types.hs new file mode 100644 index 0000000..d3d800e --- /dev/null +++ b/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 diff --git a/Network/IRC/Protocol.hs b/Network/IRC/Protocol.hs index 97e28ea..f64abeb 100644 --- a/Network/IRC/Protocol.hs +++ b/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 - quitMessage = drop 1 . unwords . drop 2 $ splits + message = strip . drop 1 . unwords . drop 3 $ splits + quitMessage = strip . drop 1 . unwords . drop 2 $ splits user = uncurry User . break (== '!') $ source mode = splits !! 3 modeArgs = drop 4 splits diff --git a/Network/IRC/Types.hs b/Network/IRC/Types.hs index 996113b..15c86fc 100644 --- a/Network/IRC/Types.hs +++ b/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 } diff --git a/Network/IRC/Util.hs b/Network/IRC/Util.hs index ad83942..c3b78ca 100644 --- a/Network/IRC/Util.hs +++ b/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 diff --git a/hask-irc.cabal b/hask-irc.cabal index 7d84628..7f88bfd 100644 --- a/hask-irc.cabal +++ b/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,