diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,5 @@ +# Changelog for dbus-menu + +## 0.1.0.0 + +* Initial release, extracted from gtk-sni-tray diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,28 @@ +BSD 3-Clause License + +Copyright (c) 2026, taffybar + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +1. Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. + +2. Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + +3. Neither the name of the copyright holder nor the names of its + contributors may be used to endorse or promote products derived from + this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,5 @@ +# dbus-menu + +A Haskell client for the [com.canonical.dbusmenu](https://wiki.ubuntu.com/DesktopExperienceTeam/ApplicationIndicators#DBus_Menu_Protocol) DBus interface, providing GTK3 menu construction from DBusMenu services. + +Extracted from [gtk-sni-tray](https://github.com/taffybar/gtk-sni-tray). diff --git a/dbus-menu.cabal b/dbus-menu.cabal new file mode 100644 --- /dev/null +++ b/dbus-menu.cabal @@ -0,0 +1,53 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.38.3. +-- +-- see: https://github.com/sol/hpack + +name: dbus-menu +version: 0.1.0.0 +synopsis: A Haskell implementation of the DBusMenu protocol +description: Haskell client for the com.canonical.dbusmenu DBus interface, providing GTK3 menu construction from DBusMenu services. +category: System +homepage: https://github.com/taffybar/dbus-menu#readme +bug-reports: https://github.com/taffybar/dbus-menu/issues +author: Ivan Malison +maintainer: IvanMalison@gmail.com +copyright: 2018 Ivan Malison +license: BSD3 +license-file: LICENSE +build-type: Simple +extra-source-files: + README.md + ChangeLog.md + dbus-xml/com.canonical.dbusmenu.xml + +source-repository head + type: git + location: https://github.com/taffybar/dbus-menu + +library + exposed-modules: + DBusMenu + DBusMenu.Client + DBusMenu.Client.Util + other-modules: + Paths_dbus_menu + hs-source-dirs: + src + pkgconfig-depends: + gtk+-3.0 + build-depends: + base >=4.7 && <5 + , containers >=0.5 && <0.8 + , dbus ==1.* + , enclosed-exceptions >=1.0.0.1 && <1.1 + , filepath >=1.3 && <1.6 + , gi-glib ==2.0.* + , gi-gtk3 ==3.0.* + , haskell-gi >=0.21.2 && <0.27 + , haskell-gi-base >=0.21.1 && <0.27 + , hslogger >=1.2 && <1.4 + , template-haskell >=2.10 && <2.23 + , text >=1.2 && <2.2 + default-language: Haskell2010 diff --git a/dbus-xml/com.canonical.dbusmenu.xml b/dbus-xml/com.canonical.dbusmenu.xml new file mode 100644 --- /dev/null +++ b/dbus-xml/com.canonical.dbusmenu.xml @@ -0,0 +1,69 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/src/DBusMenu.hs b/src/DBusMenu.hs new file mode 100644 --- /dev/null +++ b/src/DBusMenu.hs @@ -0,0 +1,286 @@ +{-# LANGUAGE OverloadedStrings #-} +module DBusMenu + ( -- * High-level menu construction + buildMenu + , populateGtkMenu + , buildGtkMenuItem + + -- * DBusMenu protocol operations + , getLayout + , aboutToShow + , sendClicked + + -- * Layout tree + , LayoutNode(..) + , variantToLayout + , tupleToLayout + + -- * Layout node property accessors + , menuItemType + , menuItemLabel + , menuItemVisible + , menuItemEnabled + , menuItemToggleType + , menuItemToggleState + ) where + +import Control.Concurrent (forkIO) +import Control.Exception.Enclosed (catchAny) +import Control.Monad (forM_, void, when) +import Data.Int (Int32) +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Maybe (fromMaybe) +import qualified Data.Text as T +import Data.Word (Word32) +import DBus +import DBus.Client +import Data.GI.Base (unsafeCastTo) +import qualified GI.Gtk as Gtk +import System.Log.Logger (Priority(..), logM) +import Text.Printf + +import qualified DBusMenu.Client as DM + +dbusMenuLogger :: Priority -> String -> IO () +dbusMenuLogger = logM "DBusMenu" + +addCssClass :: Gtk.Widget -> T.Text -> IO () +addCssClass widget cssClass = + Gtk.widgetGetStyleContext widget >>= (`Gtk.styleContextAddClass` cssClass) + +-- | A node in the DBusMenu layout tree. +data LayoutNode = LayoutNode + { lnId :: Int32 + , lnProps :: Map String Variant + , lnChildren :: [LayoutNode] + } deriving (Eq, Show) + +type LayoutTuple = (Int32, Map String Variant, [Variant]) + +-- | Parse a DBus Variant into a LayoutNode. +variantToLayout :: Variant -> Maybe LayoutNode +variantToLayout v = do + (i, props, kids) <- fromVariant v :: Maybe LayoutTuple + children <- traverse variantToLayout kids + pure LayoutNode { lnId = i, lnProps = props, lnChildren = children } + +-- | Convert a raw layout tuple into a LayoutNode. +tupleToLayout :: LayoutTuple -> LayoutNode +tupleToLayout (i, props, kids) = + LayoutNode + { lnId = i + , lnProps = props + , lnChildren = [ n | v <- kids, Just n <- [variantToLayout v] ] + } + +-- | Unwrap an Either MethodError, failing on Left. +unwrapCall :: String -> Either MethodError a -> IO a +unwrapCall label (Left err) = fail $ label <> " failed: " <> show err +unwrapCall _ (Right a) = pure a + +-- | Notify the DBusMenu service that a menu item is about to be shown. +-- Returns True if the service indicates an update is needed. +aboutToShow :: Client -> BusName -> ObjectPath -> Int32 -> IO Bool +aboutToShow client dest path i = + either (const False) id <$> DM.aboutToShow client dest path i + +-- | Fetch the layout tree from the DBusMenu service. +getLayout :: Client -> BusName -> ObjectPath -> Int32 -> Int32 -> [String] -> IO (Word32, LayoutNode) +getLayout client dest path parentId depth propNames = do + (rev, tup) <- unwrapCall "GetLayout" =<< + DM.getLayout client dest path parentId depth propNames + pure (rev, tupleToLayout tup) + +-- | Send a \"clicked\" event to the DBusMenu service for the given item. +-- Runs asynchronously on a forked thread. +sendClicked :: Client -> BusName -> ObjectPath -> Int32 -> Word32 -> IO () +sendClicked client dest path itemId ts = do + dbusMenuLogger DEBUG $ + printf "sendClicked: id=%d dest=%s path=%s ts=%d" + itemId (show dest) (show path) ts + let mc = DM.eventMethodCall + { methodCallDestination = Just dest + , methodCallPath = path + , methodCallBody = + [ toVariant itemId + , toVariant ("clicked" :: String) + , toVariant (toVariant (0 :: Int32)) + , toVariant ts + ] + } + -- Send on a forked thread to avoid blocking GTK; use `call` instead of + -- `callNoReply` so we can detect service errors. + void $ forkIO $ catchAny + (do result <- call client mc + case result of + Left err -> dbusMenuLogger WARNING $ + printf "sendClicked: Event error: %s" (show err) + Right _ -> dbusMenuLogger DEBUG "sendClicked: Event succeeded") + (\e -> dbusMenuLogger WARNING $ + printf "sendClicked: Event exception: %s" (show e)) + +getPropS :: String -> LayoutNode -> Maybe String +getPropS key LayoutNode { lnProps = props } = + Map.lookup key props >>= fromVariant + +getPropB :: String -> LayoutNode -> Maybe Bool +getPropB key LayoutNode { lnProps = props } = + Map.lookup key props >>= fromVariant + +getPropI32 :: String -> LayoutNode -> Maybe Int32 +getPropI32 key LayoutNode { lnProps = props } = + Map.lookup key props >>= fromVariant + +-- | The item type (e.g. @\"separator\"@), or Nothing for standard items. +menuItemType :: LayoutNode -> Maybe String +menuItemType = getPropS "type" + +-- | The display label, defaulting to @\"\"@ if absent. +menuItemLabel :: LayoutNode -> String +menuItemLabel n = + fromMaybe "" (getPropS "label" n) + +-- | Whether the item is visible, defaulting to True. +menuItemVisible :: LayoutNode -> Bool +menuItemVisible n = fromMaybe True (getPropB "visible" n) + +-- | Whether the item is enabled\/sensitive, defaulting to True. +menuItemEnabled :: LayoutNode -> Bool +menuItemEnabled n = fromMaybe True (getPropB "enabled" n) + +-- | The toggle type (e.g. @\"checkmark\"@, @\"radio\"@), if any. +menuItemToggleType :: LayoutNode -> Maybe String +menuItemToggleType = getPropS "toggle-type" + +-- | The toggle state: 0 = off, 1 = on, -1 = indeterminate. +menuItemToggleState :: LayoutNode -> Maybe Int32 +menuItemToggleState = getPropI32 "toggle-state" + +-- | Populate a GTK Menu widget with items from a layout tree. +-- Clears any existing children first. +-- +-- CSS classes applied to the menu: @dbusmenu-menu@ +populateGtkMenu :: Client -> BusName -> ObjectPath -> Gtk.Menu -> LayoutNode -> IO () +populateGtkMenu client dest path gtkMenu root = do + gtkMenuW <- Gtk.toWidget gtkMenu + addCssClass gtkMenuW "dbusmenu-menu" + + -- Clear existing children (for refreshes, e.g. submenus). + children <- Gtk.containerGetChildren gtkMenu + forM_ children Gtk.widgetDestroy + + forM_ (lnChildren root) $ \child -> when (menuItemVisible child) $ do + widget <- buildGtkMenuItem client dest path child + Gtk.menuShellAppend gtkMenu widget + +-- | Build a single GTK MenuItem from a layout node. +-- +-- CSS classes applied: +-- +-- * @dbusmenu-item@ on every item +-- * @dbusmenu-separator@ on separator items +-- * @dbusmenu-toggle@ on checkmark and radio items +-- * @dbusmenu-checkmark@ on checkmark items +-- * @dbusmenu-radio@ on radio items +-- * @dbusmenu-checked@ on active\/checked toggle items +-- * @dbusmenu-has-submenu@ on items with children +-- +-- Submenus get: +-- +-- * @dbusmenu-menu@ (base menu class) +-- * @dbusmenu-submenu@ +buildGtkMenuItem :: Client -> BusName -> ObjectPath -> LayoutNode -> IO Gtk.MenuItem +buildGtkMenuItem client dest path node = do + let isChecked = menuItemToggleState node == Just 1 + item <- case menuItemType node of + Just "separator" -> do + sep <- Gtk.separatorMenuItemNew + unsafeCastTo Gtk.MenuItem sep + _ -> do + let label = T.pack (menuItemLabel node) + case menuItemToggleType node of + Just "checkmark" -> do + c <- Gtk.checkMenuItemNewWithMnemonic label + Gtk.checkMenuItemSetActive c isChecked + unsafeCastTo Gtk.MenuItem c + Just "radio" -> do + c <- Gtk.checkMenuItemNewWithMnemonic label + Gtk.checkMenuItemSetDrawAsRadio c True + Gtk.checkMenuItemSetActive c isChecked + unsafeCastTo Gtk.MenuItem c + _ -> Gtk.menuItemNewWithMnemonic label + + Gtk.widgetSetName item (T.pack ("dbusmenu-item-" <> show (lnId node))) + itemW <- Gtk.toWidget item + addCssClass itemW "dbusmenu-item" + + case menuItemType node of + Just "separator" -> addCssClass itemW "dbusmenu-separator" + _ -> pure () + + case menuItemToggleType node of + Just "checkmark" -> do + addCssClass itemW "dbusmenu-toggle" + addCssClass itemW "dbusmenu-checkmark" + when isChecked $ addCssClass itemW "dbusmenu-checked" + Just "radio" -> do + addCssClass itemW "dbusmenu-toggle" + addCssClass itemW "dbusmenu-radio" + when isChecked $ addCssClass itemW "dbusmenu-checked" + _ -> pure () + + Gtk.widgetSetSensitive item (menuItemEnabled node) + + -- Submenu handling: build children now, and refresh on show via AboutToShow/GetLayout. + if null (lnChildren node) + then do + _ <- Gtk.onMenuItemActivate item $ + catchAny + (do ts <- Gtk.getCurrentEventTime + sendClicked client dest path (lnId node) ts) + (\e -> dbusMenuLogger WARNING $ + printf "Menu item %d click failed (stale ID?): %s" + (lnId node) (show e)) + pure () + else do + addCssClass itemW "dbusmenu-has-submenu" + submenu <- Gtk.menuNew + Gtk.widgetSetName submenu (T.pack ("dbusmenu-submenu-" <> show (lnId node))) + submenuW <- Gtk.toWidget submenu + addCssClass submenuW "dbusmenu-submenu" + -- Populate with the eagerly-fetched layout so submenus are usable even if + -- the service doesn't support/require lazy updates. + populateGtkMenu client dest path submenu node + let refresh = + catchAny + (do -- Allow the service to update the submenu content lazily. + _ <- aboutToShow client dest path (lnId node) + (_, layout) <- getLayout client dest path (lnId node) 1 [] + populateGtkMenu client dest path submenu layout + Gtk.widgetShowAll submenu) + (\e -> dbusMenuLogger WARNING $ + printf "Submenu %d refresh failed (stale ID?): %s" + (lnId node) (show e)) + _ <- Gtk.onWidgetShow submenu refresh + Gtk.menuItemSetSubmenu item (Just submenu) + + pure item + +-- | Build a complete GTK Menu from a DBusMenu service. +-- +-- CSS classes applied to the root menu: @dbusmenu-menu@, @dbusmenu-root@ +buildMenu :: Client -> BusName -> ObjectPath -> IO Gtk.Menu +buildMenu client dest path = do + dbusMenuLogger DEBUG $ + printf "buildMenu: dest=%s path=%s" (show dest) (show path) + _ <- aboutToShow client dest path 0 + (_, layout) <- getLayout client dest path 0 (-1) [] + dbusMenuLogger DEBUG $ + printf "buildMenu: root has %d children" (length (lnChildren layout)) + menu <- Gtk.menuNew + Gtk.widgetSetName menu "dbusmenu-root" + menuW <- Gtk.toWidget menu + addCssClass menuW "dbusmenu-root" + populateGtkMenu client dest path menu layout + pure menu diff --git a/src/DBusMenu/Client.hs b/src/DBusMenu/Client.hs new file mode 100644 --- /dev/null +++ b/src/DBusMenu/Client.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE TemplateHaskell #-} +module DBusMenu.Client where + +import DBus.Generation +import System.FilePath +import DBusMenu.Client.Util + +-- Generates DBus client functions/signals for the com.canonical.dbusmenu +-- interface from introspection XML, similar to Taffybar's approach. +generateClientFromFile + defaultRecordGenerationParams + defaultGenerationParams { genTakeSignalErrorHandler = True } + False + ("dbus-xml" "com.canonical.dbusmenu.xml") diff --git a/src/DBusMenu/Client/Util.hs b/src/DBusMenu/Client/Util.hs new file mode 100644 --- /dev/null +++ b/src/DBusMenu/Client/Util.hs @@ -0,0 +1,111 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskellQuotes #-} +module DBusMenu.Client.Util + ( RecordGenerationParams(..) + , GetTypeForName + , defaultRecordGenerationParams + , generateClientFromFile + ) where + +import Control.Monad (forM) +import DBus (ObjectPath) +import DBus.Generation +import qualified DBus.Internal.Types as DBusTypes +import qualified DBus.Introspection as I +import qualified Data.Char as Char +import qualified Data.Coerce as Coerce +import qualified Data.Maybe as Maybe +import qualified Data.Text.IO as TIO +import Language.Haskell.TH +import Language.Haskell.TH.Syntax (addDependentFile, makeRelativeToProject) + +type GetTypeForName = String -> DBusTypes.Type -> Maybe Type + +data RecordGenerationParams = RecordGenerationParams + { recordName :: Maybe String + , recordPrefix :: String + , recordTypeForName :: GetTypeForName + } + +defaultRecordGenerationParams :: RecordGenerationParams +defaultRecordGenerationParams = RecordGenerationParams + { recordName = Nothing + , recordPrefix = "_" + , recordTypeForName = const $ const Nothing + } + +deriveShowAndEQ :: [DerivClause] +deriveShowAndEQ = + [DerivClause Nothing [ConT ''Eq, ConT ''Show]] + +buildDataFromNameTypePairs :: Name -> [(Name, Type)] -> Dec +buildDataFromNameTypePairs name pairs = + DataD [] name [] Nothing [RecC name (map mkVarBangType pairs)] deriveShowAndEQ + where + mkVarBangType (fieldName, fieldType) = + ( fieldName + , Bang NoSourceUnpackedness NoSourceStrictness + , fieldType + ) + +generateGetAllRecord + :: RecordGenerationParams + -> GenerationParams + -> I.Interface + -> Q [Dec] +generateGetAllRecord + RecordGenerationParams + { recordName = recordNameString + , recordPrefix = prefix + , recordTypeForName = getTypeForName + } + GenerationParams { getTHType = getArgType } + I.Interface + { I.interfaceName = interfaceName + , I.interfaceProperties = properties + } = do + let theRecordName = + mkName $ + maybe + (map Char.toUpper $ filter Char.isLetter $ Coerce.coerce interfaceName) + id + recordNameString + getPairFromProperty + I.Property { I.propertyName = propName, I.propertyType = propType } = + ( mkName $ prefix ++ propName + , Maybe.fromMaybe (getArgType propType) $ + getTypeForName propName propType + ) + getAllRecord = + buildDataFromNameTypePairs theRecordName $ + map getPairFromProperty properties + pure [getAllRecord] + +getIntrospectionObjectFromFile :: FilePath -> ObjectPath -> Q I.Object +getIntrospectionObjectFromFile filepath path = do + realPath <- makeRelativeToProject filepath + addDependentFile realPath + xml <- runIO (TIO.readFile realPath) + case I.parseXML path xml of + Nothing -> fail $ "Failed to parse DBus introspection XML: " <> filepath + Just obj -> pure obj + +generateClientFromFile + :: RecordGenerationParams + -> GenerationParams + -> Bool + -> FilePath + -> Q [Dec] +generateClientFromFile recordGenerationParams params useObjectPath filepath = do + obj <- getIntrospectionObjectFromFile filepath "/" + let actualObjectPath = I.objectPath obj + realParams = + if useObjectPath + then params { genObjectPath = Just actualObjectPath } + else params + (<++>) = liftA2 (++) + fmap concat $ forM (I.objectInterfaces obj) $ \interface -> do + generateGetAllRecord recordGenerationParams params interface <++> + generateClient realParams interface <++> + generateSignalsFromInterface realParams interface