From 0fd124535ae8005d712d5741dbe73e2e4e5b7bfa Mon Sep 17 00:00:00 2001 From: TheDaemoness Date: Mon, 14 Aug 2023 22:59:31 -0700 Subject: [PATCH 1/4] Implement initial verion of a /who view Known bug: your nick is not colored correctly. Documentation, /grep, and /url support are still todo. Also moves the loading elipses for /list next to the channel count. --- glirc.cabal | 2 + lib/src/Irc/UserInfo.hs | 4 +- src/Client/Commands/Queries.hs | 23 +++-- src/Client/Image/Message.hs | 2 +- src/Client/Image/StatusLine.hs | 1 + src/Client/State/Focus.hs | 1 + src/Client/State/Network.hs | 11 +- src/Client/View.hs | 37 ++++--- src/Client/View/ChannelList.hs | 7 +- src/Client/View/Who.hs | 93 +++++++++++++++++ src/Client/WhoReply.hs | 183 +++++++++++++++++++++++++++++++++ 11 files changed, 331 insertions(+), 33 deletions(-) create mode 100644 src/Client/View/Who.hs create mode 100644 src/Client/WhoReply.hs diff --git a/glirc.cabal b/glirc.cabal index 9e43895f..2ffabc4b 100644 --- a/glirc.cabal +++ b/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: diff --git a/lib/src/Irc/UserInfo.hs b/lib/src/Irc/UserInfo.hs index 4128d353..f8c2a350 100644 --- a/lib/src/Irc/UserInfo.hs +++ b/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 diff --git a/src/Client/Commands/Queries.hs b/src/Client/Commands/Queries.hs index 5d43bc50..f809caa7 100644 --- a/src/Client/Commands/Queries.hs +++ b/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 = diff --git a/src/Client/Image/Message.hs b/src/Client/Image/Message.hs index ab55a07c..ae8dc151 100644 --- a/src/Client/Image/Message.hs +++ b/src/Client/Image/Message.hs @@ -26,7 +26,7 @@ module Client.Image.Message , timeImage , drawWindowLine , modesImage - + , prettyTime , parseIrcTextWithNicks , Highlight(..) ) where diff --git a/src/Client/Image/StatusLine.hs b/src/Client/Image/StatusLine.hs index c7091ad6..04c58cef 100644 --- a/src/Client/Image/StatusLine.hs +++ b/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 ':' diff --git a/src/Client/State/Focus.hs b/src/Client/State/Focus.hs index 7cc40dff..b0e06cdf 100644 --- a/src/Client/State/Focus.hs +++ b/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. diff --git a/src/Client/State/Network.hs b/src/Client/State/Network.hs index 3c9c20a8..780ada64 100644 --- a/src/Client/State/Network.hs +++ b/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 diff --git a/src/Client/View.hs b/src/Client/View.hs index 5606961c..033cc8d5 100644 --- a/src/Client/View.hs +++ b/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 diff --git a/src/Client/View/ChannelList.hs b/src/Client/View/ChannelList.hs index c8fcae3a..5d9132af 100644 --- a/src/Client/View/ChannelList.hs +++ b/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]] ++ diff --git a/src/Client/View/Who.hs b/src/Client/View/Who.hs new file mode 100644 index 00000000..6458de07 --- /dev/null +++ b/src/Client/View/Who.hs @@ -0,0 +1,93 @@ +{-# Language OverloadedStrings #-} +{-| +Module : Client.View.Who +Description : Line renderer for /who replies +Copyright : (c) TheDaemoness, 2023 +License : ISC +Maintainer : emertens@gmail.com + +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' = entries + images = concatMap renderEntry entries' + + label txt image = text' (view palLabel pal) txt <> image <> text' defAttr " " + identifier = coloredIdentifier pal NormalIdentifier HashMap.empty + 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 $ + [label "acct: " $ identifier acct | + acct <- [view whoAcct entry], idText acct /= "0"] ++ + [label "ip: " $ text' defAttr ip | + ip <- [view whoIp entry], ip /= "255.255.255.255"] ++ + [label "server: " $ identifier sid | + sid <- [view whoServer entry], not (Text.null $ idText sid)] ++ + [label "away" $ text' defAttr "" | + (view whoAway entry) == Just True] ++ + [label "flags: " $ text' defAttr flags | + flags <- [view whoMiscFlags entry], not (Text.null flags)] ++ + [label "hops: " $ string defAttr (show hops) | + Just hops <- [view whoHops entry]] ++ + [label "idle: " $ string defAttr (prettyTime 1 idle) | + idle <- [view whoIdleSecs entry], not (null idle)] ++ + [label "oplvl: " $ text' defAttr lvl | + lvl <- [view whoOpLvl entry], lvl /= "n/a"] ++ + [label "gecos: " $ parseIrcText' False pal real | + real <- [view whoRealname entry], not (Text.null real)] + + 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 "" diff --git a/src/Client/WhoReply.hs b/src/Client/WhoReply.hs new file mode 100644 index 00000000..0e155d47 --- /dev/null +++ b/src/Client/WhoReply.hs @@ -0,0 +1,183 @@ +{-# Language TemplateHaskell, OverloadedStrings, BangPatterns #-} + +{-| +Module : Client.WhoReply +Description : Parsed replies from WHO +Copyright : (c) TheDaemoness, 2023 +License : ISC +Maintainer : emertens@gmail.com + +Because WHOX allows for a LOT of fiddliness regarding parameters, +this is extracted from Client.State.Network and given its own module. +-} + +module Client.WhoReply + ( WhoReply + , WhoReplyItem + , newWhoReply + , finishWhoReply + , recordWhoReply + , recordWhoXReply + + -- Lenses + , whoQuery + , whoFields + , whoToken + , whoDone + , whoItems + , whoChan + , whoUserInfo + , whoIp + , whoServer + , whoAway + , whoMiscFlags + , whoHops + , whoIdleSecs + , whoAcct + , whoOpLvl + , whoRealname + ) where + +import Control.Lens +import Control.Lens.Unsound (lensProduct) -- Don't worry about it. Ctrl+F SOUNDNESS. +import Data.List (sort) +import Data.Set (Set) +import qualified Data.Set as Set +import Data.Text (Text) +import qualified Data.Text as Text +import Irc.Identifier +import Irc.UserInfo +import Text.Read (readMaybe) + +data WhoReply = WhoReply + { _whoQuery :: !(Text, Maybe Text) + , _whoFields :: !(Set Char) + , _whoToken :: !String + , _whoDone :: !Bool + , _whoItems :: ![WhoReplyItem] + } + +data WhoReplyItem = WhoReplyItem + { _whoChan :: !Identifier + , _whoUserInfo :: !UserInfo + , _whoIp :: !Text -- We don't have iproute; (Maybe IP) would be nice here. + , _whoServer :: !Identifier + , _whoAway :: !(Maybe Bool) + , _whoMiscFlags :: !Text + , _whoHops :: !(Maybe Int) + , _whoIdleSecs :: !String -- This can be a Maybe Int, but prettyTime takes a String. + , _whoAcct :: !Identifier + , _whoOpLvl :: !Text + , _whoRealname :: !Text + } deriving (Eq, Ord) + +makeLenses ''WhoReply +makeLenses ''WhoReplyItem + +newWhoReply :: Text -> String -> WhoReply +newWhoReply query "" = WhoReply + { _whoQuery = (query, Nothing) + , _whoToken = "" + , _whoFields = Set.empty + , _whoDone = False + , _whoItems = [] + } +newWhoReply query ('%':arg) = WhoReply + { _whoQuery = (query, Just $ Text.pack ('%':arg)) + , _whoToken = token + , _whoFields = fieldSet + , _whoDone = False + , _whoItems = [] + } + where + fieldSet = Set.fromList fields + (fields, token) = break (== ',') arg +newWhoReply query arg = WhoReply + { _whoQuery = (query, Just $ Text.pack arg) + , _whoToken = "" + , _whoFields = Set.empty + , _whoDone = False + , _whoItems = [] + } + +splitFlags :: String -> (Maybe Bool, Text) +splitFlags ('G':rest) = (Just True, Text.pack rest) +splitFlags ('H':rest) = (Just False, Text.pack rest) +splitFlags rest = (Nothing, Text.pack rest) + +newWhoReplyItem :: WhoReplyItem +newWhoReplyItem = WhoReplyItem + { _whoChan = mkId "*" + , _whoUserInfo = UserInfo + { userNick = mkId "" + , userName = "" + , userHost = "" + } + , _whoIp = "255.255.255.255" + , _whoServer = "" + , _whoAway = Nothing + , _whoMiscFlags = "" + , _whoHops = Nothing + , _whoIdleSecs = "" + , _whoAcct = "0" + , _whoOpLvl = "n/a" + , _whoRealname = "" + } + +finishWhoReply :: WhoReply -> WhoReply +finishWhoReply wr = wr { _whoDone = True, _whoItems = sort (_whoItems wr) } + +recordWhoReply :: [Text] -> WhoReply -> WhoReply +recordWhoReply [_, chan, uname, host, server, nick, flags, hcrn] reply + | _whoDone reply = reply + | otherwise = reply { _whoItems = wri:_whoItems reply} + where + wri = newWhoReplyItem + { _whoChan = mkId chan + , _whoUserInfo = UserInfo { userNick = mkId nick, userName = uname, userHost = host } + , _whoServer = mkId server + , _whoAway = away + , _whoMiscFlags = miscFlags + , _whoHops = readMaybe $ Text.unpack hops + , _whoRealname = Text.stripStart realname + } + (hops, realname) = Text.break (== ' ') hcrn + (away, miscFlags) = splitFlags $ Text.unpack flags +recordWhoReply _ reply = reply + +-- | Field names for WHOX replies in order, excluding 't'. +whoXReplyFields :: [Char] +whoXReplyFields = "cuihsnfdlaor" + +recordWhoXReply :: [Text] -> WhoReply -> WhoReply +recordWhoXReply [] reply = reply +recordWhoXReply (_:args) reply + | _whoDone reply = reply + | _whoToken reply == "" = withWri args + | null args = reply + | _whoToken reply == Text.unpack (head args) = withWri $ tail args + | otherwise = reply + where + fields = filter ((flip Set.member) (_whoFields reply)) whoXReplyFields + withWri args' = reply { _whoItems = recordWhoXReply' (zip args' fields) newWhoReplyItem:_whoItems reply} + +recordWhoXReply' :: [(Text, Char)] -> WhoReplyItem -> WhoReplyItem +recordWhoXReply' [] = id +recordWhoXReply' ((arg, kind):rest) = recordWhoXReply' rest . updateFn + where + updateFn = case kind of + 'a' -> set whoAcct (mkId arg) + 'c' -> set whoChan (mkId arg) + 'd' -> set whoHops (readMaybe $ Text.unpack arg) + -- SOUNDNESS: whoAway and whoMiscFlags project disjoint parts of WhoReplyItem + 'f' -> set (lensProduct whoAway whoMiscFlags) flagsSplit + 'h' -> set (whoUserInfo . uiHost) arg + 'i' -> set whoIp arg + 'l' -> set whoIdleSecs (Text.unpack arg) + 'n' -> set (whoUserInfo . uiNick) (mkId arg) + 'o' -> set whoOpLvl arg + 'r' -> set whoRealname arg + 's' -> set whoServer (mkId arg) + 'u' -> set (whoUserInfo . uiName) arg + _ -> id + flagsSplit = splitFlags $ Text.unpack arg From efb0147b5b53f1b05a33dec2ef6a5d2843deb501 Mon Sep 17 00:00:00 2001 From: TheDaemoness Date: Tue, 15 Aug 2023 09:53:38 -0700 Subject: [PATCH 2/4] Improve who view Added /grep support. Account is now displayed as $a:accountname. Flags now get the sigils color. Reversed who reply item order. --- src/Client/View/Who.hs | 79 +++++++++++++++++++++++++++++------------- src/Client/WhoReply.hs | 2 +- 2 files changed, 55 insertions(+), 26 deletions(-) diff --git a/src/Client/View/Who.hs b/src/Client/View/Who.hs index 6458de07..9096adc4 100644 --- a/src/Client/View/Who.hs +++ b/src/Client/View/Who.hs @@ -11,7 +11,7 @@ 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.Message (IdentifierColorMode(NormalIdentifier), coloredIdentifier, coloredUserInfo, RenderMode (DetailedRender), prettyTime, cleanText) import Client.Image.PackedImage import Client.Image.Palette import Client.State @@ -20,8 +20,10 @@ import Client.WhoReply import Control.Lens import Data.Text (Text) import qualified Data.Text as Text +import qualified Data.Text.Lazy as LText import Graphics.Vty.Attributes (defAttr) import Irc.Identifier +import Irc.UserInfo (renderUserInfo) import qualified Data.HashMap.Strict as HashMap import Client.Image.MircFormatting (parseIrcText') @@ -50,35 +52,37 @@ whoLines' cs width st whorpl = view csWhoReply cs (query, arg) = view whoQuery whorpl entries = view whoItems whorpl - entries' = entries - images = concatMap renderEntry entries' + entries' = clientFilter st filterOn entries - label txt image = text' (view palLabel pal) txt <> image <> text' defAttr " " - identifier = coloredIdentifier pal NormalIdentifier HashMap.empty + filterOn entry = LText.fromChunks $ concat $ reverse $ addFields entry + (\x -> [" gecos: ", cleanText x]) + (\x -> [" oplvl: ", x]) + (\x -> [" idle: ", Text.pack x]) + (\x -> [" hops: ", Text.pack $ show x]) + (\x -> [" flags: ", x]) + (const [" away"]) + (\x -> [" server: ", idText x]) + (\x -> [" ip: ", x]) + (\x -> [" $a:", idText x]) + [[ renderUserInfo $ view whoUserInfo entry ]] + + 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 $ - [label "acct: " $ identifier acct | - acct <- [view whoAcct entry], idText acct /= "0"] ++ - [label "ip: " $ text' defAttr ip | - ip <- [view whoIp entry], ip /= "255.255.255.255"] ++ - [label "server: " $ identifier sid | - sid <- [view whoServer entry], not (Text.null $ idText sid)] ++ - [label "away" $ text' defAttr "" | - (view whoAway entry) == Just True] ++ - [label "flags: " $ text' defAttr flags | - flags <- [view whoMiscFlags entry], not (Text.null flags)] ++ - [label "hops: " $ string defAttr (show hops) | - Just hops <- [view whoHops entry]] ++ - [label "idle: " $ string defAttr (prettyTime 1 idle) | - idle <- [view whoIdleSecs entry], not (null idle)] ++ - [label "oplvl: " $ text' defAttr lvl | - lvl <- [view whoOpLvl entry], lvl /= "n/a"] ++ - [label "gecos: " $ parseIrcText' False pal real | - real <- [view whoRealname entry], not (Text.null real)] + renderSuffix entry = mconcat $ reverse $ addFields entry + (label "gecos: " . parseIrcText' False pal) + (label "oplvl: " . text' defAttr) + (label "idle: " . string defAttr . prettyTime 1) + (label "hops: " . string defAttr . show) + (label "flags: " . text' (view palSigil pal)) + (const $ label "away" $ text' defAttr "" ) + (label "server: " . identifier) + (label "ip: " . text' defAttr) + (label "$a:" . identifier) + [] countImagePending = countImage <> text' (view palLabel pal) "..." countImage = text' (view palLabel pal) "Users in " <> @@ -87,7 +91,32 @@ whoLines' cs width st 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 + + addFields wri gecos oplvl idle hops flags away server ip acct initList = + addFieldIf (require notNull . view whoRealname) gecos $ + addFieldIf (require (/= "n/a") . view whoOpLvl) oplvl $ + addFieldIf (require notNullOrZero . view whoIdleSecs) idle $ + addFieldIf (\n -> view whoHops n >>= require (> 0)) hops $ + addFieldIf (require notNull . view whoMiscFlags) flags $ + addFieldIf (\n -> view whoAway n >>= require id) away $ + addFieldIf (require (notNull . idText) . view whoServer) server $ + addFieldIf (require (/= "255.255.255.255") . view whoIp) ip $ + addFieldIf (require (/= "0") . view whoAcct) acct initList + where + addFieldIf :: (WhoReplyItem -> Maybe a) -> (a -> b) -> [b] -> [b] + addFieldIf getF mapF list = case getF wri of + Just v -> mapF v:list + Nothing -> list + notNull = not . Text.null + notNullOrZero "" = False + notNullOrZero "0" = False + notNullOrZero _ = True + require f v + | f v = Just v + | otherwise = Nothing diff --git a/src/Client/WhoReply.hs b/src/Client/WhoReply.hs index 0e155d47..485e1464 100644 --- a/src/Client/WhoReply.hs +++ b/src/Client/WhoReply.hs @@ -125,7 +125,7 @@ newWhoReplyItem = WhoReplyItem } finishWhoReply :: WhoReply -> WhoReply -finishWhoReply wr = wr { _whoDone = True, _whoItems = sort (_whoItems wr) } +finishWhoReply wr = wr { _whoDone = True, _whoItems = reverse $ sort (_whoItems wr) } recordWhoReply :: [Text] -> WhoReply -> WhoReply recordWhoReply [_, chan, uname, host, server, nick, flags, hcrn] reply From f57099ebf757006926d63bf9c34f3144877deb2f Mon Sep 17 00:00:00 2001 From: TheDaemoness Date: Tue, 15 Aug 2023 12:42:58 -0700 Subject: [PATCH 3/4] Add /url support to who view, reorganize code --- src/Client/State.hs | 19 ++++++++--- src/Client/View/Who.hs | 61 +++++++---------------------------- src/Client/WhoReply.hs | 72 +++++++++++++++++++++++++++++++++++------- 3 files changed, 87 insertions(+), 65 deletions(-) diff --git a/src/Client/State.hs b/src/Client/State.hs index 2328246a..872fa0a1 100644 --- a/src/Client/State.hs +++ b/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 diff --git a/src/Client/View/Who.hs b/src/Client/View/Who.hs index 9096adc4..084d6615 100644 --- a/src/Client/View/Who.hs +++ b/src/Client/View/Who.hs @@ -11,7 +11,7 @@ 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, cleanText) +import Client.Image.Message (IdentifierColorMode(NormalIdentifier), coloredIdentifier, coloredUserInfo, RenderMode (DetailedRender), prettyTime) import Client.Image.PackedImage import Client.Image.Palette import Client.State @@ -20,10 +20,8 @@ import Client.WhoReply import Control.Lens import Data.Text (Text) import qualified Data.Text as Text -import qualified Data.Text.Lazy as LText import Graphics.Vty.Attributes (defAttr) import Irc.Identifier -import Irc.UserInfo (renderUserInfo) import qualified Data.HashMap.Strict as HashMap import Client.Image.MircFormatting (parseIrcText') @@ -52,19 +50,7 @@ whoLines' cs width st whorpl = view csWhoReply cs (query, arg) = view whoQuery whorpl entries = view whoItems whorpl - entries' = clientFilter st filterOn entries - - filterOn entry = LText.fromChunks $ concat $ reverse $ addFields entry - (\x -> [" gecos: ", cleanText x]) - (\x -> [" oplvl: ", x]) - (\x -> [" idle: ", Text.pack x]) - (\x -> [" hops: ", Text.pack $ show x]) - (\x -> [" flags: ", x]) - (const [" away"]) - (\x -> [" server: ", idText x]) - (\x -> [" ip: ", x]) - (\x -> [" $a:", idText x]) - [[ renderUserInfo $ view whoUserInfo entry ]] + entries' = clientFilter st whoFilterText entries images = concatMap renderEntry entries' renderEntry :: WhoReplyItem -> [Image'] @@ -72,17 +58,17 @@ whoLines' cs width st -- 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 $ reverse $ addFields entry - (label "gecos: " . parseIrcText' False pal) - (label "oplvl: " . text' defAttr) - (label "idle: " . string defAttr . prettyTime 1) - (label "hops: " . string defAttr . show) - (label "flags: " . text' (view palSigil pal)) - (const $ label "away" $ text' defAttr "" ) - (label "server: " . identifier) - (label "ip: " . text' defAttr) + 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 " <> @@ -97,26 +83,3 @@ whoLines' cs width st label txt image = text' (view palLabel pal) txt <> image <> text' defAttr " " identifier = coloredIdentifier pal NormalIdentifier HashMap.empty - - addFields wri gecos oplvl idle hops flags away server ip acct initList = - addFieldIf (require notNull . view whoRealname) gecos $ - addFieldIf (require (/= "n/a") . view whoOpLvl) oplvl $ - addFieldIf (require notNullOrZero . view whoIdleSecs) idle $ - addFieldIf (\n -> view whoHops n >>= require (> 0)) hops $ - addFieldIf (require notNull . view whoMiscFlags) flags $ - addFieldIf (\n -> view whoAway n >>= require id) away $ - addFieldIf (require (notNull . idText) . view whoServer) server $ - addFieldIf (require (/= "255.255.255.255") . view whoIp) ip $ - addFieldIf (require (/= "0") . view whoAcct) acct initList - where - addFieldIf :: (WhoReplyItem -> Maybe a) -> (a -> b) -> [b] -> [b] - addFieldIf getF mapF list = case getF wri of - Just v -> mapF v:list - Nothing -> list - notNull = not . Text.null - notNullOrZero "" = False - notNullOrZero "0" = False - notNullOrZero _ = True - require f v - | f v = Just v - | otherwise = Nothing diff --git a/src/Client/WhoReply.hs b/src/Client/WhoReply.hs index 485e1464..7f2f39a6 100644 --- a/src/Client/WhoReply.hs +++ b/src/Client/WhoReply.hs @@ -18,6 +18,8 @@ module Client.WhoReply , finishWhoReply , recordWhoReply , recordWhoXReply + , mapJoinWhoFields + , whoFilterText -- Lenses , whoQuery @@ -25,7 +27,6 @@ module Client.WhoReply , whoToken , whoDone , whoItems - , whoChan , whoUserInfo , whoIp , whoServer @@ -38,6 +39,7 @@ module Client.WhoReply , whoRealname ) where +import Client.Image.Message (cleanText) import Control.Lens import Control.Lens.Unsound (lensProduct) -- Don't worry about it. Ctrl+F SOUNDNESS. import Data.List (sort) @@ -45,6 +47,7 @@ import Data.Set (Set) import qualified Data.Set as Set import Data.Text (Text) import qualified Data.Text as Text +import qualified Data.Text.Lazy as LText import Irc.Identifier import Irc.UserInfo import Text.Read (readMaybe) @@ -58,15 +61,14 @@ data WhoReply = WhoReply } data WhoReplyItem = WhoReplyItem - { _whoChan :: !Identifier - , _whoUserInfo :: !UserInfo + { _whoUserInfo :: !UserInfo + , _whoAcct :: !Identifier , _whoIp :: !Text -- We don't have iproute; (Maybe IP) would be nice here. , _whoServer :: !Identifier , _whoAway :: !(Maybe Bool) , _whoMiscFlags :: !Text , _whoHops :: !(Maybe Int) , _whoIdleSecs :: !String -- This can be a Maybe Int, but prettyTime takes a String. - , _whoAcct :: !Identifier , _whoOpLvl :: !Text , _whoRealname :: !Text } deriving (Eq, Ord) @@ -107,19 +109,18 @@ splitFlags rest = (Nothing, Text.pack rest) newWhoReplyItem :: WhoReplyItem newWhoReplyItem = WhoReplyItem - { _whoChan = mkId "*" - , _whoUserInfo = UserInfo + { _whoUserInfo = UserInfo { userNick = mkId "" , userName = "" , userHost = "" } + , _whoAcct = "0" , _whoIp = "255.255.255.255" , _whoServer = "" , _whoAway = Nothing , _whoMiscFlags = "" , _whoHops = Nothing , _whoIdleSecs = "" - , _whoAcct = "0" , _whoOpLvl = "n/a" , _whoRealname = "" } @@ -128,13 +129,12 @@ finishWhoReply :: WhoReply -> WhoReply finishWhoReply wr = wr { _whoDone = True, _whoItems = reverse $ sort (_whoItems wr) } recordWhoReply :: [Text] -> WhoReply -> WhoReply -recordWhoReply [_, chan, uname, host, server, nick, flags, hcrn] reply +recordWhoReply [_, _, uname, host, server, nick, flags, hcrn] reply | _whoDone reply = reply | otherwise = reply { _whoItems = wri:_whoItems reply} where wri = newWhoReplyItem - { _whoChan = mkId chan - , _whoUserInfo = UserInfo { userNick = mkId nick, userName = uname, userHost = host } + { _whoUserInfo = UserInfo { userNick = mkId nick, userName = uname, userHost = host } , _whoServer = mkId server , _whoAway = away , _whoMiscFlags = miscFlags @@ -167,7 +167,7 @@ recordWhoXReply' ((arg, kind):rest) = recordWhoXReply' rest . updateFn where updateFn = case kind of 'a' -> set whoAcct (mkId arg) - 'c' -> set whoChan (mkId arg) + -- Skip c 'd' -> set whoHops (readMaybe $ Text.unpack arg) -- SOUNDNESS: whoAway and whoMiscFlags project disjoint parts of WhoReplyItem 'f' -> set (lensProduct whoAway whoMiscFlags) flagsSplit @@ -181,3 +181,53 @@ recordWhoXReply' ((arg, kind):rest) = recordWhoXReply' rest . updateFn 'u' -> set (whoUserInfo . uiName) arg _ -> id flagsSplit = splitFlags $ Text.unpack arg + +-- Map non-default field values and join them into a list. +mapJoinWhoFields :: WhoReplyItem -> + (UserInfo -> a) -> + (Identifier -> a) -> + (Text -> a) -> + (Identifier -> a) -> + a -> + (Text -> a) -> + (Int -> a) -> + (String -> a) -> + (Text -> a) -> + (Text -> a) -> + [a] +mapJoinWhoFields wri userinfo acct ip server away flags hops idle oplvl gecos = reverse $ + addFieldIf (require notNull . view whoRealname) gecos $ + addFieldIf (require (/= "n/a") . view whoOpLvl) oplvl $ + addFieldIf (require notNullOrZero . view whoIdleSecs) idle $ + addFieldIf (\n -> view whoHops n >>= require (> 0)) hops $ + addFieldIf (require notNull . view whoMiscFlags) flags $ + addFieldIf (\n -> view whoAway n >>= require id) (const away) $ + addFieldIf (require (notNull . idText) . view whoServer) server $ + addFieldIf (require (/= "255.255.255.255") . view whoIp) ip $ + addFieldIf (require (/= "0") . view whoAcct) acct + [userinfo $ view whoUserInfo wri] + where + addFieldIf :: (WhoReplyItem -> Maybe a) -> (a -> b) -> [b] -> [b] + addFieldIf getF mapF list = case getF wri of + Just v -> mapF v:list + Nothing -> list + notNull = not . Text.null + notNullOrZero "" = False + notNullOrZero "0" = False + notNullOrZero _ = True + require f v + | f v = Just v + | otherwise = Nothing + +whoFilterText :: WhoReplyItem -> LText.Text +whoFilterText entry = LText.fromChunks $ concat $ mapJoinWhoFields entry + (\x -> [renderUserInfo x]) + (\x -> [" $a:", idText x]) + (\x -> [" ip: ", x]) + (\x -> [" server: ", idText x]) + [" away"] + (\x -> [" flags: ", x]) + (\x -> [" hops: ", Text.pack $ show x]) + (\x -> [" idle: ", Text.pack x]) + (\x -> [" oplvl: ", x]) + (\x -> [" gecos: ", cleanText x]) From 8bacd77fa467ef65e193c71f9dbbaa6c1dc7d8b3 Mon Sep 17 00:00:00 2001 From: TheDaemoness Date: Sat, 2 Sep 2023 16:23:51 -0700 Subject: [PATCH 4/4] Highlight the user's nick in the /who view --- src/Client/View/Who.hs | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/src/Client/View/Who.hs b/src/Client/View/Who.hs index 084d6615..800cca53 100644 --- a/src/Client/View/Who.hs +++ b/src/Client/View/Who.hs @@ -24,6 +24,7 @@ import Graphics.Vty.Attributes (defAttr) import Irc.Identifier import qualified Data.HashMap.Strict as HashMap import Client.Image.MircFormatting (parseIrcText') +import Client.State.Focus (Focus(NetworkFocus)) -- | -- | Render the lines used by the @/who@ command in normal mode. @@ -56,7 +57,8 @@ whoLines' cs width st 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) + renderPrefix entry = coloredUserInfo pal DetailedRender hilites (view whoUserInfo entry) + where hilites = clientHighlightsFocus (NetworkFocus (view csNetwork cs)) st renderSuffix :: WhoReplyItem -> Image' renderSuffix entry = mconcat $ mapJoinWhoFields entry (const mempty) @@ -82,4 +84,5 @@ whoLines' cs width st _ -> text' defAttr "" label txt image = text' (view palLabel pal) txt <> image <> text' defAttr " " + -- Don't use hilites here; the identifiers are never the user's nick. identifier = coloredIdentifier pal NormalIdentifier HashMap.empty