Added forget nicks command, fuzzy time in replies
This commit is contained in:
parent
a055a3d474
commit
a3231878b0
@ -115,7 +115,7 @@ messageProcessLoop = messageProcessLoop' 0
|
||||
mLine <- readLine lineChan
|
||||
case mLine of
|
||||
Timeout ->
|
||||
getCurrentTime >>= \t -> dispatchHandlers bot (Message t "" IdleMsg) >> return Idle
|
||||
getCurrentTime >>= \t -> dispatchHandlers bot (Message t "" IdleMsg) >> return Idle
|
||||
EOF -> infoM "Connection closed" >> return Disconnected
|
||||
Line _ _ -> error "This should never happen"
|
||||
Msg (message@Message { .. }) -> do
|
||||
|
||||
@ -2,11 +2,15 @@
|
||||
|
||||
module Network.IRC.Util where
|
||||
|
||||
import qualified Data.Text.Lazy as LzT
|
||||
import qualified Data.Text.Format as TF
|
||||
|
||||
import ClassyPrelude
|
||||
import Control.Arrow (Arrow)
|
||||
import Control.Concurrent.Lifted (Chan)
|
||||
import Control.Monad.Base (MonadBase)
|
||||
import Data.Text (strip)
|
||||
import Data.Time (diffUTCTime)
|
||||
|
||||
oneSec :: Int
|
||||
oneSec = 1000000
|
||||
@ -42,3 +46,39 @@ 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)
|
||||
|
||||
-- | Display a time span as one time relative to another.
|
||||
relativeTime :: UTCTime -> UTCTime -> Text
|
||||
relativeTime t1 t2 =
|
||||
maybe "unknown" (LzT.toStrict . format) $ find (\(s,_,_) -> abs period >= s) ranges
|
||||
where
|
||||
minute = 60; hour = minute * 60; day = hour * 24;
|
||||
week = day * 7; month = day * 30; year = month * 12
|
||||
|
||||
format range =
|
||||
(if period > 0 then "in " else "")
|
||||
++ case range of
|
||||
(0, _, _) -> "moments"
|
||||
(_, str, 0) -> pack str
|
||||
(_, str, base) -> TF.format (fromString str) $ TF.Only (abs $ round (period / base) :: Integer)
|
||||
++ (if period < 0 then " ago" else "")
|
||||
|
||||
period = t1 `diffUTCTime` t2
|
||||
|
||||
ranges = [(year*2, "{} years", year)
|
||||
,(year, "a year", 0)
|
||||
,(month*2, "{} months", month)
|
||||
,(month, "a month", 0)
|
||||
,(week*2, "{} weeks", week)
|
||||
,(week, "a week", 0)
|
||||
,(day*2, "{} days", day)
|
||||
,(day, "a day", 0)
|
||||
,(hour*4, "{} hours", hour)
|
||||
,(hour*3, "a few hours", 0)
|
||||
,(hour*2, "{} hours", hour)
|
||||
,(hour, "an hour", 0)
|
||||
,(minute*31, "{} minutes", minute)
|
||||
,(minute*30, "half an hour", 0)
|
||||
,(minute*2, "{} minutes", minute)
|
||||
,(minute, "a minute", 0)
|
||||
,(0, "{} seconds", 1)
|
||||
]
|
||||
|
||||
@ -23,34 +23,37 @@ 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
|
||||
getByNickQ :: Nick -> Query NickTracking (Maybe NickTrack)
|
||||
getByNickQ nick = do
|
||||
NickTracking { .. } <- ask
|
||||
return . getOne $ nickTracking @= nick
|
||||
|
||||
getByCanonicalNick :: CanonicalNick -> Query NickTracking [NickTrack]
|
||||
getByCanonicalNick canonicalNick = do
|
||||
getByCanonicalNickQ :: CanonicalNick -> Query NickTracking [NickTrack]
|
||||
getByCanonicalNickQ canonicalNick = do
|
||||
NickTracking { .. } <- ask
|
||||
return . IS.toList $ nickTracking @= canonicalNick
|
||||
|
||||
saveNickTrack :: NickTrack -> Update NickTracking ()
|
||||
saveNickTrack nt = do
|
||||
saveNickTrackQ :: NickTrack -> Update NickTracking ()
|
||||
saveNickTrackQ nt = do
|
||||
NickTracking { .. } <- get
|
||||
put . NickTracking $ IS.updateIx (nick nt) nt nickTracking
|
||||
|
||||
$(makeAcidic ''NickTracking ['getByNick, 'getByCanonicalNick, 'saveNickTrack])
|
||||
$(makeAcidic ''NickTracking ['getByNickQ, 'getByCanonicalNickQ, 'saveNickTrackQ])
|
||||
|
||||
getByNick :: AcidState NickTracking -> Text -> IO (Maybe NickTrack)
|
||||
getByNick acid = query acid . GetByNickQ . Nick
|
||||
|
||||
saveNickTrack :: AcidState NickTracking -> NickTrack -> IO ()
|
||||
saveNickTrack acid = update acid . SaveNickTrackQ
|
||||
|
||||
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
|
||||
nickTrackerMsg state message@Message { .. } = case msgDetails of
|
||||
ChannelMsg { .. } -> updateNickTrack state user msg msgTime >> handleCommands
|
||||
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
|
||||
@ -69,39 +72,40 @@ nickTrackerMsg state Message { .. } = case msgDetails of
|
||||
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 $
|
||||
modifyOnlineNicks f = atomicModIORef state $ \s -> s { onlineNicks = f . onlineNicks $ s }
|
||||
add = modifyOnlineNicks . flip ((. (Nick . userNick)) . flip insertSet)
|
||||
remove = modifyOnlineNicks . flip ((. (Nick . userNick)) . flip deleteSet)
|
||||
swap users = modifyOnlineNicks $
|
||||
let (oNick, nNick) = both (Nick . userNick) users
|
||||
in deleteSet oNick . insertSet nNick
|
||||
refresh = atomicModIORef state . modifyOnlineNicks . const . setFromList . map Nick
|
||||
refresh = modifyOnlineNicks . const . setFromList . map Nick
|
||||
|
||||
commands = [ ("!nick", handleNickCommand)
|
||||
, ("!seen", handleSeenCommand) ]
|
||||
commands = [ ("!nick", handleNickCommand)
|
||||
, ("!seen", handleSeenCommand)
|
||||
, ("!forgetnicks", handleForgetNicksCommand)]
|
||||
|
||||
handleCommands msg = case find ((`isPrefixOf` msg) . fst) commands of
|
||||
handleCommands = case find ((`isPrefixOf` msg msgDetails) . fst) commands of
|
||||
Nothing -> return Nothing
|
||||
Just (_, handler) -> handler state msg
|
||||
Just (_, handler) -> handler state message
|
||||
|
||||
updateNickTrack :: MonadMsgHandler m => IORef NickTrackingState -> User -> Text -> UTCTime -> m ()
|
||||
updateNickTrack state user message msgTime = io $ do
|
||||
NickTrackingState { .. } <- readIORef state
|
||||
let nck = userNick user
|
||||
mnt <- query acid . GetByNick $ Nick nck
|
||||
mnt <- getByNick acid nck
|
||||
(message', lastMessageOn', cn) <- case (message, mnt) of
|
||||
("", Just (NickTrack { .. })) -> return (lastMessage, lastMessageOn, canonicalNick)
|
||||
(_, Just (NickTrack { .. })) -> return (message, msgTime, canonicalNick)
|
||||
_ -> newCanonicalNick >>= \cn -> return (message, msgTime, cn)
|
||||
|
||||
update acid . SaveNickTrack $
|
||||
NickTrack (Nick nck) cn (LastSeenOn msgTime) lastMessageOn' message'
|
||||
saveNickTrack acid $ NickTrack (Nick nck) cn (LastSeenOn msgTime) lastMessageOn' message'
|
||||
|
||||
handleNickChange :: MonadMsgHandler m => IORef NickTrackingState -> User -> Text -> UTCTime -> m ()
|
||||
handleNickChange state user newNick msgTime = io $ do
|
||||
NickTrackingState { .. } <- readIORef state
|
||||
let prevNick = userNick user
|
||||
mpnt <- query acid . GetByNick $ Nick prevNick
|
||||
mnt <- query acid . GetByNick $ Nick newNick
|
||||
mpnt <- getByNick acid prevNick
|
||||
mnt <- getByNick acid newNick
|
||||
mInfo <- case (mpnt, mnt) of
|
||||
(Nothing, _) -> newCanonicalNick >>= \cn -> return $ Just ("", cn, msgTime)
|
||||
(Just pnt, Nothing) ->
|
||||
@ -112,49 +116,59 @@ handleNickChange state user newNick msgTime = io $ do
|
||||
_ -> return Nothing
|
||||
|
||||
whenJust mInfo $ \(message, cn, lastMessageOn') ->
|
||||
update acid . SaveNickTrack $
|
||||
NickTrack (Nick newNick) cn (LastSeenOn msgTime) lastMessageOn' message
|
||||
saveNickTrack acid $ NickTrack (Nick newNick) cn (LastSeenOn msgTime) lastMessageOn' message
|
||||
|
||||
newCanonicalNick :: IO CanonicalNick
|
||||
newCanonicalNick = map (CanonicalNick . pack . U.toString) U.nextRandom
|
||||
|
||||
withNickTracks :: MonadMsgHandler m
|
||||
=> (Text -> [NickTrack] -> HashSet Nick -> IO Text) -> IORef NickTrackingState -> Text
|
||||
=> (Text -> [NickTrack] -> HashSet Nick -> IO Text) -> IORef NickTrackingState -> Message
|
||||
-> m (Maybe Command)
|
||||
withNickTracks f state msg = io $ do
|
||||
withNickTracks f state message = io $ do
|
||||
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) >>= \nts -> f nick nts onlineNicks
|
||||
let nick = clean . unwords . drop 1 . words . msg . msgDetails $ message
|
||||
if nick == ""
|
||||
then return Nothing
|
||||
else do
|
||||
mcn <- liftM (map canonicalNick) . getByNick acid $ nick
|
||||
map (Just . ChannelMsgReply) $ case mcn of
|
||||
Nothing -> return $ "Unknown nick: " ++ nick
|
||||
Just cn -> io $ query acid (GetByCanonicalNickQ cn) >>= \nts -> f nick nts onlineNicks
|
||||
|
||||
handleNickCommand :: MonadMsgHandler m => IORef NickTrackingState -> Text -> m (Maybe Command)
|
||||
handleNickCommand :: MonadMsgHandler m => IORef NickTrackingState -> Message -> 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 NickTrackingState -> Text -> m (Maybe Command)
|
||||
handleSeenCommand :: MonadMsgHandler m => IORef NickTrackingState -> Message -> 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
|
||||
|
||||
now <- io getCurrentTime
|
||||
return $
|
||||
(if any (`member` onlineNicks) . map nick $ nickTracks
|
||||
then nck ++ " is online now"
|
||||
else nck ++ " was last seen on " ++ fmtTime lastSeenOn') ++
|
||||
else nck ++ " was last seen " ++ relativeTime lastSeenOn' now) ++
|
||||
(if nck /= lastSeenAs then " as " ++ lastSeenAs else "") ++
|
||||
(if clean lastMessage' == "" then "" else
|
||||
" and at " ++ fmtTime lastMessageOn' ++ " " ++ nck ++
|
||||
" and " ++ relativeTime lastMessageOn' now ++ " " ++ nck ++
|
||||
(if nck /= lastMessageAs then " as " ++ lastMessageAs else "") ++
|
||||
" said: " ++ lastMessage')
|
||||
where
|
||||
fmtTime = pack . formatTime defaultTimeLocale "%F %T"
|
||||
|
||||
handleForgetNicksCommand :: MonadMsgHandler m => IORef NickTrackingState -> Message -> m (Maybe Command)
|
||||
handleForgetNicksCommand state Message { msgDetails = ~ChannelMsg { .. }, .. } = do
|
||||
NickTrackingState { .. } <- readIORef state
|
||||
let nick = userNick user
|
||||
io $ do
|
||||
Just nt <- getByNick acid nick
|
||||
cn <- newCanonicalNick
|
||||
saveNickTrack acid $ nt { canonicalNick = cn }
|
||||
return . Just . ChannelMsgReply $ "Forgot all alternate nicks of " ++ nick
|
||||
|
||||
stopNickTracker :: MonadMsgHandler m => IORef NickTrackingState -> m ()
|
||||
stopNickTracker state = io $ do
|
||||
@ -169,7 +183,6 @@ mkMsgHandler BotConfig { .. } _ "nicktracker" = do
|
||||
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 }
|
||||
|
||||
Loading…
Reference in New Issue
Block a user