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

Added tracking of online nicks

Browse Source
This commit is contained in:
Abhinav Sarkar 2014-05-25 14:51:33 +05:30
parent 7c5ee230e4
commit aaab36d743
9 changed files with 171 additions and 126 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
Network/IRC/Handlers/Auth.hs
View File

@ -1,5 +1,3 @@
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}

102
Network/IRC/Handlers/NickTracker.hs
View File

@ -1,22 +1,23 @@
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# 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 qualified Data.Configurator as CF
import qualified Data.IxSet as IS
import qualified Data.UUID as U
import qualified Data.UUID.V4 as U
import ClassyPrelude
import ClassyPrelude hiding (swap)
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.Convertible (convert)
import Data.IxSet (getOne, (@=))
import Data.Time (addUTCTime, NominalDiffTime)
import Network.IRC.Handlers.NickTracker.Types
import Network.IRC.Types hiding (Nick)
@ -39,18 +40,42 @@ saveNickTrack nt = do
$(makeAcidic ''NickTracking ['getByNick, 'getByCanonicalNick, 'saveNickTrack])
nickTrackerMsg :: MonadMsgHandler m => IORef (AcidState NickTracking) -> Message -> m (Maybe Command)
data NickTrackingState = NickTrackingState { acid :: AcidState NickTracking
, refreshInterval :: NominalDiffTime
, onlineNicks :: HashSet Nick
, lastRefreshOn :: UTCTime }
modifyOnlineNicks :: (HashSet Nick -> HashSet Nick) -> NickTrackingState -> NickTrackingState
modifyOnlineNicks f state = state { onlineNicks = f . onlineNicks $ state }
nickTrackerMsg :: MonadMsgHandler m => IORef NickTrackingState -> Message -> m (Maybe Command)
nickTrackerMsg state Message { .. } = case msgDetails of
ChannelMsg { .. } -> updateNickTrack state user msg msgTime >> handleCommands msg
ActionMsg { .. } -> updateNickTrack state user msg msgTime >> return Nothing
JoinMsg { .. } -> updateNickTrack state user "" msgTime >> return Nothing
PartMsg { .. } -> updateNickTrack state user msg msgTime >> return Nothing
QuitMsg { .. } -> updateNickTrack state user msg msgTime >> return Nothing
NickMsg { .. } -> handleNickChange state user newNick msgTime >> return Nothing
NamesMsg { .. } ->
mapM_ (\n -> updateNickTrack state (User n "") "" msgTime) nicks >> return Nothing
ChannelMsg { .. } -> updateNickTrack state user msg msgTime >> handleCommands msg
ActionMsg { .. } -> updateNickTrack state user msg msgTime >> return Nothing
JoinMsg { .. } -> updateNickTrack state user "" msgTime >> add user >> return Nothing
PartMsg { .. } -> updateNickTrack state user msg msgTime >> remove user >> return Nothing
QuitMsg { .. } -> updateNickTrack state user msg msgTime >> remove user >> return Nothing
NickMsg { .. } ->
handleNickChange state user newNick msgTime >> swap (user, User newNick "") >> return Nothing
NamesMsg { .. } -> do
mapM_ (\n -> updateNickTrack state (User n "") "" msgTime) nicks
refresh nicks >> updateRefreshTime >> return Nothing
IdleMsg { .. } -> do
NickTrackingState { .. } <- readIORef state
if addUTCTime refreshInterval lastRefreshOn < msgTime
then updateRefreshTime >> return (Just NamesCmd)
else return Nothing
_ -> return Nothing
where
updateRefreshTime = atomicModIORef state $ \ s -> s { lastRefreshOn = msgTime }
add = atomicModIORef state . modifyOnlineNicks . flip ((. (Nick . userNick)) . flip insertSet)
remove = atomicModIORef state . modifyOnlineNicks . flip ((. (Nick . userNick)) . flip deleteSet)
swap users = atomicModIORef state . modifyOnlineNicks $
let (oNick, nNick) = both (Nick . userNick) users
in deleteSet oNick . insertSet nNick
refresh = atomicModIORef state . modifyOnlineNicks . const . setFromList . map Nick
commands = [ ("!nick", handleNickCommand)
, ("!seen", handleSeenCommand) ]
@ -58,9 +83,9 @@ nickTrackerMsg state Message { .. } = case msgDetails of
Nothing -> return Nothing
Just (_, handler) -> handler state msg
updateNickTrack :: MonadMsgHandler m => IORef (AcidState NickTracking) -> User -> Text -> UTCTime -> m ()
updateNickTrack :: MonadMsgHandler m => IORef NickTrackingState -> User -> Text -> UTCTime -> m ()
updateNickTrack state user message msgTime = io $ do
acid <- readIORef state
NickTrackingState { .. } <- readIORef state
let nck = userNick user
mnt <- query acid . GetByNick $ Nick nck
(message', lastMessageOn', cn) <- case (message, mnt) of
@ -71,9 +96,9 @@ updateNickTrack state user message msgTime = io $ do
update acid . SaveNickTrack $
NickTrack (Nick nck) cn (LastSeenOn msgTime) lastMessageOn' message'
handleNickChange :: MonadMsgHandler m => IORef (AcidState NickTracking) -> User -> Text -> UTCTime -> m ()
handleNickChange :: MonadMsgHandler m => IORef NickTrackingState -> User -> Text -> UTCTime -> m ()
handleNickChange state user newNick msgTime = io $ do
acid <- readIORef state
NickTrackingState { .. } <- readIORef state
let prevNick = userNick user
mpnt <- query acid . GetByNick $ Nick prevNick
mnt <- query acid . GetByNick $ Nick newNick
@ -94,49 +119,56 @@ newCanonicalNick :: IO CanonicalNick
newCanonicalNick = map (CanonicalNick . pack . U.toString) U.nextRandom
withNickTracks :: MonadMsgHandler m
=> (Text -> [NickTrack] -> IO Text) -> IORef (AcidState NickTracking) -> Text
=> (Text -> [NickTrack] -> HashSet Nick -> IO Text) -> IORef NickTrackingState -> Text
-> m (Maybe Command)
withNickTracks f state msg = io $ do
acid <- readIORef state
let nick = clean . unwords . drop 1 . words $ msg
mcn <- liftM (map canonicalNick) . query acid . GetByNick $ Nick nick
NickTrackingState { .. } <- readIORef state
let nick = clean . unwords . drop 1 . words $ msg
mcn <- liftM (map canonicalNick) . query acid . GetByNick $ Nick nick
map (Just . ChannelMsgReply) $ case mcn of
Nothing -> return $ "Unknown nick: " ++ nick
Just cn -> io $ query acid (GetByCanonicalNick cn) >>= f nick
Just cn -> io $ query acid (GetByCanonicalNick cn) >>= \nts -> f nick nts onlineNicks
handleNickCommand :: MonadMsgHandler m => IORef(AcidState NickTracking) -> Text -> m (Maybe Command)
handleNickCommand = withNickTracks $ \nck nickTracks -> do
handleNickCommand :: MonadMsgHandler m => IORef NickTrackingState -> Text -> m (Maybe Command)
handleNickCommand = withNickTracks $ \nck nickTracks _ -> do
let nicks = map ((\(Nick n) -> n) . nick) nickTracks
if length nicks == 1
then return $ nck ++ " has only one nick"
else return $ nck ++ "'s other nicks are: " ++ intercalate ", " (filter (/= nck) nicks)
handleSeenCommand :: MonadMsgHandler m => IORef(AcidState NickTracking) -> Text -> m (Maybe Command)
handleSeenCommand = withNickTracks $ \nick nickTracks -> do
handleSeenCommand :: MonadMsgHandler m => IORef NickTrackingState -> Text -> m (Maybe Command)
handleSeenCommand = withNickTracks $ \nck nickTracks onlineNicks -> do
let NickTrack { lastSeenOn = LastSeenOn lastSeenOn'
, nick = Nick lastSeenAs } = maximumByEx (comparing lastSeenOn) nickTracks
let NickTrack { lastMessageOn = lastMessageOn'
, lastMessage = lastMessage'
, nick = Nick lastMessageAs } = maximumByEx (comparing lastMessageOn) nickTracks
return $ nick ++ " was last seen on " ++ fmtTime lastSeenOn' ++
(if nick /= lastSeenAs then " as " ++ lastSeenAs else "") ++
return $ (if any (`member` onlineNicks) . map nick $ nickTracks
then nck ++ " is online now"
else nck ++ " was last seen on " ++ fmtTime lastSeenOn') ++
(if nck /= lastSeenAs then " as " ++ lastSeenAs else "") ++
(if clean lastMessage' == "" then "" else
" and at " ++ fmtTime lastMessageOn' ++ " " ++ nick ++
(if nick /= lastMessageAs then " as " ++ lastMessageAs else "") ++
" and at " ++ fmtTime lastMessageOn' ++ " " ++ nck ++
(if nck /= lastMessageAs then " as " ++ lastMessageAs else "") ++
" said: " ++ lastMessage')
where
fmtTime = pack . formatTime defaultTimeLocale "%F %T"
stopNickTracker :: MonadMsgHandler m => IORef (AcidState NickTracking) -> m ()
stopNickTracker :: MonadMsgHandler m => IORef NickTrackingState -> m ()
stopNickTracker state = io $ do
acid <- readIORef state
NickTrackingState { .. } <- readIORef state
createArchive acid
createCheckpointAndClose acid
mkMsgHandler :: BotConfig -> Chan SomeEvent -> MsgHandlerName -> IO (Maybe MsgHandler)
mkMsgHandler BotConfig { .. } _ "nicktracker" = do
state <- io $ openLocalState emptyNickTracking >>= newIORef
state <- io $ do
now <- getCurrentTime
refreshInterval <- map convert (CF.lookupDefault 60 config "nicktracker.refresh_interval" :: IO Int)
acid <- openLocalState emptyNickTracking
newIORef (NickTrackingState acid refreshInterval mempty now)
return . Just $ newMsgHandler { onMessage = nickTrackerMsg state
, onStop = stopNickTracker state
, onHelp = return helpMsgs }

3
Network/IRC/Handlers/NickTracker/Types.hs
View File

@ -1,4 +1,3 @@
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE TemplateHaskell #-}
module Network.IRC.Handlers.NickTracker.Types where
@ -8,7 +7,7 @@ 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 Nick = Nick Text deriving (Eq, Ord, Show, Data, Typeable, Hashable)
newtype CanonicalNick = CanonicalNick Text deriving (Eq, Ord, Show, Data, Typeable)
newtype LastSeenOn = LastSeenOn UTCTime deriving (Eq, Ord, Show, Data, Typeable)

4
Network/IRC/Handlers/SongSearch.hs
View File

@ -1,8 +1,4 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
module Network.IRC.Handlers.SongSearch (mkMsgHandler) where

62
Network/IRC/Protocol.hs
View File

@ -9,8 +9,7 @@ import Data.Text (strip)
import Network.IRC.Types
data MessageParseType = Names
| Whois
data MessageParseType = Names
deriving (Show, Eq)
data MessagePart = MessagePart { msgParserType :: MessageParseType
@ -28,38 +27,38 @@ type MessageParser = BotConfig -> UTCTime -> Text -> [MessagePart] -> MessagePar
parseLine :: BotConfig -> UTCTime -> Text -> [MessagePart] -> (Maybe Message, [MessagePart])
parseLine botConfig time line msgParts =
case lineParser botConfig time line msgParts of
Done message@(Message { msgDetails = OtherMsg { .. }, .. }) _ ->
fromMaybe (Just message, msgParts) . flip (`foldl'` Nothing) parsers $ \parseResult parser ->
case parseResult of
Just _ -> parseResult
Nothing -> case parser botConfig time line msgParts of
Reject -> Nothing
Partial msgParts' -> Just (Nothing, msgParts')
Done message' msgParts' -> Just (Just message', msgParts')
Done message _ -> (Just message, msgParts)
_ -> error "This should never happen"
fromMaybe (Nothing, msgParts) . flip (`foldl'` Nothing) parsers $ \parseResult parser ->
case parseResult of
Just _ -> parseResult
Nothing -> case parser botConfig time line msgParts of
Reject -> Nothing
Partial msgParts' -> Just (Nothing, msgParts')
Done message' msgParts' -> Just (Just message', msgParts')
where
parsers = [namesParser]
parsers = [pingParser, namesParser, lineParser]
pingParser :: MessageParser
pingParser _ time line msgParts
| "PING :" `isPrefixOf` line = Done (Message time line . PingMsg . drop 6 $ line) msgParts
| otherwise = Reject
lineParser :: MessageParser
lineParser BotConfig { .. } time line msgParts
| "PING :" `isPrefixOf` line = flip Done msgParts $ Message time line $ PingMsg (drop 6 line)
| otherwise = flip Done msgParts $ case command of
"PONG" -> Message time line $ PongMsg message
"JOIN" -> Message time line $ JoinMsg user
"QUIT" -> Message time line $ QuitMsg user quitMessage
"PART" -> Message time line $ PartMsg user message
"KICK" -> Message time line $ KickMsg user kicked kickReason
"MODE" -> if source == botNick
then Message time line $ ModeMsg Self target message []
else Message time line $ ModeMsg user target mode modeArgs
"NICK" -> Message time line $ NickMsg user (drop 1 target)
"433" -> Message time line NickInUseMsg
"PRIVMSG" | target /= channel -> Message time line $ PrivMsg user message
| isActionMsg -> Message time line $ ActionMsg user (initDef . drop 8 $ message)
| otherwise -> Message time line $ ChannelMsg user message
_ -> Message time line $ OtherMsg source command target message
lineParser BotConfig { .. } time line msgParts = flip Done msgParts . Message time line $
case command of
"PONG" -> PongMsg message
"JOIN" -> JoinMsg user
"QUIT" -> QuitMsg user quitMessage
"PART" -> PartMsg user message
"KICK" -> KickMsg user kicked kickReason
"MODE" -> if source == botNick
then ModeMsg Self target message []
else ModeMsg user target mode modeArgs
"NICK" -> NickMsg user (drop 1 target)
"433" -> NickInUseMsg
"PRIVMSG" | target /= channel -> PrivMsg user message
| isActionMsg -> ActionMsg user (initDef . drop 8 $ message)
| otherwise -> ChannelMsg user message
_ -> OtherMsg source command target message
where
splits = words line
command = splits !! 1
@ -92,7 +91,6 @@ namesParser BotConfig { .. } time line msgParts = case command of
stripNickPrefix = pack . dropWhile (`elem` ("~&@%+" :: String)) . unpack
namesNicks line' = map stripNickPrefix . words . drop 1 . unwords . drop 5 . words $ line'
lineFromCommand :: BotConfig -> Command -> Maybe Text
lineFromCommand BotConfig { .. } command = case command of
PongCmd { .. } -> Just $ "PONG :" ++ rmsg

6
Network/IRC/Types.hs
View File

@ -1,7 +1,5 @@
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
@ -31,6 +29,7 @@ module Network.IRC.Types
where
import ClassyPrelude
import Control.Monad.Base (MonadBase)
import Control.Monad.Reader (ReaderT, MonadReader, runReaderT)
import Control.Monad.State (StateT, MonadState, execStateT)
import Data.Configurator.Types (Config)
@ -153,9 +152,10 @@ newtype MsgHandlerT a = MsgHandlerT { _runMsgHandler :: ReaderT BotConfig IO a }
, Applicative
, Monad
, MonadIO
, MonadBase IO
, MonadReader BotConfig )
class (MonadIO m, Applicative m, MonadReader BotConfig m) => MonadMsgHandler m where
class (MonadIO m, Applicative m, MonadReader BotConfig m, MonadBase IO m) => MonadMsgHandler m where
msgHandler :: MsgHandlerT a -> m a
instance MonadMsgHandler MsgHandlerT where

11
Network/IRC/Util.hs
View File

@ -1,7 +1,11 @@
{-# LANGUAGE FlexibleContexts #-}
module Network.IRC.Util where
import ClassyPrelude
import Control.Arrow (Arrow)
import Control.Concurrent.Lifted (Chan)
import Control.Monad.Base (MonadBase)
import Data.Text (strip)
oneSec :: Int
@ -31,3 +35,10 @@ clean = toLower . strip
io :: MonadIO m => IO a -> m a
io = liftIO
both :: Arrow cat => cat b d -> cat (b, b) (d, d)
both f = first f . second f
atomicModIORef :: MonadBase IO f => IORef t -> (t -> t) -> f ()
atomicModIORef ref f = void . atomicModifyIORef' ref $ \v -> (f v, v)

5
config.cfg.template
View File

@ -2,6 +2,7 @@ server = "irc.freenode.net"
port = 6667
channel = "#testtesttest"
nick = "haskman"
timeout = 130
msghandlers = ["greeter", "welcomer", "songsearch", "auth", "nicktracker"]
songsearch {
@ -11,3 +12,7 @@ songsearch {
messagelogger {
logdir = "./logs/"
}
nicktracker {
refresh_interval = 60
}

102
hask-irc.cabal
View File

@ -50,31 +50,34 @@ cabal-version: >=1.10
library
default-extensions: NoImplicitPrelude, OverloadedStrings, RecordWildCards, ScopedTypeVariables,
BangPatterns, TupleSections, NamedFieldPuns
BangPatterns, TupleSections, NamedFieldPuns, GeneralizedNewtypeDeriving,
DeriveDataTypeable
build-depends: base >=4.5 && <4.8,
text >=0.11 && <0.12,
mtl >=2.1 && <2.2,
network >=2.3 && <2.5,
configurator >=0.2 && <0.3,
time >=1.4 && <1.5,
curl-aeson >=0.0.3 && <0.1,
aeson >=0.6.0.0 && <0.7,
HTTP >=4000 && <5000,
transformers >=0.3 && <0.4,
classy-prelude >=0.9 && <1.0,
text-format >=0.3 && <0.4,
filepath >=1.3 && <1.4,
directory >=1.2 && <1.3,
lifted-base >=0.2 && <0.3,
unix >=2.7 && <2.8,
convertible >=1.1 && <1.2,
hslogger >=1.2 && <1.3,
hslogger-template >=2.0 && <2.1,
ixset >=1.0 && <1.1,
acid-state >=0.12 && <0.13,
safecopy >=0.8 && <0.9,
uuid >=1.3 && <1.4
build-depends: base >=4.5 && <4.8,
text >=0.11 && <0.12,
mtl >=2.1 && <2.2,
network >=2.3 && <2.5,
configurator >=0.2 && <0.3,
time >=1.4 && <1.5,
curl-aeson >=0.0.3 && <0.1,
aeson >=0.6.0.0 && <0.7,
HTTP >=4000 && <5000,
transformers >=0.3 && <0.4,
classy-prelude >=0.9 && <1.0,
text-format >=0.3 && <0.4,
filepath >=1.3 && <1.4,
directory >=1.2 && <1.3,
lifted-base >=0.2 && <0.3,
unix >=2.7 && <2.8,
convertible >=1.1 && <1.2,
hslogger >=1.2 && <1.3,
hslogger-template >=2.0 && <2.1,
ixset >=1.0 && <1.1,
acid-state >=0.12 && <0.13,
safecopy >=0.8 && <0.9,
uuid >=1.3 && <1.4,
transformers-base >=0.4 && <0.5,
unordered-containers >=0.2 && <0.3
exposed-modules: Network.IRC.Types, Network.IRC.Protocol,
Network.IRC.Handlers, Network.IRC.Client
@ -93,32 +96,35 @@ executable hask-irc
-- LANGUAGE extensions used by modules in this package.
default-extensions: NoImplicitPrelude, OverloadedStrings, RecordWildCards, ScopedTypeVariables,
BangPatterns, TupleSections, NamedFieldPuns
BangPatterns, TupleSections, NamedFieldPuns, GeneralizedNewtypeDeriving,
DeriveDataTypeable
-- Other library packages from which modules are imported.
build-depends: base >=4.5 && <4.8,
text >=0.11 && <0.12,
mtl >=2.1 && <2.2,
network >=2.3 && <2.5,
configurator >=0.2 && <0.3,
time >=1.4 && <1.5,
curl-aeson >=0.0.3 && <0.1,
aeson >=0.6.0.0 && <0.7,
HTTP >=4000 && <5000,
transformers >=0.3 && <0.4,
classy-prelude >=0.9 && <1.0,
text-format >=0.3 && <0.4,
filepath >=1.3 && <1.4,
directory >=1.2 && <1.3,
lifted-base >=0.2 && <0.3,
unix >=2.7 && <2.8,
convertible >=1.1 && <1.2,
hslogger >=1.2 && <1.3,
hslogger-template >=2.0 && <2.1,
ixset >=1.0 && <1.1,
acid-state >=0.12 && <0.13,
safecopy >=0.8 && <0.9,
uuid >=1.3 && <1.4
build-depends: base >=4.5 && <4.8,
text >=0.11 && <0.12,
mtl >=2.1 && <2.2,
network >=2.3 && <2.5,
configurator >=0.2 && <0.3,
time >=1.4 && <1.5,
curl-aeson >=0.0.3 && <0.1,
aeson >=0.6.0.0 && <0.7,
HTTP >=4000 && <5000,
transformers >=0.3 && <0.4,
classy-prelude >=0.9 && <1.0,
text-format >=0.3 && <0.4,
filepath >=1.3 && <1.4,
directory >=1.2 && <1.3,
lifted-base >=0.2 && <0.3,
unix >=2.7 && <2.8,
convertible >=1.1 && <1.2,
hslogger >=1.2 && <1.3,
hslogger-template >=2.0 && <2.1,
ixset >=1.0 && <1.1,
acid-state >=0.12 && <0.13,
safecopy >=0.8 && <0.9,
uuid >=1.3 && <1.4,
transformers-base >=0.4 && <0.5,
unordered-containers >=0.2 && <0.3
-- Directories containing source files.
-- hs-source-dirs: