hask-irc/src/Network/IRC/Handlers/NickTracker.hs

181 lines
8.6 KiB
Haskell
Raw Normal View History

2014-05-23 02:45:45 +05:30
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
module Network.IRC.Handlers.NickTracker (mkMsgHandler) where
2014-05-25 14:51:33 +05:30
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
2014-05-23 02:45:45 +05:30
2014-05-25 14:51:33 +05:30
import ClassyPrelude hiding (swap)
2014-05-23 02:45:45 +05:30
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)
2014-05-25 14:51:33 +05:30
import Data.Convertible (convert)
2014-05-23 02:45:45 +05:30
import Data.IxSet (getOne, (@=))
2014-05-25 14:51:33 +05:30
import Data.Time (addUTCTime, NominalDiffTime)
2014-05-23 02:45:45 +05:30
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
saveNickTrack :: NickTrack -> Update NickTracking ()
saveNickTrack nt = do
NickTracking { .. } <- get
put . NickTracking $ IS.updateIx (nick nt) nt nickTracking
$(makeAcidic ''NickTracking ['getByNick, 'getByCanonicalNick, 'saveNickTrack])
2014-05-25 14:51:33 +05:30
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)
2014-05-25 01:09:31 +05:30
nickTrackerMsg state Message { .. } = case msgDetails of
2014-05-25 14:51:33 +05:30
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
2014-05-25 15:52:15 +05:30
forM_ nicks $ \n -> updateNickTrack state (User n "") "" msgTime
2014-05-25 14:51:33 +05:30
refresh nicks >> updateRefreshTime >> return Nothing
IdleMsg { .. } -> do
NickTrackingState { .. } <- readIORef state
if addUTCTime refreshInterval lastRefreshOn < msgTime
then updateRefreshTime >> return (Just NamesCmd)
else return Nothing
2014-05-24 23:49:52 +05:30
_ -> return Nothing
2014-05-23 02:45:45 +05:30
where
2014-05-25 14:51:33 +05:30
updateRefreshTime = atomicModIORef state $ \ s -> s { lastRefreshOn = msgTime }
2014-05-25 15:52:15 +05:30
add = atomicModIORef state . modifyOnlineNicks . flip ((. (Nick . userNick)) . flip insertSet)
remove = atomicModIORef state . modifyOnlineNicks . flip ((. (Nick . userNick)) . flip deleteSet)
2014-05-25 14:51:33 +05:30
swap users = atomicModIORef state . modifyOnlineNicks $
let (oNick, nNick) = both (Nick . userNick) users
in deleteSet oNick . insertSet nNick
2014-05-25 15:52:15 +05:30
refresh = atomicModIORef state . modifyOnlineNicks . const . setFromList . map Nick
2014-05-25 14:51:33 +05:30
2014-05-23 04:38:52 +05:30
commands = [ ("!nick", handleNickCommand)
, ("!seen", handleSeenCommand) ]
2014-05-23 04:56:26 +05:30
2014-05-24 23:49:52 +05:30
handleCommands msg = case find ((`isPrefixOf` msg) . fst) commands of
2014-05-23 04:56:26 +05:30
Nothing -> return Nothing
2014-05-24 23:49:52 +05:30
Just (_, handler) -> handler state msg
2014-05-25 14:51:33 +05:30
updateNickTrack :: MonadMsgHandler m => IORef NickTrackingState -> User -> Text -> UTCTime -> m ()
2014-05-24 23:49:52 +05:30
updateNickTrack state user message msgTime = io $ do
2014-05-25 14:51:33 +05:30
NickTrackingState { .. } <- readIORef state
2014-05-24 23:49:52 +05:30
let nck = userNick user
mnt <- query acid . GetByNick $ Nick nck
(message', lastMessageOn', cn) <- case (message, mnt) of
("", Just (NickTrack { .. })) -> return (lastMessage, lastMessageOn, canonicalNick)
(_, Just (NickTrack { .. })) -> return (message, msgTime, canonicalNick)
2014-05-25 01:09:31 +05:30
_ -> newCanonicalNick >>= \cn -> return (message, msgTime, cn)
2014-05-24 23:49:52 +05:30
update acid . SaveNickTrack $
NickTrack (Nick nck) cn (LastSeenOn msgTime) lastMessageOn' message'
2014-05-25 14:51:33 +05:30
handleNickChange :: MonadMsgHandler m => IORef NickTrackingState -> User -> Text -> UTCTime -> m ()
2014-05-24 23:49:52 +05:30
handleNickChange state user newNick msgTime = io $ do
2014-05-25 14:51:33 +05:30
NickTrackingState { .. } <- readIORef state
2014-05-24 23:49:52 +05:30
let prevNick = userNick user
mpnt <- query acid . GetByNick $ Nick prevNick
mnt <- query acid . GetByNick $ Nick newNick
mInfo <- case (mpnt, mnt) of
(Nothing, _) -> newCanonicalNick >>= \cn -> return $ Just ("", cn, msgTime)
(Just pnt, Nothing) ->
return $ Just (lastMessage pnt, canonicalNick pnt, lastMessageOn pnt)
(Just pnt, Just nt) | canonicalNick pnt == canonicalNick nt -> do
let nt' = maximumByEx (comparing lastMessageOn) [pnt, nt]
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
newCanonicalNick :: IO CanonicalNick
newCanonicalNick = map (CanonicalNick . pack . U.toString) U.nextRandom
2014-05-23 04:38:52 +05:30
2014-05-23 04:56:26 +05:30
withNickTracks :: MonadMsgHandler m
2014-05-25 14:51:33 +05:30
=> (Text -> [NickTrack] -> HashSet Nick -> IO Text) -> IORef NickTrackingState -> Text
2014-05-23 04:56:26 +05:30
-> m (Maybe Command)
2014-05-23 12:21:38 +05:30
withNickTracks f state msg = io $ do
2014-05-25 14:51:33 +05:30
NickTrackingState { .. } <- readIORef state
let nick = clean . unwords . drop 1 . words $ msg
mcn <- liftM (map canonicalNick) . query acid . GetByNick $ Nick nick
2014-05-23 12:21:38 +05:30
map (Just . ChannelMsgReply) $ case mcn of
2014-05-23 04:56:26 +05:30
Nothing -> return $ "Unknown nick: " ++ nick
2014-05-25 14:51:33 +05:30
Just cn -> io $ query acid (GetByCanonicalNick cn) >>= \nts -> f nick nts onlineNicks
2014-05-23 02:45:45 +05:30
2014-05-25 14:51:33 +05:30
handleNickCommand :: MonadMsgHandler m => IORef NickTrackingState -> Text -> m (Maybe Command)
handleNickCommand = withNickTracks $ \nck nickTracks _ -> do
2014-05-23 04:56:26 +05:30
let nicks = map ((\(Nick n) -> n) . nick) nickTracks
2014-05-23 04:38:52 +05:30
if length nicks == 1
then return $ nck ++ " has only one nick"
else return $ nck ++ "'s other nicks are: " ++ intercalate ", " (filter (/= nck) nicks)
2014-05-25 14:51:33 +05:30
handleSeenCommand :: MonadMsgHandler m => IORef NickTrackingState -> Text -> m (Maybe Command)
handleSeenCommand = withNickTracks $ \nck nickTracks onlineNicks -> do
2014-05-23 04:38:52 +05:30
let NickTrack { lastSeenOn = LastSeenOn lastSeenOn'
2014-05-23 04:56:26 +05:30
, nick = Nick lastSeenAs } = maximumByEx (comparing lastSeenOn) nickTracks
2014-05-23 04:38:52 +05:30
let NickTrack { lastMessageOn = lastMessageOn'
2014-05-23 04:56:26 +05:30
, lastMessage = lastMessage'
, nick = Nick lastMessageAs } = maximumByEx (comparing lastMessageOn) nickTracks
2014-05-23 04:38:52 +05:30
2014-05-25 15:52:15 +05:30
return $
(if any (`member` onlineNicks) . map nick $ nickTracks
then nck ++ " is online now"
else nck ++ " was last seen on " ++ fmtTime lastSeenOn') ++
2014-05-25 14:51:33 +05:30
(if nck /= lastSeenAs then " as " ++ lastSeenAs else "") ++
2014-05-23 12:21:38 +05:30
(if clean lastMessage' == "" then "" else
2014-05-25 14:51:33 +05:30
" and at " ++ fmtTime lastMessageOn' ++ " " ++ nck ++
(if nck /= lastMessageAs then " as " ++ lastMessageAs else "") ++
2014-05-23 12:21:38 +05:30
" said: " ++ lastMessage')
2014-05-23 04:38:52 +05:30
where
fmtTime = pack . formatTime defaultTimeLocale "%F %T"
2014-05-25 14:51:33 +05:30
stopNickTracker :: MonadMsgHandler m => IORef NickTrackingState -> m ()
2014-05-23 12:21:38 +05:30
stopNickTracker state = io $ do
2014-05-25 14:51:33 +05:30
NickTrackingState { .. } <- readIORef state
2014-05-23 02:45:45 +05:30
createArchive acid
createCheckpointAndClose acid
mkMsgHandler :: BotConfig -> Chan SomeEvent -> MsgHandlerName -> IO (Maybe MsgHandler)
mkMsgHandler BotConfig { .. } _ "nicktracker" = do
2014-05-25 14:51:33 +05:30
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)
2014-05-23 02:45:45 +05:30
return . Just $ newMsgHandler { onMessage = nickTrackerMsg state
, onStop = stopNickTracker state
2014-05-24 23:49:52 +05:30
, onHelp = return helpMsgs }
2014-05-23 02:45:45 +05:30
where
2014-05-23 04:38:52 +05:30
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>") ]
2014-05-23 04:56:26 +05:30
mkMsgHandler _ _ _ = return Nothing