Consolidated Nick types

master
Abhinav Sarkar 2014-06-01 02:11:20 +05:30
parent a3231878b0
commit 068b967e8e
10 changed files with 71 additions and 49 deletions

View File

@ -49,11 +49,11 @@ lineParser BotConfig { .. } time line msgParts = flip Done msgParts . Message ti
"JOIN" -> JoinMsg user "JOIN" -> JoinMsg user
"QUIT" -> QuitMsg user quitMessage "QUIT" -> QuitMsg user quitMessage
"PART" -> PartMsg user message "PART" -> PartMsg user message
"KICK" -> KickMsg user kicked kickReason "KICK" -> KickMsg user (Nick kicked) kickReason
"MODE" -> if source == botNick "MODE" -> if Nick source == botNick
then ModeMsg Self target message [] then ModeMsg Self target message []
else ModeMsg user target mode modeArgs else ModeMsg user target mode modeArgs
"NICK" -> NickMsg user (drop 1 target) "NICK" -> NickMsg user $ Nick (drop 1 target)
"433" -> NickInUseMsg "433" -> NickInUseMsg
"PRIVMSG" | target /= channel -> PrivMsg user message "PRIVMSG" | target /= channel -> PrivMsg user message
| isActionMsg -> ActionMsg user (initDef . drop 8 $ 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 target = splits !! 2
message = strip . drop 1 . unwords . drop 3 $ splits message = strip . drop 1 . unwords . drop 3 $ splits
quitMessage = strip . drop 1 . unwords . drop 2 $ 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 mode = splits !! 3
modeArgs = drop 4 splits modeArgs = drop 4 splits
kicked = splits !! 3 kicked = splits !! 3
@ -89,17 +89,18 @@ namesParser BotConfig { .. } time line msgParts = case command of
where where
(_ : command : target : _) = words line (_ : command : target : _) = words line
stripNickPrefix = pack . dropWhile (`elem` ("~&@%+" :: String)) . unpack 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 -> Maybe Text
lineFromCommand BotConfig { .. } command = case command of lineFromCommand BotConfig { .. } command = case command of
PongCmd { .. } -> Just $ "PONG :" ++ rmsg PongCmd { .. } -> Just $ "PONG :" ++ rmsg
PingCmd { .. } -> Just $ "PING :" ++ rmsg PingCmd { .. } -> Just $ "PING :" ++ rmsg
NickCmd -> Just $ "NICK " ++ botNick NickCmd -> Just $ "NICK " ++ nickToText botNick
UserCmd -> Just $ "USER " ++ botNick ++ " 0 * :" ++ botNick UserCmd -> Just $ "USER " ++ nickToText botNick ++ " 0 * :" ++ nickToText botNick
JoinCmd -> Just $ "JOIN " ++ channel JoinCmd -> Just $ "JOIN " ++ channel
QuitCmd -> Just "QUIT" QuitCmd -> Just "QUIT"
ChannelMsgReply { .. } -> Just $ "PRIVMSG " ++ channel ++ " :" ++ rmsg ChannelMsgReply { .. } -> Just $ "PRIVMSG " ++ channel ++ " :" ++ rmsg
PrivMsgReply (User { .. }) rmsg -> Just $ "PRIVMSG " ++ userNick ++ " :" ++ rmsg PrivMsgReply (User { .. }) rmsg -> Just $ "PRIVMSG " ++ nickToText userNick ++ " :" ++ rmsg
NamesCmd -> Just $ "NAMES " ++ channel NamesCmd -> Just $ "NAMES " ++ channel
_ -> Nothing _ -> Nothing

View File

@ -1,10 +1,12 @@
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-} {-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TemplateHaskell #-}
module Network.IRC.Types module Network.IRC.Types
( Nick ( Nick (..)
, MsgHandlerName , MsgHandlerName
, User (..) , User (..)
, Message (..) , Message (..)
@ -33,14 +35,21 @@ import Control.Monad.Base (MonadBase)
import Control.Monad.Reader (ReaderT, MonadReader, runReaderT) import Control.Monad.Reader (ReaderT, MonadReader, runReaderT)
import Control.Monad.State (StateT, MonadState, execStateT) import Control.Monad.State (StateT, MonadState, execStateT)
import Data.Configurator.Types (Config) import Data.Configurator.Types (Config)
import Data.Data (Data)
import Data.SafeCopy (base, deriveSafeCopy)
import Data.Typeable (cast) import Data.Typeable (cast)
import Network.IRC.Util import Network.IRC.Util
-- IRC related -- IRC related
type Nick = Text newtype Nick = Nick { nickToText :: Text }
type MsgHandlerName = 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 } data User = Self | User { userNick :: !Nick, userServer :: !Text }
deriving (Show, Eq) deriving (Show, Eq)
@ -104,10 +113,12 @@ data EventResponse = RespNothing
-- Bot -- Bot
type MsgHandlerName = Text
data BotConfig = BotConfig { server :: !Text data BotConfig = BotConfig { server :: !Text
, port :: !Int , port :: !Int
, channel :: !Text , channel :: !Text
, botNick :: !Text , botNick :: !Nick
, botTimeout :: !Int , botTimeout :: !Int
, msgHandlerInfo :: !(Map MsgHandlerName (Map Text Text)) , msgHandlerInfo :: !(Map MsgHandlerName (Map Text Text))
, config :: !Config } , config :: !Config }

View File

@ -57,6 +57,7 @@ library
text >=0.11 && <0.12, text >=0.11 && <0.12,
mtl >=2.1 && <2.2, mtl >=2.1 && <2.2,
configurator >=0.2 && <0.3, configurator >=0.2 && <0.3,
safecopy >=0.8 && <0.9,
time >=1.4 && <1.5, time >=1.4 && <1.5,
classy-prelude >=0.9 && <1.0, classy-prelude >=0.9 && <1.0,
text-format >=0.3 && <0.4, text-format >=0.3 && <0.4,

View File

@ -74,5 +74,5 @@ mkMsgHandler BotConfig { .. } _ "auth" = do
, onStop = stopAuth state , onStop = stopAuth state
, onHelp = return $ singletonMap "token" helpMsg } , onHelp = return $ singletonMap "token" helpMsg }
where 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 mkMsgHandler _ _ _ = return Nothing

