diff --git a/hask-irc-core/Network/IRC/Bot.hs b/hask-irc-core/Network/IRC/Bot.hs index f92839e..a62d887 100644 --- a/hask-irc-core/Network/IRC/Bot.hs +++ b/hask-irc-core/Network/IRC/Bot.hs @@ -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 diff --git a/hask-irc-core/Network/IRC/Util.hs b/hask-irc-core/Network/IRC/Util.hs index f8d3ab5..b402f4d 100644 --- a/hask-irc-core/Network/IRC/Util.hs +++ b/hask-irc-core/Network/IRC/Util.hs @@ -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) + ] diff --git a/hask-irc-handlers/Network/IRC/Handlers/NickTracker.hs b/hask-irc-handlers/Network/IRC/Handlers/NickTracker.hs index 712fad5..08b77f4 100644 --- a/hask-irc-handlers/Network/IRC/Handlers/NickTracker.hs +++ b/hask-irc-handlers/Network/IRC/Handlers/NickTracker.hs @@ -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 }