Track identify-msg status

lib/src/Irc/Message.hs

@@ -79,7 +79,7 @@ data IrcMsg
   | Tagmsg !Source !Identifier -- ^ source target
   deriving Show
 
-data Source = Source { srcUser :: {-# UNPACK #-}!UserInfo, srcAcct :: !Text }
+data Source = Source { srcUser :: {-# UNPACK #-}!UserInfo, srcAcct :: !Text, srcIdentified :: !Bool }
   deriving Show
 
 data CapMore = CapMore | CapDone
@@ -112,11 +112,13 @@ msgSource :: RawIrcMsg -> Maybe Source
 msgSource msg =
   case view msgPrefix msg of
     Nothing -> Nothing
-    Just p ->
-      case [a | TagEntry "account" a <- view msgTags msg ] of
-        []  -> Just (Source p "")
-        a:_ -> Just (Source p a)
-
+    Just p -> Just Source{ srcUser = p, srcAcct = acct, srcIdentified = identified }
+      where
+        acct = 
+          case [a | TagEntry "account" a <- view msgTags msg ] of
+            []  -> ""
+            a:_ -> a
+        identified = not (null [() | TagEntry "solanum.chat/identified" _ <- view msgTags msg ])
 
 -- | Interpret a low-level 'RawIrcMsg' as a high-level 'IrcMsg'.
 -- Messages that can't be understood are wrapped in 'UnknownMsg'.
@@ -319,8 +321,8 @@ msgActor msg =
     Tagmsg x _    -> Just x
 
 renderSource :: Source -> Text
-renderSource (Source u "") = renderUserInfo u
-renderSource (Source u a) = renderUserInfo u <> "(" <> a <> ")"
+renderSource (Source u "" _) = renderUserInfo u
+renderSource (Source u a _) = renderUserInfo u <> "(" <> a <> ")"
 
 -- | Text representation of an IRC message to be used for matching with
 -- regular expressions.

src/Client/CApi/Exports.hs

@@ -248,7 +248,7 @@ glirc_inject_chat stab netPtr netLen srcPtr srcLen tgtPtr tgtLen msgPtr msgLen =
      now  <- getZonedTime
 
      let msg = ClientMessage
-                 { _msgBody    = IrcBody (Privmsg (Source (parseUserInfo src) "") tgt txt)
+                 { _msgBody    = IrcBody (Privmsg (Source (parseUserInfo src) "" False) tgt txt)
                  , _msgTime    = now
                  , _msgNetwork = net
                  }

src/Client/Commands.hs

@@ -44,7 +44,7 @@ import Control.Exception (displayException, try)
 import Control.Lens
 import Control.Monad (guard, foldM)
 import Data.Foldable (foldl', toList)
-import Data.Maybe (fromMaybe)
+import Data.Maybe (fromMaybe, maybeToList)
 import Data.Text (Text)
 import Data.Text qualified as Text
 import Data.Time (getZonedTime)
@@ -67,7 +67,6 @@ import Client.Commands.Toggles (togglesCommands)
 import Client.Commands.Types
 import Client.Commands.Window (windowCommands, focusNames)
 import Client.Commands.ZNC (zncCommands)
-import Data.Maybe (maybeToList)
 
 -- | Interpret the given chat message or command. Leading @/@ indicates a
 -- command. Otherwise if a channel or user query is focused a chat message will

src/Client/Commands/Chat.hs

@@ -331,7 +331,7 @@ chatCommand' ::
 chatCommand' con targetTxts cs st =
   do now <- getZonedTime
      let targetIds = mkId <$> targetTxts
-         !myNick = Source (view csUserInfo cs) ""
+         !myNick = Source (view csUserInfo cs) (view csAccount cs) True
          network = view csNetwork cs
          entries = [ (targetId,
                           ClientMessage
@@ -382,7 +382,7 @@ cmdMe :: ChannelCommand String
 cmdMe channelId cs st rest =
   do now <- getZonedTime
      let actionTxt = Text.pack ("\^AACTION " ++ rest ++ "\^A")
-         !myNick = Source (view csUserInfo cs) ""
+         !myNick = Source (view csUserInfo cs) (view csAccount cs) True
          network = view csNetwork cs
          entry = ClientMessage
                     { _msgTime = now
@@ -411,7 +411,7 @@ executeChat focus msg st =
 
              when allow (sendMsg cs (ircPrivmsg tgtTxt msgTxt))
 
-             let myNick = Source (view csUserInfo cs) ""
+             let myNick = Source (view csUserInfo cs) (view csAccount cs) True
                  entry = ClientMessage
                    { _msgTime    = now
                    , _msgNetwork = network

src/Client/Hook/DroneBLRelay.hs

@@ -35,7 +35,7 @@ droneblRelayHook args = Just (MessageHook "droneblrelay" False (remap (map mkId
 -- | Remap messages from #dronebl that match one of the
 -- rewrite rules.
 remap :: [Identifier] -> IrcMsg -> MessageResult
-remap nicks (Privmsg (Source (UserInfo nick _ _) _) chan@"#dronebl" msg)
+remap nicks (Privmsg (Source (UserInfo nick _ _) _ _) chan@"#dronebl" msg)
   | nick `elem` nicks
   , Just sub <- rules chan msg = RemapMessage sub
 remap _ _ = PassMessage
@@ -121,7 +121,7 @@ joinMsg ::
   IrcMsg
 joinMsg chan srv nick user host =
   Join
-    (Source (UserInfo (mkId (nick <> "@" <> srv)) user host) "")
+    (Source (UserInfo (mkId (nick <> "@" <> srv)) user host) "" False)
     chan
     "" -- account
     "" -- gecos
@@ -189,7 +189,7 @@ modeMsg chan srv nick modes =
 userInfo ::
   Text {- ^ nickname -} ->
   Source
-userInfo nick = Source (UserInfo (mkId nick) "*" "*") ""
+userInfo nick = Source (UserInfo (mkId nick) "" "") "" False
 
 ------------------------------------------------------------------------
 

src/Client/Hook/Matterbridge.hs

@@ -46,9 +46,9 @@ matterbridgeHook (nick:chans) = Just (MessageHook "matterbridge" False (remap (m
 remap :: Identifier -> (Identifier -> Bool) -> IrcMsg -> MessageResult
 remap nick chanfilter ircmsg =
   case ircmsg of
-    Privmsg (Source ui _) chan msg
+    Privmsg (Source ui _ _) chan msg
       | view uiNick ui == nick, chanfilter chan -> remap' Msg ui chan msg
-    Ctcp (Source ui _) chan "ACTION" msg
+    Ctcp (Source ui _ _) chan "ACTION" msg
       | view uiNick ui == nick, chanfilter chan -> remap' Act ui chan msg
     _ -> PassMessage
 
@@ -63,4 +63,4 @@ newmsg Msg src chan msg = Privmsg src chan msg
 newmsg Act src chan msg = Ctcp src chan "ACTION" msg
 
 fakeUser :: Text -> UserInfo -> Source
-fakeUser nick ui = Source (set uiNick (mkId nick) ui) ""
+fakeUser nick ui = Source (set uiNick (mkId nick) ui) "" False

src/Client/Hook/Snotice.hs

@@ -30,12 +30,14 @@ snoticeHook = MessageHook "snotice" True remap
 remap ::
   IrcMsg -> MessageResult
 
-remap (Notice (Source (UserInfo u "" "") _) _ msg)
+remap (Notice (Source (UserInfo u "" "") _ _) _ msg)
   | Just msg1 <- Text.stripPrefix "*** Notice -- " msg
   , let msg2 = Text.filter (\x -> x /= '\x02' && x /= '\x0f') msg1
   , Just (lvl, cat) <- characterize msg2
   = if lvl < 1 then OmitMessage
-               else RemapMessage (Notice (Source (UserInfo u "" "*") "") cat msg1)
+               else RemapMessage (Notice (Source (UserInfo u "" "*") "" True) cat msg1)
+                    -- @*@ host causes the client not to treat this as a server message
+                    -- which would then be routed to the server window
 
 remap _ = PassMessage
 

src/Client/Hook/Znc/Buffextras.hs

@@ -52,7 +52,7 @@ remap _ _ = PassMessage
 prefixedParser :: Identifier -> Parser IrcMsg
 prefixedParser chan = do
     pfx <- prefixParser
-    let src = Source pfx ""
+    let src = Source pfx "" False
     choice
       [ Join src chan "" "" <$ skipToken "joined"
       , Quit src . filterEmpty <$ skipToken "quit:" <*> P.takeText

src/Client/Image/Message.hs

@@ -38,9 +38,7 @@ import Client.Image.PackedImage (char, imageWidth, string, text', Image')
 import Client.Image.Palette
 import Client.Message
 import Client.State.Window (unpackTimeOfDay, wlImage, wlPrefix, wlTimestamp, WindowLine)
-import Client.UserHost ( uhAccount, UserAndHost )
-import Control.Applicative ((<|>))
-import Control.Lens (view, (^?), filtered, folded, views, Ixed(ix), At (at))
+import Control.Lens (view, views, At (at))
 import Data.Char (ord, chr, isControl)
 import Data.Hashable (hash)
 import Data.HashMap.Strict (HashMap)
@@ -65,7 +63,7 @@ data MessageRendererParams = MessageRendererParams
   , rendUserSigils :: [Char] -- ^ sender sigils
   , rendHighlights :: HashMap Identifier Highlight -- ^ words to highlight
   , rendPalette    :: Palette -- ^ nick color palette
-  , rendAccounts   :: Maybe (HashMap Identifier UserAndHost)
+  , rendAccounts   :: Bool -- ^ should we indicate account and identified status?
   , rendNetPalette :: NetworkPalette
   , rendChanTypes  :: [Char] -- ^ A list of valid channel name prefixes.
   }
@@ -77,7 +75,7 @@ defaultRenderParams = MessageRendererParams
   , rendUserSigils  = ""
   , rendHighlights  = HashMap.empty
   , rendPalette     = defaultPalette
-  , rendAccounts    = Nothing
+  , rendAccounts    = False
   , rendNetPalette  = defaultNetworkPalette
   , rendChanTypes   = "#&!+" -- Default for if we aren't told otherwise by ISUPPORT.
   }
@@ -220,22 +218,18 @@ ircLinePrefix !rp body =
 
       who n   = string (view palSigil pal) sigils <> ui
         where
-          baseUI    = coloredUserInfo pal rm hilites (srcUser n)
-          ui = case rendAccounts rp of
-                 Nothing -> baseUI -- not tracking any accounts
-                 Just accts ->
-                   let tagAcct = if Text.null (srcAcct n) then Nothing else Just (srcAcct n)
-
-                       isKnown acct = not (Text.null acct || acct == "*")
-                       lkupAcct = accts
-                             ^? ix (userNick (srcUser n))
-                              . uhAccount
-                              . filtered isKnown in
-                   case tagAcct <|> lkupAcct of
-                     Just acct
-                       | mkId acct == userNick (srcUser n) -> baseUI
-                       | otherwise -> baseUI <> "(" <> ctxt acct <> ")"
-                     Nothing -> "~" <> baseUI
+          ui = prefix <> coloredUserInfo pal rm hilites (srcUser n) <> suffix
+          prefix
+            | rendAccounts rp, not (srcIdentified n) = "~"
+            | otherwise = mempty
+
+          suffix
+            | rendAccounts rp
+            , not (Text.null (srcAcct n))
+            , mkId (srcAcct n) /= userNick (srcUser n)
+            ="(" <> ctxt (srcAcct n) <> ")"
+            | otherwise = mempty
+
   in
   case body of
     Join       {} -> mempty
@@ -381,11 +375,9 @@ fullIrcLineImage !rp body =
         -- nick!user@host
         plainWho (srcUser n) <>
 
-        case rendAccounts rp ^? folded . ix (userNick (srcUser n)) . uhAccount of
-          _ | not (Text.null (srcAcct n)) -> text' quietAttr ("(" <> cleanText (srcAcct n) <> ")")
-          Just acct
-            | not (Text.null acct) -> text' quietAttr ("(" <> cleanText acct <> ")")
-          _ -> ""
+        if rendAccounts rp && not (Text.null (srcAcct n))
+          then text' quietAttr ("(" <> cleanText (srcAcct n) <> ")")
+          else ""
   in
   case body of
     Nick old new ->

src/Client/State.hs

@@ -360,7 +360,7 @@ recordChannelMessage' create network channel msg st
       , rendUserSigils  = computeMsgLineSigils network channel' msg st
       , rendHighlights  = highlights
       , rendPalette     = clientPalette st
-      , rendAccounts    = accounts
+      , rendAccounts    = view (csSettings . ssShowAccounts) cs
       , rendNetPalette  = clientNetworkPalette st
       , rendChanTypes   = "#&!+" -- TODO: Don't hardcode this, use CHANTYPES ISUPPORT.
       }
@@ -372,11 +372,6 @@ recordChannelMessage' create network channel msg st
     importance              = msgImportance msg st
     highlights              = clientHighlightsFocus (ChannelFocus network channel) st
 
-    accounts =
-      if view (csSettings . ssShowAccounts) cs
-      then Just (view csUsers cs)
-      else Nothing
-
 
 recordLogLine ::
   ClientMessage {- ^ message      -} ->

src/Client/State/Network.hs

@@ -38,6 +38,7 @@ module Client.State.Network
   , csStatusMsg
   , csSettings
   , csUserInfo
+  , csAccount
   , csUsers
   , csUser
   , csModeCount
@@ -140,6 +141,7 @@ data NetworkState = NetworkState
   , _csStatusMsg    :: ![Char] -- ^ modes that prefix statusmsg channel names
   , _csSettings     :: !ServerSettings -- ^ settings used for this connection
   , _csUserInfo     :: !UserInfo -- ^ usermask used by the server for this connection
+  , _csAccount      :: !Text -- ^ account name for this connection or ""
   , _csUsers        :: !(HashMap Identifier UserAndHost) -- ^ user and hostname for other nicks
   , _csModeCount    :: !Int -- ^ maximum mode changes per MODE command
   , _csNetwork      :: !Text -- ^ name of network connection
@@ -306,6 +308,7 @@ newNetworkState ::
   NetworkState      {- ^ new network state         -}
 newNetworkState network settings sock ping seed = NetworkState
   { _csUserInfo     = UserInfo "*" "" ""
+  , _csAccount      = ""
   , _csChannels     = HashMap.empty
   , _csChannelList  = newChannelList Nothing Nothing
   , _csWhoReply     = finishWhoReply $ newWhoReply "" ""

src/Client/View/Messages.hs

@@ -23,13 +23,11 @@ import           Client.Image.Palette
 import           Client.Message
 import           Client.State
 import           Client.State.Focus
-import           Client.State.Network
 import           Client.State.Window
 import           Control.Lens
 import           Control.Monad
 import           Data.List
 import           Irc.Identifier
-import           Irc.Message
 import           Irc.UserInfo