WIP use DBus dependency API everywhere

bin/xmobar.hs

@@ -42,7 +42,8 @@ import           XMonad.Internal.DBus.Brightness.IntelBacklight (blPath)
 import           XMonad.Internal.DBus.Common                    (xmonadBus)
 import           XMonad.Internal.DBus.Control                   (pathExists)
 import           XMonad.Internal.DBus.Screensaver               (ssPath)
-import           XMonad.Internal.Shell                          (fmtCmd)
+import           XMonad.Internal.Dependency
+-- import           XMonad.Internal.Shell                          (fmtCmd)
 import qualified XMonad.Internal.Theme                          as T
 import           Xmobar
 
@@ -226,6 +227,19 @@ toJust x b = if b then Just x else Nothing
 whenDBusPath :: Bool -> BusName -> ObjectPath -> CmdSpec -> IO (Maybe CmdSpec)
 whenDBusPath usesys b p cs = toJust cs <$> pathExists usesys b p
 
+dbusDep :: Bool -> BusName -> ObjectPath -> InterfaceName -> DBusMember -> Dependency
+dbusDep usesys bus obj iface mem =
+  Dependency { depRequired = True, depData = d }
+  where
+    d = DBusEndpoint
+      { ddDbusBus = bus
+      , ddDbusSystem = usesys
+      , ddDbusObject = obj
+      , ddDbusInterface = iface
+      , ddDbusMember = mem
+      }
+
+
 -- in the case of network interfaces, assume that the system uses systemd in
 -- which case ethernet interfaces always start with "en" and wireless
 -- interfaces always start with "wl"
@@ -275,8 +289,11 @@ getVPN = do
   where
     args = ["-c", "no", "-t", "-f", "TYPE", "c", "show"]
 
-getBt :: IO (Maybe CmdSpec)
+getBt :: IO (MaybeExe CmdSpec)
-getBt = whenDBusPath True btBus btPath btCmd
+-- getBt = whenDBusPath True btBus btPath btCmd
+getBt = runIfInstalled [dep] btCmd
+  where
+    dep = dbusDep True btBus btPath btInterface $ Property_ btPowered
 
 getAlsa :: IO (Maybe CmdSpec)
 getAlsa = toJust alsaCmd . isJust <$> findExecutable "alsactl"
@@ -289,6 +306,10 @@ getSs = whenDBusPath False xmonadBus ssPath ssCmd
 
 getAllCommands :: IO BarRegions
 getAllCommands = do
