Added forget nicks command, fuzzy time in replies

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

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)
+             ]

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)
+getByNickQ :: Nick -> Query NickTracking (Maybe NickTrack)
-getByNick nick = do
+getByNickQ nick = do
   NickTracking { .. } <- ask
   return . getOne $ nickTracking @= nick
 
-getByCanonicalNick :: CanonicalNick -> Query NickTracking [NickTrack]
+getByCanonicalNickQ :: CanonicalNick -> Query NickTracking [NickTrack]
-getByCanonicalNick canonicalNick = do
+getByCanonicalNickQ canonicalNick = do
   NickTracking { .. } <- ask
   return . IS.toList $ nickTracking @= canonicalNick
 
-saveNickTrack :: NickTrack -> Update NickTracking ()
+saveNickTrackQ :: NickTrack -> Update NickTracking ()
-saveNickTrack nt = do
+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
+nickTrackerMsg state message@Message { .. } = case msgDetails of
-  ChannelMsg { .. } -> updateNickTrack state user msg msgTime >> handleCommands msg
+  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)
+    modifyOnlineNicks f = atomicModIORef state $ \s -> s { onlineNicks = f . onlineNicks $ s }
-    remove     = atomicModIORef state . modifyOnlineNicks . flip ((. (Nick . userNick)) . flip deleteSet)
+    add        = modifyOnlineNicks . flip ((. (Nick . userNick)) . flip insertSet)
-    swap users = atomicModIORef state . modifyOnlineNicks $
+    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)
+    commands = [ ("!nick",        handleNickCommand)
-               , ("!seen", handleSeenCommand) ]
+               , ("!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 $
+  saveNickTrack acid $ NickTrack (Nick nck) cn (LastSeenOn msgTime) lastMessageOn' message'
-    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
+  mpnt         <- getByNick acid prevNick
-  mnt          <- query acid . GetByNick $ Nick newNick
+  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 $
+    saveNickTrack acid $ NickTrack (Nick newNick) cn (LastSeenOn msgTime) lastMessageOn' message
-      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
+  let nick = clean . unwords . drop 1 . words . msg . msgDetails $ message
-  mcn            <- liftM (map canonicalNick) . query acid . GetByNick $ Nick nick
+  if nick == ""
-  map (Just . ChannelMsgReply) $ case mcn of
+    then return Nothing
-    Nothing -> return $ "Unknown nick: " ++ nick
+    else do
-    Just cn -> io $ query acid (GetByCanonicalNick cn) >>= \nts -> f nick nts onlineNicks
+      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 }