abhin4v/hask-irc
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Consolidated Nick types

Browse Source
This commit is contained in:
Abhinav Sarkar 2014-06-01 02:11:20 +05:30
parent a3231878b0
commit 068b967e8e
10 changed files with 71 additions and 49 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

17
hask-irc-core/Network/IRC/Protocol.hs
View File

@ -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

19
hask-irc-core/Network/IRC/Types.hs
View File

@ -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 }

1
hask-irc-core/hask-irc-core.cabal
View File

@ -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,

2
hask-irc-handlers/Network/IRC/Handlers/Auth.hs
View File

@ -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

3
hask-irc-handlers/Network/IRC/Handlers/Auth/Types.hs
View File

@ -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 ++ "]"

5
hask-irc-handlers/Network/IRC/Handlers/Greet.hs
View File

@ -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

20
hask-irc-handlers/Network/IRC/Handlers/MessageLogger.hs
View File

@ -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)

35
hask-irc-handlers/Network/IRC/Handlers/NickTracker.hs
View File

@ -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 <user nick>"),
("!seen", "Lets you know when a user was last seen online and last spoke in the channel. !seen <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>"),
("!forgetnicks", "Forgets all your alternate nicks. !forgetnicks") ]
mkMsgHandler _ _ _ = return Nothing

4
hask-irc-handlers/Network/IRC/Handlers/NickTracker/Types.hs
View File

@ -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)

14
hask-irc-runner/Network/IRC/Runner.hs
View File

@ -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