View File

@ -23,4 +23,5 @@ data AuthEvent = AuthEvent Nick Token (MVar Bool) deriving (Typeable)
instance Event AuthEvent instance Event AuthEvent
instance Show AuthEvent where instance Show AuthEvent where
show (AuthEvent user token _) = "AuthEvent[" ++ unpack user ++ ", " ++ unpack token ++ "]" show (AuthEvent nick token _) =
"AuthEvent[" ++ unpack (nickToText nick) ++ ", " ++ unpack token ++ "]"

View File

@ -14,7 +14,8 @@ mkMsgHandler _ _ _ = return Nothing
greeter :: MonadMsgHandler m => Message -> m (Maybe Command) greeter :: MonadMsgHandler m => Message -> m (Maybe Command)
greeter Message { msgDetails = ChannelMsg { .. }, .. } = greeter Message { msgDetails = ChannelMsg { .. }, .. } =
return . map (ChannelMsgReply . (++ userNick user) . (++ " ")) . find (== clean msg) $ greetings return . map (ChannelMsgReply . (++ nickToText (userNick user)) . (++ " "))
. find (== clean msg) $ greetings
where 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" ]
@ -24,7 +25,7 @@ welcomer :: MonadMsgHandler m => Message -> m (Maybe Command)
welcomer Message { msgDetails = JoinMsg { .. }, .. } = do welcomer Message { msgDetails = JoinMsg { .. }, .. } = do
BotConfig { .. } <- ask BotConfig { .. } <- ask
if userNick user /= botNick if userNick user /= botNick
then return . Just . ChannelMsgReply $ "welcome back " ++ userNick user then return . Just . ChannelMsgReply $ "welcome back " ++ nickToText (userNick user)
else return Nothing else return Nothing
welcomer _ = return Nothing welcomer _ = return Nothing

