From 068b967e8e7128bcfd92331df281246885682b85 Mon Sep 17 00:00:00 2001 From: Abhinav Sarkar Date: Sun, 1 Jun 2014 02:11:20 +0530 Subject: [PATCH] Consolidated Nick types --- hask-irc-core/Network/IRC/Protocol.hs | 17 ++++----- hask-irc-core/Network/IRC/Types.hs | 19 +++++++--- hask-irc-core/hask-irc-core.cabal | 1 + .../Network/IRC/Handlers/Auth.hs | 2 +- .../Network/IRC/Handlers/Auth/Types.hs | 3 +- .../Network/IRC/Handlers/Greet.hs | 5 +-- .../Network/IRC/Handlers/MessageLogger.hs | 20 ++++++----- .../Network/IRC/Handlers/NickTracker.hs | 35 +++++++++++-------- .../Network/IRC/Handlers/NickTracker/Types.hs | 4 +-- hask-irc-runner/Network/IRC/Runner.hs | 14 ++++---- 10 files changed, 71 insertions(+), 49 deletions(-) diff --git a/hask-irc-core/Network/IRC/Protocol.hs b/hask-irc-core/Network/IRC/Protocol.hs index 733cac1..ce53605 100644 --- a/hask-irc-core/Network/IRC/Protocol.hs +++ b/hask-irc-core/Network/IRC/Protocol.hs @@ -49,11 +49,11 @@ lineParser BotConfig { .. } time line msgParts = flip Done msgParts . Message ti "JOIN" -> JoinMsg user "QUIT" -> QuitMsg user quitMessage "PART" -> PartMsg user message - "KICK" -> KickMsg user kicked kickReason - "MODE" -> if source == botNick + "KICK" -> KickMsg user (Nick kicked) kickReason + "MODE" -> if Nick source == botNick then ModeMsg Self target message [] else ModeMsg user target mode modeArgs - "NICK" -> NickMsg user (drop 1 target) + "NICK" -> NickMsg user $ Nick (drop 1 target) "433" -> NickInUseMsg "PRIVMSG" | target /= channel -> PrivMsg user message | isActionMsg -> ActionMsg user (initDef . drop 8 $ message) @@ -66,7 +66,7 @@ lineParser BotConfig { .. } time line msgParts = flip Done msgParts . Message ti target = splits !! 2 message = strip . drop 1 . unwords . drop 3 $ splits quitMessage = strip . drop 1 . unwords . drop 2 $ splits - user = uncurry User . second (drop 1) . break (== '!') $ source + user = uncurry User . (Nick *** drop 1) . break (== '!') $ source mode = splits !! 3 modeArgs = drop 4 splits kicked = splits !! 3 @@ -89,17 +89,18 @@ namesParser BotConfig { .. } time line msgParts = case command of where (_ : command : target : _) = words line stripNickPrefix = pack . dropWhile (`elem` ("~&@%+" :: String)) . unpack - namesNicks line' = map stripNickPrefix . words . drop 1 . unwords . drop 5 . words $ line' + namesNicks line' = + map (Nick . stripNickPrefix) . words . drop 1 . unwords . drop 5 . words $ line' lineFromCommand :: BotConfig -> Command -> Maybe Text lineFromCommand BotConfig { .. } command = case command of PongCmd { .. } -> Just $ "PONG :" ++ rmsg PingCmd { .. } -> Just $ "PING :" ++ rmsg - NickCmd -> Just $ "NICK " ++ botNick - UserCmd -> Just $ "USER " ++ botNick ++ " 0 * :" ++ botNick + NickCmd -> Just $ "NICK " ++ nickToText botNick + UserCmd -> Just $ "USER " ++ nickToText botNick ++ " 0 * :" ++ nickToText botNick JoinCmd -> Just $ "JOIN " ++ channel QuitCmd -> Just "QUIT" ChannelMsgReply { .. } -> Just $ "PRIVMSG " ++ channel ++ " :" ++ rmsg - PrivMsgReply (User { .. }) rmsg -> Just $ "PRIVMSG " ++ userNick ++ " :" ++ rmsg + PrivMsgReply (User { .. }) rmsg -> Just $ "PRIVMSG " ++ nickToText userNick ++ " :" ++ rmsg NamesCmd -> Just $ "NAMES " ++ channel _ -> Nothing diff --git a/hask-irc-core/Network/IRC/Types.hs b/hask-irc-core/Network/IRC/Types.hs index 6f3e93b..5e02e76 100644 --- a/hask-irc-core/Network/IRC/Types.hs +++ b/hask-irc-core/Network/IRC/Types.hs @@ -1,10 +1,12 @@ +{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TemplateHaskell #-} module Network.IRC.Types - ( Nick + ( Nick (..) , MsgHandlerName , User (..) , Message (..) @@ -33,14 +35,21 @@ import Control.Monad.Base (MonadBase) import Control.Monad.Reader (ReaderT, MonadReader, runReaderT) import Control.Monad.State (StateT, MonadState, execStateT) import Data.Configurator.Types (Config) +import Data.Data (Data) +import Data.SafeCopy (base, deriveSafeCopy) import Data.Typeable (cast) import Network.IRC.Util -- IRC related -type Nick = Text -type MsgHandlerName = Text +newtype Nick = Nick { nickToText :: Text } + deriving (Eq, Ord, Data, Typeable, Hashable) + +instance Show Nick where + show = unpack . nickToText + +$(deriveSafeCopy 0 'base ''Nick) data User = Self | User { userNick :: !Nick, userServer :: !Text } deriving (Show, Eq) @@ -104,10 +113,12 @@ data EventResponse = RespNothing -- Bot +type MsgHandlerName = Text + data BotConfig = BotConfig { server :: !Text , port :: !Int , channel :: !Text - , botNick :: !Text + , botNick :: !Nick , botTimeout :: !Int , msgHandlerInfo :: !(Map MsgHandlerName (Map Text Text)) , config :: !Config } diff --git a/hask-irc-core/hask-irc-core.cabal b/hask-irc-core/hask-irc-core.cabal index e6ede76..19dd353 100644 --- a/hask-irc-core/hask-irc-core.cabal +++ b/hask-irc-core/hask-irc-core.cabal @@ -57,6 +57,7 @@ library text >=0.11 && <0.12, mtl >=2.1 && <2.2, configurator >=0.2 && <0.3, + safecopy >=0.8 && <0.9, time >=1.4 && <1.5, classy-prelude >=0.9 && <1.0, text-format >=0.3 && <0.4, diff --git a/hask-irc-handlers/Network/IRC/Handlers/Auth.hs b/hask-irc-handlers/Network/IRC/Handlers/Auth.hs index f56a279..f12cbc7 100644 --- a/hask-irc-handlers/Network/IRC/Handlers/Auth.hs +++ b/hask-irc-handlers/Network/IRC/Handlers/Auth.hs @@ -74,5 +74,5 @@ mkMsgHandler BotConfig { .. } _ "auth" = do , onStop = stopAuth state , onHelp = return $ singletonMap "token" helpMsg } where - helpMsg = "Send a PM to get a new auth token. /msg " ++ botNick ++ " token" + helpMsg = "Send a PM to get a new auth token. /msg " ++ nickToText botNick ++ " token" mkMsgHandler _ _ _ = return Nothing diff --git a/hask-irc-handlers/Network/IRC/Handlers/Auth/Types.hs b/hask-irc-handlers/Network/IRC/Handlers/Auth/Types.hs index c961101..265d1b1 100644 --- a/hask-irc-handlers/Network/IRC/Handlers/Auth/Types.hs +++ b/hask-irc-handlers/Network/IRC/Handlers/Auth/Types.hs @@ -23,4 +23,5 @@ data AuthEvent = AuthEvent Nick Token (MVar Bool) deriving (Typeable) instance Event AuthEvent instance Show AuthEvent where - show (AuthEvent user token _) = "AuthEvent[" ++ unpack user ++ ", " ++ unpack token ++ "]" + show (AuthEvent nick token _) = + "AuthEvent[" ++ unpack (nickToText nick) ++ ", " ++ unpack token ++ "]" diff --git a/hask-irc-handlers/Network/IRC/Handlers/Greet.hs b/hask-irc-handlers/Network/IRC/Handlers/Greet.hs index 833135c..2ca7f68 100644 --- a/hask-irc-handlers/Network/IRC/Handlers/Greet.hs +++ b/hask-irc-handlers/Network/IRC/Handlers/Greet.hs @@ -14,7 +14,8 @@ mkMsgHandler _ _ _ = return Nothing greeter :: MonadMsgHandler m => Message -> m (Maybe Command) greeter Message { msgDetails = ChannelMsg { .. }, .. } = - return . map (ChannelMsgReply . (++ userNick user) . (++ " ")) . find (== clean msg) $ greetings + return . map (ChannelMsgReply . (++ nickToText (userNick user)) . (++ " ")) + . find (== clean msg) $ greetings where greetings = [ "hi", "hello", "hey", "sup", "bye" , "good morning", "good evening", "good night" ] @@ -24,7 +25,7 @@ welcomer :: MonadMsgHandler m => Message -> m (Maybe Command) welcomer Message { msgDetails = JoinMsg { .. }, .. } = do BotConfig { .. } <- ask if userNick user /= botNick - then return . Just . ChannelMsgReply $ "welcome back " ++ userNick user + then return . Just . ChannelMsgReply $ "welcome back " ++ nickToText (userNick user) else return Nothing welcomer _ = return Nothing diff --git a/hask-irc-handlers/Network/IRC/Handlers/MessageLogger.hs b/hask-irc-handlers/Network/IRC/Handlers/MessageLogger.hs index 8224d74..3a45d58 100644 --- a/hask-irc-handlers/Network/IRC/Handlers/MessageLogger.hs +++ b/hask-irc-handlers/Network/IRC/Handlers/MessageLogger.hs @@ -32,7 +32,7 @@ getLogFilePath :: BotConfig -> IO FilePath getLogFilePath BotConfig { .. } = do logFileDir <- C.require config "messagelogger.logdir" createDirectoryIfMissing True logFileDir - return $ logFileDir unpack (channel ++ "-" ++ botNick) <.> "log" + return $ logFileDir unpack (channel ++ "-" ++ nickToText botNick) <.> "log" openLogFile :: FilePath -> IO Handle openLogFile logFilePath = do @@ -74,16 +74,18 @@ withLogFile action state = do messageLogger :: MonadMsgHandler m => Message -> IORef LoggerState -> m (Maybe Command) messageLogger Message { .. } = case msgDetails of - ChannelMsg { .. } -> log "<{}> {}" [userNick user, msg] - ActionMsg { .. } -> log "<{}> {} {}" [userNick user, userNick user, msg] - KickMsg { .. } -> log "** {} KICKED {} :{}" [userNick user, kickedNick, msg] - JoinMsg { .. } -> log "** {} JOINED" [userNick user] - PartMsg { .. } -> log "** {} PARTED :{}" [userNick user, msg] - QuitMsg { .. } -> log "** {} QUIT :{}" [userNick user, msg] - NickMsg { .. } -> log "** {} CHANGED NICK TO {}" [userNick user, newNick] - NamesMsg { .. } -> log "** USERS {}" [unwords nicks] + ChannelMsg { .. } -> log "<{}> {}" [nick user, msg] + ActionMsg { .. } -> log "<{}> {} {}" [nick user, nick user, msg] + KickMsg { .. } -> log "** {} KICKED {} :{}" [nick user, nickToText kickedNick, msg] + JoinMsg { .. } -> log "** {} JOINED" [nick user] + PartMsg { .. } -> log "** {} PARTED :{}" [nick user, msg] + QuitMsg { .. } -> log "** {} QUIT :{}" [nick user, msg] + NickMsg { .. } -> log "** {} CHANGED NICK TO {}" [nick user, nickToText newNick] + NamesMsg { .. } -> log "** USERS {}" [unwords . map nickToText $ nicks] _ -> const $ return Nothing where + nick = nickToText . userNick + log format args = withLogFile $ \logFile -> TF.hprint logFile ("[{}] " ++ format ++ "\n") $ TF.buildParams (fmtTime msgTime : args) diff --git a/hask-irc-handlers/Network/IRC/Handlers/NickTracker.hs b/hask-irc-handlers/Network/IRC/Handlers/NickTracker.hs index 08b77f4..f2ec879 100644 --- a/hask-irc-handlers/Network/IRC/Handlers/NickTracker.hs +++ b/hask-irc-handlers/Network/IRC/Handlers/NickTracker.hs @@ -20,9 +20,11 @@ import Data.IxSet (getOne, (@=)) import Data.Time (addUTCTime, NominalDiffTime) import Network.IRC.Handlers.NickTracker.Types -import Network.IRC.Types hiding (Nick) +import Network.IRC.Types import Network.IRC.Util +-- database + getByNickQ :: Nick -> Query NickTracking (Maybe NickTrack) getByNickQ nick = do NickTracking { .. } <- ask @@ -40,12 +42,14 @@ saveNickTrackQ nt = do $(makeAcidic ''NickTracking ['getByNickQ, 'getByCanonicalNickQ, 'saveNickTrackQ]) -getByNick :: AcidState NickTracking -> Text -> IO (Maybe NickTrack) -getByNick acid = query acid . GetByNickQ . Nick +getByNick :: AcidState NickTracking -> Nick -> IO (Maybe NickTrack) +getByNick acid = query acid . GetByNickQ saveNickTrack :: AcidState NickTracking -> NickTrack -> IO () saveNickTrack acid = update acid . SaveNickTrackQ +-- handler + data NickTrackingState = NickTrackingState { acid :: AcidState NickTracking , refreshInterval :: NominalDiffTime , onlineNicks :: HashSet Nick @@ -73,14 +77,14 @@ nickTrackerMsg state message@Message { .. } = case msgDetails of updateRefreshTime = atomicModIORef state $ \ s -> s { lastRefreshOn = msgTime } modifyOnlineNicks f = atomicModIORef state $ \s -> s { onlineNicks = f . onlineNicks $ s } - add = modifyOnlineNicks . flip ((. (Nick . userNick)) . flip insertSet) - remove = modifyOnlineNicks . flip ((. (Nick . userNick)) . flip deleteSet) + add = modifyOnlineNicks . flip ((. userNick) . flip insertSet) + remove = modifyOnlineNicks . flip ((. userNick) . flip deleteSet) swap users = modifyOnlineNicks $ - let (oNick, nNick) = both (Nick . userNick) users + let (oNick, nNick) = both userNick users in deleteSet oNick . insertSet nNick - refresh = modifyOnlineNicks . const . setFromList . map Nick + refresh = modifyOnlineNicks . const . setFromList - commands = [ ("!nick", handleNickCommand) + commands = [ ("!nicks", handleNickCommand) , ("!seen", handleSeenCommand) , ("!forgetnicks", handleForgetNicksCommand)] @@ -98,9 +102,9 @@ updateNickTrack state user message msgTime = io $ do (_, Just (NickTrack { .. })) -> return (message, msgTime, canonicalNick) _ -> newCanonicalNick >>= \cn -> return (message, msgTime, cn) - saveNickTrack acid $ NickTrack (Nick nck) cn (LastSeenOn msgTime) lastMessageOn' message' + saveNickTrack acid $ NickTrack nck cn (LastSeenOn msgTime) lastMessageOn' message' -handleNickChange :: MonadMsgHandler m => IORef NickTrackingState -> User -> Text -> UTCTime -> m () +handleNickChange :: MonadMsgHandler m => IORef NickTrackingState -> User -> Nick -> UTCTime -> m () handleNickChange state user newNick msgTime = io $ do NickTrackingState { .. } <- readIORef state let prevNick = userNick user @@ -116,7 +120,7 @@ handleNickChange state user newNick msgTime = io $ do _ -> return Nothing whenJust mInfo $ \(message, cn, lastMessageOn') -> - saveNickTrack acid $ NickTrack (Nick newNick) cn (LastSeenOn msgTime) lastMessageOn' message + saveNickTrack acid $ NickTrack newNick cn (LastSeenOn msgTime) lastMessageOn' message newCanonicalNick :: IO CanonicalNick newCanonicalNick = map (CanonicalNick . pack . U.toString) U.nextRandom @@ -130,7 +134,7 @@ withNickTracks f state message = io $ do if nick == "" then return Nothing else do - mcn <- liftM (map canonicalNick) . getByNick acid $ nick + mcn <- liftM (map canonicalNick) . getByNick acid . Nick $ nick map (Just . ChannelMsgReply) $ case mcn of Nothing -> return $ "Unknown nick: " ++ nick Just cn -> io $ query acid (GetByCanonicalNickQ cn) >>= \nts -> f nick nts onlineNicks @@ -168,7 +172,7 @@ handleForgetNicksCommand state Message { msgDetails = ~ChannelMsg { .. }, .. } = Just nt <- getByNick acid nick cn <- newCanonicalNick saveNickTrack acid $ nt { canonicalNick = cn } - return . Just . ChannelMsgReply $ "Forgot all alternate nicks of " ++ nick + return . Just . ChannelMsgReply $ "Forgot all alternate nicks of " ++ nickToText nick stopNickTracker :: MonadMsgHandler m => IORef NickTrackingState -> m () stopNickTracker state = io $ do @@ -188,6 +192,7 @@ mkMsgHandler BotConfig { .. } _ "nicktracker" = do , onHelp = return helpMsgs } where helpMsgs = mapFromList [ - ("!nick", "Shows the user's other nicks. !nick "), - ("!seen", "Lets you know when a user was last seen online and last spoke in the channel. !seen ") ] + ("!nicks", "Shows alternate nicks of the user. !nicks "), + ("!seen", "Lets you know when a user was last seen online and last spoke in the channel. !seen "), + ("!forgetnicks", "Forgets all your alternate nicks. !forgetnicks") ] mkMsgHandler _ _ _ = return Nothing diff --git a/hask-irc-handlers/Network/IRC/Handlers/NickTracker/Types.hs b/hask-irc-handlers/Network/IRC/Handlers/NickTracker/Types.hs index a33c3b7..2529d4a 100644 --- a/hask-irc-handlers/Network/IRC/Handlers/NickTracker/Types.hs +++ b/hask-irc-handlers/Network/IRC/Handlers/NickTracker/Types.hs @@ -7,7 +7,8 @@ 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, Hashable) +import Network.IRC.Types + newtype CanonicalNick = CanonicalNick Text deriving (Eq, Ord, Show, Data, Typeable) newtype LastSeenOn = LastSeenOn UTCTime deriving (Eq, Ord, Show, Data, Typeable) @@ -27,7 +28,6 @@ instance Indexable NickTrack where newtype NickTracking = NickTracking { nickTracking :: IxSet NickTrack } deriving (Eq, Ord, Show, Data, Typeable) -$(deriveSafeCopy 0 'base ''Nick) $(deriveSafeCopy 0 'base ''CanonicalNick) $(deriveSafeCopy 0 'base ''LastSeenOn) $(deriveSafeCopy 0 'base ''NickTrack) diff --git a/hask-irc-runner/Network/IRC/Runner.hs b/hask-irc-runner/Network/IRC/Runner.hs index a4d6548..f88858d 100644 --- a/hask-irc-runner/Network/IRC/Runner.hs +++ b/hask-irc-runner/Network/IRC/Runner.hs @@ -57,13 +57,13 @@ loadBotConfig configFile = do eBotConfig <- try $ do handlers :: [Text] <- CF.require cfg "msghandlers" let handlerInfo = foldl' (\m h -> insertMap h mempty m) mempty handlers - BotConfig <$> - CF.require cfg "server" <*> - CF.require cfg "port" <*> - CF.require cfg "channel" <*> - CF.require cfg "nick" <*> - CF.require cfg "timeout" <*> - pure handlerInfo <*> + BotConfig <$> + CF.require cfg "server" <*> + CF.require cfg "port" <*> + CF.require cfg "channel" <*> + (Nick <$> CF.require cfg "nick") <*> + CF.require cfg "timeout" <*> + pure handlerInfo <*> pure cfg case eBotConfig of