Add basics for configurable message routing

For now, allows changing where RPL_MON* replies are routed.
glguy · Aug 14, 2024 · 3a9f270 · 3a9f270
1 parent 8de23ba
commit 3a9f270
Show file tree

Hide file tree

Showing 3 changed files with 42 additions and 6 deletions.
diff --git a/src/Client/Configuration/ServerSettings.hs b/src/Client/Configuration/ServerSettings.hs
@@ -59,6 +59,7 @@ module Client.Configuration.ServerSettings
   , ssCapabilities
   , ssWindowHints
   , ssPalette
+  , ssRouting
 
   -- * SASL Mechanisms
   , SaslMechanism(..)
@@ -95,6 +96,7 @@ import Client.Configuration.Colors (attrSpec)
 import Client.Configuration.Macros (macroCommandSpec)
 import Client.Image.Palette (NetworkPalette (..), defaultNetworkPalette)
 import Client.State.Focus ( Focus (NetworkFocus, ChannelFocus) )
+import Client.State.Target (Routing (..), defaultRouting)
 import Client.State.Window (ActivityFilter (..))
 import Config.Schema.Spec
 import Control.Exception (Exception, displayException, throwIO, try)
@@ -165,6 +167,7 @@ data ServerSettings = ServerSettings
   , _ssCapabilities     :: ![Text] -- ^ Extra capabilities to unconditionally request
   , _ssWindowHints      :: Map Focus WindowHint
   , _ssPalette          :: NetworkPalette
+  , _ssRouting          :: Routing
   }
   deriving Show
 
@@ -263,6 +266,7 @@ defaultServerSettings =
        , _ssCapabilities     = []
        , _ssWindowHints      = Map.empty
        , _ssPalette          = defaultNetworkPalette
+       , _ssRouting          = defaultRouting
        }
 
 serverSpec :: ValueSpec (Maybe Text, ServerSettings -> ServerSettings)
@@ -399,6 +403,9 @@ serverSpec = sectionsSpec "server-settings" $
 
       , req "palette" ssPalette netPaletteSpec
         "Network-specific palette overrides"
+
+      , req "routing" ssRouting routingSpec
+        "Overrides for which windows receive which messages"
       ]
 
 windowHintsSpec :: ValueSpec (Map Focus WindowHint)
@@ -615,3 +622,14 @@ netPaletteSpec =
     colorMapSpec = HashMap.fromList . concatMap expand <$> assocSpec attrSpec
       where
         expand (modes, style) = [(mode, style) | mode <- Text.unpack modes, isLetter mode]
+
+routingSpec :: ValueSpec Routing
+routingSpec =
+  sectionsSpec "routing" $
+  do _routeMonToNet <- fromMaybe False <$> optSection' "monitor" routeMonSpec
+                       "Which window to send RPL_MON* messages to"
+     pure Routing{..}
+  where
+    routeMonSpec =
+      False <$ atomSpec "user" <!>
+      True  <$ atomSpec "network"
diff --git a/src/Client/EventLoop.hs b/src/Client/EventLoop.hs
@@ -21,7 +21,7 @@ import Client.CApi (ThreadEntry, popTimer)
 import Client.Commands (CommandResult(..), execute, executeUserCommand, tabCompletion)
 import Client.Configuration (configJumpModifier, configKeyMap, configWindowNames, configDigraphs, configNotifications)
 import Client.Configuration.Notifications (notifyCmd)
-import Client.Configuration.ServerSettings ( ssReconnectAttempts )
+import Client.Configuration.ServerSettings ( ssReconnectAttempts, ssRouting )
 import Client.EventLoop.Actions (keyToAction, Action(..))
 import Client.EventLoop.Errors (exceptionToLines)
 import Client.EventLoop.Network (clientResponse)
@@ -337,7 +337,7 @@ doNetworkLine networkId time line st =
                             Just irc' -> recordIrcMessage network target msg st1
                               where
                                 myNick = view csNick cs
-                                target = msgTarget myNick irc
+                                target = msgTarget (view (csSettings . ssRouting) cs) myNick irc
                                 msg = ClientMessage
                                       { _msgTime    = time'
                                       , _msgNetwork = network
@@ -357,7 +357,7 @@ startTLSLine network cs st raw =
   do now <- getZonedTime
      let irc = cookIrcMsg raw
          myNick = view csNick cs
-         target = msgTarget myNick irc
+         target = msgTarget (view (csSettings . ssRouting) cs) myNick irc
          msg = ClientMessage
              { _msgTime    = now
              , _msgNetwork = network

diff --git a/src/Client/State/Target.hs b/src/Client/State/Target.hs
@@ -12,26 +12,42 @@ This module contains glirc-specific overrides of the message routing provided by
 
 module Client.State.Target
   (
-    MessageTarget(..)
+    Routing(..)
+  , defaultRouting
+  , routeMonToNet
+
+  , MessageTarget(..)
   , msgTarget
   ) where
 
+import           Control.Lens
 import qualified Data.Text as Text
 import           Irc.Codes
 import           Irc.Identifier (Identifier, mkId)
 import           Irc.Message (IrcMsg(..), srcUser)
 import qualified Irc.Message as Msg
 import           Irc.UserInfo (userNick, parseUserInfo)
 
+data Routing = Routing
+  { _routeMonToNet :: !Bool -- ^ Put RPL_MON* messages in the network window instead of user windows
+  } deriving Show
+
+defaultRouting :: Routing
+defaultRouting =  Routing
+  { _routeMonToNet = False
+  }
+
+makeLenses ''Routing
+
 data MessageTarget
   = TargetDrop                 -- ^ Do not record the message anywhere.
   | TargetUser     !Identifier -- ^ Record the message in all channels/PMs shared with the user.
   | TargetWindow   !Identifier -- ^ Directed message to channel or from user.
   | TargetExisting !Identifier -- ^ As @TargetWindow@ but only for existing windows.
   | TargetNetwork              -- ^ Record the message in the network window.
 
-msgTarget :: Identifier -> IrcMsg -> MessageTarget
-msgTarget nick msg =
+msgTarget :: Routing -> Identifier -> IrcMsg -> MessageTarget
+msgTarget routing nick msg =
   case msg of
     Authenticate{}  -> TargetDrop
     BatchStart{}    -> TargetDrop
@@ -40,6 +56,8 @@ msgTarget nick msg =
     Pong{}          -> TargetDrop
     Away user _     -> TargetExisting (userNick (srcUser user))
     Invite _ _ chan -> TargetWindow chan
+    Reply _ RPL_MONONLINE _  | _routeMonToNet routing -> TargetNetwork
+    Reply _ RPL_MONOFFLINE _ | _routeMonToNet routing -> TargetNetwork
     Reply _ RPL_MONONLINE [_,who]  | [who'] <- Text.split (==',') who ->
       TargetWindow (userNick $ parseUserInfo who')
     Reply _ RPL_MONOFFLINE [_,who] | [who'] <- Text.split (==',') who ->