diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,14 @@ # Changelog for gtk-sni-tray +## 0.2.0.0 + +- Breaking: remove `buildTrayWithPriority`, `buildTrayWithPixbufTransform`, + and `buildTrayWithPriorityAndPixbufTransform`. +- Consolidate tray configuration into `TrayParams` with new fields: + `trayPriorityConfig`, `trayPixbufTransform`, and `trayEventHooks`. +- Add click interception hooks via `TrayEventHooks`/`TrayClickHook` so callers + can run custom per-item behavior and choose default/override/consume. + ## 0.1.15.0 - Fix: respect the user's GTK icon theme when an SNI item provides IconThemePath diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -1,706 +1,780 @@ {-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-deprecations #-} -module Main where - -import Control.Monad -import DBus.Client -import Data.Int -import Data.Char (toLower) -import Data.Maybe -import Data.Ratio -import qualified Data.Map.Strict as Map -import qualified Data.Text as T -import Data.Version (showVersion) -import qualified DBus as DBus -import qualified GI.Gdk as Gdk -import qualified GI.Gtk as Gtk -import Graphics.UI.GIGtkStrut -import Options.Applicative -import qualified StatusNotifier.Host.Service as Host -import qualified StatusNotifier.Icon.Pixbuf as IconPixbuf -import StatusNotifier.TransparentWindow -import StatusNotifier.Tray -import System.Log.Logger -import System.Posix.Process -import System.Environment (lookupEnv) -import System.Exit (exitFailure) -import Text.Printf - -import Paths_gtk_sni_tray (version) - -import qualified GI.GtkLayerShell as GtkLayerShell - -data Backend = BackendX11 | BackendWayland deriving (Eq, Show) - -data BackendChoice = BackendAuto | BackendX11Choice | BackendWaylandChoice - deriving (Eq, Show, Read) - -data IconRecolorMode - = IconRecolorNone - | IconRecolorMono - | IconRecolorDuotone - deriving (Eq, Show, Read) - -detectBackend :: IO Backend -detectBackend = do - supported <- GtkLayerShell.isSupported - pure $ if supported then BackendWayland else BackendX11 - -backendChoiceP :: Parser BackendChoice -backendChoiceP = - option (eitherReader parseBackendChoice) - ( long "backend" - <> help "Backend selection: auto | x11 | wayland" - <> value BackendAuto - <> metavar "BACKEND" - ) - where - parseBackendChoice s = - case map toLower s of - "auto" -> Right BackendAuto - "x11" -> Right BackendX11Choice - "wayland" -> Right BackendWaylandChoice - _ -> Left "expected one of: auto, x11, wayland" - -logRuntimeInfo :: BackendChoice -> Backend -> IO () -logRuntimeInfo backendChoice backend = do - sessionType <- lookupEnv "XDG_SESSION_TYPE" - waylandDisplay <- lookupEnv "WAYLAND_DISPLAY" - gdkBackend <- lookupEnv "GDK_BACKEND" - mDisplay <- Gdk.displayGetDefault - displayName <- case mDisplay of - Nothing -> pure Nothing - Just d -> Just <$> Gdk.displayGetName d - layerShellSupported <- GtkLayerShell.isSupported - logM "StatusNotifier.StandaloneWindow" INFO $ - printf "backendChoice=%s backend=%s layerShellSupported=%s XDG_SESSION_TYPE=%s WAYLAND_DISPLAY=%s GDK_BACKEND=%s gdkDisplay=%s" - (show backendChoice) - (show backend) - (show layerShellSupported) - (show sessionType) - (show waylandDisplay) - (show gdkBackend) - (show displayName) - -hasStatusNotifierWatcher :: Client -> IO Bool -hasStatusNotifierWatcher client = do - let mc = - (DBus.methodCall dbusPath - (DBus.interfaceName_ "org.freedesktop.DBus") - (DBus.memberName_ "NameHasOwner")) - { DBus.methodCallDestination = Just dbusName - , DBus.methodCallBody = [DBus.toVariant ("org.kde.StatusNotifierWatcher" :: String)] - } - reply <- call_ client mc - case DBus.methodReturnBody reply of - [v] -> pure $ fromMaybe False (DBus.fromVariant v) - _ -> pure False - -setupLayerShellWindow :: StrutConfig -> Gtk.Window -> Bool -> IO () -setupLayerShellWindow StrutConfig - { strutWidth = widthSize - , strutHeight = heightSize - , strutXPadding = xpadding - , strutYPadding = ypadding - , strutMonitor = monitorNumber - , strutPosition = position - , strutAlignment = alignment - , strutDisplayName = maybeDisplayName - } window reserveSpace = do - supported <- GtkLayerShell.isSupported - unless supported $ - logM "StatusNotifier.StandaloneWindow" WARNING $ - "Wayland detected, but gtk-layer-shell is not supported; falling back to a regular toplevel window" - when supported $ do - Gtk.windowSetDecorated window False - - maybeDisplay <- maybe Gdk.displayGetDefault Gdk.displayOpen maybeDisplayName - case maybeDisplay of - Nothing -> logM "StatusNotifier.StandaloneWindow" WARNING "Failed to get GDK display for layer-shell" - Just display -> do - nMonitors <- Gdk.displayGetNMonitors display - logM "StatusNotifier.StandaloneWindow" INFO $ printf "GDK monitors reported: %d" nMonitors - - let tryIndex idx = if idx < 0 || idx >= nMonitors then pure Nothing else Gdk.displayGetMonitor display idx - - mPrimary <- Gdk.displayGetPrimaryMonitor display - mChosen <- case monitorNumber of - Nothing -> pure mPrimary - Just idx -> tryIndex idx - - monitor <- - case mChosen <|> mPrimary of - Just m -> pure (Just m) - Nothing -> tryIndex 0 - - GtkLayerShell.initForWindow window - GtkLayerShell.setKeyboardMode window GtkLayerShell.KeyboardModeNone - GtkLayerShell.setNamespace window (T.pack "gtk-sni-tray") - GtkLayerShell.setLayer window GtkLayerShell.LayerTop - - GtkLayerShell.setMargin window GtkLayerShell.EdgeLeft xpadding - GtkLayerShell.setMargin window GtkLayerShell.EdgeRight xpadding - GtkLayerShell.setMargin window GtkLayerShell.EdgeTop ypadding - GtkLayerShell.setMargin window GtkLayerShell.EdgeBottom ypadding - - let setAnchor = GtkLayerShell.setAnchor window - case position of - TopPos -> do - setAnchor GtkLayerShell.EdgeTop True - setAnchor GtkLayerShell.EdgeBottom False - setAnchor GtkLayerShell.EdgeLeft True - setAnchor GtkLayerShell.EdgeRight True - BottomPos -> do - setAnchor GtkLayerShell.EdgeTop False - setAnchor GtkLayerShell.EdgeBottom True - setAnchor GtkLayerShell.EdgeLeft True - setAnchor GtkLayerShell.EdgeRight True - LeftPos -> do - setAnchor GtkLayerShell.EdgeLeft True - setAnchor GtkLayerShell.EdgeRight False - setAnchor GtkLayerShell.EdgeTop True - setAnchor GtkLayerShell.EdgeBottom True - RightPos -> do - setAnchor GtkLayerShell.EdgeLeft False - setAnchor GtkLayerShell.EdgeRight True - setAnchor GtkLayerShell.EdgeTop True - setAnchor GtkLayerShell.EdgeBottom True - - let fallbackExclusive = - if reserveSpace - then case position of - TopPos -> case heightSize of ExactSize h -> h + 2 * ypadding; _ -> 0 - BottomPos -> case heightSize of ExactSize h -> h + 2 * ypadding; _ -> 0 - LeftPos -> case widthSize of ExactSize w -> w + 2 * xpadding; _ -> 0 - RightPos -> case widthSize of ExactSize w -> w + 2 * xpadding; _ -> 0 - else 0 - GtkLayerShell.setExclusiveZone window fallbackExclusive - - case monitor of - Nothing -> logM "StatusNotifier.StandaloneWindow" WARNING "Failed to select a GDK monitor for layer-shell; using fallback sizing/anchors" - Just m -> do - GtkLayerShell.setMonitor window m - isPrim <- Gdk.monitorIsPrimary m - model <- Gdk.monitorGetModel m - manuf <- Gdk.monitorGetManufacturer m - logM "StatusNotifier.StandaloneWindow" INFO $ - printf "Using monitor primary=%s manufacturer=%s model=%s" - (show isPrim) (show manuf) (show model) - - monitorGeometry <- Gdk.monitorGetGeometry m - monitorWidth <- Gdk.getRectangleWidth monitorGeometry - monitorHeight <- Gdk.getRectangleHeight monitorGeometry - let availableWidth = monitorWidth - (2 * xpadding) - availableHeight = monitorHeight - (2 * ypadding) - width = - case widthSize of - ExactSize w -> w - ScreenRatio p -> - floor $ p * fromIntegral availableWidth - height = - case heightSize of - ExactSize h -> h - ScreenRatio p -> - floor $ p * fromIntegral availableHeight - clampNonNegative x = if x < 0 then 0 else x - centerOffset availSize size = - clampNonNegative $ (availSize - size) `div` 2 - endOffset availSize size = - clampNonNegative $ availSize - size - - (leftMargin, rightMargin, topMargin, bottomMargin) = - case position of - TopPos -> - let offset = - if width >= availableWidth - then 0 - else case alignment of - Beginning -> 0 - Center -> centerOffset availableWidth width - End -> endOffset availableWidth width - l = xpadding + offset - r = xpadding - in (l, r, ypadding, ypadding) - BottomPos -> - let offset = - if width >= availableWidth - then 0 - else case alignment of - Beginning -> 0 - Center -> centerOffset availableWidth width - End -> endOffset availableWidth width - l = xpadding + offset - r = xpadding - in (l, r, ypadding, ypadding) - LeftPos -> - let offset = - if height >= availableHeight - then 0 - else case alignment of - Beginning -> 0 - Center -> centerOffset availableHeight height - End -> endOffset availableHeight height - t = ypadding + offset - b = ypadding - in (xpadding, xpadding, t, b) - RightPos -> - let offset = - if height >= availableHeight - then 0 - else case alignment of - Beginning -> 0 - Center -> centerOffset availableHeight height - End -> endOffset availableHeight height - t = ypadding + offset - b = ypadding - in (xpadding, xpadding, t, b) - - exclusive = - if reserveSpace - then case position of - TopPos -> height + topMargin - BottomPos -> height + bottomMargin - LeftPos -> width + leftMargin - RightPos -> width + rightMargin - else 0 - - Gtk.windowSetDefaultSize window (fromIntegral width) (fromIntegral height) - let (reqWidth, reqHeight) = - case position of - TopPos -> (min width availableWidth, height) - BottomPos -> (min width availableWidth, height) - LeftPos -> (width, min height availableHeight) - RightPos -> (width, min height availableHeight) - Gtk.widgetSetSizeRequest window - (fromIntegral reqWidth) - (fromIntegral reqHeight) - - GtkLayerShell.setMargin window GtkLayerShell.EdgeLeft leftMargin - GtkLayerShell.setMargin window GtkLayerShell.EdgeRight rightMargin - GtkLayerShell.setMargin window GtkLayerShell.EdgeTop topMargin - GtkLayerShell.setMargin window GtkLayerShell.EdgeBottom bottomMargin - - case position of - TopPos -> do - setAnchor GtkLayerShell.EdgeTop True - setAnchor GtkLayerShell.EdgeBottom False - if width >= availableWidth - then do - setAnchor GtkLayerShell.EdgeLeft True - setAnchor GtkLayerShell.EdgeRight True - else case alignment of - Beginning -> do - setAnchor GtkLayerShell.EdgeLeft True - setAnchor GtkLayerShell.EdgeRight False - Center -> do - setAnchor GtkLayerShell.EdgeLeft True - setAnchor GtkLayerShell.EdgeRight False - End -> do - setAnchor GtkLayerShell.EdgeLeft False - setAnchor GtkLayerShell.EdgeRight True - BottomPos -> do - setAnchor GtkLayerShell.EdgeTop False - setAnchor GtkLayerShell.EdgeBottom True - if width >= availableWidth - then do - setAnchor GtkLayerShell.EdgeLeft True - setAnchor GtkLayerShell.EdgeRight True - else case alignment of - Beginning -> do - setAnchor GtkLayerShell.EdgeLeft True - setAnchor GtkLayerShell.EdgeRight False - Center -> do - setAnchor GtkLayerShell.EdgeLeft True - setAnchor GtkLayerShell.EdgeRight False - End -> do - setAnchor GtkLayerShell.EdgeLeft False - setAnchor GtkLayerShell.EdgeRight True - LeftPos -> do - setAnchor GtkLayerShell.EdgeLeft True - setAnchor GtkLayerShell.EdgeRight False - if height >= availableHeight - then do - setAnchor GtkLayerShell.EdgeTop True - setAnchor GtkLayerShell.EdgeBottom True - else case alignment of - Beginning -> do - setAnchor GtkLayerShell.EdgeTop True - setAnchor GtkLayerShell.EdgeBottom False - Center -> do - setAnchor GtkLayerShell.EdgeTop True - setAnchor GtkLayerShell.EdgeBottom False - End -> do - setAnchor GtkLayerShell.EdgeTop False - setAnchor GtkLayerShell.EdgeBottom True - RightPos -> do - setAnchor GtkLayerShell.EdgeLeft False - setAnchor GtkLayerShell.EdgeRight True - if height >= availableHeight - then do - setAnchor GtkLayerShell.EdgeTop True - setAnchor GtkLayerShell.EdgeBottom True - else case alignment of - Beginning -> do - setAnchor GtkLayerShell.EdgeTop True - setAnchor GtkLayerShell.EdgeBottom False - Center -> do - setAnchor GtkLayerShell.EdgeTop True - setAnchor GtkLayerShell.EdgeBottom False - End -> do - setAnchor GtkLayerShell.EdgeTop False - setAnchor GtkLayerShell.EdgeBottom True - - GtkLayerShell.setExclusiveZone window exclusive - -positionP :: Parser StrutPosition -positionP = fromMaybe TopPos <$> optional - ( flag' TopPos - ( long "top" - <> help "Position the bar at the top of the screen" - ) - <|> flag' BottomPos - ( long "bottom" - <> help "Position the bar at the bottom of the screen" - ) - <|> flag' LeftPos - ( long "left" - <> help "Position the bar on the left side of the screen" - ) - <|> flag' RightPos - ( long "right" - <> help "Position the bar on the right side of the screen" - )) - -alignmentP :: Parser StrutAlignment -alignmentP = fromMaybe Center <$> optional - ( flag' Beginning - ( long "beginning" - <> help "Use beginning alignment" - ) - <|> flag' Center - ( long "center" - <> help "Use center alignment" - ) - <|> flag' End - ( long "end" - <> help "Use end alignment" - )) - -sizeP :: Parser Int32 -sizeP = - option auto - ( long "size" - <> short 's' - <> help "Set the size of the bar" - <> value 30 - <> metavar "SIZE" - ) - -paddingP :: Parser Int32 -paddingP = - option auto - ( long "padding" - <> short 'p' - <> help "Set the padding of the bar" - <> value 0 - <> metavar "PADDING" - ) - -monitorNumberP :: Parser [Int32] -monitorNumberP = many $ - option auto - ( long "monitor" - <> short 'm' - <> help "Display a tray bar on the given monitor" - <> metavar "MONITOR" - ) - -logP :: Parser Priority -logP = - option auto - ( long "log-level" - <> short 'l' - <> help "Set the log level" - <> metavar "LEVEL" - <> value WARNING - ) - -colorP :: Parser (Maybe String) -colorP = optional $ - strOption - ( long "color" - <> short 'c' - <> help "Set the background color of the tray; See https://developer.gnome.org/gdk3/stable/gdk3-RGBA-Colors.html#gdk-rgba-parse for acceptable values" - <> metavar "COLOR" - ) - -expandP :: Parser Bool -expandP = - switch - ( long "expand" - <> help "Let icons expand into the space allocated to the tray" - <> short 'e' - ) - -centerIconsP :: Parser Bool -centerIconsP = - switch - ( long "center-icons" - <> help "Center the tray icons within the bar" - ) - -startWatcherP :: Parser Bool -startWatcherP = - switch - ( long "watcher" - <> short 'w' - <> help "Start a Watcher to handle SNI registration if one does not exist" - ) - -noStrutP :: Parser Bool -noStrutP = - switch - ( long "no-strut" - <> help "Do not reserve space for the window (X11: no strut; Wayland: exclusive zone 0)" - ) - -barLengthP :: Parser Rational -barLengthP = - option auto - ( long "length" - <> help "Set the proportion of the screen that the tray bar should occupy -- values are parsed as haskell rationals (e.g. 1 % 2)" - <> value 1 - ) - -overlayScaleP :: Parser Rational -overlayScaleP = - option auto - ( long "overlay-scale" - <> short 'o' - <> help "The proportion of the tray icon's size that should be set for overlay icons." - <> value (5 % 7) - ) - -iconPreferenceP :: Parser TrayIconPreference -iconPreferenceP = - option (eitherReader parsePref) - ( long "icon-preference" - <> help "Icon preference when both are provided: pixmaps (default) | themed" - <> value PreferPixmaps - <> metavar "PREFERENCE" - ) - where - parsePref s = - case map toLower s of - "pixmaps" -> Right PreferPixmaps - "pixmap" -> Right PreferPixmaps - "themed" -> Right PreferThemedIcons - "theme" -> Right PreferThemedIcons - _ -> Left "expected one of: pixmaps, themed" - -iconRecolorModeP :: Parser IconRecolorMode -iconRecolorModeP = - option (eitherReader parseMode) - ( long "icon-recolor" - <> help "Recolor icons based on their alpha mask: none (default) | mono | duotone" - <> value IconRecolorNone - <> metavar "MODE" - ) - where - parseMode s = - case map toLower s of - "none" -> Right IconRecolorNone - "mono" -> Right IconRecolorMono - "duo" -> Right IconRecolorDuotone - "duotone" -> Right IconRecolorDuotone - _ -> Left "expected one of: none, mono, duotone" - -menuBackendP :: Parser MenuBackend -menuBackendP = - option (eitherReader parseMenuBackend) - ( long "menu-backend" - <> help "Menu backend: haskell (default) | libdbusmenu" - <> value HaskellDBusMenu - <> metavar "BACKEND" - ) - where - parseMenuBackend s = - case map toLower s of - "libdbusmenu" -> Right LibDBusMenu - "haskell" -> Right HaskellDBusMenu - _ -> Left "expected one of: libdbusmenu, haskell" - -getColor :: String -> IO Gdk.RGBA -getColor colorString = do - rgba <- Gdk.newZeroRGBA - colorParsed <- Gdk.rGBAParse rgba (T.pack colorString) - unless colorParsed $ do - logM "StatusNotifier.Tray" WARNING "Failed to parse provided color" - void $ Gdk.rGBAParse rgba "#000000" - return rgba - -buildWindows :: StrutPosition - -> StrutAlignment - -> Int32 - -> Int32 - -> [Int32] - -> Priority - -> BackendChoice - -> Maybe String - -> Bool - -> Bool - -> Bool - -> Bool - -> Rational - -> Rational - -> MenuBackend - -> TrayIconPreference - -> IconRecolorMode - -> IO () -buildWindows pos align size padding monitors priority backendChoice maybeColorString expand - centerIcons startWatcher noStrut barLength overlayScale menuBackend iconPreference iconRecolorMode = do - _ <- Gtk.init Nothing - logger <- getLogger "StatusNotifier" - saveGlobalLogger $ setLevel priority logger - detectedBackend <- detectBackend - let backend = - case backendChoice of - BackendAuto -> detectedBackend - BackendX11Choice -> BackendX11 - BackendWaylandChoice -> BackendWayland - client <- connectSession - logRuntimeInfo backendChoice backend - watcherPresent <- hasStatusNotifierWatcher client - unless watcherPresent $ do - logM "StatusNotifier" WARNING $ - "No StatusNotifierWatcher found on D-Bus (org.kde.StatusNotifierWatcher). Tray will likely be empty." - unless startWatcher $ - logM "StatusNotifier" WARNING $ - "Start a watcher first (recommended) or run with --watcher to start one in-process." - _ <- getRootLogger - pid <- getProcessID - host <- - Host.build - Host.defaultParams - { Host.dbusClient = Just client - , Host.uniqueIdentifier = printf "standalone-%s" $ show pid - , Host.startWatcher = startWatcher - } - >>= maybe (logM "StatusNotifier" ERROR "Failed to start StatusNotifier host" >> exitFailure) pure - initialItems <- Host.itemInfoMap host - logM "StatusNotifier" INFO $ printf "Initial tray items: %d" (Map.size initialItems) - let c1 = - defaultStrutConfig - { strutPosition = pos - , strutAlignment = align - , strutXPadding = padding - , strutYPadding = padding - } - defaultRatio = ScreenRatio barLength - configBase = - case pos of - TopPos -> c1 {strutHeight = ExactSize size, strutWidth = defaultRatio} - BottomPos -> - c1 {strutHeight = ExactSize size, strutWidth = defaultRatio} - RightPos -> - c1 {strutHeight = defaultRatio, strutWidth = ExactSize size} - LeftPos -> - c1 {strutHeight = defaultRatio, strutWidth = ExactSize size} - buildWithConfig config = do - let orientation = - case strutPosition config of - TopPos -> Gtk.OrientationHorizontal - BottomPos -> Gtk.OrientationHorizontal - _ -> Gtk.OrientationVertical - mixWord8 t a b = - let ta = fromIntegral a :: Double - tb = fromIntegral b :: Double - out = ta + max 0 (min 1 t) * (tb - ta) - in fromIntegral (max (0 :: Int) (min 255 (round out))) - mixRgb8 t (IconPixbuf.Rgb8 r g b) (IconPixbuf.Rgb8 r2 g2 b2) = - IconPixbuf.Rgb8 (mixWord8 t r r2) (mixWord8 t g g2) (mixWord8 t b b2) - mkIconTransform = - case iconRecolorMode of - IconRecolorNone -> Nothing - IconRecolorMono -> - Just $ \image pb -> do - ctx <- Gtk.widgetGetStyleContext image - fg <- Gtk.styleContextGetColor ctx [Gtk.StateFlagsNormal] - fg8 <- IconPixbuf.rgb8FromGdkRGBA fg - mpb <- IconPixbuf.recolorPixbufMonochrome fg8 pb - return $ fromMaybe pb mpb - IconRecolorDuotone -> - Just $ \image pb -> do - ctx <- Gtk.widgetGetStyleContext image - fg <- Gtk.styleContextGetColor ctx [Gtk.StateFlagsNormal] - fg8 <- IconPixbuf.rgb8FromGdkRGBA fg - let black = IconPixbuf.Rgb8 0 0 0 - white = IconPixbuf.Rgb8 255 255 255 - dark = mixRgb8 0.35 fg8 black - light = mixRgb8 0.35 fg8 white - mpb <- IconPixbuf.recolorPixbufDuotone dark light pb - return $ fromMaybe pb mpb - tray <- - buildTrayWithPixbufTransform host client - TrayParams - { trayOrientation = orientation - , trayImageSize = Expand - , trayIconExpand = expand - , trayIconPreference = iconPreference - , trayAlignment = align - , trayOverlayScale = overlayScale - , trayLeftClickAction = Activate - , trayMiddleClickAction = SecondaryActivate - , trayRightClickAction = PopupMenu - , trayMenuBackend = menuBackend - , trayCenterIcons = centerIcons - } - mkIconTransform - window <- Gtk.windowNew Gtk.WindowTypeToplevel - Gtk.windowSetResizable window False - Gtk.windowSetSkipTaskbarHint window True - Gtk.windowSetSkipPagerHint window True - Gtk.windowSetAcceptFocus window False - Gtk.windowSetFocusOnMap window False - Gtk.windowSetKeepAbove window True - Gtk.windowSetTypeHint window Gdk.WindowTypeHintDock - case backend of - BackendX11 -> - when (not noStrut) $ setupStrutWindow config window - BackendWayland -> - setupLayerShellWindow config window (not noStrut) - maybe - (makeWindowTransparent window) - (getColor >=> - Gtk.widgetOverrideBackgroundColor window [Gtk.StateFlagsNormal] . - Just) - maybeColorString - Gtk.containerAdd window tray - Gtk.widgetShowAll window - runForMonitor monitor = - buildWithConfig configBase {strutMonitor = Just monitor} - if null monitors - then buildWithConfig configBase - else mapM_ runForMonitor monitors - Gtk.main - -parser :: Parser (IO ()) -parser = - buildWindows <$> positionP <*> alignmentP <*> sizeP <*> paddingP <*> - monitorNumberP <*> logP <*> backendChoiceP <*> colorP <*> expandP <*> - centerIconsP <*> startWatcherP <*> - noStrutP <*> barLengthP <*> overlayScaleP <*> menuBackendP <*> iconPreferenceP <*> iconRecolorModeP - -versionOption :: Parser (a -> a) -versionOption = infoOption - (printf "gtk-sni-tray-standalone %s" $ showVersion version) - ( long "version" - <> help "Show the version number of gtk-sni-tray" - ) - -main :: IO () -main = - join $ execParser $ info (helper <*> versionOption <*> parser) - ( fullDesc - <> progDesc "Run a standalone StatusNotifierItem/AppIndicator tray" - ) + +module Main where + +import Control.Monad +import qualified DBus as DBus +import DBus.Client +import Data.Char (toLower) +import Data.Int +import qualified Data.Map.Strict as Map +import Data.Maybe +import Data.Ratio +import qualified Data.Text as T +import Data.Version (showVersion) +import qualified GI.Gdk as Gdk +import qualified GI.Gtk as Gtk +import qualified GI.GtkLayerShell as GtkLayerShell +import Graphics.UI.GIGtkStrut +import Options.Applicative +import Paths_gtk_sni_tray (version) +import qualified StatusNotifier.Host.Service as Host +import qualified StatusNotifier.Icon.Pixbuf as IconPixbuf +import StatusNotifier.TransparentWindow +import StatusNotifier.Tray +import System.Environment (lookupEnv) +import System.Exit (exitFailure) +import System.Log.Logger +import System.Posix.Process +import Text.Printf + +data Backend = BackendX11 | BackendWayland deriving (Eq, Show) + +data BackendChoice = BackendAuto | BackendX11Choice | BackendWaylandChoice + deriving (Eq, Show, Read) + +data IconRecolorMode + = IconRecolorNone + | IconRecolorMono + | IconRecolorDuotone + deriving (Eq, Show, Read) + +detectBackend :: IO Backend +detectBackend = do + supported <- GtkLayerShell.isSupported + pure $ if supported then BackendWayland else BackendX11 + +backendChoiceP :: Parser BackendChoice +backendChoiceP = + option + (eitherReader parseBackendChoice) + ( long "backend" + <> help "Backend selection: auto | x11 | wayland" + <> value BackendAuto + <> metavar "BACKEND" + ) + where + parseBackendChoice s = + case map toLower s of + "auto" -> Right BackendAuto + "x11" -> Right BackendX11Choice + "wayland" -> Right BackendWaylandChoice + _ -> Left "expected one of: auto, x11, wayland" + +logRuntimeInfo :: BackendChoice -> Backend -> IO () +logRuntimeInfo backendChoice backend = do + sessionType <- lookupEnv "XDG_SESSION_TYPE" + waylandDisplay <- lookupEnv "WAYLAND_DISPLAY" + gdkBackend <- lookupEnv "GDK_BACKEND" + mDisplay <- Gdk.displayGetDefault + displayName <- case mDisplay of + Nothing -> pure Nothing + Just d -> Just <$> Gdk.displayGetName d + layerShellSupported <- GtkLayerShell.isSupported + logM "StatusNotifier.StandaloneWindow" INFO $ + printf + "backendChoice=%s backend=%s layerShellSupported=%s XDG_SESSION_TYPE=%s WAYLAND_DISPLAY=%s GDK_BACKEND=%s gdkDisplay=%s" + (show backendChoice) + (show backend) + (show layerShellSupported) + (show sessionType) + (show waylandDisplay) + (show gdkBackend) + (show displayName) + +hasStatusNotifierWatcher :: Client -> IO Bool +hasStatusNotifierWatcher client = do + let mc = + ( DBus.methodCall + dbusPath + (DBus.interfaceName_ "org.freedesktop.DBus") + (DBus.memberName_ "NameHasOwner") + ) + { DBus.methodCallDestination = Just dbusName, + DBus.methodCallBody = [DBus.toVariant ("org.kde.StatusNotifierWatcher" :: String)] + } + reply <- call_ client mc + case DBus.methodReturnBody reply of + [v] -> pure $ fromMaybe False (DBus.fromVariant v) + _ -> pure False + +setupLayerShellWindow :: StrutConfig -> Gtk.Window -> Bool -> IO () +setupLayerShellWindow + StrutConfig + { strutWidth = widthSize, + strutHeight = heightSize, + strutXPadding = xpadding, + strutYPadding = ypadding, + strutMonitor = monitorNumber, + strutPosition = position, + strutAlignment = alignment, + strutDisplayName = maybeDisplayName + } + window + reserveSpace = do + supported <- GtkLayerShell.isSupported + unless supported $ + logM "StatusNotifier.StandaloneWindow" WARNING $ + "Wayland detected, but gtk-layer-shell is not supported; falling back to a regular toplevel window" + when supported $ do + Gtk.windowSetDecorated window False + + maybeDisplay <- maybe Gdk.displayGetDefault Gdk.displayOpen maybeDisplayName + case maybeDisplay of + Nothing -> logM "StatusNotifier.StandaloneWindow" WARNING "Failed to get GDK display for layer-shell" + Just display -> do + nMonitors <- Gdk.displayGetNMonitors display + logM "StatusNotifier.StandaloneWindow" INFO $ printf "GDK monitors reported: %d" nMonitors + + let tryIndex idx = if idx < 0 || idx >= nMonitors then pure Nothing else Gdk.displayGetMonitor display idx + + mPrimary <- Gdk.displayGetPrimaryMonitor display + mChosen <- case monitorNumber of + Nothing -> pure mPrimary + Just idx -> tryIndex idx + + monitor <- + case mChosen <|> mPrimary of + Just m -> pure (Just m) + Nothing -> tryIndex 0 + + GtkLayerShell.initForWindow window + GtkLayerShell.setKeyboardMode window GtkLayerShell.KeyboardModeNone + GtkLayerShell.setNamespace window (T.pack "gtk-sni-tray") + GtkLayerShell.setLayer window GtkLayerShell.LayerTop + + GtkLayerShell.setMargin window GtkLayerShell.EdgeLeft xpadding + GtkLayerShell.setMargin window GtkLayerShell.EdgeRight xpadding + GtkLayerShell.setMargin window GtkLayerShell.EdgeTop ypadding + GtkLayerShell.setMargin window GtkLayerShell.EdgeBottom ypadding + + let setAnchor = GtkLayerShell.setAnchor window + case position of + TopPos -> do + setAnchor GtkLayerShell.EdgeTop True + setAnchor GtkLayerShell.EdgeBottom False + setAnchor GtkLayerShell.EdgeLeft True + setAnchor GtkLayerShell.EdgeRight True + BottomPos -> do + setAnchor GtkLayerShell.EdgeTop False + setAnchor GtkLayerShell.EdgeBottom True + setAnchor GtkLayerShell.EdgeLeft True + setAnchor GtkLayerShell.EdgeRight True + LeftPos -> do + setAnchor GtkLayerShell.EdgeLeft True + setAnchor GtkLayerShell.EdgeRight False + setAnchor GtkLayerShell.EdgeTop True + setAnchor GtkLayerShell.EdgeBottom True + RightPos -> do + setAnchor GtkLayerShell.EdgeLeft False + setAnchor GtkLayerShell.EdgeRight True + setAnchor GtkLayerShell.EdgeTop True + setAnchor GtkLayerShell.EdgeBottom True + + let fallbackExclusive = + if reserveSpace + then case position of + TopPos -> case heightSize of ExactSize h -> h + 2 * ypadding; _ -> 0 + BottomPos -> case heightSize of ExactSize h -> h + 2 * ypadding; _ -> 0 + LeftPos -> case widthSize of ExactSize w -> w + 2 * xpadding; _ -> 0 + RightPos -> case widthSize of ExactSize w -> w + 2 * xpadding; _ -> 0 + else 0 + GtkLayerShell.setExclusiveZone window fallbackExclusive + + case monitor of + Nothing -> logM "StatusNotifier.StandaloneWindow" WARNING "Failed to select a GDK monitor for layer-shell; using fallback sizing/anchors" + Just m -> do + GtkLayerShell.setMonitor window m + isPrim <- Gdk.monitorIsPrimary m + model <- Gdk.monitorGetModel m + manuf <- Gdk.monitorGetManufacturer m + logM "StatusNotifier.StandaloneWindow" INFO $ + printf + "Using monitor primary=%s manufacturer=%s model=%s" + (show isPrim) + (show manuf) + (show model) + + monitorGeometry <- Gdk.monitorGetGeometry m + monitorWidth <- Gdk.getRectangleWidth monitorGeometry + monitorHeight <- Gdk.getRectangleHeight monitorGeometry + let availableWidth = monitorWidth - (2 * xpadding) + availableHeight = monitorHeight - (2 * ypadding) + width = + case widthSize of + ExactSize w -> w + ScreenRatio p -> + floor $ p * fromIntegral availableWidth + height = + case heightSize of + ExactSize h -> h + ScreenRatio p -> + floor $ p * fromIntegral availableHeight + clampNonNegative x = if x < 0 then 0 else x + centerOffset availSize size = + clampNonNegative $ (availSize - size) `div` 2 + endOffset availSize size = + clampNonNegative $ availSize - size + + (leftMargin, rightMargin, topMargin, bottomMargin) = + case position of + TopPos -> + let offset = + if width >= availableWidth + then 0 + else case alignment of + Beginning -> 0 + Center -> centerOffset availableWidth width + End -> endOffset availableWidth width + l = xpadding + offset + r = xpadding + in (l, r, ypadding, ypadding) + BottomPos -> + let offset = + if width >= availableWidth + then 0 + else case alignment of + Beginning -> 0 + Center -> centerOffset availableWidth width + End -> endOffset availableWidth width + l = xpadding + offset + r = xpadding + in (l, r, ypadding, ypadding) + LeftPos -> + let offset = + if height >= availableHeight + then 0 + else case alignment of + Beginning -> 0 + Center -> centerOffset availableHeight height + End -> endOffset availableHeight height + t = ypadding + offset + b = ypadding + in (xpadding, xpadding, t, b) + RightPos -> + let offset = + if height >= availableHeight + then 0 + else case alignment of + Beginning -> 0 + Center -> centerOffset availableHeight height + End -> endOffset availableHeight height + t = ypadding + offset + b = ypadding + in (xpadding, xpadding, t, b) + + exclusive = + if reserveSpace + then case position of + TopPos -> height + topMargin + BottomPos -> height + bottomMargin + LeftPos -> width + leftMargin + RightPos -> width + rightMargin + else 0 + + Gtk.windowSetDefaultSize window (fromIntegral width) (fromIntegral height) + let (reqWidth, reqHeight) = + case position of + TopPos -> (min width availableWidth, height) + BottomPos -> (min width availableWidth, height) + LeftPos -> (width, min height availableHeight) + RightPos -> (width, min height availableHeight) + Gtk.widgetSetSizeRequest + window + (fromIntegral reqWidth) + (fromIntegral reqHeight) + + GtkLayerShell.setMargin window GtkLayerShell.EdgeLeft leftMargin + GtkLayerShell.setMargin window GtkLayerShell.EdgeRight rightMargin + GtkLayerShell.setMargin window GtkLayerShell.EdgeTop topMargin + GtkLayerShell.setMargin window GtkLayerShell.EdgeBottom bottomMargin + + case position of + TopPos -> do + setAnchor GtkLayerShell.EdgeTop True + setAnchor GtkLayerShell.EdgeBottom False + if width >= availableWidth + then do + setAnchor GtkLayerShell.EdgeLeft True + setAnchor GtkLayerShell.EdgeRight True + else case alignment of + Beginning -> do + setAnchor GtkLayerShell.EdgeLeft True + setAnchor GtkLayerShell.EdgeRight False + Center -> do + setAnchor GtkLayerShell.EdgeLeft True + setAnchor GtkLayerShell.EdgeRight False + End -> do + setAnchor GtkLayerShell.EdgeLeft False + setAnchor GtkLayerShell.EdgeRight True + BottomPos -> do + setAnchor GtkLayerShell.EdgeTop False + setAnchor GtkLayerShell.EdgeBottom True + if width >= availableWidth + then do + setAnchor GtkLayerShell.EdgeLeft True + setAnchor GtkLayerShell.EdgeRight True + else case alignment of + Beginning -> do + setAnchor GtkLayerShell.EdgeLeft True + setAnchor GtkLayerShell.EdgeRight False + Center -> do + setAnchor GtkLayerShell.EdgeLeft True + setAnchor GtkLayerShell.EdgeRight False + End -> do + setAnchor GtkLayerShell.EdgeLeft False + setAnchor GtkLayerShell.EdgeRight True + LeftPos -> do + setAnchor GtkLayerShell.EdgeLeft True + setAnchor GtkLayerShell.EdgeRight False + if height >= availableHeight + then do + setAnchor GtkLayerShell.EdgeTop True + setAnchor GtkLayerShell.EdgeBottom True + else case alignment of + Beginning -> do + setAnchor GtkLayerShell.EdgeTop True + setAnchor GtkLayerShell.EdgeBottom False + Center -> do + setAnchor GtkLayerShell.EdgeTop True + setAnchor GtkLayerShell.EdgeBottom False + End -> do + setAnchor GtkLayerShell.EdgeTop False + setAnchor GtkLayerShell.EdgeBottom True + RightPos -> do + setAnchor GtkLayerShell.EdgeLeft False + setAnchor GtkLayerShell.EdgeRight True + if height >= availableHeight + then do + setAnchor GtkLayerShell.EdgeTop True + setAnchor GtkLayerShell.EdgeBottom True + else case alignment of + Beginning -> do + setAnchor GtkLayerShell.EdgeTop True + setAnchor GtkLayerShell.EdgeBottom False + Center -> do + setAnchor GtkLayerShell.EdgeTop True + setAnchor GtkLayerShell.EdgeBottom False + End -> do + setAnchor GtkLayerShell.EdgeTop False + setAnchor GtkLayerShell.EdgeBottom True + + GtkLayerShell.setExclusiveZone window exclusive + +positionP :: Parser StrutPosition +positionP = + fromMaybe TopPos + <$> optional + ( flag' + TopPos + ( long "top" + <> help "Position the bar at the top of the screen" + ) + <|> flag' + BottomPos + ( long "bottom" + <> help "Position the bar at the bottom of the screen" + ) + <|> flag' + LeftPos + ( long "left" + <> help "Position the bar on the left side of the screen" + ) + <|> flag' + RightPos + ( long "right" + <> help "Position the bar on the right side of the screen" + ) + ) + +alignmentP :: Parser StrutAlignment +alignmentP = + fromMaybe Center + <$> optional + ( flag' + Beginning + ( long "beginning" + <> help "Use beginning alignment" + ) + <|> flag' + Center + ( long "center" + <> help "Use center alignment" + ) + <|> flag' + End + ( long "end" + <> help "Use end alignment" + ) + ) + +sizeP :: Parser Int32 +sizeP = + option + auto + ( long "size" + <> short 's' + <> help "Set the size of the bar" + <> value 30 + <> metavar "SIZE" + ) + +paddingP :: Parser Int32 +paddingP = + option + auto + ( long "padding" + <> short 'p' + <> help "Set the padding of the bar" + <> value 0 + <> metavar "PADDING" + ) + +monitorNumberP :: Parser [Int32] +monitorNumberP = + many $ + option + auto + ( long "monitor" + <> short 'm' + <> help "Display a tray bar on the given monitor" + <> metavar "MONITOR" + ) + +logP :: Parser Priority +logP = + option + auto + ( long "log-level" + <> short 'l' + <> help "Set the log level" + <> metavar "LEVEL" + <> value WARNING + ) + +colorP :: Parser (Maybe String) +colorP = + optional $ + strOption + ( long "color" + <> short 'c' + <> help "Set the background color of the tray; See https://developer.gnome.org/gdk3/stable/gdk3-RGBA-Colors.html#gdk-rgba-parse for acceptable values" + <> metavar "COLOR" + ) + +expandP :: Parser Bool +expandP = + switch + ( long "expand" + <> help "Let icons expand into the space allocated to the tray" + <> short 'e' + ) + +centerIconsP :: Parser Bool +centerIconsP = + switch + ( long "center-icons" + <> help "Center the tray icons within the bar" + ) + +startWatcherP :: Parser Bool +startWatcherP = + switch + ( long "watcher" + <> short 'w' + <> help "Start a Watcher to handle SNI registration if one does not exist" + ) + +noStrutP :: Parser Bool +noStrutP = + switch + ( long "no-strut" + <> help "Do not reserve space for the window (X11: no strut; Wayland: exclusive zone 0)" + ) + +barLengthP :: Parser Rational +barLengthP = + option + auto + ( long "length" + <> help "Set the proportion of the screen that the tray bar should occupy -- values are parsed as haskell rationals (e.g. 1 % 2)" + <> value 1 + ) + +overlayScaleP :: Parser Rational +overlayScaleP = + option + auto + ( long "overlay-scale" + <> short 'o' + <> help "The proportion of the tray icon's size that should be set for overlay icons." + <> value (5 % 7) + ) + +iconPreferenceP :: Parser TrayIconPreference +iconPreferenceP = + option + (eitherReader parsePref) + ( long "icon-preference" + <> help "Icon preference when both are provided: pixmaps (default) | themed" + <> value PreferPixmaps + <> metavar "PREFERENCE" + ) + where + parsePref s = + case map toLower s of + "pixmaps" -> Right PreferPixmaps + "pixmap" -> Right PreferPixmaps + "themed" -> Right PreferThemedIcons + "theme" -> Right PreferThemedIcons + _ -> Left "expected one of: pixmaps, themed" + +iconRecolorModeP :: Parser IconRecolorMode +iconRecolorModeP = + option + (eitherReader parseMode) + ( long "icon-recolor" + <> help "Recolor icons based on their alpha mask: none (default) | mono | duotone" + <> value IconRecolorNone + <> metavar "MODE" + ) + where + parseMode s = + case map toLower s of + "none" -> Right IconRecolorNone + "mono" -> Right IconRecolorMono + "duo" -> Right IconRecolorDuotone + "duotone" -> Right IconRecolorDuotone + _ -> Left "expected one of: none, mono, duotone" + +menuBackendP :: Parser MenuBackend +menuBackendP = + option + (eitherReader parseMenuBackend) + ( long "menu-backend" + <> help "Menu backend: haskell (default) | libdbusmenu" + <> value HaskellDBusMenu + <> metavar "BACKEND" + ) + where + parseMenuBackend s = + case map toLower s of + "libdbusmenu" -> Right LibDBusMenu + "haskell" -> Right HaskellDBusMenu + _ -> Left "expected one of: libdbusmenu, haskell" + +getColor :: String -> IO Gdk.RGBA +getColor colorString = do + rgba <- Gdk.newZeroRGBA + colorParsed <- Gdk.rGBAParse rgba (T.pack colorString) + unless colorParsed $ do + logM "StatusNotifier.Tray" WARNING "Failed to parse provided color" + void $ Gdk.rGBAParse rgba "#000000" + return rgba + +buildWindows :: + StrutPosition -> + StrutAlignment -> + Int32 -> + Int32 -> + [Int32] -> + Priority -> + BackendChoice -> + Maybe String -> + Bool -> + Bool -> + Bool -> + Bool -> + Rational -> + Rational -> + MenuBackend -> + TrayIconPreference -> + IconRecolorMode -> + IO () +buildWindows + pos + align + size + padding + monitors + priority + backendChoice + maybeColorString + expand + centerIcons + startWatcher + noStrut + barLength + overlayScale + menuBackend + iconPreference + iconRecolorMode = do + _ <- Gtk.init Nothing + logger <- getLogger "StatusNotifier" + saveGlobalLogger $ setLevel priority logger + detectedBackend <- detectBackend + let backend = + case backendChoice of + BackendAuto -> detectedBackend + BackendX11Choice -> BackendX11 + BackendWaylandChoice -> BackendWayland + client <- connectSession + logRuntimeInfo backendChoice backend + watcherPresent <- hasStatusNotifierWatcher client + unless watcherPresent $ do + logM "StatusNotifier" WARNING $ + "No StatusNotifierWatcher found on D-Bus (org.kde.StatusNotifierWatcher). Tray will likely be empty." + unless startWatcher $ + logM "StatusNotifier" WARNING $ + "Start a watcher first (recommended) or run with --watcher to start one in-process." + _ <- getRootLogger + pid <- getProcessID + host <- + Host.build + Host.defaultParams + { Host.dbusClient = Just client, + Host.uniqueIdentifier = printf "standalone-%s" $ show pid, + Host.startWatcher = startWatcher + } + >>= maybe (logM "StatusNotifier" ERROR "Failed to start StatusNotifier host" >> exitFailure) pure + initialItems <- Host.itemInfoMap host + logM "StatusNotifier" INFO $ printf "Initial tray items: %d" (Map.size initialItems) + let c1 = + defaultStrutConfig + { strutPosition = pos, + strutAlignment = align, + strutXPadding = padding, + strutYPadding = padding + } + defaultRatio = ScreenRatio barLength + configBase = + case pos of + TopPos -> c1 {strutHeight = ExactSize size, strutWidth = defaultRatio} + BottomPos -> + c1 {strutHeight = ExactSize size, strutWidth = defaultRatio} + RightPos -> + c1 {strutHeight = defaultRatio, strutWidth = ExactSize size} + LeftPos -> + c1 {strutHeight = defaultRatio, strutWidth = ExactSize size} + buildWithConfig config = do + let orientation = + case strutPosition config of + TopPos -> Gtk.OrientationHorizontal + BottomPos -> Gtk.OrientationHorizontal + _ -> Gtk.OrientationVertical + mixWord8 t a b = + let ta = fromIntegral a :: Double + tb = fromIntegral b :: Double + out = ta + max 0 (min 1 t) * (tb - ta) + in fromIntegral (max (0 :: Int) (min 255 (round out))) + mixRgb8 t (IconPixbuf.Rgb8 r g b) (IconPixbuf.Rgb8 r2 g2 b2) = + IconPixbuf.Rgb8 (mixWord8 t r r2) (mixWord8 t g g2) (mixWord8 t b b2) + mkIconTransform = + case iconRecolorMode of + IconRecolorNone -> Nothing + IconRecolorMono -> + Just $ \image pb -> do + ctx <- Gtk.widgetGetStyleContext image + fg <- Gtk.styleContextGetColor ctx [Gtk.StateFlagsNormal] + fg8 <- IconPixbuf.rgb8FromGdkRGBA fg + mpb <- IconPixbuf.recolorPixbufMonochrome fg8 pb + return $ fromMaybe pb mpb + IconRecolorDuotone -> + Just $ \image pb -> do + ctx <- Gtk.widgetGetStyleContext image + fg <- Gtk.styleContextGetColor ctx [Gtk.StateFlagsNormal] + fg8 <- IconPixbuf.rgb8FromGdkRGBA fg + let black = IconPixbuf.Rgb8 0 0 0 + white = IconPixbuf.Rgb8 255 255 255 + dark = mixRgb8 0.35 fg8 black + light = mixRgb8 0.35 fg8 white + mpb <- IconPixbuf.recolorPixbufDuotone dark light pb + return $ fromMaybe pb mpb + tray <- + buildTray + host + client + TrayParams + { trayOrientation = orientation, + trayImageSize = Expand, + trayIconExpand = expand, + trayIconPreference = iconPreference, + trayAlignment = align, + trayOverlayScale = overlayScale, + trayLeftClickAction = Activate, + trayMiddleClickAction = SecondaryActivate, + trayRightClickAction = PopupMenu, + trayMenuBackend = menuBackend, + trayCenterIcons = centerIcons, + trayPriorityConfig = defaultTrayPriorityConfig, + trayPixbufTransform = mkIconTransform, + trayEventHooks = defaultTrayEventHooks + } + window <- Gtk.windowNew Gtk.WindowTypeToplevel + Gtk.windowSetResizable window False + Gtk.windowSetSkipTaskbarHint window True + Gtk.windowSetSkipPagerHint window True + Gtk.windowSetAcceptFocus window False + Gtk.windowSetFocusOnMap window False + Gtk.windowSetKeepAbove window True + Gtk.windowSetTypeHint window Gdk.WindowTypeHintDock + case backend of + BackendX11 -> + when (not noStrut) $ setupStrutWindow config window + BackendWayland -> + setupLayerShellWindow config window (not noStrut) + maybe + (makeWindowTransparent window) + ( getColor + >=> Gtk.widgetOverrideBackgroundColor window [Gtk.StateFlagsNormal] + . Just + ) + maybeColorString + Gtk.containerAdd window tray + Gtk.widgetShowAll window + runForMonitor monitor = + buildWithConfig configBase {strutMonitor = Just monitor} + if null monitors + then buildWithConfig configBase + else mapM_ runForMonitor monitors + Gtk.main + +parser :: Parser (IO ()) +parser = + buildWindows + <$> positionP + <*> alignmentP + <*> sizeP + <*> paddingP + <*> monitorNumberP + <*> logP + <*> backendChoiceP + <*> colorP + <*> expandP + <*> centerIconsP + <*> startWatcherP + <*> noStrutP + <*> barLengthP + <*> overlayScaleP + <*> menuBackendP + <*> iconPreferenceP + <*> iconRecolorModeP + +versionOption :: Parser (a -> a) +versionOption = + infoOption + (printf "gtk-sni-tray-standalone %s" $ showVersion version) + ( long "version" + <> help "Show the version number of gtk-sni-tray" + ) + +main :: IO () +main = + join $ + execParser $ + info + (helper <*> versionOption <*> parser) + ( fullDesc + <> progDesc "Run a standalone StatusNotifierItem/AppIndicator tray" + ) diff --git a/gtk-sni-tray.cabal b/gtk-sni-tray.cabal --- a/gtk-sni-tray.cabal +++ b/gtk-sni-tray.cabal @@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: gtk-sni-tray -version: 0.1.15.0 +version: 0.2.0.0 synopsis: A standalone StatusNotifierItem/AppIndicator tray description: Please see the README on Github at category: System diff --git a/src/StatusNotifier/Tray.hs b/src/StatusNotifier/Tray.hs --- a/src/StatusNotifier/Tray.hs +++ b/src/StatusNotifier/Tray.hs @@ -1,873 +1,993 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE OverloadedLabels #-} -{-# LANGUAGE CPP #-} -module StatusNotifier.Tray where - -import Control.Concurrent.MVar as MV -import Data.IORef (newIORef, readIORef, writeIORef) -import Control.Exception.Base -import Control.Exception.Enclosed (catchAny) -import Control.Monad -import Control.Monad.Trans.Class -import Control.Monad.Trans.Maybe -import DBus.Client -import qualified DBus.Internal.Types as DBusTypes -import Data.Bool (bool) -import qualified Data.ByteString as BS -import Data.Coerce -import Data.Foldable (traverse_) -import Data.GI.Base (unsafeCastTo) -import Data.GI.Base.GError -import Data.Int -import Data.List -import qualified Data.Map.Strict as Map -import Data.Maybe -import Data.Ord -import Data.Ratio -import qualified Data.Text as T -import qualified GI.DbusmenuGtk3.Objects.Menu as DM -import qualified GI.GLib as GLib -import GI.GLib.Structs.Bytes -import qualified GI.Gdk as Gdk -import GI.Gdk.Enums -import GI.Gdk.Structs.EventScroll -import GI.GdkPixbuf.Enums -import GI.GdkPixbuf.Objects.Pixbuf as Gdk -import qualified GI.Gtk as Gtk -import GI.Gtk.Flags -import GI.Gtk.Objects.IconTheme -import Graphics.UI.GIGtkStrut -import qualified DBusMenu -import StatusNotifier.Host.Service -import qualified StatusNotifier.Item.Client as IC -import System.Directory -import System.FilePath -import System.Log.Logger -import Text.Printf -import Foreign.Ptr (Ptr) - -trayLogger :: Priority -> String -> IO () -trayLogger = logM "StatusNotifier.Tray" - --- | Optional post-processing hook for item icons. This is applied after scaling --- and overlay composition. -type PixbufTransform = Gtk.Image -> Pixbuf -> IO Pixbuf - -logItemInfo :: ItemInfo -> String -> IO () -logItemInfo info message = - trayLogger INFO $ printf "%s - %s pixmap count: %s" message - (show $ info { iconPixmaps = []}) - (show $ length $ iconPixmaps info) - -getScaledWidthHeight :: Bool -> Int32 -> Int32 -> Int32 -> (Int32, Int32) -getScaledWidthHeight shouldTargetWidth targetSize width height = - let getRatio :: Int32 -> Rational - getRatio toScale = - fromIntegral targetSize / fromIntegral toScale - getOther :: Int32 -> Int32 -> Int32 - getOther toScale other = max 1 $ floor $ getRatio toScale * fromIntegral other - in - if shouldTargetWidth - then (targetSize, getOther width height) - else (getOther height width, targetSize) - -scalePixbufToSize :: Int32 -> Gtk.Orientation -> Pixbuf -> IO Pixbuf -scalePixbufToSize size orientation pixbuf = do - width <- pixbufGetWidth pixbuf - height <- pixbufGetHeight pixbuf - let warnAndReturnOrig = - trayLogger WARNING "Unable to scale pixbuf" >> return pixbuf - if width <= 0 || height <= 0 - then warnAndReturnOrig - else do - let targetWidth = case orientation of - Gtk.OrientationHorizontal -> False - _ -> True - (scaledWidth, scaledHeight) = - getScaledWidthHeight targetWidth size width height - trayLogger DEBUG $ - printf - "Scaling pb to %s, actualW: %s, actualH: %s, scaledW: %s, scaledH: %s" - (show size) (show width) (show height) - (show scaledWidth) (show scaledHeight) - - trayLogger DEBUG $ printf "targetW: %s, targetH: %s" - (show scaledWidth) (show scaledHeight) - maybe warnAndReturnOrig return =<< - pixbufScaleSimple pixbuf scaledWidth scaledHeight InterpTypeBilinear - -themeLoadFlags :: [IconLookupFlags] -themeLoadFlags = [IconLookupFlagsGenericFallback, IconLookupFlagsUseBuiltin] - -getThemeWithOptionalSearchPath :: Maybe String -> IO IconTheme -getThemeWithOptionalSearchPath themePath = do - theme <- iconThemeGetDefault - forM_ (themePath >>= nonEmpty) $ \p -> do - -- Respect the user's configured icon theme by using GTK's default theme - -- object, but include any item-provided IconThemePath as an additional - -- search path. - -- - -- Some items provide IconThemePath pointing inside a theme dir, e.g.: - -- .../Papirus/64x64/mimetypes - -- GTK expects search paths that contain theme directories, so also try to - -- append the parent directory of any ancestor that contains index.theme. - pathsToAppend <- pathsForIconThemePath p - existing <- iconThemeGetSearchPath theme - forM_ pathsToAppend $ \p' -> - unless (p' `elem` existing) $ iconThemeAppendSearchPath theme p' - return theme - where - nonEmpty "" = Nothing - nonEmpty x = Just x - -pathsForIconThemePath :: FilePath -> IO [FilePath] -pathsForIconThemePath rawPath = do - mThemeDir <- findAncestorWithIndexTheme 8 rawPath - let base = - case mThemeDir of - Nothing -> [] - Just themeDir -> [takeDirectory themeDir] - return $ nub $ base ++ [rawPath] - where - findAncestorWithIndexTheme :: Int -> FilePath -> IO (Maybe FilePath) - findAncestorWithIndexTheme 0 _ = return Nothing - findAncestorWithIndexTheme n p = do - hasIndex <- doesFileExist (p "index.theme") - if hasIndex - then return (Just p) - else do - let parent = takeDirectory p - if parent == p - then return Nothing - else findAncestorWithIndexTheme (n - 1) parent - -catchGErrorsAsLeft :: IO a -> IO (Either GError a) -catchGErrorsAsLeft action = catch (Right <$> action) (return . Left) - -catchGErrorsAsNothing :: IO a -> IO (Maybe a) -catchGErrorsAsNothing action = catchGErrorsAsLeft action >>= rightToJustLogLeft - where rightToJustLogLeft (Right value) = return $ Just value - rightToJustLogLeft (Left err) = do - trayLogger WARNING $ printf "Encountered error: %s" $ show err - return Nothing - -safePixbufNewFromFile :: FilePath -> IO (Maybe Gdk.Pixbuf) -safePixbufNewFromFile = - handleResult . catchGErrorsAsNothing . Gdk.pixbufNewFromFile - where -#if MIN_VERSION_gi_gdkpixbuf(2,0,26) - handleResult = fmap join -#else - handleResult = id -#endif - -getIconPixbufByName :: Int32 -> T.Text -> Maybe String -> IO (Maybe Pixbuf) -getIconPixbufByName size name themePath = do - trayLogger DEBUG $ printf "Getting Pixbuf from name for %s" name - themeForIcon <- getThemeWithOptionalSearchPath themePath - - let panelName = T.pack $ printf "%s-panel" name - -- Avoid relying on iconThemeHasIcon: it can be overly strict when fallback - -- loading is enabled. Just try to load and fall back if it fails. - let tryLoad :: T.Text -> IO (Maybe Pixbuf) - tryLoad iconName = - catchAny (iconThemeLoadIcon themeForIcon iconName size themeLoadFlags) - (const $ pure Nothing) - - themedPixbuf <- do - pbPanel <- tryLoad panelName - case pbPanel of - Just _ -> return pbPanel - Nothing -> tryLoad name - - case themedPixbuf of - Just _ -> return themedPixbuf - Nothing -> do - trayLogger DEBUG $ printf "Trying to load icon %s as filepath" name - -- Try to load the icon as a filepath - let nameString = T.unpack name - fileExists <- doesFileExist nameString - maybeFile <- if fileExists - then return $ Just nameString - else fmap join $ sequenceA $ getIconPathFromThemePath nameString <$> themePath -#if MIN_VERSION_gi_gdkpixbuf(2,0,26) - let handleResult = fmap join . sequenceA -#else - let handleResult = sequenceA -#endif - handleResult $ safePixbufNewFromFile <$> maybeFile - -getIconPathFromThemePath :: String -> String -> IO (Maybe String) -getIconPathFromThemePath name themePath = if name == "" then return Nothing else do - trayLogger DEBUG $ printf - "Trying to load icon %s as filepath with theme path %s" - name themePath - pathExists <- doesDirectoryExist themePath - if pathExists - then do - fileNames <- catchAny (listDirectory themePath) (const $ return []) - trayLogger DEBUG $ printf - "Found files in theme path %s" (show fileNames) - return $ (themePath ) <$> find (isPrefixOf name) fileNames - else return Nothing - -getIconPixbufFromByteString :: Int32 -> Int32 -> BS.ByteString -> IO (Maybe Pixbuf) -getIconPixbufFromByteString width height byteString - | width <= 0 || height <= 0 = do - trayLogger WARNING $ printf "Invalid icon dimensions: %dx%d" width height - return Nothing - | otherwise = catchGErrorsAsNothing $ do - trayLogger DEBUG "Getting Pixbuf from bytestring" - bytes <- bytesNew $ Just byteString - let bytesPerPixel = 4 - rowStride = width * bytesPerPixel - sampleBits = 8 - pixbufNewFromBytes bytes ColorspaceRgb True sampleBits width height rowStride - -data ItemContext = ItemContext - { contextName :: DBusTypes.BusName - , contextMenuPath :: Maybe DBusTypes.ObjectPath - , contextImage :: Gtk.Image - , contextButton :: Gtk.EventBox - } - -data TrayImageSize = Expand | TrayImageSize Int32 - -data TrayClickAction = Activate | SecondaryActivate | PopupMenu - -data MenuBackend = LibDBusMenu | HaskellDBusMenu deriving (Eq, Show) - -data TrayItemMatcher = TrayItemMatcher - { trayItemMatcherDescription :: String - , trayItemMatcherPredicate :: ItemInfo -> Bool - } - -data TrayPriorityConfig = TrayPriorityConfig - { trayPriorityMatchers :: [TrayItemMatcher] - } - -defaultTrayPriorityConfig :: TrayPriorityConfig -defaultTrayPriorityConfig = TrayPriorityConfig { trayPriorityMatchers = [] } - -mkTrayItemMatcher :: String -> (ItemInfo -> Bool) -> TrayItemMatcher -mkTrayItemMatcher = TrayItemMatcher - -trayMatchAny :: [TrayItemMatcher] -> TrayItemMatcher -trayMatchAny matchers = mkTrayItemMatcher "any" $ \info -> - any (\matcher -> trayItemMatcherPredicate matcher info) matchers - -trayMatchAll :: [TrayItemMatcher] -> TrayItemMatcher -trayMatchAll matchers = mkTrayItemMatcher "all" $ \info -> - all (\matcher -> trayItemMatcherPredicate matcher info) matchers - -trayMatchNot :: TrayItemMatcher -> TrayItemMatcher -trayMatchNot matcher = - mkTrayItemMatcher ("not(" <> trayItemMatcherDescription matcher <> ")") $ - not . trayItemMatcherPredicate matcher - -normalizeText :: T.Text -> T.Text -normalizeText = T.toCaseFold - -containsCI :: T.Text -> T.Text -> Bool -containsCI needle haystack = - normalizeText needle `T.isInfixOf` normalizeText haystack - -equalsCI :: T.Text -> T.Text -> Bool -equalsCI left right = normalizeText left == normalizeText right - -matchOnTextFields :: - String -> - (T.Text -> T.Text -> Bool) -> - [ItemInfo -> Maybe T.Text] -> - T.Text -> - TrayItemMatcher -matchOnTextFields matcherName comparator fieldGetters target = - mkTrayItemMatcher matcherName $ \info -> - any - (\fieldGetter -> maybe False (comparator target) (fieldGetter info)) - fieldGetters - -serviceNameText :: ItemInfo -> T.Text -serviceNameText = T.pack . (coerce :: DBusTypes.BusName -> String) . itemServiceName - -servicePathText :: ItemInfo -> T.Text -servicePathText = T.pack . (coerce :: DBusTypes.ObjectPath -> String) . itemServicePath - -menuPathText :: ItemInfo -> Maybe T.Text -menuPathText = fmap (T.pack . (coerce :: DBusTypes.ObjectPath -> String)) . menuPath - -itemIdText :: ItemInfo -> Maybe T.Text -itemIdText = fmap T.pack . itemId - -itemCategoryText :: ItemInfo -> Maybe T.Text -itemCategoryText = fmap T.pack . itemCategory - -itemStatusText :: ItemInfo -> Maybe T.Text -itemStatusText = fmap T.pack . itemStatus - -iconNameText :: ItemInfo -> T.Text -iconNameText = T.pack . iconName - -iconTitleText :: ItemInfo -> T.Text -iconTitleText = T.pack . iconTitle - -tooltipTitleText :: ItemInfo -> Maybe T.Text -tooltipTitleText info = (\(_, _, titleText, _) -> T.pack titleText) <$> itemToolTip info - -tooltipBodyText :: ItemInfo -> Maybe T.Text -tooltipBodyText info = (\(_, _, _, bodyText) -> T.pack bodyText) <$> itemToolTip info - -trayMatchServiceNameContains :: T.Text -> TrayItemMatcher -trayMatchServiceNameContains = - matchOnTextFields "service-name-contains" containsCI [Just . serviceNameText] - -trayMatchServiceNameEquals :: T.Text -> TrayItemMatcher -trayMatchServiceNameEquals = - matchOnTextFields "service-name-equals" equalsCI [Just . serviceNameText] - -trayMatchServicePathContains :: T.Text -> TrayItemMatcher -trayMatchServicePathContains = - matchOnTextFields "service-path-contains" containsCI [Just . servicePathText] - -trayMatchServicePathEquals :: T.Text -> TrayItemMatcher -trayMatchServicePathEquals = - matchOnTextFields "service-path-equals" equalsCI [Just . servicePathText] - -trayMatchMenuPathContains :: T.Text -> TrayItemMatcher -trayMatchMenuPathContains = - matchOnTextFields "menu-path-contains" containsCI [menuPathText] - -trayMatchMenuPathEquals :: T.Text -> TrayItemMatcher -trayMatchMenuPathEquals = - matchOnTextFields "menu-path-equals" equalsCI [menuPathText] - -trayMatchItemIdContains :: T.Text -> TrayItemMatcher -trayMatchItemIdContains = - matchOnTextFields "item-id-contains" containsCI [itemIdText] - -trayMatchItemIdEquals :: T.Text -> TrayItemMatcher -trayMatchItemIdEquals = - matchOnTextFields "item-id-equals" equalsCI [itemIdText] - -trayMatchItemCategoryContains :: T.Text -> TrayItemMatcher -trayMatchItemCategoryContains = - matchOnTextFields "item-category-contains" containsCI [itemCategoryText] - -trayMatchItemCategoryEquals :: T.Text -> TrayItemMatcher -trayMatchItemCategoryEquals = - matchOnTextFields "item-category-equals" equalsCI [itemCategoryText] - -trayMatchStatusContains :: T.Text -> TrayItemMatcher -trayMatchStatusContains = - matchOnTextFields "item-status-contains" containsCI [itemStatusText] - -trayMatchStatusEquals :: T.Text -> TrayItemMatcher -trayMatchStatusEquals = - matchOnTextFields "item-status-equals" equalsCI [itemStatusText] - -trayMatchIconNameContains :: T.Text -> TrayItemMatcher -trayMatchIconNameContains = - matchOnTextFields "icon-name-contains" containsCI [Just . iconNameText] - -trayMatchIconNameEquals :: T.Text -> TrayItemMatcher -trayMatchIconNameEquals = - matchOnTextFields "icon-name-equals" equalsCI [Just . iconNameText] - -trayMatchIconTitleContains :: T.Text -> TrayItemMatcher -trayMatchIconTitleContains = - matchOnTextFields "icon-title-contains" containsCI [Just . iconTitleText] - -trayMatchIconTitleEquals :: T.Text -> TrayItemMatcher -trayMatchIconTitleEquals = - matchOnTextFields "icon-title-equals" equalsCI [Just . iconTitleText] - -trayMatchTooltipContains :: T.Text -> TrayItemMatcher -trayMatchTooltipContains = - matchOnTextFields "tooltip-contains" containsCI [tooltipTitleText, tooltipBodyText] - -trayMatchTooltipEquals :: T.Text -> TrayItemMatcher -trayMatchTooltipEquals = - matchOnTextFields "tooltip-equals" equalsCI [tooltipTitleText, tooltipBodyText] - -trayMatchAnyTextContains :: T.Text -> TrayItemMatcher -trayMatchAnyTextContains = - matchOnTextFields - "any-text-contains" - containsCI - [ Just . serviceNameText - , Just . servicePathText - , menuPathText - , itemIdText - , itemCategoryText - , itemStatusText - , Just . iconNameText - , Just . iconTitleText - , tooltipTitleText - , tooltipBodyText - ] - -trayMatchIsMenu :: Bool -> TrayItemMatcher -trayMatchIsMenu expected = - mkTrayItemMatcher "is-menu" $ \info -> itemIsMenu info == expected - --- | Controls whether to prefer application-provided pixmaps or themed icons --- when both are present. Some items provide both. -data TrayIconPreference - = PreferPixmaps - | PreferThemedIcons - deriving (Eq, Show, Read) - -data TrayParams = TrayParams - { trayOrientation :: Gtk.Orientation - , trayImageSize :: TrayImageSize - , trayIconExpand :: Bool - , trayIconPreference :: TrayIconPreference - , trayAlignment :: StrutAlignment - , trayOverlayScale :: Rational - , trayLeftClickAction :: TrayClickAction - , trayMiddleClickAction :: TrayClickAction - , trayRightClickAction :: TrayClickAction - , trayMenuBackend :: MenuBackend - , trayCenterIcons :: Bool - } - -defaultTrayParams :: TrayParams -defaultTrayParams = TrayParams - { trayOrientation = Gtk.OrientationHorizontal - , trayImageSize = Expand - , trayIconExpand = False - , trayIconPreference = PreferPixmaps - , trayAlignment = End - , trayOverlayScale = 2 % 5 - , trayLeftClickAction = Activate - , trayMiddleClickAction = SecondaryActivate - , trayRightClickAction = PopupMenu - , trayMenuBackend = HaskellDBusMenu - , trayCenterIcons = False - } - -buildTray :: Host -> Client -> TrayParams -> IO Gtk.Box -buildTray host client params = - buildTrayWithPixbufTransform host client params Nothing - -buildTrayWithPriority :: Host -> Client -> TrayParams -> TrayPriorityConfig -> IO Gtk.Box -buildTrayWithPriority host client params priorityConfig = - buildTrayWithPriorityAndPixbufTransform host client params priorityConfig Nothing - -buildTrayWithPixbufTransform :: Host -> Client -> TrayParams -> Maybe PixbufTransform -> IO Gtk.Box -buildTrayWithPixbufTransform host client params mTransform = - buildTrayWithPriorityAndPixbufTransform host client params defaultTrayPriorityConfig mTransform - -buildTrayWithPriorityAndPixbufTransform :: Host -> Client -> TrayParams -> TrayPriorityConfig -> Maybe PixbufTransform -> IO Gtk.Box -buildTrayWithPriorityAndPixbufTransform Host - { itemInfoMap = getInfoMap - , addUpdateHandler = addUHandler - , removeUpdateHandler = removeUHandler - } - client - TrayParams { trayOrientation = orientation - , trayImageSize = imageSize - , trayIconExpand = shouldExpand - , trayIconPreference = iconPreference - , trayAlignment = alignment - , trayOverlayScale = overlayScale - , trayLeftClickAction = leftClickAction - , trayMiddleClickAction = middleClickAction - , trayRightClickAction = rightClickAction - , trayMenuBackend = menuBackend - , trayCenterIcons = centerIcons - } - TrayPriorityConfig { trayPriorityMatchers = priorityMatchers } - mTransform = do - trayLogger INFO "Building tray" - - trayBox <- Gtk.boxNew orientation 0 - when centerIcons $ case orientation of - Gtk.OrientationHorizontal -> Gtk.widgetSetHalign trayBox Gtk.AlignCenter - _ -> Gtk.widgetSetValign trayBox Gtk.AlignCenter - Gtk.widgetGetStyleContext trayBox >>= - flip Gtk.styleContextAddClass "tray-box" - contextMap <- MV.newMVar Map.empty - - let getContext name = Map.lookup name <$> MV.readMVar contextMap - showInfo info = show info { iconPixmaps = [] } - - getSize rectangle = - case orientation of - Gtk.OrientationHorizontal -> - Gdk.getRectangleHeight rectangle - _ -> - Gdk.getRectangleWidth rectangle - - getInfoAttr fn def name = maybe def fn . Map.lookup name <$> getInfoMap - - getInfo :: ItemInfo -> DBusTypes.BusName -> IO ItemInfo - getInfo = getInfoAttr id - - getPriorityIndex info = - fromMaybe - (length priorityMatchers) - (findIndex (\matcher -> trayItemMatcherPredicate matcher info) priorityMatchers) - - reorderTrayByPriority = when (not (null priorityMatchers)) $ do - currentChildren <- Gtk.containerGetChildren trayBox - contexts <- MV.readMVar contextMap - contextWidgets <- forM (Map.toList contexts) $ - \(busName, ItemContext { contextButton = button }) -> do - widget <- Gtk.toWidget button - return (busName, widget) - infoMap <- getInfoMap - let childRows = - [ let busName = fst <$> find (\(_, widget) -> widget == child) contextWidgets - itemInfo = busName >>= (`Map.lookup` infoMap) - priority = maybe (length priorityMatchers) getPriorityIndex itemInfo - in (priority, currentIndex, child) - | (currentIndex, child) <- zip [0 :: Int ..] currentChildren - ] - sortedChildren = - [ child - | (_, _, child) <- - sortOn (\(priority, currentIndex, _) -> (priority, currentIndex)) childRows - ] - forM_ (zip [0 :: Int ..] sortedChildren) $ - \(newIndex, child) -> - Gtk.boxReorderChild trayBox child (fromIntegral newIndex) - - applyTransform :: Gtk.Image -> Maybe Pixbuf -> IO (Maybe Pixbuf) - applyTransform _ Nothing = return Nothing - applyTransform image (Just pb) = - case mTransform of - Nothing -> return (Just pb) - Just f -> Just <$> f image pb - - updateIconFromInfo info@ItemInfo { itemServiceName = name } = - getContext name >>= updateIcon - where updateIcon Nothing = updateHandler ItemAdded info - updateIcon (Just ItemContext { contextImage = image } ) = do - size <- case imageSize of - TrayImageSize size -> return size - Expand -> Gtk.widgetGetAllocation image >>= getSize - getScaledPixBufFromInfo size info - >>= applyTransform image - >>= - let handlePixbuf mpbuf = - if isJust mpbuf - then Gtk.imageSetFromPixbuf image mpbuf - else trayLogger WARNING $ - printf "Failed to get pixbuf for %s" $ - showInfo info - in handlePixbuf - - getTooltipText ItemInfo { itemToolTip = Just (_, _, titleText, fullText )} - | titleText == fullText = fullText - | titleText == "" = fullText - | fullText == "" = titleText - | otherwise = printf "%s: %s" titleText fullText - getTooltipText _ = "" - - setTooltipText widget info = - Gtk.widgetSetTooltipText widget $ Just $ T.pack $ getTooltipText info - - updateHandler ItemAdded - info@ItemInfo { menuPath = pathForMenu - , itemServiceName = serviceName - , itemServicePath = servicePath - } = - do - let serviceNameStr = (coerce serviceName :: String) - servicePathStr = coerce servicePath :: String - logText = printf "Adding widget for %s - %s" - serviceNameStr servicePathStr - - trayLogger INFO logText - - eventBox <- Gtk.eventBoxNew - Gtk.widgetAddEvents eventBox [Gdk.EventMaskScrollMask] - Gtk.widgetGetStyleContext eventBox >>= - flip Gtk.styleContextAddClass "tray-icon-button" - - image <- Gtk.imageNew - - case imageSize of - Expand -> do - lastAllocation <- MV.newMVar Nothing - - let setPixbuf allocation = - do - size <- getSize allocation - - actualWidth <- Gdk.getRectangleWidth allocation - actualHeight <- Gdk.getRectangleHeight allocation - - requestResize <- MV.modifyMVar lastAllocation $ \previous -> - let thisTime = Just (size, actualWidth, actualHeight) - in return (thisTime, thisTime /= previous) - - trayLogger DEBUG $ - printf - ("Allocating image size %s, width %s," <> - " height %s, resize %s") - (show size) - (show actualWidth) - (show actualHeight) - (show requestResize) - - when requestResize $ do - trayLogger DEBUG "Requesting resize" - pixBuf0 <- getInfo info serviceName >>= - getScaledPixBufFromInfo size - pixBuf <- applyTransform image pixBuf0 - when (isNothing pixBuf) $ - trayLogger WARNING $ - printf "Got null pixbuf for info %s" $ - showInfo info - Gtk.imageSetFromPixbuf image pixBuf - void $ traverse - (\pb -> do - width <- pixbufGetWidth pb - height <- pixbufGetHeight pb - Gtk.widgetSetSizeRequest image width height) - pixBuf - void (Gdk.threadsAddIdle GLib.PRIORITY_DEFAULT $ - Gtk.widgetQueueResize image >> return False) - - _ <- Gtk.onWidgetSizeAllocate image setPixbuf - return () - TrayImageSize size -> do - pixBuf0 <- getScaledPixBufFromInfo size info - pixBuf <- applyTransform image pixBuf0 - Gtk.imageSetFromPixbuf image pixBuf - - Gtk.widgetGetStyleContext image >>= - flip Gtk.styleContextAddClass "tray-icon-image" - - Gtk.containerAdd eventBox image - setTooltipText eventBox info - - let context = - ItemContext { contextName = serviceName - , contextMenuPath = pathForMenu - , contextImage = image - , contextButton = eventBox - } - - popupGtkMenu gtkMenu mEvent = do - Gtk.menuAttachToWidget gtkMenu eventBox Nothing - _ <- Gtk.onWidgetHide gtkMenu $ - void $ GLib.idleAdd GLib.PRIORITY_LOW $ do - Gtk.widgetDestroy gtkMenu - return False - Gtk.widgetShowAll gtkMenu - Gtk.menuPopupAtPointer gtkMenu mEvent - - _ <- Gtk.onWidgetButtonPressEvent eventBox $ \event -> do - -- Capture the current event as a Gdk.Event before any - -- blocking calls (DBus etc.) so menuPopupAtPointer can - -- use its coordinates for popup positioning. - currentEvent <- Gtk.getCurrentEvent - mouseButton <- Gdk.getEventButtonButton event - x <- round <$> Gdk.getEventButtonXRoot event - y <- round <$> Gdk.getEventButtonYRoot event - action <- case mouseButton of - 1 -> bool leftClickAction PopupMenu <$> getInfoAttr - itemIsMenu True serviceName - 2 -> return middleClickAction - _ -> return rightClickAction - let logActionError actionName e = - trayLogger WARNING $ printf "%s failed for %s: %s" - (actionName :: String) - (coerce serviceName :: String) - (show e) - case action of - Activate -> catchAny - (void $ IC.activate client serviceName servicePath x y) - (logActionError "Activate") - SecondaryActivate -> catchAny - (void $ IC.secondaryActivate client - serviceName servicePath x y) - (logActionError "SecondaryActivate") - PopupMenu -> do - menuPath' <- getInfoAttr menuPath Nothing serviceName - traverse_ - (\p -> catchAny - (case menuBackend of - LibDBusMenu -> do - let sn = T.pack (coerce serviceName :: String) - mp = T.pack (coerce p :: String) - gtkMenu <- DM.menuNew sn mp >>= unsafeCastTo Gtk.Menu - Gtk.menuAttachToWidget gtkMenu eventBox Nothing - _ <- Gtk.onWidgetHide gtkMenu $ - void $ GLib.idleAdd GLib.PRIORITY_DEFAULT_IDLE $ do - Gtk.widgetDestroy gtkMenu - return False - -- libdbusmenu-gtk fetches the menu layout - -- asynchronously; showing before the root menuitem - -- is available triggers assertion failures. Defer - -- the popup until the menu is populated. - attemptsRef <- newIORef (0 :: Int) - _ <- GLib.timeoutAdd GLib.PRIORITY_DEFAULT 50 $ do - n <- readIORef attemptsRef - if n >= 100 - then do - Gtk.widgetDestroy gtkMenu - return False - else do - writeIORef attemptsRef (n + 1) - children <- Gtk.containerGetChildren gtkMenu - if null children - then return True - else do - Gtk.widgetShowAll gtkMenu - -- libdbusmenu is populated asynchronously, so we popup later via a - -- timeout. On Wayland, popups generally need the original trigger - -- event; use menuPopupAtWidget anchored to the EventBox to avoid - -- "no trigger event" and invalid rect_window assertions. - -- Anchor to the actual icon widget so the popup aligns with the - -- visible image, not the full EventBox allocation. - Gtk.menuPopupAtWidget - gtkMenu - image - GravitySouth - GravityNorth - currentEvent - return False - return () - HaskellDBusMenu -> do - gtkMenu <- DBusMenu.buildMenu client serviceName p - popupGtkMenu gtkMenu currentEvent) - (logActionError "PopupMenu")) - menuPath' - return False - _ <- Gtk.onWidgetScrollEvent eventBox $ \event -> do - direction <- getEventScrollDirection event - let direction' = case direction of - ScrollDirectionUp -> Just "vertical" - ScrollDirectionDown -> Just "vertical" - ScrollDirectionLeft -> Just "horizontal" - ScrollDirectionRight -> Just "horizontal" - _ -> Nothing - delta = case direction of - ScrollDirectionUp -> -1 - ScrollDirectionDown -> 1 - ScrollDirectionLeft -> -1 - ScrollDirectionRight -> 1 - _ -> 0 - traverse_ (\d -> catchAny - (void $ IC.scroll client serviceName servicePath delta d) - (\e -> trayLogger WARNING $ printf "Scroll failed for %s: %s" - (coerce serviceName :: String) (show e))) direction' - return False - - MV.modifyMVar_ contextMap $ return . Map.insert serviceName context - - Gtk.widgetShowAll eventBox - let packFn = - case alignment of - End -> Gtk.boxPackEnd - _ -> Gtk.boxPackStart - - packFn trayBox eventBox shouldExpand True 0 - - updateHandler ItemRemoved ItemInfo { itemServiceName = name } - = getContext name >>= removeWidget - where removeWidget Nothing = - trayLogger WARNING "removeWidget: unrecognized service name." - removeWidget (Just ItemContext { contextButton = widgetToRemove }) = - do - Gtk.containerRemove trayBox widgetToRemove - MV.modifyMVar_ contextMap $ return . Map.delete name - - updateHandler IconUpdated i = updateIconFromInfo i - updateHandler OverlayIconUpdated i = updateIconFromInfo i - - updateHandler ToolTipUpdated info@ItemInfo { itemServiceName = name } = - void $ getContext name >>= - traverse (flip setTooltipText info . contextButton) - - updateHandler _ _ = return () - - maybeAddOverlayToPixbuf size info pixbuf = do - _ <- runMaybeT $ do - let overlayHeight = floor (fromIntegral size * overlayScale) - overlayPixbuf <- - MaybeT $ getOverlayPixBufFromInfo overlayHeight info >>= - traverse (scalePixbufToSize overlayHeight Gtk.OrientationHorizontal) - lift $ do - actualOHeight <- getPixbufHeight overlayPixbuf - actualOWidth <- getPixbufWidth overlayPixbuf - _mainHeight <- getPixbufHeight pixbuf - _mainWidth <- getPixbufWidth pixbuf - pixbufComposite overlayPixbuf pixbuf - 0 0 - actualOWidth actualOHeight - 0 0 - 1.0 1.0 - InterpTypeBilinear - 255 - return pixbuf - - getScaledPixBufFromInfo size info = - getPixBufFromInfo size info >>= - traverse (scalePixbufToSize size orientation >=> - maybeAddOverlayToPixbuf size info) - - getPixBufFromInfo size - ItemInfo { iconName = name - , iconThemePath = mpath - , iconPixmaps = pixmaps - } = getPixBufFrom size name mpath pixmaps - - getOverlayPixBufFromInfo size - ItemInfo - { overlayIconName = name - , iconThemePath = mpath - , overlayIconPixmaps = pixmaps - } = getPixBufFrom size (fromMaybe "" name) - mpath pixmaps - - getPixBufFrom size name mpath pixmaps = do - let tooSmall (w, h, _) = w < size || h < size - largeEnough = filter (not . tooSmall) pixmaps - orderer (w1, h1, _) (w2, h2, _) = - case comparing id w1 w2 of - EQ -> comparing id h1 h2 - a -> a - selectedPixmap = - if null largeEnough - then maximumBy orderer pixmaps - else minimumBy orderer largeEnough - getFromPixmaps (w, h, p) = - if BS.length p == 0 - then return Nothing - else getIconPixbufFromByteString w h p - getFromThemed = - if name == "" - then return Nothing - else getIconPixbufByName size (T.pack name) mpath - firstJustM a b = do - ma <- a - case ma of - Just _ -> return ma - Nothing -> b - - if null pixmaps - then getIconPixbufByName size (T.pack name) mpath - else case iconPreference of - PreferThemedIcons -> - firstJustM getFromThemed (getFromPixmaps selectedPixmap) - PreferPixmaps -> - firstJustM (getFromPixmaps selectedPixmap) getFromThemed - - uiUpdateHandler updateType info = - void $ Gdk.threadsAddIdle GLib.PRIORITY_DEFAULT $ - catchAny - (updateHandler updateType info - >> reorderTrayByPriority - >> return False) - (\e -> do - trayLogger WARNING $ printf "Update handler failed: %s" (show e) - return False) - - handlerId <- addUHandler uiUpdateHandler - _ <- Gtk.onWidgetDestroy trayBox $ removeUHandler handlerId - return trayBox +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE OverloadedStrings #-} + +module StatusNotifier.Tray where + +import Control.Concurrent.MVar as MV +import Control.Exception.Base +import Control.Exception.Enclosed (catchAny) +import Control.Monad +import Control.Monad.Trans.Class +import Control.Monad.Trans.Maybe +import DBus.Client +import qualified DBus.Internal.Types as DBusTypes +import qualified DBusMenu +import qualified Data.ByteString as BS +import Data.Coerce +import Data.Foldable (traverse_) +import Data.GI.Base (unsafeCastTo) +import Data.GI.Base.GError +import Data.IORef (newIORef, readIORef, writeIORef) +import Data.Int +import Data.List +import qualified Data.Map.Strict as Map +import Data.Maybe +import Data.Ord +import Data.Ratio +import qualified Data.Text as T +import Data.Word +import Foreign.Ptr (Ptr) +import qualified GI.DbusmenuGtk3.Objects.Menu as DM +import qualified GI.GLib as GLib +import GI.GLib.Structs.Bytes +import qualified GI.Gdk as Gdk +import GI.Gdk.Enums +import GI.Gdk.Structs.EventScroll +import GI.GdkPixbuf.Enums +import GI.GdkPixbuf.Objects.Pixbuf as Gdk +import qualified GI.Gtk as Gtk +import GI.Gtk.Flags +import GI.Gtk.Objects.IconTheme +import Graphics.UI.GIGtkStrut +import StatusNotifier.Host.Service +import qualified StatusNotifier.Item.Client as IC +import System.Directory +import System.FilePath +import System.Log.Logger +import Text.Printf + +trayLogger :: Priority -> String -> IO () +trayLogger = logM "StatusNotifier.Tray" + +-- | Optional post-processing hook for item icons. This is applied after scaling +-- and overlay composition. +type PixbufTransform = Gtk.Image -> Pixbuf -> IO Pixbuf + +logItemInfo :: ItemInfo -> String -> IO () +logItemInfo info message = + trayLogger INFO $ + printf + "%s - %s pixmap count: %s" + message + (show $ info {iconPixmaps = []}) + (show $ length $ iconPixmaps info) + +getScaledWidthHeight :: Bool -> Int32 -> Int32 -> Int32 -> (Int32, Int32) +getScaledWidthHeight shouldTargetWidth targetSize width height = + let getRatio :: Int32 -> Rational + getRatio toScale = + fromIntegral targetSize / fromIntegral toScale + getOther :: Int32 -> Int32 -> Int32 + getOther toScale other = max 1 $ floor $ getRatio toScale * fromIntegral other + in if shouldTargetWidth + then (targetSize, getOther width height) + else (getOther height width, targetSize) + +scalePixbufToSize :: Int32 -> Gtk.Orientation -> Pixbuf -> IO Pixbuf +scalePixbufToSize size orientation pixbuf = do + width <- pixbufGetWidth pixbuf + height <- pixbufGetHeight pixbuf + let warnAndReturnOrig = + trayLogger WARNING "Unable to scale pixbuf" >> return pixbuf + if width <= 0 || height <= 0 + then warnAndReturnOrig + else do + let targetWidth = case orientation of + Gtk.OrientationHorizontal -> False + _ -> True + (scaledWidth, scaledHeight) = + getScaledWidthHeight targetWidth size width height + trayLogger DEBUG $ + printf + "Scaling pb to %s, actualW: %s, actualH: %s, scaledW: %s, scaledH: %s" + (show size) + (show width) + (show height) + (show scaledWidth) + (show scaledHeight) + + trayLogger DEBUG $ + printf + "targetW: %s, targetH: %s" + (show scaledWidth) + (show scaledHeight) + maybe warnAndReturnOrig return + =<< pixbufScaleSimple pixbuf scaledWidth scaledHeight InterpTypeBilinear + +themeLoadFlags :: [IconLookupFlags] +themeLoadFlags = [IconLookupFlagsGenericFallback, IconLookupFlagsUseBuiltin] + +getThemeWithOptionalSearchPath :: Maybe String -> IO IconTheme +getThemeWithOptionalSearchPath themePath = do + theme <- iconThemeGetDefault + forM_ (themePath >>= nonEmpty) $ \p -> do + -- Respect the user's configured icon theme by using GTK's default theme + -- object, but include any item-provided IconThemePath as an additional + -- search path. + -- + -- Some items provide IconThemePath pointing inside a theme dir, e.g.: + -- .../Papirus/64x64/mimetypes + -- GTK expects search paths that contain theme directories, so also try to + -- append the parent directory of any ancestor that contains index.theme. + pathsToAppend <- pathsForIconThemePath p + existing <- iconThemeGetSearchPath theme + forM_ pathsToAppend $ \p' -> + unless (p' `elem` existing) $ iconThemeAppendSearchPath theme p' + return theme + where + nonEmpty "" = Nothing + nonEmpty x = Just x + +pathsForIconThemePath :: FilePath -> IO [FilePath] +pathsForIconThemePath rawPath = do + mThemeDir <- findAncestorWithIndexTheme 8 rawPath + let base = + case mThemeDir of + Nothing -> [] + Just themeDir -> [takeDirectory themeDir] + return $ nub $ base ++ [rawPath] + where + findAncestorWithIndexTheme :: Int -> FilePath -> IO (Maybe FilePath) + findAncestorWithIndexTheme 0 _ = return Nothing + findAncestorWithIndexTheme n p = do + hasIndex <- doesFileExist (p "index.theme") + if hasIndex + then return (Just p) + else do + let parent = takeDirectory p + if parent == p + then return Nothing + else findAncestorWithIndexTheme (n - 1) parent + +catchGErrorsAsLeft :: IO a -> IO (Either GError a) +catchGErrorsAsLeft action = catch (Right <$> action) (return . Left) + +catchGErrorsAsNothing :: IO a -> IO (Maybe a) +catchGErrorsAsNothing action = catchGErrorsAsLeft action >>= rightToJustLogLeft + where + rightToJustLogLeft (Right value) = return $ Just value + rightToJustLogLeft (Left err) = do + trayLogger WARNING $ printf "Encountered error: %s" $ show err + return Nothing + +safePixbufNewFromFile :: FilePath -> IO (Maybe Gdk.Pixbuf) +safePixbufNewFromFile = + handleResult . catchGErrorsAsNothing . Gdk.pixbufNewFromFile + where +#if MIN_VERSION_gi_gdkpixbuf(2,0,26) + handleResult = fmap join +#else + handleResult = id +#endif + +getIconPixbufByName :: Int32 -> T.Text -> Maybe String -> IO (Maybe Pixbuf) +getIconPixbufByName size name themePath = do + trayLogger DEBUG $ printf "Getting Pixbuf from name for %s" name + themeForIcon <- getThemeWithOptionalSearchPath themePath + + let panelName = T.pack $ printf "%s-panel" name + -- Avoid relying on iconThemeHasIcon: it can be overly strict when fallback + -- loading is enabled. Just try to load and fall back if it fails. + let tryLoad :: T.Text -> IO (Maybe Pixbuf) + tryLoad iconName = + catchAny + (iconThemeLoadIcon themeForIcon iconName size themeLoadFlags) + (const $ pure Nothing) + + themedPixbuf <- do + pbPanel <- tryLoad panelName + case pbPanel of + Just _ -> return pbPanel + Nothing -> tryLoad name + + case themedPixbuf of + Just _ -> return themedPixbuf + Nothing -> do + trayLogger DEBUG $ printf "Trying to load icon %s as filepath" name + -- Try to load the icon as a filepath + let nameString = T.unpack name + fileExists <- doesFileExist nameString + maybeFile <- + if fileExists + then return $ Just nameString + else fmap join $ sequenceA $ getIconPathFromThemePath nameString <$> themePath + fmap join $ sequenceA $ safePixbufNewFromFile <$> maybeFile + +getIconPathFromThemePath :: String -> String -> IO (Maybe String) +getIconPathFromThemePath name themePath = + if name == "" + then return Nothing + else do + trayLogger DEBUG $ + printf + "Trying to load icon %s as filepath with theme path %s" + name + themePath + pathExists <- doesDirectoryExist themePath + if pathExists + then do + fileNames <- catchAny (listDirectory themePath) (const $ return []) + trayLogger DEBUG $ + printf + "Found files in theme path %s" + (show fileNames) + return $ (themePath ) <$> find (isPrefixOf name) fileNames + else return Nothing + +getIconPixbufFromByteString :: Int32 -> Int32 -> BS.ByteString -> IO (Maybe Pixbuf) +getIconPixbufFromByteString width height byteString + | width <= 0 || height <= 0 = do + trayLogger WARNING $ printf "Invalid icon dimensions: %dx%d" width height + return Nothing + | otherwise = catchGErrorsAsNothing $ do + trayLogger DEBUG "Getting Pixbuf from bytestring" + bytes <- bytesNew $ Just byteString + let bytesPerPixel = 4 + rowStride = width * bytesPerPixel + sampleBits = 8 + pixbufNewFromBytes bytes ColorspaceRgb True sampleBits width height rowStride + +data ItemContext = ItemContext + { contextName :: DBusTypes.BusName, + contextMenuPath :: Maybe DBusTypes.ObjectPath, + contextImage :: Gtk.Image, + contextButton :: Gtk.EventBox + } + +data TrayImageSize = Expand | TrayImageSize Int32 + +data TrayClickAction = Activate | SecondaryActivate | PopupMenu deriving (Eq, Show) + +data TrayClickContext = TrayClickContext + { trayClickItemInfo :: ItemInfo, + trayClickButton :: Word32, + trayClickXRoot :: Int32, + trayClickYRoot :: Int32, + trayClickModifiers :: [Gdk.ModifierType], + trayClickDefaultAction :: TrayClickAction + } + +data TrayClickDecision + = UseDefaultClickAction + | OverrideClickAction TrayClickAction + | ConsumeClick + deriving (Eq, Show) + +type TrayClickHook = TrayClickContext -> IO TrayClickDecision + +data TrayEventHooks = TrayEventHooks + { trayClickHook :: Maybe TrayClickHook + } + +defaultTrayEventHooks :: TrayEventHooks +defaultTrayEventHooks = TrayEventHooks {trayClickHook = Nothing} + +data MenuBackend = LibDBusMenu | HaskellDBusMenu deriving (Eq, Show) + +data TrayItemMatcher = TrayItemMatcher + { trayItemMatcherDescription :: String, + trayItemMatcherPredicate :: ItemInfo -> Bool + } + +data TrayPriorityConfig = TrayPriorityConfig + { trayPriorityMatchers :: [TrayItemMatcher] + } + +defaultTrayPriorityConfig :: TrayPriorityConfig +defaultTrayPriorityConfig = TrayPriorityConfig {trayPriorityMatchers = []} + +mkTrayItemMatcher :: String -> (ItemInfo -> Bool) -> TrayItemMatcher +mkTrayItemMatcher = TrayItemMatcher + +trayMatchAny :: [TrayItemMatcher] -> TrayItemMatcher +trayMatchAny matchers = mkTrayItemMatcher "any" $ \info -> + any (\matcher -> trayItemMatcherPredicate matcher info) matchers + +trayMatchAll :: [TrayItemMatcher] -> TrayItemMatcher +trayMatchAll matchers = mkTrayItemMatcher "all" $ \info -> + all (\matcher -> trayItemMatcherPredicate matcher info) matchers + +trayMatchNot :: TrayItemMatcher -> TrayItemMatcher +trayMatchNot matcher = + mkTrayItemMatcher ("not(" <> trayItemMatcherDescription matcher <> ")") $ + not . trayItemMatcherPredicate matcher + +normalizeText :: T.Text -> T.Text +normalizeText = T.toCaseFold + +containsCI :: T.Text -> T.Text -> Bool +containsCI needle haystack = + normalizeText needle `T.isInfixOf` normalizeText haystack + +equalsCI :: T.Text -> T.Text -> Bool +equalsCI left right = normalizeText left == normalizeText right + +matchOnTextFields :: + String -> + (T.Text -> T.Text -> Bool) -> + [ItemInfo -> Maybe T.Text] -> + T.Text -> + TrayItemMatcher +matchOnTextFields matcherName comparator fieldGetters target = + mkTrayItemMatcher matcherName $ \info -> + any + (\fieldGetter -> maybe False (comparator target) (fieldGetter info)) + fieldGetters + +serviceNameText :: ItemInfo -> T.Text +serviceNameText = T.pack . (coerce :: DBusTypes.BusName -> String) . itemServiceName + +servicePathText :: ItemInfo -> T.Text +servicePathText = T.pack . (coerce :: DBusTypes.ObjectPath -> String) . itemServicePath + +menuPathText :: ItemInfo -> Maybe T.Text +menuPathText = fmap (T.pack . (coerce :: DBusTypes.ObjectPath -> String)) . menuPath + +itemIdText :: ItemInfo -> Maybe T.Text +itemIdText = fmap T.pack . itemId + +itemCategoryText :: ItemInfo -> Maybe T.Text +itemCategoryText = fmap T.pack . itemCategory + +itemStatusText :: ItemInfo -> Maybe T.Text +itemStatusText = fmap T.pack . itemStatus + +iconNameText :: ItemInfo -> T.Text +iconNameText = T.pack . iconName + +iconTitleText :: ItemInfo -> T.Text +iconTitleText = T.pack . iconTitle + +tooltipTitleText :: ItemInfo -> Maybe T.Text +tooltipTitleText info = (\(_, _, titleText, _) -> T.pack titleText) <$> itemToolTip info + +tooltipBodyText :: ItemInfo -> Maybe T.Text +tooltipBodyText info = (\(_, _, _, bodyText) -> T.pack bodyText) <$> itemToolTip info + +trayMatchServiceNameContains :: T.Text -> TrayItemMatcher +trayMatchServiceNameContains = + matchOnTextFields "service-name-contains" containsCI [Just . serviceNameText] + +trayMatchServiceNameEquals :: T.Text -> TrayItemMatcher +trayMatchServiceNameEquals = + matchOnTextFields "service-name-equals" equalsCI [Just . serviceNameText] + +trayMatchServicePathContains :: T.Text -> TrayItemMatcher +trayMatchServicePathContains = + matchOnTextFields "service-path-contains" containsCI [Just . servicePathText] + +trayMatchServicePathEquals :: T.Text -> TrayItemMatcher +trayMatchServicePathEquals = + matchOnTextFields "service-path-equals" equalsCI [Just . servicePathText] + +trayMatchMenuPathContains :: T.Text -> TrayItemMatcher +trayMatchMenuPathContains = + matchOnTextFields "menu-path-contains" containsCI [menuPathText] + +trayMatchMenuPathEquals :: T.Text -> TrayItemMatcher +trayMatchMenuPathEquals = + matchOnTextFields "menu-path-equals" equalsCI [menuPathText] + +trayMatchItemIdContains :: T.Text -> TrayItemMatcher +trayMatchItemIdContains = + matchOnTextFields "item-id-contains" containsCI [itemIdText] + +trayMatchItemIdEquals :: T.Text -> TrayItemMatcher +trayMatchItemIdEquals = + matchOnTextFields "item-id-equals" equalsCI [itemIdText] + +trayMatchItemCategoryContains :: T.Text -> TrayItemMatcher +trayMatchItemCategoryContains = + matchOnTextFields "item-category-contains" containsCI [itemCategoryText] + +trayMatchItemCategoryEquals :: T.Text -> TrayItemMatcher +trayMatchItemCategoryEquals = + matchOnTextFields "item-category-equals" equalsCI [itemCategoryText] + +trayMatchStatusContains :: T.Text -> TrayItemMatcher +trayMatchStatusContains = + matchOnTextFields "item-status-contains" containsCI [itemStatusText] + +trayMatchStatusEquals :: T.Text -> TrayItemMatcher +trayMatchStatusEquals = + matchOnTextFields "item-status-equals" equalsCI [itemStatusText] + +trayMatchIconNameContains :: T.Text -> TrayItemMatcher +trayMatchIconNameContains = + matchOnTextFields "icon-name-contains" containsCI [Just . iconNameText] + +trayMatchIconNameEquals :: T.Text -> TrayItemMatcher +trayMatchIconNameEquals = + matchOnTextFields "icon-name-equals" equalsCI [Just . iconNameText] + +trayMatchIconTitleContains :: T.Text -> TrayItemMatcher +trayMatchIconTitleContains = + matchOnTextFields "icon-title-contains" containsCI [Just . iconTitleText] + +trayMatchIconTitleEquals :: T.Text -> TrayItemMatcher +trayMatchIconTitleEquals = + matchOnTextFields "icon-title-equals" equalsCI [Just . iconTitleText] + +trayMatchTooltipContains :: T.Text -> TrayItemMatcher +trayMatchTooltipContains = + matchOnTextFields "tooltip-contains" containsCI [tooltipTitleText, tooltipBodyText] + +trayMatchTooltipEquals :: T.Text -> TrayItemMatcher +trayMatchTooltipEquals = + matchOnTextFields "tooltip-equals" equalsCI [tooltipTitleText, tooltipBodyText] + +trayMatchAnyTextContains :: T.Text -> TrayItemMatcher +trayMatchAnyTextContains = + matchOnTextFields + "any-text-contains" + containsCI + [ Just . serviceNameText, + Just . servicePathText, + menuPathText, + itemIdText, + itemCategoryText, + itemStatusText, + Just . iconNameText, + Just . iconTitleText, + tooltipTitleText, + tooltipBodyText + ] + +trayMatchIsMenu :: Bool -> TrayItemMatcher +trayMatchIsMenu expected = + mkTrayItemMatcher "is-menu" $ \info -> itemIsMenu info == expected + +-- | Controls whether to prefer application-provided pixmaps or themed icons +-- when both are present. Some items provide both. +data TrayIconPreference + = PreferPixmaps + | PreferThemedIcons + deriving (Eq, Show, Read) + +data TrayParams = TrayParams + { trayOrientation :: Gtk.Orientation, + trayImageSize :: TrayImageSize, + trayIconExpand :: Bool, + trayIconPreference :: TrayIconPreference, + trayAlignment :: StrutAlignment, + trayOverlayScale :: Rational, + trayLeftClickAction :: TrayClickAction, + trayMiddleClickAction :: TrayClickAction, + trayRightClickAction :: TrayClickAction, + trayMenuBackend :: MenuBackend, + trayCenterIcons :: Bool, + trayPriorityConfig :: TrayPriorityConfig, + trayPixbufTransform :: Maybe PixbufTransform, + trayEventHooks :: TrayEventHooks + } + +defaultTrayParams :: TrayParams +defaultTrayParams = + TrayParams + { trayOrientation = Gtk.OrientationHorizontal, + trayImageSize = Expand, + trayIconExpand = False, + trayIconPreference = PreferPixmaps, + trayAlignment = End, + trayOverlayScale = 2 % 5, + trayLeftClickAction = Activate, + trayMiddleClickAction = SecondaryActivate, + trayRightClickAction = PopupMenu, + trayMenuBackend = HaskellDBusMenu, + trayCenterIcons = False, + trayPriorityConfig = defaultTrayPriorityConfig, + trayPixbufTransform = Nothing, + trayEventHooks = defaultTrayEventHooks + } + +buildTray :: Host -> Client -> TrayParams -> IO Gtk.Box +buildTray + Host + { itemInfoMap = getInfoMap, + addUpdateHandler = addUHandler, + removeUpdateHandler = removeUHandler + } + client + TrayParams + { trayOrientation = orientation, + trayImageSize = imageSize, + trayIconExpand = shouldExpand, + trayIconPreference = iconPreference, + trayAlignment = alignment, + trayOverlayScale = overlayScale, + trayLeftClickAction = leftClickAction, + trayMiddleClickAction = middleClickAction, + trayRightClickAction = rightClickAction, + trayMenuBackend = menuBackend, + trayCenterIcons = centerIcons, + trayPriorityConfig = + TrayPriorityConfig + { trayPriorityMatchers = priorityMatchers + }, + trayPixbufTransform = mTransform, + trayEventHooks = + TrayEventHooks + { trayClickHook = mClickHook + } + } = + do + trayLogger INFO "Building tray" + + trayBox <- Gtk.boxNew orientation 0 + when centerIcons $ case orientation of + Gtk.OrientationHorizontal -> Gtk.widgetSetHalign trayBox Gtk.AlignCenter + _ -> Gtk.widgetSetValign trayBox Gtk.AlignCenter + Gtk.widgetGetStyleContext trayBox + >>= flip Gtk.styleContextAddClass "tray-box" + contextMap <- MV.newMVar Map.empty + + let getContext name = Map.lookup name <$> MV.readMVar contextMap + showInfo info = show info {iconPixmaps = []} + + getSize rectangle = + case orientation of + Gtk.OrientationHorizontal -> + Gdk.getRectangleHeight rectangle + _ -> + Gdk.getRectangleWidth rectangle + + getInfoAttr fn def name = maybe def fn . Map.lookup name <$> getInfoMap + + getInfo :: ItemInfo -> DBusTypes.BusName -> IO ItemInfo + getInfo = getInfoAttr id + + getPriorityIndex info = + fromMaybe + (length priorityMatchers) + (findIndex (\matcher -> trayItemMatcherPredicate matcher info) priorityMatchers) + + reorderTrayByPriority = when (not (null priorityMatchers)) $ do + currentChildren <- Gtk.containerGetChildren trayBox + contexts <- MV.readMVar contextMap + contextWidgets <- forM (Map.toList contexts) $ + \(busName, ItemContext {contextButton = button}) -> do + widget <- Gtk.toWidget button + return (busName, widget) + infoMap <- getInfoMap + let childRows = + [ let busName = fst <$> find (\(_, widget) -> widget == child) contextWidgets + itemInfo = busName >>= (`Map.lookup` infoMap) + priority = maybe (length priorityMatchers) getPriorityIndex itemInfo + in (priority, currentIndex, child) + | (currentIndex, child) <- zip [0 :: Int ..] currentChildren + ] + sortedChildren = + [ child + | (_, _, child) <- + sortOn (\(priority, currentIndex, _) -> (priority, currentIndex)) childRows + ] + forM_ (zip [0 :: Int ..] sortedChildren) $ + \(newIndex, child) -> + Gtk.boxReorderChild trayBox child (fromIntegral newIndex) + + applyTransform :: Gtk.Image -> Maybe Pixbuf -> IO (Maybe Pixbuf) + applyTransform _ Nothing = return Nothing + applyTransform image (Just pb) = + case mTransform of + Nothing -> return (Just pb) + Just f -> Just <$> f image pb + + updateIconFromInfo info@ItemInfo {itemServiceName = name} = + getContext name >>= updateIcon + where + updateIcon Nothing = updateHandler ItemAdded info + updateIcon (Just ItemContext {contextImage = image}) = do + size <- case imageSize of + TrayImageSize size -> return size + Expand -> Gtk.widgetGetAllocation image >>= getSize + getScaledPixBufFromInfo size info + >>= applyTransform image + >>= let handlePixbuf mpbuf = + if isJust mpbuf + then Gtk.imageSetFromPixbuf image mpbuf + else + trayLogger WARNING $ + printf "Failed to get pixbuf for %s" $ + showInfo info + in handlePixbuf + + getTooltipText ItemInfo {itemToolTip = Just (_, _, titleText, fullText)} + | titleText == fullText = fullText + | titleText == "" = fullText + | fullText == "" = titleText + | otherwise = printf "%s: %s" titleText fullText + getTooltipText _ = "" + + setTooltipText widget info = + Gtk.widgetSetTooltipText widget $ Just $ T.pack $ getTooltipText info + + updateHandler + ItemAdded + info@ItemInfo + { menuPath = pathForMenu, + itemServiceName = serviceName, + itemServicePath = servicePath + } = + do + let serviceNameStr = (coerce serviceName :: String) + servicePathStr = coerce servicePath :: String + logText = + printf + "Adding widget for %s - %s" + serviceNameStr + servicePathStr + + trayLogger INFO logText + + eventBox <- Gtk.eventBoxNew + Gtk.widgetAddEvents eventBox [Gdk.EventMaskScrollMask] + Gtk.widgetGetStyleContext eventBox + >>= flip Gtk.styleContextAddClass "tray-icon-button" + + image <- Gtk.imageNew + + case imageSize of + Expand -> do + lastAllocation <- MV.newMVar Nothing + + let setPixbuf allocation = + do + size <- getSize allocation + + actualWidth <- Gdk.getRectangleWidth allocation + actualHeight <- Gdk.getRectangleHeight allocation + + requestResize <- MV.modifyMVar lastAllocation $ \previous -> + let thisTime = Just (size, actualWidth, actualHeight) + in return (thisTime, thisTime /= previous) + + trayLogger DEBUG $ + printf + ( "Allocating image size %s, width %s," + <> " height %s, resize %s" + ) + (show size) + (show actualWidth) + (show actualHeight) + (show requestResize) + + when requestResize $ do + trayLogger DEBUG "Requesting resize" + pixBuf0 <- + getInfo info serviceName + >>= getScaledPixBufFromInfo size + pixBuf <- applyTransform image pixBuf0 + when (isNothing pixBuf) $ + trayLogger WARNING $ + printf "Got null pixbuf for info %s" $ + showInfo info + Gtk.imageSetFromPixbuf image pixBuf + void $ + traverse + ( \pb -> do + width <- pixbufGetWidth pb + height <- pixbufGetHeight pb + Gtk.widgetSetSizeRequest image width height + ) + pixBuf + void + ( Gdk.threadsAddIdle GLib.PRIORITY_DEFAULT $ + Gtk.widgetQueueResize image >> return False + ) + + _ <- Gtk.onWidgetSizeAllocate image setPixbuf + return () + TrayImageSize size -> do + pixBuf0 <- getScaledPixBufFromInfo size info + pixBuf <- applyTransform image pixBuf0 + Gtk.imageSetFromPixbuf image pixBuf + + Gtk.widgetGetStyleContext image + >>= flip Gtk.styleContextAddClass "tray-icon-image" + + Gtk.containerAdd eventBox image + setTooltipText eventBox info + + let context = + ItemContext + { contextName = serviceName, + contextMenuPath = pathForMenu, + contextImage = image, + contextButton = eventBox + } + + popupGtkMenu gtkMenu mEvent = do + Gtk.menuAttachToWidget gtkMenu eventBox Nothing + _ <- Gtk.onWidgetHide gtkMenu $ + void $ + GLib.idleAdd GLib.PRIORITY_LOW $ do + Gtk.widgetDestroy gtkMenu + return False + Gtk.widgetShowAll gtkMenu + Gtk.menuPopupAtPointer gtkMenu mEvent + + _ <- Gtk.onWidgetButtonPressEvent eventBox $ \event -> do + -- Capture the current event as a Gdk.Event before any + -- blocking calls (DBus etc.) so menuPopupAtPointer can + -- use its coordinates for popup positioning. + currentEvent <- Gtk.getCurrentEvent + currentInfo <- getInfo info serviceName + mouseButton <- Gdk.getEventButtonButton event + x <- round <$> Gdk.getEventButtonXRoot event + y <- round <$> Gdk.getEventButtonYRoot event + modifiers <- Gdk.getEventButtonState event + let defaultAction = case mouseButton of + 1 -> if itemIsMenu currentInfo then PopupMenu else leftClickAction + 2 -> middleClickAction + _ -> rightClickAction + clickDecision <- + maybe + (pure UseDefaultClickAction) + ( \hook -> + hook + TrayClickContext + { trayClickItemInfo = currentInfo, + trayClickButton = mouseButton, + trayClickXRoot = x, + trayClickYRoot = y, + trayClickModifiers = modifiers, + trayClickDefaultAction = defaultAction + } + ) + mClickHook + let mAction = case clickDecision of + UseDefaultClickAction -> Just defaultAction + OverrideClickAction action -> Just action + ConsumeClick -> Nothing + let logActionError actionName e = + trayLogger WARNING $ + printf + "%s failed for %s: %s" + (actionName :: String) + (coerce serviceName :: String) + (show e) + traverse_ + ( \action -> case action of + Activate -> + catchAny + (void $ IC.activate client serviceName servicePath x y) + (logActionError "Activate") + SecondaryActivate -> + catchAny + ( void $ + IC.secondaryActivate + client + serviceName + servicePath + x + y + ) + (logActionError "SecondaryActivate") + PopupMenu -> do + let menuPath' = menuPath currentInfo + traverse_ + ( \p -> + catchAny + ( case menuBackend of + LibDBusMenu -> do + let sn = T.pack (coerce serviceName :: String) + mp = T.pack (coerce p :: String) + gtkMenu <- DM.menuNew sn mp >>= unsafeCastTo Gtk.Menu + Gtk.menuAttachToWidget gtkMenu eventBox Nothing + _ <- Gtk.onWidgetHide gtkMenu $ + void $ + GLib.idleAdd GLib.PRIORITY_DEFAULT_IDLE $ do + Gtk.widgetDestroy gtkMenu + return False + -- libdbusmenu-gtk fetches the menu layout + -- asynchronously; showing before the root menuitem + -- is available triggers assertion failures. Defer + -- the popup until the menu is populated. + attemptsRef <- newIORef (0 :: Int) + _ <- GLib.timeoutAdd GLib.PRIORITY_DEFAULT 50 $ do + n <- readIORef attemptsRef + if n >= 100 + then do + Gtk.widgetDestroy gtkMenu + return False + else do + writeIORef attemptsRef (n + 1) + children <- Gtk.containerGetChildren gtkMenu + if null children + then return True + else do + Gtk.widgetShowAll gtkMenu + -- libdbusmenu is populated asynchronously, so we popup later via a + -- timeout. On Wayland, popups generally need the original trigger + -- event; use menuPopupAtWidget anchored to the EventBox to avoid + -- "no trigger event" and invalid rect_window assertions. + -- Anchor to the actual icon widget so the popup aligns with the + -- visible image, not the full EventBox allocation. + Gtk.menuPopupAtWidget + gtkMenu + image + GravitySouth + GravityNorth + currentEvent + return False + return () + HaskellDBusMenu -> do + gtkMenu <- DBusMenu.buildMenu client serviceName p + popupGtkMenu gtkMenu currentEvent + ) + (logActionError "PopupMenu") + ) + menuPath' + ) + mAction + return False + _ <- Gtk.onWidgetScrollEvent eventBox $ \event -> do + direction <- getEventScrollDirection event + let direction' = case direction of + ScrollDirectionUp -> Just "vertical" + ScrollDirectionDown -> Just "vertical" + ScrollDirectionLeft -> Just "horizontal" + ScrollDirectionRight -> Just "horizontal" + _ -> Nothing + delta = case direction of + ScrollDirectionUp -> -1 + ScrollDirectionDown -> 1 + ScrollDirectionLeft -> -1 + ScrollDirectionRight -> 1 + _ -> 0 + traverse_ + ( \d -> + catchAny + (void $ IC.scroll client serviceName servicePath delta d) + ( \e -> + trayLogger WARNING $ + printf + "Scroll failed for %s: %s" + (coerce serviceName :: String) + (show e) + ) + ) + direction' + return False + + MV.modifyMVar_ contextMap $ return . Map.insert serviceName context + + Gtk.widgetShowAll eventBox + let packFn = + case alignment of + End -> Gtk.boxPackEnd + _ -> Gtk.boxPackStart + + packFn trayBox eventBox shouldExpand True 0 + updateHandler ItemRemoved ItemInfo {itemServiceName = name} = + getContext name >>= removeWidget + where + removeWidget Nothing = + trayLogger WARNING "removeWidget: unrecognized service name." + removeWidget (Just ItemContext {contextButton = widgetToRemove}) = + do + Gtk.containerRemove trayBox widgetToRemove + MV.modifyMVar_ contextMap $ return . Map.delete name + updateHandler IconUpdated i = updateIconFromInfo i + updateHandler OverlayIconUpdated i = updateIconFromInfo i + updateHandler ToolTipUpdated info@ItemInfo {itemServiceName = name} = + void $ + getContext name + >>= traverse (flip setTooltipText info . contextButton) + updateHandler _ _ = return () + + maybeAddOverlayToPixbuf size info pixbuf = do + _ <- runMaybeT $ do + let overlayHeight = floor (fromIntegral size * overlayScale) + overlayPixbuf <- + MaybeT $ + getOverlayPixBufFromInfo overlayHeight info + >>= traverse (scalePixbufToSize overlayHeight Gtk.OrientationHorizontal) + lift $ do + actualOHeight <- getPixbufHeight overlayPixbuf + actualOWidth <- getPixbufWidth overlayPixbuf + _mainHeight <- getPixbufHeight pixbuf + _mainWidth <- getPixbufWidth pixbuf + pixbufComposite + overlayPixbuf + pixbuf + 0 + 0 + actualOWidth + actualOHeight + 0 + 0 + 1.0 + 1.0 + InterpTypeBilinear + 255 + return pixbuf + + getScaledPixBufFromInfo size info = + getPixBufFromInfo size info + >>= traverse + ( scalePixbufToSize size orientation + >=> maybeAddOverlayToPixbuf size info + ) + + getPixBufFromInfo + size + ItemInfo + { iconName = name, + iconThemePath = mpath, + iconPixmaps = pixmaps + } = getPixBufFrom size name mpath pixmaps + + getOverlayPixBufFromInfo + size + ItemInfo + { overlayIconName = name, + iconThemePath = mpath, + overlayIconPixmaps = pixmaps + } = + getPixBufFrom + size + (fromMaybe "" name) + mpath + pixmaps + + getPixBufFrom size name mpath pixmaps = do + let tooSmall (w, h, _) = w < size || h < size + largeEnough = filter (not . tooSmall) pixmaps + orderer (w1, h1, _) (w2, h2, _) = + case comparing id w1 w2 of + EQ -> comparing id h1 h2 + a -> a + selectedPixmap = + if null largeEnough + then maximumBy orderer pixmaps + else minimumBy orderer largeEnough + getFromPixmaps (w, h, p) = + if BS.length p == 0 + then return Nothing + else getIconPixbufFromByteString w h p + getFromThemed = + if name == "" + then return Nothing + else getIconPixbufByName size (T.pack name) mpath + firstJustM a b = do + ma <- a + case ma of + Just _ -> return ma + Nothing -> b + + if null pixmaps + then getIconPixbufByName size (T.pack name) mpath + else case iconPreference of + PreferThemedIcons -> + firstJustM getFromThemed (getFromPixmaps selectedPixmap) + PreferPixmaps -> + firstJustM (getFromPixmaps selectedPixmap) getFromThemed + + uiUpdateHandler updateType info = + void $ + Gdk.threadsAddIdle GLib.PRIORITY_DEFAULT $ + catchAny + ( updateHandler updateType info + >> reorderTrayByPriority + >> return False + ) + ( \e -> do + trayLogger WARNING $ printf "Update handler failed: %s" (show e) + return False + ) + + handlerId <- addUHandler uiUpdateHandler + _ <- Gtk.onWidgetDestroy trayBox $ removeUHandler handlerId + return trayBox