ADD awkward dbus dependency support
This commit is contained in:
parent
952e10b1a5
commit
197f303111
|
@ -73,8 +73,10 @@ main = do
|
||||||
, dxScreensaverCtrl = sc
|
, dxScreensaverCtrl = sc
|
||||||
} <- startXMonadService
|
} <- startXMonadService
|
||||||
(h, p) <- spawnPipe "xmobar"
|
(h, p) <- spawnPipe "xmobar"
|
||||||
_ <- forkIO runPowermon
|
powermonAction <- runPowermon
|
||||||
_ <- forkIO runRemovableMon
|
removableAction <- runRemovableMon
|
||||||
|
mapM_ forkIO powermonAction
|
||||||
|
mapM_ forkIO removableAction
|
||||||
_ <- forkIO $ runWorkspaceMon allDWs
|
_ <- forkIO $ runWorkspaceMon allDWs
|
||||||
let ts = ThreadState
|
let ts = ThreadState
|
||||||
{ client = cl
|
{ client = cl
|
||||||
|
@ -83,7 +85,7 @@ main = do
|
||||||
}
|
}
|
||||||
ext <- evalExternal $ externalBindings bc sc ts
|
ext <- evalExternal $ externalBindings bc sc ts
|
||||||
let ekbs = filterExternal ext
|
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
|
-- IDK why this is necessary; nothing prior to this line will print if missing
|
||||||
hFlush stdout
|
hFlush stdout
|
||||||
launch
|
launch
|
||||||
|
|
|
@ -18,7 +18,7 @@ import Data.Connection
|
||||||
|
|
||||||
import Text.Read (readMaybe)
|
import Text.Read (readMaybe)
|
||||||
|
|
||||||
import System.Directory (doesPathExist)
|
-- import System.Directory (doesPathExist)
|
||||||
import System.IO.Streams as S (read)
|
import System.IO.Streams as S (read)
|
||||||
import System.IO.Streams.UnixSocket
|
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
|
-- | Spawn a new thread that will listen for ACPI events on the acpid socket
|
||||||
-- and send ClientMessage events when it receives them
|
-- and send ClientMessage events when it receives them
|
||||||
runPowermon :: IO ()
|
runPowermon :: IO (MaybeExe (IO ()))
|
||||||
runPowermon = do
|
runPowermon = runIfInstalled [pathR acpiPath] listenACPI
|
||||||
e <- doesPathExist acpiPath
|
|
||||||
if e then listenACPI else
|
|
||||||
print ("WARNING: ACPI socket not found; disabling ACPI event management" :: String)
|
|
||||||
|
|
||||||
-- | Handle ClientMessage event containing and ACPI event (to be used in
|
-- | Handle ClientMessage event containing and ACPI event (to be used in
|
||||||
-- Xmonad's event hook)
|
-- Xmonad's event hook)
|
||||||
|
|
|
@ -14,7 +14,7 @@ import Data.Map.Lazy (Map, member)
|
||||||
import DBus
|
import DBus
|
||||||
import DBus.Client
|
import DBus.Client
|
||||||
|
|
||||||
import XMonad.Internal.DBus.Control (pathExists)
|
-- import XMonad.Internal.DBus.Control (pathExists)
|
||||||
import XMonad.Internal.Dependency
|
import XMonad.Internal.Dependency
|
||||||
|
|
||||||
bus :: BusName
|
bus :: BusName
|
||||||
|
@ -32,6 +32,23 @@ memAdded = memberName_ "InterfacesAdded"
|
||||||
memRemoved :: MemberName
|
memRemoved :: MemberName
|
||||||
memRemoved = memberName_ "InterfacesRemoved"
|
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 :: FilePath
|
||||||
driveInsertedSound = "smb_powerup.wav"
|
driveInsertedSound = "smb_powerup.wav"
|
||||||
|
|
||||||
|
@ -74,8 +91,5 @@ listenDevices = do
|
||||||
addMatch' client m p f = addMatch client ruleUdisks { matchMember = Just m }
|
addMatch' client m p f = addMatch client ruleUdisks { matchMember = Just m }
|
||||||
$ playSoundMaybe p . f . signalBody
|
$ playSoundMaybe p . f . signalBody
|
||||||
|
|
||||||
runRemovableMon :: IO ()
|
runRemovableMon :: IO (MaybeExe (IO ()))
|
||||||
runRemovableMon = do
|
runRemovableMon = runIfInstalled [addedDep, removedDep] listenDevices
|
||||||
e <- pathExists True bus path
|
|
||||||
if e then listenDevices else
|
|
||||||
putStrLn "WARNING: udisks not running. Super Mario disk sounds disabled."
|
|
||||||
|
|
|
@ -1,3 +1,5 @@
|
||||||
|
{-# LANGUAGE DeriveTraversable #-}
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Functions for handling dependencies
|
-- | Functions for handling dependencies
|
||||||
|
|
||||||
|
@ -6,6 +8,7 @@ module XMonad.Internal.Dependency
|
||||||
, UnitType(..)
|
, UnitType(..)
|
||||||
, Dependency(..)
|
, Dependency(..)
|
||||||
, DependencyData(..)
|
, DependencyData(..)
|
||||||
|
, DBusMember(..)
|
||||||
, MaybeX
|
, MaybeX
|
||||||
, exe
|
, exe
|
||||||
, systemUnit
|
, systemUnit
|
||||||
|
@ -39,8 +42,12 @@ import Control.Arrow ((***))
|
||||||
import Control.Monad (filterM, join)
|
import Control.Monad (filterM, join)
|
||||||
import Control.Monad.IO.Class
|
import Control.Monad.IO.Class
|
||||||
|
|
||||||
import Data.List (partition)
|
import Data.List (partition, find)
|
||||||
import Data.Maybe (isJust)
|
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.Directory (findExecutable, readable, writable)
|
||||||
import System.Exit
|
import System.Exit
|
||||||
|
@ -56,8 +63,20 @@ import XMonad.Internal.Shell
|
||||||
|
|
||||||
data UnitType = SystemUnit | UserUnit deriving (Eq, Show)
|
data UnitType = SystemUnit | UserUnit deriving (Eq, Show)
|
||||||
|
|
||||||
|
data DBusMember = Method_ MemberName
|
||||||
|
| Signal_ MemberName
|
||||||
|
| Property_ String
|
||||||
|
deriving (Eq, Show)
|
||||||
|
|
||||||
data DependencyData = Executable String
|
data DependencyData = Executable String
|
||||||
| AccessiblePath FilePath Bool Bool
|
| AccessiblePath FilePath Bool Bool
|
||||||
|
| DBusEndpoint
|
||||||
|
{ ddDbusBus:: BusName
|
||||||
|
, ddDbusSystem :: Bool
|
||||||
|
, ddDbusObject :: ObjectPath
|
||||||
|
, ddDbusInterface :: InterfaceName
|
||||||
|
, ddDbusMember :: DBusMember
|
||||||
|
}
|
||||||
| Systemd UnitType String
|
| Systemd UnitType String
|
||||||
deriving (Eq, Show)
|
deriving (Eq, Show)
|
||||||
|
|
||||||
|
@ -105,7 +124,7 @@ userUnit = unit UserUnit
|
||||||
data MaybeExe a = Installed a [DependencyData]
|
data MaybeExe a = Installed a [DependencyData]
|
||||||
| Missing [DependencyData] [DependencyData]
|
| Missing [DependencyData] [DependencyData]
|
||||||
| Ignore
|
| Ignore
|
||||||
deriving (Eq, Show)
|
deriving (Eq, Show, Foldable, Traversable)
|
||||||
|
|
||||||
instance Functor MaybeExe where
|
instance Functor MaybeExe where
|
||||||
fmap f (Installed x ds) = Installed (f x) ds
|
fmap f (Installed x ds) = Installed (f x) ds
|
||||||
|
@ -155,12 +174,38 @@ pathAccessible p testread testwrite = do
|
||||||
-- (_, Just False) -> Just "file not writable"
|
-- (_, Just False) -> Just "file not writable"
|
||||||
-- _ -> Nothing
|
-- _ -> 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
|
-- TODO somehow get this to preserve error messages if something isn't found
|
||||||
depInstalled :: DependencyData -> IO Bool
|
depInstalled :: DependencyData -> IO Bool
|
||||||
depInstalled (Executable n) = exeInstalled n
|
depInstalled (Executable n) = exeInstalled n
|
||||||
depInstalled (Systemd t n) = unitInstalled t n
|
depInstalled (Systemd t n) = unitInstalled t n
|
||||||
depInstalled (AccessiblePath p r w) = pathAccessible p r w
|
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 :: [Dependency] -> IO ([DependencyData], [DependencyData])
|
||||||
checkInstalled = fmap go . filterMissing
|
checkInstalled = fmap go . filterMissing
|
||||||
|
@ -218,6 +263,7 @@ partitionMissing = foldl (\(a, b) -> ((a++) *** (b++)) . go) ([], [])
|
||||||
|
|
||||||
fmtMissing :: DependencyData -> String
|
fmtMissing :: DependencyData -> String
|
||||||
-- TODO this error message is lame
|
-- 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 True False) = "path '" ++ p ++ "' not readable"
|
||||||
fmtMissing (AccessiblePath p False True) = "path '" ++ p ++ "' not writable"
|
fmtMissing (AccessiblePath p False True) = "path '" ++ p ++ "' not writable"
|
||||||
fmtMissing (AccessiblePath p True True) = "path '" ++ p ++ "' not readable/writable"
|
fmtMissing (AccessiblePath p True True) = "path '" ++ p ++ "' not readable/writable"
|
||||||
|
|
Loading…
Reference in New Issue