{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -fno-warn-deprecations #-}
module Main where
import Control.Monad
import qualified 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 = max x 0
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,
trayShowNewIconsImmediately = True,
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 ->
unless 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"
)