From 197f303111658aab8b7441cb005a0a7dd38c7b86 Mon Sep 17 00:00:00 2001 From: ndwarshuis Date: Sun, 7 Nov 2021 20:16:53 -0500 Subject: [PATCH] ADD awkward dbus dependency support --- bin/xmonad.hs | 8 +-- lib/XMonad/Internal/Concurrent/ACPIEvent.hs | 9 ++-- lib/XMonad/Internal/Concurrent/Removable.hs | 28 ++++++++--- lib/XMonad/Internal/Dependency.hs | 54 +++++++++++++++++++-- 4 files changed, 79 insertions(+), 20 deletions(-) diff --git a/bin/xmonad.hs b/bin/xmonad.hs index 087131b..6d9555d 100644 --- a/bin/xmonad.hs +++ b/bin/xmonad.hs @@ -73,8 +73,10 @@ main = do , dxScreensaverCtrl = sc } <- startXMonadService (h, p) <- spawnPipe "xmobar" - _ <- forkIO runPowermon - _ <- forkIO runRemovableMon + powermonAction <- runPowermon + removableAction <- runRemovableMon + mapM_ forkIO powermonAction + mapM_ forkIO removableAction _ <- forkIO $ runWorkspaceMon allDWs let ts = ThreadState { client = cl @@ -83,7 +85,7 @@ main = do } ext <- evalExternal $ externalBindings bc sc ts let ekbs = filterExternal ext - warnMissing $ externalToMissing ext + warnMissing $ externalToMissing ext ++ fmap (fmap io) [powermonAction, removableAction] -- IDK why this is necessary; nothing prior to this line will print if missing hFlush stdout launch diff --git a/lib/XMonad/Internal/Concurrent/ACPIEvent.hs b/lib/XMonad/Internal/Concurrent/ACPIEvent.hs index ec20567..48d1041 100644 --- a/lib/XMonad/Internal/Concurrent/ACPIEvent.hs +++ b/lib/XMonad/Internal/Concurrent/ACPIEvent.hs @@ -18,7 +18,7 @@ import Data.Connection import Text.Read (readMaybe) -import System.Directory (doesPathExist) +-- import System.Directory (doesPathExist) import System.IO.Streams as S (read) import System.IO.Streams.UnixSocket @@ -94,11 +94,8 @@ acpiPath = "/var/run/acpid.socket" -- | Spawn a new thread that will listen for ACPI events on the acpid socket -- and send ClientMessage events when it receives them -runPowermon :: IO () -runPowermon = do - e <- doesPathExist acpiPath - if e then listenACPI else - print ("WARNING: ACPI socket not found; disabling ACPI event management" :: String) +runPowermon :: IO (MaybeExe (IO ())) +runPowermon = runIfInstalled [pathR acpiPath] listenACPI -- | Handle ClientMessage event containing and ACPI event (to be used in -- Xmonad's event hook) diff --git a/lib/XMonad/Internal/Concurrent/Removable.hs b/lib/XMonad/Internal/Concurrent/Removable.hs index 26bce44..7e88ae4 100644 --- a/lib/XMonad/Internal/Concurrent/Removable.hs +++ b/lib/XMonad/Internal/Concurrent/Removable.hs @@ -9,12 +9,12 @@ module XMonad.Internal.Concurrent.Removable (runRemovableMon) where import Control.Concurrent import Control.Monad -import Data.Map.Lazy (Map, member) +import Data.Map.Lazy (Map, member) import DBus import DBus.Client -import XMonad.Internal.DBus.Control (pathExists) +-- import XMonad.Internal.DBus.Control (pathExists) import XMonad.Internal.Dependency bus :: BusName @@ -32,6 +32,23 @@ memAdded = memberName_ "InterfacesAdded" memRemoved :: MemberName memRemoved = memberName_ "InterfacesRemoved" +dbusDep :: MemberName -> Dependency +dbusDep m = Dependency { depRequired = True, depData = d } + where + d = DBusEndpoint + { ddDbusBus = bus + , ddDbusSystem = True + , ddDbusObject = path + , ddDbusInterface = interface + , ddDbusMember = Signal_ m + } + +addedDep :: Dependency +addedDep = dbusDep memAdded + +removedDep :: Dependency +removedDep = dbusDep memRemoved + driveInsertedSound :: FilePath driveInsertedSound = "smb_powerup.wav" @@ -74,8 +91,5 @@ listenDevices = do addMatch' client m p f = addMatch client ruleUdisks { matchMember = Just m } $ playSoundMaybe p . f . signalBody -runRemovableMon :: IO () -runRemovableMon = do - e <- pathExists True bus path - if e then listenDevices else - putStrLn "WARNING: udisks not running. Super Mario disk sounds disabled." +runRemovableMon :: IO (MaybeExe (IO ())) +runRemovableMon = runIfInstalled [addedDep, removedDep] listenDevices diff --git a/lib/XMonad/Internal/Dependency.hs b/lib/XMonad/Internal/Dependency.hs index 675bf20..94977f3 100644 --- a/lib/XMonad/Internal/Dependency.hs +++ b/lib/XMonad/Internal/Dependency.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE DeriveTraversable #-} + -------------------------------------------------------------------------------- -- | Functions for handling dependencies @@ -6,6 +8,7 @@ module XMonad.Internal.Dependency , UnitType(..) , Dependency(..) , DependencyData(..) + , DBusMember(..) , MaybeX , exe , systemUnit @@ -39,8 +42,12 @@ import Control.Arrow ((***)) import Control.Monad (filterM, join) import Control.Monad.IO.Class -import Data.List (partition) -import Data.Maybe (isJust) +import Data.List (partition, find) +import Data.Maybe (isJust, listToMaybe, fromMaybe) + +import DBus +import DBus.Client +import qualified DBus.Introspection as I import System.Directory (findExecutable, readable, writable) import System.Exit @@ -56,8 +63,20 @@ import XMonad.Internal.Shell data UnitType = SystemUnit | UserUnit deriving (Eq, Show) +data DBusMember = Method_ MemberName + | Signal_ MemberName + | Property_ String + deriving (Eq, Show) + data DependencyData = Executable String | AccessiblePath FilePath Bool Bool + | DBusEndpoint + { ddDbusBus:: BusName + , ddDbusSystem :: Bool + , ddDbusObject :: ObjectPath + , ddDbusInterface :: InterfaceName + , ddDbusMember :: DBusMember + } | Systemd UnitType String deriving (Eq, Show) @@ -105,7 +124,7 @@ userUnit = unit UserUnit data MaybeExe a = Installed a [DependencyData] | Missing [DependencyData] [DependencyData] | Ignore - deriving (Eq, Show) + deriving (Eq, Show, Foldable, Traversable) instance Functor MaybeExe where fmap f (Installed x ds) = Installed (f x) ds @@ -155,12 +174,38 @@ pathAccessible p testread testwrite = do -- (_, Just False) -> Just "file not writable" -- _ -> Nothing +dbusInstalled :: BusName -> Bool -> ObjectPath -> InterfaceName -> DBusMember + -> IO Bool +dbusInstalled bus usesystem objpath iface mem = do + client <- if usesystem then connectSystem else connectSession + reply <- call_ client (methodCall objpath + (interfaceName_ "org.freedesktop.DBus.Introspectable") + (memberName_ "Introspect")) + { methodCallDestination = Just bus + } + let res = findMem =<< I.parseXML objpath =<< fromVariant + =<< listToMaybe (methodReturnBody reply) + disconnect client + return $ fromMaybe False res + where + findMem obj = fmap (matchMem mem) + $ find (\i -> I.interfaceName i == iface) + $ I.objectInterfaces obj + matchMem (Method_ n) = elem n . fmap I.methodName . I.interfaceMethods + matchMem (Signal_ n) = elem n . fmap I.signalName . I.interfaceSignals + matchMem (Property_ n) = elem n . fmap I.propertyName . I.interfaceProperties + -- TODO somehow get this to preserve error messages if something isn't found depInstalled :: DependencyData -> IO Bool depInstalled (Executable n) = exeInstalled n depInstalled (Systemd t n) = unitInstalled t n depInstalled (AccessiblePath p r w) = pathAccessible p r w - -- (AccessiblePath p r w) -> pathAccessible p r w +depInstalled DBusEndpoint { ddDbusBus = b + , ddDbusSystem = s + , ddDbusObject = o + , ddDbusInterface = i + , ddDbusMember = m + } = dbusInstalled b s o i m checkInstalled :: [Dependency] -> IO ([DependencyData], [DependencyData]) checkInstalled = fmap go . filterMissing @@ -218,6 +263,7 @@ partitionMissing = foldl (\(a, b) -> ((a++) *** (b++)) . go) ([], []) fmtMissing :: DependencyData -> String -- TODO this error message is lame +fmtMissing DBusEndpoint {} = "some random dbus path is missing" fmtMissing (AccessiblePath p True False) = "path '" ++ p ++ "' not readable" fmtMissing (AccessiblePath p False True) = "path '" ++ p ++ "' not writable" fmtMissing (AccessiblePath p True True) = "path '" ++ p ++ "' not readable/writable"