View File

@ -32,7 +32,7 @@ getLogFilePath :: BotConfig -> IO FilePath
getLogFilePath BotConfig { .. } = do getLogFilePath BotConfig { .. } = do
logFileDir <- C.require config "messagelogger.logdir" logFileDir <- C.require config "messagelogger.logdir"
createDirectoryIfMissing True logFileDir createDirectoryIfMissing True logFileDir
return $ logFileDir </> unpack (channel ++ "-" ++ botNick) <.> "log" return $ logFileDir </> unpack (channel ++ "-" ++ nickToText botNick) <.> "log"
openLogFile :: FilePath -> IO Handle openLogFile :: FilePath -> IO Handle
openLogFile logFilePath = do openLogFile logFilePath = do
@ -74,16 +74,18 @@ withLogFile action state = do
messageLogger :: MonadMsgHandler m => Message -> IORef LoggerState -> m (Maybe Command) messageLogger :: MonadMsgHandler m => Message -> IORef LoggerState -> m (Maybe Command)
messageLogger Message { .. } = case msgDetails of messageLogger Message { .. } = case msgDetails of
ChannelMsg { .. } -> log "<{}> {}" [userNick user, msg] ChannelMsg { .. } -> log "<{}> {}" [nick user, msg]
ActionMsg { .. } -> log "<{}> {} {}" [userNick user, userNick user, msg] ActionMsg { .. } -> log "<{}> {} {}" [nick user, nick user, msg]
KickMsg { .. } -> log "** {} KICKED {} :{}" [userNick user, kickedNick, msg] KickMsg { .. } -> log "** {} KICKED {} :{}" [nick user, nickToText kickedNick, msg]
JoinMsg { .. } -> log "** {} JOINED" [userNick user] JoinMsg { .. } -> log "** {} JOINED" [nick user]
PartMsg { .. } -> log "** {} PARTED :{}" [userNick user, msg] PartMsg { .. } -> log "** {} PARTED :{}" [nick user, msg]
QuitMsg { .. } -> log "** {} QUIT :{}" [userNick user, msg] QuitMsg { .. } -> log "** {} QUIT :{}" [nick user, msg]
NickMsg { .. } -> log "** {} CHANGED NICK TO {}" [userNick user, newNick] NickMsg { .. } -> log "** {} CHANGED NICK TO {}" [nick user, nickToText newNick]
NamesMsg { .. } -> log "** USERS {}" [unwords nicks] NamesMsg { .. } -> log "** USERS {}" [unwords . map nickToText $ nicks]
_ -> const $ return Nothing _ -> const $ return Nothing
where where
nick = nickToText . userNick
log format args = withLogFile $ \logFile -> log format args = withLogFile $ \logFile ->
TF.hprint logFile ("[{}] " ++ format ++ "\n") $ TF.buildParams (fmtTime msgTime : args) TF.hprint logFile ("[{}] " ++ format ++ "\n") $ TF.buildParams (fmtTime msgTime : args)

View File

