Implement terminal notifications

glirc.cabal

@@ -102,6 +102,7 @@ library
     Client.EventLoop.Actions
     Client.EventLoop.Errors
     Client.EventLoop.Network
+    Client.EventLoop.Notifications
     Client.Hook
     Client.Hook.DroneBLRelay
     Client.Hook.Matterbridge

src/Client/Configuration.hs

@@ -77,7 +77,7 @@ import Client.Commands.Interpolation (Macro)
 import Client.Commands.Recognizer (Recognizer)
 import Client.Configuration.Colors (attrSpec)
 import Client.Configuration.Macros (macroMapSpec)
-import Client.Configuration.Notifications (NotifyWith, NotifyWhile(NotifyWhileUnfocused), notifySpec, notifyWithDefault, notifyWhileSpec)
+import Client.Configuration.Notifications (NotifyWith(NotifyWithDefault), NotifyWhile(NotifyWhileUnfocused), notifySpec, notifyWhileSpec)
 import Client.Configuration.ServerSettings
 import Client.EventLoop.Actions
 import Client.Image.Palette
@@ -299,7 +299,7 @@ configurationSpec = sectionsSpec "config-file" $
                                "Initial setting for visibility of ping times"
      _configDigraphs        <- sec' mempty "extra-digraphs" (Map.fromList <$> listSpec digraphSpec)
                                "Extra digraphs"
-     _configNotifications   <- sec' notifyWithDefault "notifications" notifySpec
+     _configNotifications   <- sec' NotifyWithDefault "notifications" notifySpec
                                "Whether and how to show notifications. Notification data is passed as arguments to custom commands."
      _configNotifyWhile     <- sec' NotifyWhileUnfocused "notify-while" notifyWhileSpec
                                "When notifications (if enabled) may be displayed"

src/Client/Configuration/Notifications.hs

@@ -6,19 +6,18 @@ Copyright   : (c) TheDaemoness, 2023
 License     : ISC
 Maintainer  : [email protected]
 -}
-module Client.Configuration.Notifications ( NotifyWith(..), NotifyWhile(..), notifyCmd, notifySpec, notifyWithDefault, notifyWhileSpec ) where
+module Client.Configuration.Notifications ( NotifyWith(..), NotifyWhile(..), notifySpec, notifyWhileSpec ) where
 
 import           Config.Schema (ValueSpec, atomSpec, nonemptySpec, stringSpec, (<!>))
-import qualified Data.Text.Lazy as LText
-import           System.Process.Typed (ProcessConfig, proc, setEnv)
-import           System.Info (os)
 import qualified Data.List.NonEmpty as NonEmpty
 
 data NotifyWith
   = NotifyWithCustom [String]
+  | NotifyWithDefault
   | NotifyWithNotifySend
   | NotifyWithOsaScript
   | NotifyWithTerminalNotifier
+  | NotifyWithTerminal
   deriving Show
 
 data NotifyWhile
@@ -27,33 +26,14 @@ data NotifyWhile
   | NotifyWhileAlways
   deriving Show
 
-notifyCmd :: NotifyWith -> Maybe ((LText.Text, LText.Text) -> ProcessConfig () () ())
-notifyCmd (NotifyWithCustom (cmd:args)) = Just $ \(header, body) ->
-  proc cmd (args ++ [LText.unpack header, LText.unpack body])
-notifyCmd NotifyWithNotifySend = Just $ \(header, body) ->
-  proc "notify-send" ["-a", "glirc", LText.unpack header, LText.unpack body]
-notifyCmd NotifyWithOsaScript = Just $ \(header, body) ->
-  setEnv [("_GLIRC_NOTIF_HEADER", LText.unpack header), ("_GLIRC_NOTIF_BODY", LText.unpack body)] $
-  proc "osascript" ["-e", script]
-  where
-    script = "display notification (system attribute \"_GLIRC_NOTIF_BODY\") with title \"glirc\" subtitle (system attribute \"_GLIRC_NOTIF_HEADER\")"
-notifyCmd NotifyWithTerminalNotifier = Just $ \(header, body) ->
-  proc "terminal-notifier" ["-title", "glirc", "-subtitle", LText.unpack header, "-message", "\\" <> LText.unpack body]
-notifyCmd _ = Nothing
-
-notifyWithDefault :: NotifyWith
-notifyWithDefault = case os of
-  "darwin" -> NotifyWithOsaScript
-  "linux"  -> NotifyWithNotifySend
-  _        -> NotifyWithCustom []
-
 notifySpec :: ValueSpec NotifyWith
 notifySpec =
   NotifyWithCustom []        <$ atomSpec "no"  <!>
