ADD awkward dbus dependency support

bin/xmonad.hs

@@ -73,8 +73,10 @@ main = do
     , dxScreensaverCtrl = sc
     } <- startXMonadService
   (h, p) <- spawnPipe "xmobar"
-  _ <- forkIO runPowermon
+  powermonAction <- runPowermon
-  _ <- forkIO runRemovableMon
+  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

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 :: 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
 -- Xmonad's event hook)

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 :: 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."

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