@ -20,9 +20,11 @@ import Data.IxSet (getOne, (@=))
import Data.Time (addUTCTime, NominalDiffTime) import Data.Time (addUTCTime, NominalDiffTime)
import Network.IRC.Handlers.NickTracker.Types import Network.IRC.Handlers.NickTracker.Types
import Network.IRC.Types hiding (Nick) import Network.IRC.Types
import Network.IRC.Util import Network.IRC.Util
-- database
getByNickQ :: Nick -> Query NickTracking (Maybe NickTrack) getByNickQ :: Nick -> Query NickTracking (Maybe NickTrack)
getByNickQ nick = do getByNickQ nick = do
NickTracking { .. } <- ask NickTracking { .. } <- ask
@ -40,12 +42,14 @@ saveNickTrackQ nt = do
$(makeAcidic ''NickTracking ['getByNickQ, 'getByCanonicalNickQ, 'saveNickTrackQ]) $(makeAcidic ''NickTracking ['getByNickQ, 'getByCanonicalNickQ, 'saveNickTrackQ])
getByNick :: AcidState NickTracking -> Text -> IO (Maybe NickTrack) getByNick :: AcidState NickTracking -> Nick -> IO (Maybe NickTrack)
getByNick acid = query acid . GetByNickQ . Nick getByNick acid = query acid . GetByNickQ
saveNickTrack :: AcidState NickTracking -> NickTrack -> IO () saveNickTrack :: AcidState NickTracking -> NickTrack -> IO ()
saveNickTrack acid = update acid . SaveNickTrackQ saveNickTrack acid = update acid . SaveNickTrackQ
-- handler
data NickTrackingState = NickTrackingState { acid :: AcidState NickTracking data NickTrackingState = NickTrackingState { acid :: AcidState NickTracking
, refreshInterval :: NominalDiffTime , refreshInterval :: NominalDiffTime
, onlineNicks :: HashSet Nick , onlineNicks :: HashSet Nick
@ -73,14 +77,14 @@ nickTrackerMsg state message@Message { .. } = case msgDetails of
updateRefreshTime = atomicModIORef state $ \ s -> s { lastRefreshOn = msgTime } updateRefreshTime = atomicModIORef state $ \ s -> s { lastRefreshOn = msgTime }
modifyOnlineNicks f = atomicModIORef state $ \s -> s { onlineNicks = f . onlineNicks $ s } modifyOnlineNicks f = atomicModIORef state $ \s -> s { onlineNicks = f . onlineNicks $ s }
add = modifyOnlineNicks . flip ((. (Nick . userNick)) . flip insertSet) add = modifyOnlineNicks . flip ((. userNick) . flip insertSet)
remove = modifyOnlineNicks . flip ((. (Nick . userNick)) . flip deleteSet) remove = modifyOnlineNicks . flip ((. userNick) . flip deleteSet)
swap users = modifyOnlineNicks $ swap users = modifyOnlineNicks $
let (oNick, nNick) = both (Nick . userNick) users let (oNick, nNick) = both userNick users
in deleteSet oNick . insertSet nNick in deleteSet oNick . insertSet nNick
refresh = modifyOnlineNicks . const . setFromList . map Nick refresh = modifyOnlineNicks . const . setFromList
commands = [ ("!nick", handleNickCommand) commands = [ ("!nicks", handleNickCommand)
, ("!seen", handleSeenCommand) , ("!seen", handleSeenCommand)
, ("!forgetnicks", handleForgetNicksCommand)] , ("!forgetnicks", handleForgetNicksCommand)]
@ -98,9 +102,9 @@ updateNickTrack state user message msgTime = io $ do
(_, Just (NickTrack { .. })) -> return (message, msgTime, canonicalNick) (_, Just (NickTrack { .. })) -> return (message, msgTime, canonicalNick)
_ -> newCanonicalNick >>= \cn -> return (message, msgTime, cn) _ -> 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 handleNickChange state user newNick msgTime = io $ do
NickTrackingState { .. } <- readIORef state NickTrackingState { .. } <- readIORef state
let prevNick = userNick user let prevNick = userNick user
@ -116,7 +120,7 @@ handleNickChange state user newNick msgTime = io $ do
_ -> return Nothing _ -> return Nothing
whenJust mInfo $ \(message, cn, lastMessageOn') -> 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 :: IO CanonicalNick
newCanonicalNick = map (CanonicalNick . pack . U.toString) U.nextRandom newCanonicalNick = map (CanonicalNick . pack . U.toString) U.nextRandom
@ -130,7 +134,7 @@ withNickTracks f state message = io $ do
if nick == "" if nick == ""
then return Nothing then return Nothing
else do else do
mcn <- liftM (map canonicalNick) . getByNick acid $ nick mcn <- liftM (map canonicalNick) . getByNick acid . Nick $ nick
map (Just . ChannelMsgReply) $ case mcn of map (Just . ChannelMsgReply) $ case mcn of
Nothing -> return $ "Unknown nick: " ++ nick Nothing -> return $ "Unknown nick: " ++ nick
Just cn -> io $ query acid (GetByCanonicalNickQ cn) >>= \nts -> f nick nts onlineNicks 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 Just nt <- getByNick acid nick
cn <- newCanonicalNick cn <- newCanonicalNick
saveNickTrack acid $ nt { canonicalNick = cn } 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 :: MonadMsgHandler m => IORef NickTrackingState -> m ()
stopNickTracker state = io $ do stopNickTracker state = io $ do
@ -188,6 +192,7 @@ mkMsgHandler BotConfig { .. } _ "nicktracker" = do
, onHelp = return helpMsgs } , onHelp = return helpMsgs }
where where
helpMsgs = mapFromList [ helpMsgs = mapFromList [
("!nick", "Shows the user's other nicks. !nick <user nick>"), ("!nicks", "Shows alternate nicks of the user. !nicks <user nick>"),
("!seen", "Lets you know when a user was last seen online and last spoke in the channel. !seen <user nick>") ] ("!seen", "Lets you know when a user was last seen online and last spoke in the channel. !seen <user nick>"),
("!forgetnicks", "Forgets all your alternate nicks. !forgetnicks") ]
mkMsgHandler _ _ _ = return Nothing mkMsgHandler _ _ _ = return Nothing

View File

@ -7,7 +7,8 @@ import Data.Data (Data)
import Data.IxSet (IxSet, Indexable (..), ixSet, ixFun) import Data.IxSet (IxSet, Indexable (..), ixSet, ixFun)
import Data.SafeCopy (base, deriveSafeCopy) 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 CanonicalNick = CanonicalNick Text deriving (Eq, Ord, Show, Data, Typeable)
newtype LastSeenOn = LastSeenOn UTCTime 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 } newtype NickTracking = NickTracking { nickTracking :: IxSet NickTrack }
deriving (Eq, Ord, Show, Data, Typeable) deriving (Eq, Ord, Show, Data, Typeable)
$(deriveSafeCopy 0 'base ''Nick)
$(deriveSafeCopy 0 'base ''CanonicalNick) $(deriveSafeCopy 0 'base ''CanonicalNick)
$(deriveSafeCopy 0 'base ''LastSeenOn) $(deriveSafeCopy 0 'base ''LastSeenOn)
$(deriveSafeCopy 0 'base ''NickTrack) $(deriveSafeCopy 0 'base ''NickTrack)

View File

@ -57,13 +57,13 @@ loadBotConfig configFile = do
eBotConfig <- try $ do eBotConfig <- try $ do
handlers :: [Text] <- CF.require cfg "msghandlers" handlers :: [Text] <- CF.require cfg "msghandlers"
let handlerInfo = foldl' (\m h -> insertMap h mempty m) mempty handlers let handlerInfo = foldl' (\m h -> insertMap h mempty m) mempty handlers
BotConfig <$> BotConfig <$>
CF.require cfg "server" <*> CF.require cfg "server" <*>
CF.require cfg "port" <*> CF.require cfg "port" <*>
CF.require cfg "channel" <*> CF.require cfg "channel" <*>
CF.require cfg "nick" <*> (Nick <$> CF.require cfg "nick") <*>
CF.require cfg "timeout" <*> CF.require cfg "timeout" <*>
pure handlerInfo <*> pure handlerInfo <*>
pure cfg pure cfg
case eBotConfig of case eBotConfig of