ADD awkward dbus dependency support

This commit is contained in:
Nathan Dwarshuis 2021-11-07 20:16:53 -05:00
parent 952e10b1a5
commit 197f303111
4 changed files with 79 additions and 20 deletions

View File

@ -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

View File

@ -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)

View File

@ -14,7 +14,7 @@ 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

View File

@ -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"