-  notifyWithDefault          <$ atomSpec "yes" <!>
+  NotifyWithDefault          <$ atomSpec "yes" <!>
   NotifyWithNotifySend       <$ atomSpec "notify-send" <!>
   NotifyWithOsaScript        <$ atomSpec "osascript" <!>
   NotifyWithTerminalNotifier <$ atomSpec "terminal-notifier" <!>
+  NotifyWithTerminal         <$ atomSpec "terminal" <!>
   NotifyWithCustom . NonEmpty.toList <$> nonemptySpec stringSpec
 
 notifyWhileSpec :: ValueSpec NotifyWhile

src/Client/EventLoop.hs

@@ -20,11 +20,11 @@ module Client.EventLoop
 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.EventLoop.Actions (keyToAction, Action(..))
 import Client.EventLoop.Errors (exceptionToLines)
 import Client.EventLoop.Network (clientResponse)
+import Client.EventLoop.Notifications (doNotify)
 import Client.Hook (applyMessageHooks, messageHookStateful)
 import Client.Image (clientPicture)
 import Client.Image.Layout (scrollAmount)
@@ -39,9 +39,9 @@ import Client.State.Focus (Subfocus(FocusMessages))
 import Client.State.Network
 import Client.State.Target (msgTarget)
 import Control.Concurrent.STM
-import Control.Exception (SomeException, Exception(fromException), catch)
+import Control.Exception (SomeException, Exception(fromException))
 import Control.Lens
