Expand the /who command

glirc.cabal

@@ -125,6 +125,7 @@ library
     Client.State.Network
     Client.State.Window
     Client.UserHost
+    Client.WhoReply
     Client.View
     Client.View.Cert
     Client.View.ChannelList
@@ -140,6 +141,7 @@ library
     Client.View.RtsStats
     Client.View.UrlSelection
     Client.View.UserList
+    Client.View.Who
     Client.View.Windows
 
   other-modules:

lib/src/Irc/UserInfo.hs

@@ -32,14 +32,14 @@ import qualified Data.Text as Text
 
 import           Irc.Identifier
 
--- | 'UserInfo' packages a nickname along with the username and hsotname
+-- | 'UserInfo' packages a nickname along with the username and hostname
 -- if they are known in the current context.
 data UserInfo = UserInfo
   { userNick :: {-# UNPACK #-} !Identifier   -- ^ nickname
   , userName :: {-# UNPACK #-} !Text -- ^ username, empty when missing
   , userHost :: {-# UNPACK #-} !Text -- ^ hostname, empty when missing
   }
-  deriving (Eq, Read, Show)
+  deriving (Eq, Ord, Read, Show)
 
 -- | Lens into 'userNick' field.
 uiNick :: Functor f => (Identifier -> f Identifier) -> UserInfo -> f UserInfo

src/Client/Commands/Queries.hs

@@ -15,8 +15,10 @@ import Client.Commands.Arguments.Spec (optionalArg, remainingArg, simpleToken, e
 import Client.Commands.TabCompletion (noNetworkTab, simpleNetworkTab)
 import Client.Commands.Types (commandSuccess, commandSuccessUpdateCS, Command(Command), CommandImpl(NetworkCommand), CommandSection(CommandSection), NetworkCommand)
 import Client.State (changeSubfocus, ClientState)
-import Client.State.Focus (Subfocus(FocusChanList))
-import Client.State.Network (sendMsg, csChannelList, clsElist, csPingStatus, _PingConnecting)
+import Client.State.Focus (Subfocus(FocusChanList, FocusWho))
+import Client.State.Network (sendMsg, csChannelList, clsElist, csPingStatus, _PingConnecting, csWhoReply)
+import Client.WhoReply (newWhoReply)
+import Control.Applicative (liftA2)
 import Control.Lens (has, set, view)
 import Control.Monad (unless)
 import Data.Maybe (fromMaybe, maybeToList)
@@ -28,8 +30,8 @@ queryCommands = CommandSection "Queries"
 
   [ Command
       (pure "who")
-      (remainingArg "arguments")
-      "Send WHO query to server with given arguments.\n"
+      (optionalArg (liftA2 (,) (simpleToken "[channel|nick|mask]") (optionalArg (simpleToken "[options]"))))
+      "Send WHO query to server with given arguments, or just show the who view.\n"
     $ NetworkCommand cmdWho simpleNetworkTab
 
   , Command
@@ -254,10 +256,15 @@ cmdWhois cs st rest =
   do sendMsg cs (ircWhois (Text.pack <$> words rest))
      commandSuccess st
 
-cmdWho :: NetworkCommand String
-cmdWho cs st rest =
-  do sendMsg cs (ircWho (Text.pack <$> words rest))
-     commandSuccess st
+cmdWho :: NetworkCommand (Maybe (String, Maybe String))
+cmdWho _  st Nothing = commandSuccess (changeSubfocus FocusWho st)
+cmdWho cs st (Just (query, arg)) =
+  do
+    let query' = Text.pack query
+    let arg' = fromMaybe "" arg
+    let cs' = set csWhoReply (newWhoReply query' arg') cs
+    sendMsg cs (ircWho (query' : (maybeToList $ Text.pack <$> arg)))
+    commandSuccessUpdateCS cs' (changeSubfocus FocusWho st)
 
 cmdWhowas :: NetworkCommand String
 cmdWhowas cs st rest =

src/Client/Image/Message.hs

@@ -26,7 +26,7 @@ module Client.Image.Message
   , timeImage
   , drawWindowLine
   , modesImage
-
+  , prettyTime
   , parseIrcTextWithNicks
   , Highlight(..)
   ) where

src/Client/Image/StatusLine.hs

@@ -387,6 +387,7 @@ viewSubfocusLabel pal subfocus =
     FocusRtsStats     -> Just $ string (view palLabel pal) "rtsstats"
     FocusCert{}       -> Just $ string (view palLabel pal) "cert"
     FocusChanList _ _ -> Just $ string (view palLabel pal) "channels"
+    FocusWho          -> Just $ string (view palLabel pal) "who"
     FocusMasks m      -> Just $ mconcat
       [ string (view palLabel pal) "masks"
       , char defAttr ':'

src/Client/State.hs

@@ -134,6 +134,7 @@ import qualified Client.State.EditBox as Edit
 import           Client.State.Focus
 import           Client.State.Network
 import           Client.State.Window
+import           Client.WhoReply (WhoReplyItem, whoFilterText, whoUserInfo, whoItems, whoRealname)
 import           ContextFilter
 import           Control.Applicative
 import           Control.Concurrent.MVar
@@ -881,6 +882,8 @@ urlList st = urlFn st
     urlFn = case (network, subfocus) of
       (Just net, FocusChanList min' max') ->
         matchesTopic min' max' . view (clientConnections . at net)
+      (Just net, FocusWho) ->
+        matchesWhoReply . view (clientConnections . at net)
       (_, _) ->
         toListOf (clientWindows . ix focus . winMessages . each . folding matchesMsg)
     focus = view clientFocus st
@@ -891,11 +894,17 @@ urlList st = urlFn st
       | url <- concatMap urlMatches $ clientFilter st id [views wlText id wl]
       ]
     matchesTopic _ _ Nothing = []
-    matchesTopic min' max' (Just ct) =
-        [ (Just $! chan, url)
-        | (chan, _, topic) <- clientFilterChannels st min' max' $ view (csChannelList . clsItems) ct
-        , url <- urlMatches $ LText.fromStrict topic
-        ]
+    matchesTopic min' max' (Just cs) =
+      [ (Just $! chan, url)
+      | (chan, _, topic) <- clientFilterChannels st min' max' $ view (csChannelList . clsItems) cs
+      , url <- urlMatches $ LText.fromStrict topic
+      ]
+    matchesWhoReply Nothing = []
+    matchesWhoReply (Just cs) =
+      [ (Just $! userNick $ view whoUserInfo wri, url)
+      | wri <- clientFilter st whoFilterText $ view (csWhoReply . whoItems) cs
+      , url <- urlMatches $ LText.fromStrict $ view whoRealname wri
+      ]
 
 -- | Remove a network connection and unlink it from the network map.
 -- This operation assumes that the network connection exists and should

src/Client/State/Focus.hs

@@ -56,6 +56,7 @@ data Subfocus
   | FocusIgnoreList  -- ^ Show ignored masks
   | FocusCert        -- ^ Show rendered certificate
   | FocusChanList (Maybe Int) (Maybe Int) -- ^ Show channel list
+  | FocusWho -- ^ Show last reply to a WHO query
   deriving (Eq,Show)
 
 -- | Unfocused first, followed by focuses sorted by network.

src/Client/State/Network.hs

@@ -28,6 +28,7 @@ module Client.State.Network
   , csNick
   , csChannels
   , csChannelList
+  , csWhoReply
   , csSocket
   , csModeTypes
   , csChannelTypes
@@ -93,6 +94,7 @@ import Client.Hooks (messageHooks)
 import Client.Network.Async (abortConnection, send, NetworkConnection, TerminationReason(PingTimeout))
 import Client.State.Channel
 import Client.UserHost (UserAndHost(UserAndHost, _uhAccount))
+import Client.WhoReply
 import Control.Lens
 import Data.Bits (Bits((.&.)))
 import Data.ByteString qualified as B
@@ -126,6 +128,7 @@ import System.Random qualified as Random
 data NetworkState = NetworkState
   { _csChannels     :: !(HashMap Identifier ChannelState) -- ^ joined channels
   , _csChannelList  :: !ChannelList -- ^ cached ELIST parameter and /list output
+  , _csWhoReply     :: !WhoReply -- ^ cached reply from the last WHO query
   , _csSocket       :: !NetworkConnection -- ^ network socket
   , _csModeTypes    :: !ModeTypes -- ^ channel mode meanings
   , _csUmodeTypes   :: !ModeTypes -- ^ user mode meanings
@@ -202,6 +205,7 @@ data Transaction
   | CapLsTransaction [(Text, Maybe Text)]
   deriving Show
 
+
 makeLenses ''NetworkState
 makeLenses ''ChannelList
 makePrisms ''Transaction
@@ -298,6 +302,7 @@ newNetworkState network settings sock ping seed = NetworkState
   { _csUserInfo     = UserInfo "*" "" ""
   , _csChannels     = HashMap.empty
   , _csChannelList  = newChannelList Nothing Nothing
+  , _csWhoReply     = finishWhoReply $ newWhoReply "" ""
   , _csSocket       = sock
   , _csChannelTypes = defaultChannelTypes
   , _csModeTypes    = defaultModeTypes
@@ -414,6 +419,7 @@ applyMessage' msgWhen msg cs =
         noReply (set (csUserInfo . uiHost) host cs)
 
     -- /who <#channel> %tuhna,616
+    -- TODO: Use a different magic token here?
     Reply _ RPL_WHOSPCRPL [_me,"616",user,host,nick,acct] ->
        let acct' = if acct == "0" then "*" else acct
        in noReply (recordUser (UserInfo (mkId nick) user host) acct' cs)
@@ -630,14 +636,15 @@ doRpl cmd msgWhen args cs =
       case args of
         _me:_tgt:uname:host:_server:nick:_ ->
           noReply $
+          over csWhoReply (recordWhoReply args) $
           over csTransaction (\t ->
             let !x  = UserInfo (mkId nick) uname host
                 !xs = view _WhoTransaction t
             in WhoTransaction (x : xs))
             cs
         _ -> noReply cs
-
-    RPL_ENDOFWHO -> noReply (massRegistration cs)
+    RPL_WHOSPCRPL -> noReply (over csWhoReply (recordWhoXReply args) cs)
+    RPL_ENDOFWHO -> noReply (over csWhoReply finishWhoReply $ massRegistration cs)
 
     RPL_CHANNELMODEIS ->
       case args of

src/Client/View.hs

@@ -30,34 +30,39 @@ import Client.View.Palette (paletteViewLines)
 import Client.View.RtsStats (rtsStatsLines)
 import Client.View.UrlSelection (urlSelectionView)
 import Client.View.UserList (userInfoImages, userListImages)
+import Client.View.Who (whoLines)
 import Client.View.Windows (windowsImages)
 import Control.Lens (view)
 
 viewLines :: Focus -> Subfocus -> Int -> ClientState -> [Image']
 viewLines focus subfocus w !st =
-  case (focus, subfocus) of
+  case (network', channel', subfocus) of
     _ | Just ("url",arg) <- clientActiveCommand st ->
       urlSelectionView w focus arg st
-    (ChannelFocus network channel, FocusInfo) ->
+    (Just network, Just channel, FocusInfo) ->
       channelInfoImages network channel st
-    (ChannelFocus network channel, FocusUsers)
+    (Just network, Just channel, FocusUsers)
       | view clientDetailView st -> userInfoImages network channel st
       | otherwise                -> userListImages network channel w st
-    (ChannelFocus network channel, FocusMasks mode) ->
+    (Just network, Just channel, FocusMasks mode) ->
       maskListImages mode network channel w st
-    (_, FocusWindows filt) -> windowsImages filt st
-    (_, FocusMentions)     -> mentionsViewLines w st
-    (_, FocusPalette)      -> paletteViewLines pal
-    (_, FocusDigraphs)     -> digraphLines w st
-    (_, FocusKeyMap)       -> keyMapLines st
-    (_, FocusHelp mb)      -> helpImageLines st mb pal
-    (_, FocusRtsStats)     -> rtsStatsLines (view clientRtsStats st) pal
-    (_, FocusIgnoreList)   -> ignoreListLines (view clientIgnores st) pal
-    (_, FocusCert)         -> certViewLines st
-    (ChannelFocus network _, FocusChanList min' max') ->
-      channelListLines network w st (min', max')
-    (NetworkFocus network  , FocusChanList min' max') ->
+    (_, _, FocusWindows filt) -> windowsImages filt st
+    (_, _, FocusMentions)     -> mentionsViewLines w st
+    (_, _, FocusPalette)      -> paletteViewLines pal
+    (_, _, FocusDigraphs)     -> digraphLines w st
+    (_, _, FocusKeyMap)       -> keyMapLines st
+    (_, _, FocusHelp mb)      -> helpImageLines st mb pal
+    (_, _, FocusRtsStats)     -> rtsStatsLines (view clientRtsStats st) pal
+    (_, _, FocusIgnoreList)   -> ignoreListLines (view clientIgnores st) pal
+    (_, _, FocusCert)         -> certViewLines st
+    (Just network, _, FocusChanList min' max') ->
       channelListLines network w st (min', max')
+    (Just network, _, FocusWho) ->
+      whoLines network w st
     _ -> chatMessageImages focus w st
   where
+    (network', channel') = case focus of
+      Unfocused -> (Nothing, Nothing)
+      NetworkFocus network -> (Just network, Nothing)
+      ChannelFocus network channel -> (Just network, Just channel)
     pal = clientPalette st

src/Client/View/ChannelList.hs

@@ -43,8 +43,8 @@ channelListLines' ::
   NetworkState ->
   Int -> ClientState -> (Maybe Int, Maybe Int) -> [Image']
 channelListLines' cs width st (min', max')
-  | chanList^.clsDone = countImage : images
-  | otherwise = countImagePending : images
+  | chanList^.clsDone = countImage <> queryPart : images
+  | otherwise = countImagePending <> queryPart : images
   where
     chanList = cs^.csChannelList
     els = chanList^.clsElist
@@ -54,8 +54,7 @@ channelListLines' cs width st (min', max')
     countImage = text' (view palLabel pal) "Channels (visible/total): " <>
                  string defAttr (show (length entries')) <>
                  char (view palLabel pal) '/' <>
-                 string defAttr (show (length entries)) <>
-                 queryPart
+                 string defAttr (show (length entries))
 
     queryPart = mconcat $
       [text' (view palLabel pal) " More-than: " <> string defAttr (show lo) | FocusChanList (Just lo) _ <- [st^.clientSubfocus]] ++

src/Client/View/Who.hs

@@ -0,0 +1,85 @@
+{-# Language OverloadedStrings #-}
+{-|
+Module      : Client.View.Who
+Description : Line renderer for /who replies
+Copyright   : (c) TheDaemoness, 2023
+License     : ISC
+Maintainer  : [email protected]
+
+This module renders the lines used in /who replies.
+-}
+module Client.View.Who ( whoLines ) where
+
+import           Client.Image.LineWrap (lineWrapPrefix)
+import           Client.Image.Message (IdentifierColorMode(NormalIdentifier), coloredIdentifier, coloredUserInfo, RenderMode (DetailedRender), prettyTime)
+import           Client.Image.PackedImage
+import           Client.Image.Palette
+import           Client.State
+import           Client.State.Network
+import           Client.WhoReply
+import           Control.Lens
+import           Data.Text (Text)
+import qualified Data.Text as Text
+import           Graphics.Vty.Attributes (defAttr)
+import           Irc.Identifier
+import qualified Data.HashMap.Strict as HashMap
+import Client.Image.MircFormatting (parseIrcText')
+
+-- |
+-- | Render the lines used by the @/who@ command in normal mode.
+whoLines ::
+  Text        {- ^ network           -} ->
+  Int         {- ^ window width      -} ->
+  ClientState {- ^ client state      -} ->
+  [Image']
+whoLines network width st =
+  -- TODO: This pattern exists in a few other views. Maybe deduplicate?
+  case preview (clientConnection network) st of
+    Just cs -> whoLines' cs width st
+    Nothing -> [text' (view palError pal) "No connection"]
+  where
+    pal = clientPalette st
+
+whoLines' :: NetworkState -> Int -> ClientState -> [Image']
+whoLines' cs width st
+  | Text.null $ view (csWhoReply . whoQuery . _1) cs = [text' (view palError pal) "No previous WHO query"]
+  | whorpl^.whoDone = countImage <> queryPart : images
+  | otherwise = countImagePending <> queryPart : images
+  where
+    pal = clientPalette st
+    whorpl = view csWhoReply cs
+    (query, arg) = view whoQuery whorpl
+    entries = view whoItems whorpl
+    entries' = clientFilter st whoFilterText entries
+
+    images = concatMap renderEntry entries'
+    renderEntry :: WhoReplyItem -> [Image']
+    renderEntry entry = reverse $ lineWrapPrefix width (renderPrefix entry) (renderSuffix entry)
+    -- Skipping rendering the channel because it doesn't add anything most of the time.
+    renderPrefix entry = coloredUserInfo pal DetailedRender HashMap.empty (view whoUserInfo entry)
+    renderSuffix :: WhoReplyItem -> Image'
+    renderSuffix entry = mconcat $ mapJoinWhoFields entry
+      (const mempty)
+      (label "$a:" . identifier)
+      (label "ip: " . text' defAttr)
+      (label "server: " . identifier)
+      (label "away" $ text' defAttr "")
+      (label "flags: " . text' (view palSigil pal))
+      (label "hops: " . string defAttr . show)
+      (label "idle: " . string defAttr . prettyTime 1)
+      (label "oplvl: " . text' defAttr)
+      (label "gecos: " . parseIrcText' False pal)
+
+    countImagePending = countImage <> text' (view palLabel pal) "..."
+    countImage = text' (view palLabel pal) "Users in " <>
+                 coloredIdentifier pal NormalIdentifier HashMap.empty (mkId query) <>
+                 text' (view palLabel pal) " (visible/total): " <>
+                 string defAttr (show (length entries')) <>
+                 char (view palLabel pal) '/' <>
+                 string defAttr (show (length entries))
+    queryPart = case arg of
+      Just txt | not (Text.null txt) -> label " Options: " $ text' defAttr txt
+      _ -> text' defAttr ""
+
+    label txt image = text' (view palLabel pal) txt <> image <> text' defAttr " "
+    identifier = coloredIdentifier pal NormalIdentifier HashMap.empty