+  getBt' <- getBt
+  let bt = case getBt' of
+             (Installed x _) -> Just x
+             _               -> Nothing
   let left =
         [ CmdSpec
           { csAlias = "UnsafeStdinReader"
@@ -299,7 +320,8 @@ getAllCommands = do
     [ getWireless
     , getEthernet
     , getVPN
-    , getBt
+    -- , getBt
+    , return bt
     , getAlsa
     , getBattery
     , getBl

bin/xmonad.hs

@@ -73,10 +73,8 @@ main = do
     , dxScreensaverCtrl = sc
     } <- startXMonadService
   (h, p) <- spawnPipe "xmobar"
-  powermonAction <- runPowermon
+  depActions <- sequence [runPowermon, runRemovableMon]
-  removableAction <- runRemovableMon
+  mapM_ (mapM_ forkIO) depActions
-  mapM_ forkIO powermonAction
-  mapM_ forkIO removableAction
   _ <- forkIO $ runWorkspaceMon allDWs
   let ts = ThreadState
         { client = cl
@@ -84,13 +82,12 @@ main = do
         , childHandles = [h]
         }
   ext <- evalExternal $ externalBindings bc sc ts
-  let ekbs = filterExternal ext
+  warnMissing $ externalToMissing ext ++ fmap (io <$>) depActions
-  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
     $ ewmh
-    $ addKeymap ekbs
+    $ addKeymap (filterExternal ext)
     $ def { terminal = myTerm
           , modMask = myModMask
           , layoutHook = myLayouts
@@ -507,9 +504,7 @@ flagKeyBinding k@KeyBinding{ kbDesc = d, kbAction = a } = case a of
   Missing _ _   -> Just $ k{ kbDesc = "[!!!]" ++  d, kbAction = skip }
   Ignore        -> Nothing
 
-externalBindings :: BrightnessControls
+externalBindings :: BrightnessControls -> SSControls -> ThreadState
-  -> MaybeExe SSControls
-  -> ThreadState
   -> [KeyGroup (IO MaybeX)]
 externalBindings bc sc ts =
   [ KeyGroup "Launchers"
@@ -571,7 +566,7 @@ externalBindings bc sc ts =
     , KeyBinding "M-<F8>" "select autorandr profile" runAutorandrMenu
     , KeyBinding "M-<F9>" "toggle ethernet" runToggleEthernet
     , KeyBinding "M-<F10>" "toggle bluetooth" runToggleBluetooth
-    , KeyBinding "M-<F11>" "toggle screensaver" $ return $ fmap (io . ssToggle) sc
+    , KeyBinding "M-<F11>" "toggle screensaver" $ return $ io <$> ssToggle sc
     , KeyBinding "M-<F12>" "switch gpu" runOptimusPrompt
     ]
   ]

lib/XMonad/Internal/DBus/Brightness/Common.hs

@@ -49,16 +49,15 @@ exportBrightnessControls :: RealFrac b => [Dependency] -> BrightnessConfig a b
   -> Client -> IO BrightnessControls
 exportBrightnessControls deps bc client = do
   (req, opt) <- checkInstalled deps
+  let callBacklight' = createInstalled req opt . callBacklight bc
   when (null req) $
     exportBrightnessControls' bc client
   return $ BrightnessControls
-    { bctlMax = callBacklight' req opt memMax
+    { bctlMax = callBacklight' memMax
-    , bctlMin = callBacklight' req opt memMin
+    , bctlMin = callBacklight' memMin
-    , bctlInc = callBacklight' req opt memInc
+    , bctlInc = callBacklight' memInc
-    , bctlDec = callBacklight' req opt memDec
+    , bctlDec = callBacklight' memDec
     }
-  where
-    callBacklight' r o = createInstalled r o . callBacklight bc
 
 callGetBrightness :: Num c => BrightnessConfig a b -> IO (Maybe c)
 callGetBrightness BrightnessConfig { bcPath = p, bcInterface = i } = do

lib/XMonad/Internal/DBus/Control.hs

@@ -33,7 +33,7 @@ data DBusXMonad = DBusXMonad
   { dxClient             :: Client
   , dxIntelBacklightCtrl :: BrightnessControls
   -- , dxClevoBacklightCtrl :: MaybeExe BrightnessControls
-  , dxScreensaverCtrl    :: MaybeExe SSControls
+  , dxScreensaverCtrl    :: SSControls
   }
 
 blankControls :: BrightnessControls
@@ -44,6 +44,9 @@ blankControls = BrightnessControls
   , bctlDec = Ignore
   }
 
+blankSSToggle :: SSControls
+blankSSToggle = SSControls { ssToggle = Ignore }
+
 startXMonadService :: IO DBusXMonad
 startXMonadService = do
   client <- connectSession
@@ -52,7 +55,7 @@ startXMonadService = do
   -- different
   (i, s) <- if requestResult /= NamePrimaryOwner then do
     putStrLn "Another service owns \"org.xmonad\""
-    return (blankControls, Ignore)
+    return (blankControls, blankSSToggle)
     else do
     putStrLn "Started xmonad dbus client"
     bc <- exportIntelBacklight client

lib/XMonad/Internal/DBus/Screensaver.hs

@@ -10,7 +10,7 @@ module XMonad.Internal.DBus.Screensaver
   , SSControls(..)
   ) where
 
-import           Control.Monad               (void)
+import           Control.Monad               (void, when)
 
 import           DBus
 import           DBus.Client
@@ -90,17 +90,16 @@ bodyGetCurrentState _   = Nothing
 --------------------------------------------------------------------------------
 -- | Exported haskell API
 
-newtype SSControls = SSControls { ssToggle :: IO () }
+newtype SSControls = SSControls { ssToggle :: MaybeExe (IO ()) }
 
-exportScreensaver :: Client -> IO (MaybeExe SSControls)
+exportScreensaver :: Client -> IO SSControls
 exportScreensaver client = do
-  d <- depInstalled $ depData dep
+  (req, opt) <- checkInstalled [exe "xset"]
-  if d then flip Installed [] <$> exportScreensaver' client
+  when (null req) $
-    else return $ Missing [depData dep] []
+    exportScreensaver' client
-  where
+  return $ SSControls { ssToggle = createInstalled req opt callToggle }
-    dep = exe "xset"
 
-exportScreensaver' :: Client -> IO SSControls
+exportScreensaver' :: Client -> IO ()
 exportScreensaver' client = do
   export client ssPath defaultInterface
     { interfaceName = interface
@@ -109,7 +108,6 @@ exportScreensaver' client = do
       , autoMethod memQuery query
       ]
     }