-import Control.Monad (when, MonadPlus(mplus), foldM, unless, void)
+import Control.Monad (when, MonadPlus(mplus), foldM, unless)
 import Data.ByteString (ByteString)
 import Data.Char (isSpace)
 import Data.Foldable (Foldable(foldl'), find, asum, traverse_)
@@ -64,8 +64,6 @@ import Irc.Codes (pattern RPL_STARTTLS)
 import Irc.Message (IrcMsg(Reply, Notice), cookIrcMsg)
 import Irc.RawIrcMsg (RawIrcMsg, TagEntry(..), asUtf8, msgTags, parseRawIrcMsg)
 import LensUtils (setStrict)
-import System.Process.Typed (startProcess, setStdin, setStdout, setStderr, nullStream)
-
 
 -- | Sum of the five possible event types the event loop handles
 data ClientEvent
@@ -180,18 +178,10 @@ processLogEntries =
   traverse_ writeLogLine . reverse . view clientLogQueue
 
 processNotifications :: ClientState -> IO ()
-processNotifications st =
-  case notifyCmd (view (clientConfig . configNotifications) st) of
-    Just cmd | clientMayNotify st -> traverse_ (spawn cmd) (view clientNotifications st)
-    _ -> return ()
-  where
-    -- TODO: May be a nicer way to handle notification failure than just silently squashing the exception
-    handleException :: SomeException -> IO ()
-    handleException _ = return ()
-    spawn cmd pair = do
-      let procCfg = setStdin nullStream . setStdout nullStream . setStderr nullStream $ cmd pair
-      -- Maybe find a nicer way to get an error out of here.
-      catch (void (startProcess procCfg)) handleException
+processNotifications st
+  | clientMayNotify st = traverse_ doNotify' (view clientNotifications st)
+  | otherwise = return ()
+  where doNotify' = doNotify $ view (clientConfig . configNotifications) st
 
 -- | Respond to a network connection successfully connecting.
 doNetworkOpen ::

src/Client/EventLoop/Notifications.hs

@@ -0,0 +1,103 @@
+{-# Language OverloadedStrings #-}
+
+{-|
+Module      : Client.EventLoop.Notification
+Description : Notification support
+Copyright   : (c) TheDaemoness, 2025
+License     : ISC
+Maintainer  : [email protected]
+
+This module dispatches notifications,
+which are status updates that are shown outside of the TUI.
+-}
+
+module Client.EventLoop.Notifications ( Notification, doNotify ) where
+
+import           Client.Configuration.Notifications ( NotifyWith(..) )
+import           Control.Exception (SomeException, catch)
+import           Control.Monad (void)
+import           Data.Maybe (fromMaybe)
+import qualified Data.Text.Lazy.IO as LTextIO
+import           Data.Text.Lazy
+import           System.Environment (lookupEnv)
+import           System.Process.Typed (ProcessConfig, proc, startProcess, setEnv, setStdin, setStdout, setStderr, nullStream)
+import           System.Info (os)
+import           System.IO (hFlush, stdout)
+
+type Notification = (Text, Text);
+
+osDefault :: NotifyWith
+osDefault = case os of
+  "darwin" -> NotifyWithOsaScript
+  "linux"  -> NotifyWithNotifySend
+  _        -> NotifyWithCustom []
+
+putStrAndFlush :: Text -> IO ()
+putStrAndFlush txt = LTextIO.putStr txt >> hFlush stdout
+
+doNotify :: NotifyWith -> Notification -> IO ()
+doNotify (NotifyWithCustom []) _ = return ()
+doNotify NotifyWithDefault notif = do
+  renderer <- renderOsc
+  case renderer of
+    Just renderer' -> putStrAndFlush $ renderer' notif
+    Nothing -> doNotify osDefault notif
+doNotify NotifyWithTerminal notif = do
+  renderer <- renderOsc
+  putStrAndFlush $ (fromMaybe renderOsc777 renderer) notif
+doNotify (NotifyWithCustom (cmd:args)) (header, body) = spawnNotifier
+    $ proc cmd (args ++ [unpack header, unpack body])
+doNotify NotifyWithNotifySend (header, body) = spawnNotifier
+    $ proc "notify-send" ["-a", "glirc", unpack header, unpack body]
+doNotify NotifyWithOsaScript (header, body) = spawnNotifier
+    $ setEnv [("_GLIRC_NOTIF_HEADER", unpack header), ("_GLIRC_NOTIF_BODY", unpack body)]
+    $ proc "osascript" ["-e", script]
+    where
+      script = "display notification (system attribute \"_GLIRC_NOTIF_BODY\") with title \"glirc\" subtitle (system attribute \"_GLIRC_NOTIF_HEADER\")"
+doNotify NotifyWithTerminalNotifier (header, body) = spawnNotifier
+    $ proc "terminal-notifier" ["-title", "glirc", "-subtitle", unpack header, "-message", "\\" <> unpack body]
+
+spawnNotifier :: ProcessConfig i o e -> IO ()
+spawnNotifier cmd = do
+  let procCfg = setStdin nullStream . setStdout nullStream $ setStderr nullStream cmd
+  catch (void (startProcess procCfg)) handleException
+  where
+    -- TODO: May be a nicer way to handle notification failure than just silently squashing the exception
+    handleException :: SomeException -> IO ()
+    handleException _ = return ()
+
+-- Here be TUI dragons.
+-- There are three different noteworthy OSC sequences for telling terminal emulators to display a notification.
+-- By far the most-widely supported is OSC 777 notify.
+-- However, we also need to support OSC 9 on iTerm2 (and ONLY iTerm2) and OSC 99 on kitty.
+-- Technically other terminals that support OSC 99 (if any exist, not sure) can be queried for support.
+-- We're not doing that. That'll be the responsibility of vty if it ever gets that functionality.
+
+type RenderFn = Notification -> Text
+
+makeOsc :: Text -> Text -> Text
+makeOsc code payload = mconcat ["\ESC]", code, ";", payload, "\ESC\\"]
+
+renderOsc777 :: RenderFn
+renderOsc777 (header, body) = makeOsc "777;notify" $ mconcat [header, ";", body]
+
+renderOsc :: IO (Maybe RenderFn)
+renderOsc = do
+  term <- lookupEnv "TERM"
+  case tryModify (stripPrefix "xterm-") . tryModify (stripSuffix "-direct") . pack <$> term of
+    -- Special terminals
+    Just "iterm2"  -> return $ Just $ \(header, body) ->
+      makeOsc "9" $ mconcat [header, ": ", body]
+    Just "kitty"  -> return $ Just $ \(header, body) -> mconcat
+      [ (makeOsc "99;i=1:d=0"    header)
+      , (makeOsc "99;i=1:p=body" body)
+      ]
+    -- Everything else
+    Just "foot"         -> return $ Just renderOsc777
+    Just "ghostty"      -> return $ Just renderOsc777
+    Just "rxvt-unicode" -> return $ Just renderOsc777
+    Just "wezterm"      -> return $ Just renderOsc777
+    _ -> return Nothing
+  where
+    tryModify :: (Text -> Maybe Text) -> Text -> Text
+    tryModify f str = fromMaybe str $ f str