dbus-menu (empty) → 0.1.0.0
raw patch · 8 files changed
+571/−0 lines, 8 filesdep +basedep +containersdep +dbus
Dependencies added: base, containers, dbus, enclosed-exceptions, filepath, gi-glib, gi-gtk3, haskell-gi, haskell-gi-base, hslogger, template-haskell, text
Files
- ChangeLog.md +5/−0
- LICENSE +28/−0
- README.md +5/−0
- dbus-menu.cabal +53/−0
- dbus-xml/com.canonical.dbusmenu.xml +69/−0
- src/DBusMenu.hs +286/−0
- src/DBusMenu/Client.hs +14/−0
- src/DBusMenu/Client/Util.hs +111/−0
+ ChangeLog.md view
@@ -0,0 +1,5 @@+# Changelog for dbus-menu++## 0.1.0.0++* Initial release, extracted from gtk-sni-tray
+ LICENSE view
@@ -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.
+ README.md view
@@ -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).
@@ -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
@@ -0,0 +1,69 @@+<node>+ <interface name="com.canonical.dbusmenu">+ <property name="Version" type="u" access="read"/>+ <property name="TextDirection" type="s" access="read"/>+ <property name="Status" type="s" access="read"/>+ <property name="IconThemePath" type="as" access="read"/>++ <method name="GetLayout">+ <arg type="i" name="parentId" direction="in"/>+ <arg type="i" name="recursionDepth" direction="in"/>+ <arg type="as" name="propertyNames" direction="in"/>+ <arg type="u" name="revision" direction="out"/>+ <arg type="(ia{sv}av)" name="layout" direction="out"/>+ <annotation name="org.qtproject.QtDBus.QtTypeName.Out1" value="DBusMenuLayout"/>+ </method>+ <method name="GetGroupProperties">+ <arg type="ai" name="ids" direction="in"/>+ <arg type="as" name="propertyNames" direction="in"/>+ <arg type="a(ia{sv})" name="properties" direction="out"/>+ <annotation name="org.qtproject.QtDBus.QtTypeName.In0" value="DBusMenuIdList"/>+ <annotation name="org.qtproject.QtDBus.QtTypeName.Out0" value="DBusMenuItemPropertiesList"/>+ </method>+ <method name="GetProperty">+ <arg type="i" name="id" direction="in"/>+ <arg type="s" name="name" direction="in"/>+ <arg type="v" name="value" direction="out"/>+ </method>+ <method name="Event">+ <arg type="i" name="id" direction="in"/>+ <arg type="s" name="eventId" direction="in"/>+ <arg type="v" name="data" direction="in"/>+ <arg type="u" name="timestamp" direction="in"/>+ </method>+ <!--<method name="EventGroup">+ <arg type="a(isvu)" name="events" direction="in"/>+ <arg type="ai" name="idErrors" direction="out"/>+ <annotation name="org.qtproject.QtDBus.QtTypeName.In0" value="DBusMenuEventList"/>+ <annotation name="org.qtproject.QtDBus.QtTypeName.Out0" value="DBusMenuIdList"/>+ </method>-->+ <method name="AboutToShow">+ <arg type="i" name="id" direction="in"/>+ <arg type="b" name="needUpdate" direction="out"/>+ </method>+ <method name="AboutToShowGroup">+ <arg type="ai" name="ids" direction="in"/>+ <arg type="ai" name="updatesNeeded" direction="out"/>+ <arg type="ai" name="idErrors" direction="out"/>+ <annotation name="org.qtproject.QtDBus.QtTypeName.In0" value="DBusMenuIdList"/>+ <annotation name="org.qtproject.QtDBus.QtTypeName.Out0" value="DBusMenuIdList"/>+ <annotation name="org.qtproject.QtDBus.QtTypeName.Out1" value="DBusMenuIdList"/>+ </method>++ <signal name="ItemsPropertiesUpdated">+ <arg type="a(ia{sv})" name="updatedProps" direction="out"/>+ <arg type="a(ias)" name="removedProps" direction="out"/>+ <annotation name="org.qtproject.QtDBus.QtTypeName.Out0" value="DBusMenuItemPropertiesList"/>+ <annotation name="org.qtproject.QtDBus.QtTypeName.Out1" value="DBusMenuItemPropertyNamesList"/>+ </signal>+ <signal name="LayoutUpdated">+ <arg type="u" name="revision" direction="out"/>+ <arg type="i" name="parent" direction="out"/>+ </signal>+ <signal name="ItemActivationRequested">+ <arg type="i" name="id" direction="out"/>+ <arg type="u" name="timestamp" direction="out"/>+ </signal>+ </interface>+</node>+
+ src/DBusMenu.hs view
@@ -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
+ src/DBusMenu/Client.hs view
@@ -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")
+ src/DBusMenu/Client/Util.hs view
@@ -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