{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedLabels #-} module StatusNotifier.Tray where import Control.Concurrent.MVar as MV 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 Data.ByteString as BS import Data.Coerce import Data.Int import Data.List import qualified Data.Map.Strict as Map import Data.Maybe import Data.Ord 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.Objects.Screen import GI.GdkPixbuf.Enums import GI.GdkPixbuf.Objects.Pixbuf 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" 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 = 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 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] getThemeWithDefaultFallbacks :: String -> IO IconTheme getThemeWithDefaultFallbacks themePath = do themeForIcon <- iconThemeNew defaultTheme <- iconThemeGetDefault _ <- runMaybeT $ do screen <- MaybeT screenGetDefault lift $ iconThemeSetScreen themeForIcon screen filePaths <- iconThemeGetSearchPath defaultTheme iconThemeAppendSearchPath themeForIcon themePath mapM_ (iconThemeAppendSearchPath themeForIcon) filePaths return themeForIcon getIconPixbufByName :: Int32 -> T.Text -> Maybe String -> IO (Maybe Pixbuf) getIconPixbufByName size name themePath = do trayLogger DEBUG $ printf "Getting Pixbuf from name for %s" name let nonEmptyThemePath = themePath >>= (\x -> if x == "" then Nothing else Just x) themeForIcon <- maybe iconThemeGetDefault getThemeWithDefaultFallbacks nonEmptyThemePath let panelName = T.pack $ printf "%s-panel" name hasPanelIcon <- iconThemeHasIcon themeForIcon panelName hasIcon <- iconThemeHasIcon themeForIcon name if hasIcon || hasPanelIcon then do let targetName = if hasPanelIcon then panelName else name trayLogger DEBUG $ printf "Found icon %s in theme" name iconThemeLoadIcon themeForIcon targetName size themeLoadFlags else 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 sequenceA $ pixbufNewFromFile <$> 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 Pixbuf getIconPixbufFromByteString width height byteString = 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 , contextMenu :: Maybe DM.Menu , contextImage :: Gtk.Image , contextButton :: Gtk.EventBox } data TrayImageSize = Expand | TrayImageSize Int32 data TrayParams = TrayParams { trayHost :: Host , trayClient :: Client , trayOrientation :: Gtk.Orientation , trayImageSize :: TrayImageSize , trayIconExpand :: Bool , trayAlignment :: StrutAlignment , trayOverlayScale :: Rational } buildTray :: TrayParams -> IO Gtk.Box buildTray TrayParams { trayHost = Host { itemInfoMap = getInfoMap , addUpdateHandler = addUHandler , removeUpdateHandler = removeUHandler } , trayClient = client , trayOrientation = orientation , trayImageSize = imageSize , trayIconExpand = shouldExpand , trayAlignment = alignment , trayOverlayScale = overlayScale } = do trayLogger INFO "Building tray" trayBox <- Gtk.boxNew orientation 0 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 getInfo def name = fromMaybe def . Map.lookup name <$> getInfoMap 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 >>= 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 servicePathStr = coerce servicePath :: String serviceMenuPathStr = coerce <$> pathForMenu logText = printf "Adding widget for %s - %s" serviceNameStr servicePathStr trayLogger INFO logText button <- Gtk.eventBoxNew image <- case imageSize of Expand -> do image <- Gtk.imageNew 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" pixBuf <- getInfo info serviceName >>= getScaledPixBufFromInfo size 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 image TrayImageSize size -> do pixBuf <- getScaledPixBufFromInfo size info Gtk.imageNewFromPixbuf pixBuf Gtk.widgetGetStyleContext image >>= flip Gtk.styleContextAddClass "tray-icon-image" Gtk.containerAdd button image setTooltipText button info maybeMenu <- sequenceA $ DM.menuNew (T.pack serviceNameStr) . T.pack <$> serviceMenuPathStr let context = ItemContext { contextName = serviceName , contextMenu = maybeMenu , contextImage = image , contextButton = button } popupItemForMenu menu = Gtk.menuPopupAtWidget menu image GravitySouthWest GravityNorthWest Nothing popupItemMenu = maybe activateItem popupItemForMenu maybeMenu >> return False activateItem = void $ IC.activate client serviceName servicePath 0 0 _ <- Gtk.onWidgetButtonPressEvent button $ const popupItemMenu MV.modifyMVar_ contextMap $ return . Map.insert serviceName context Gtk.widgetShowAll button let packFn = case alignment of End -> Gtk.boxPackEnd _ -> Gtk.boxPackStart packFn trayBox button shouldExpand True 0 updateHandler ItemRemoved ItemInfo { itemServiceName = name } = getContext name >>= removeWidget where removeWidget Nothing = trayLogger INFO "Attempt to remove widget with 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 -- Top left corner actualOWidth actualOHeight -- Overlay size 0 0 -- Offset 1.0 1.0 -- Scale InterpTypeBilinear -- InterpType 255 -- Source image alpha return pixbuf getScaledPixBufFromInfo size info = getPixBufFromInfo size info >>= traverse (scalePixbufToSize size orientation >=> maybeAddOverlayToPixbuf size info) getPixBufFromInfo size info@ItemInfo { iconName = name , iconThemePath = mpath , iconPixmaps = pixmaps } = getPixBufFrom size name mpath pixmaps getOverlayPixBufFromInfo size info@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 Nothing else Just $ getIconPixbufFromByteString w h p if null pixmaps then getIconPixbufByName size (T.pack name) mpath else sequenceA $ getFromPixmaps selectedPixmap uiUpdateHandler updateType info = void $ Gdk.threadsAddIdle GLib.PRIORITY_DEFAULT $ updateHandler updateType info >> return False handlerId <- addUHandler uiUpdateHandler _ <- Gtk.onWidgetDestroy trayBox $ removeUHandler handlerId return trayBox