diff --git a/glirc.cabal b/glirc.cabal index 3f8b1fa4..d11842b1 100644 --- a/glirc.cabal +++ b/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 diff --git a/src/Client/Configuration.hs b/src/Client/Configuration.hs index 4fcf8e61..3a490532 100644 --- a/src/Client/Configuration.hs +++ b/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" diff --git a/src/Client/Configuration/Notifications.hs b/src/Client/Configuration/Notifications.hs index f40fba99..e00c0aa7 100644 --- a/src/Client/Configuration/Notifications.hs +++ b/src/Client/Configuration/Notifications.hs @@ -6,19 +6,18 @@ Copyright : (c) TheDaemoness, 2023 License : ISC Maintainer : emertens@gmail.com -} -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 diff --git a/src/Client/EventLoop.hs b/src/Client/EventLoop.hs index 5b79acd6..5f010434 100644 --- a/src/Client/EventLoop.hs +++ b/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 :: diff --git a/src/Client/EventLoop/Notifications.hs b/src/Client/EventLoop/Notifications.hs new file mode 100644 index 00000000..3365334d --- /dev/null +++ b/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 : emertens@gmail.com + +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