-  return $ SSControls { ssToggle = callToggle }
 
 callToggle :: IO ()
 callToggle = void $ callMethod $ methodCall ssPath interface memToggle

lib/XMonad/Internal/Dependency.hs

@@ -42,12 +42,12 @@ import           Control.Arrow           ((***))
 import           Control.Monad           (filterM, join)
 import           Control.Monad.IO.Class
 
-import           Data.List               (partition, find)
+import           Data.List               (find, partition)
-import           Data.Maybe              (isJust, listToMaybe, fromMaybe)
+import           Data.Maybe              (fromMaybe, isJust, listToMaybe)
 
 import           DBus
 import           DBus.Client
-import qualified DBus.Introspection as I
+import qualified DBus.Introspection      as I
 
 import           System.Directory        (findExecutable, readable, writable)
 import           System.Exit
@@ -71,11 +71,11 @@ data DBusMember = Method_ MemberName
 data DependencyData = Executable String
   | AccessiblePath FilePath Bool Bool
   | DBusEndpoint
-    { ddDbusBus:: BusName
+    { ddDbusBus       :: BusName
-    , ddDbusSystem :: Bool
+    , ddDbusSystem    :: Bool
-    , ddDbusObject :: ObjectPath
+    , ddDbusObject    :: ObjectPath
     , ddDbusInterface :: InterfaceName
-    , ddDbusMember :: DBusMember
+    , ddDbusMember    :: DBusMember
     }
   | Systemd UnitType String
   deriving (Eq, Show)
@@ -174,15 +174,18 @@ pathAccessible p testread testwrite = do
         -- (_, Just False)          -> Just "file not writable"
         -- _                        -> Nothing
 
+introspectInterface :: InterfaceName
+introspectInterface = interfaceName_ "org.freedesktop.DBus.Introspectable"
+
+introspectMethod :: MemberName
+introspectMethod = memberName_ "Introspect"
+
 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
+  reply <- call_ client (methodCall objpath introspectInterface introspectMethod)
-                         (interfaceName_ "org.freedesktop.DBus.Introspectable")
+           { methodCallDestination = Just bus }
-                         (memberName_ "Introspect"))
-           { methodCallDestination = Just bus
-           }
   let res = findMem =<< I.parseXML objpath =<< fromVariant
         =<< listToMaybe (methodReturnBody reply)
   disconnect client
@@ -218,7 +221,8 @@ createInstalled req opt x = if null req then Installed x opt else Missing req op
 filterMissing :: [Dependency] -> IO [Dependency]
 filterMissing = filterM (fmap not . depInstalled . depData)
 
-runIfInstalled :: MonadIO m => [Dependency] -> m a -> IO (MaybeExe (m a))
+-- runIfInstalled :: MonadIO m => [Dependency] -> m a -> IO (MaybeExe (m a))
+runIfInstalled :: [Dependency] -> a -> IO (MaybeExe a)
 runIfInstalled ds x = do
   (req, opt) <- checkInstalled ds
   return $ createInstalled req opt x

lib/Xmobar/Plugins/Bluetooth.hs

@@ -11,6 +11,8 @@ module Xmobar.Plugins.Bluetooth
   , btAlias
   , btBus
   , btPath
+  , btPowered
+  , btInterface
   ) where
 
 import           DBus
@@ -24,9 +26,17 @@ data Bluetooth = Bluetooth (String, String, String) Int
 
 callGetPowered :: Client -> IO (Either MethodError Variant)
 callGetPowered client =
-  getProperty client (methodCall btPath "org.bluez.Adapter1" "Powered")
+  getProperty client (methodCall btPath btInterface $ memberName_ btPowered)
     { methodCallDestination = Just btBus }
 
+btInterface :: InterfaceName
+btInterface = "org.bluez.Adapter1"
+
+-- weird that this is a string when introspecting but a member name when calling
+-- a method, not sure if it is supposed to work like that
+btPowered :: String
+btPowered = "Powered"
+
 btBus :: BusName
 btBus = "org.bluez"