ENH make a few more desktop dep trees more specific

bin/xmobar.hs

@@ -11,13 +11,11 @@ module Main (main) where
 -- * Theme integration with xmonad (shared module imported below)
 -- * A custom Locks plugin from my own forked repo
 
-import           Data.Either
 import           Data.List
 import           Data.Maybe
 
 import           DBus.Client
 
-import           System.Directory
 import           System.Exit
 import           System.IO
 import           System.IO.Error
@@ -181,15 +179,13 @@ type BarFeature = Sometimes CmdSpec
 -- TODO what if I don't have a wireless card?
 getWireless :: BarFeature
 getWireless = sometimes1 "wireless status indicator" "sysfs path"
-  $ IORoot wirelessCmd
-  $ Only $ readInterface "get wifi interface" isWireless
+  $ IORoot wirelessCmd $ Only readWireless
 
 getEthernet :: Maybe Client -> BarFeature
 getEthernet cl = iconDBus "ethernet status indicator" root tree
   where
     root useIcon tree' = DBusRoot (const . ethernetCmd useIcon) tree' cl
-    tree = And1 (Only readEth) (Only_ devDep)
-    readEth = readInterface "read ethernet interface" isEthernet
+    tree = And1 (Only readEthernet) (Only_ devDep)
 
 getBattery :: BarFeature
 getBattery = iconIO_ "battery level indicator" root tree
@@ -389,35 +385,6 @@ dateCmd = CmdSpec
 
 --------------------------------------------------------------------------------
 -- | low-level testing functions
---
--- 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"
-
-isWireless :: String -> Bool
-isWireless ('w':'l':_) = True
-isWireless _           = False
-
-isEthernet :: String -> Bool
-isEthernet ('e':'n':_) = True
-isEthernet _           = False
-
-listInterfaces :: IO [String]
-listInterfaces = fromRight [] <$> tryIOError (listDirectory sysfsNet)
-
-sysfsNet :: FilePath
-sysfsNet = "/sys/class/net"
-
-readInterface :: String -> (String -> Bool) -> IODependency String
-readInterface n f = IORead n go
-  where
-    go = io $ do
-      ns <- filter f <$> listInterfaces
-      case ns of
-        [] -> return $ Left [Msg Error "no interfaces found"]
-        (x:xs) -> do
-          return $ Right $ PostPass x
-            $ fmap (Msg Warn . ("ignoring extra interface: " ++)) xs
 
 vpnPresent :: IO (Maybe Msg)
 vpnPresent =

bin/xmonad.hs

@@ -678,14 +678,15 @@ externalBindings ts db =
     , KeyBinding "M-C-<F7>" "start Isync Timer" $ Left runStartISyncTimer
     , KeyBinding "M-<F8>" "select autorandr profile" $ Left runAutorandrMenu
     , KeyBinding "M-<F9>" "toggle ethernet" $ Left runToggleEthernet
-    , KeyBinding "M-<F10>" "toggle bluetooth" $ Left runToggleBluetooth
-    , KeyBinding "M-<F11>" "toggle screensaver" $ Left $ ioSometimes $ callToggle cl
+    , KeyBinding "M-<F10>" "toggle bluetooth" $ Left $ runToggleBluetooth sys
+    , KeyBinding "M-<F11>" "toggle screensaver" $ Left $ ioSometimes $ callToggle ses
     , KeyBinding "M-<F12>" "switch gpu" $ Left runOptimusPrompt
     ]
   ]
   where
-    cl = dbSesClient db
-    brightessControls ctl getter = (ioSometimes . getter . ctl) cl
+    ses = dbSesClient db
+    sys = dbSysClient db
+    brightessControls ctl getter = (ioSometimes . getter . ctl) ses
     ib = Left . brightessControls intelBacklightControls
     ck = Left . brightessControls clevoKeyboardControls
     ftrAlways n = Right . Always n . Always_ . FallbackAlone

lib/XMonad/Internal/Command/Desktop.hs

@@ -41,6 +41,8 @@ module XMonad.Internal.Command.Desktop
 import           Control.Monad               (void)
 import           Control.Monad.IO.Class
 
+import           DBus.Client
+
 import           System.Directory
     ( createDirectoryIfMissing
     , getHomeDirectory
@@ -51,6 +53,7 @@ import           System.FilePath
 import           XMonad                      (asks)
 import           XMonad.Actions.Volume
 import           XMonad.Core                 hiding (spawn)
+import           XMonad.Internal.DBus.Common
 import           XMonad.Internal.Dependency
 import           XMonad.Internal.Notify
 import           XMonad.Internal.Process
@@ -90,10 +93,6 @@ myNotificationCtrl = "dunstctl"
 volumeChangeSound :: FilePath
 volumeChangeSound = "smb_fireball.wav"
 
--- TODO make this dynamic (like in xmobar)
-ethernetIface :: String
-ethernetIface = "enp7s0f1"
-
 --------------------------------------------------------------------------------
 -- | Some nice apps
 
@@ -211,11 +210,12 @@ runNetAppDaemon = sometimesIO_ "network applet" "NM-applet" tree cmd
     tree = Only_ $ localExe "nm-applet"
     cmd = snd <$> spawnPipe "nm-applet"
 
--- TODO test that bluetooth dbus interface is up
-runToggleBluetooth :: SometimesX
-runToggleBluetooth =
-  sometimesIO_ "bluetooth toggle" "bluetoothctl" (Only_ $ sysExe myBluetooth)
-  $ spawn
+runToggleBluetooth :: Maybe Client -> SometimesX
+runToggleBluetooth cl =
+  sometimesDBus cl "bluetooth toggle" "bluetoothctl" tree cmd
+  where
+    tree = And_ (Only_ $ DBusIO $ sysExe myBluetooth) (Only_ $ Bus btBus)
+    cmd _ = spawn
       $ myBluetooth ++ " show | grep -q \"Powered: no\""
       #!&& "a=on"
       #!|| "a=off"
@@ -223,12 +223,15 @@ runToggleBluetooth =
       #!&& fmtNotifyCmd defNoteInfo { body = Just $ Text "bluetooth powered $a" }
 
 runToggleEthernet :: SometimesX
-runToggleEthernet = sometimesIO_ "ethernet toggle" "nmcli" (Only_ $ sysExe "nmcli")
-  $ spawn
-  $ "nmcli -g GENERAL.STATE device show " ++ ethernetIface ++ " | grep -q disconnected"
+runToggleEthernet = sometimes1 "ethernet toggle" "nmcli" $ IORoot (spawn . cmd) $
+  And1 (Only readEthernet) (Only_ $ sysExe "nmcli")
+  where
+    -- TODO make this less noisy
+    cmd iface =
+      "nmcli -g GENERAL.STATE device show " ++ iface ++ " | grep -q disconnected"
       #!&& "a=connect"
       #!|| "a=disconnect"
-  #!>> fmtCmd "nmcli" ["device", "$a", ethernetIface]
+      #!>> fmtCmd "nmcli" ["device", "$a", iface]
       #!&& fmtNotifyCmd defNoteInfo { body = Just $ Text "ethernet \"$a\"ed"  }
 
 runStartISyncTimer :: SometimesX

lib/XMonad/Internal/DBus/Common.hs

@@ -3,9 +3,14 @@
 
 module XMonad.Internal.DBus.Common
   ( xmonadBusName
+  , btBus
   ) where
 
 import           DBus
 
 xmonadBusName :: BusName
 xmonadBusName = busName_ "org.xmonad"
+
+btBus :: BusName
+btBus = busName_ "org.bluez"
+

lib/XMonad/Internal/Dependency.hs

@@ -65,6 +65,8 @@ module XMonad.Internal.Dependency
   , fontTree_
   , fontAlways
   , fontSometimes
+  , readEthernet
+  , readWireless
 
   -- lifting
   , ioSometimes
@@ -107,6 +109,7 @@ import           Control.Monad.State
 import           Data.Aeson              hiding (Error, Result)
 import           Data.Aeson.Key
 import           Data.Bifunctor
+import           Data.Either
 import qualified Data.HashMap.Strict     as H
 import           Data.Hashable
 import           Data.List
@@ -124,6 +127,7 @@ import           System.Directory
 import           System.Environment
 import           System.Exit
 import           System.FilePath
+import           System.IO.Error
 import           System.Posix.Files
 
 import           XMonad.Core             (X, io)
@@ -164,19 +168,24 @@ evalSometimes x = either goFail goPass =<< evalSometimesMsg x
   where
     goPass (a, ws) = putErrors ws >> return (Just a)
     goFail es = putErrors es >> return Nothing
-    putErrors = io . mapM_ printMsg
+    putErrors = mapM_ printMsg
 
 -- | Return the action of an Always
 evalAlways :: Always a -> FIO a
 evalAlways a = do
   (x, ws) <- evalAlwaysMsg a
-  io $ mapM_ printMsg ws
+  mapM_ printMsg ws
   return x
 
-printMsg :: FMsg -> IO ()
+printMsg :: FMsg -> FIO ()
 printMsg (FMsg fn n (Msg ll m)) = do
-  p <- getProgName
-  putStrLn $ unwords [bracket p, bracket $ show ll, bracket fn, bracket n, m]
+  xl <- asks xpLogLevel
+  p <- io getProgName
+  io $ when (ll >= xl) $ putStrLn $ unwords [ bracket p
+                                            , bracket $ show ll
+                                            , bracket fn
+                                            , bracket n, m
+                                            ]
 
 --------------------------------------------------------------------------------
 -- | Feature status
@@ -723,6 +732,43 @@ testFont' fam = maybe pass (Left . (:[])) <$> shellTest cmd msg
     qFam = singleQuote fam
     pass = Right $ PostPass (buildFont $ Just fam) []
 
+--------------------------------------------------------------------------------
+-- | network dependencies
+--
+-- ASSUME that the system uses systemd in which case ethernet interfaces always
+-- start with "en" and wireless interfaces always start with "wl"
+
+readEthernet :: IODependency String
+readEthernet = readInterface "get ethernet interface" isEthernet
+
+readWireless :: IODependency String
+readWireless = readInterface "get wireless interface" isWireless
+
+isWireless :: String -> Bool
+isWireless ('w':'l':_) = True
+isWireless _           = False
+
+isEthernet :: String -> Bool
+isEthernet ('e':'n':_) = True
+isEthernet _           = False
+
+listInterfaces :: IO [String]
+listInterfaces = fromRight [] <$> tryIOError (listDirectory sysfsNet)
+
+sysfsNet :: FilePath
+sysfsNet = "/sys/class/net"
+
+readInterface :: String -> (String -> Bool) -> IODependency String
+readInterface n f = IORead n go
+  where
+    go = io $ do
+      ns <- filter f <$> listInterfaces
+      case ns of
+        [] -> return $ Left [Msg Error "no interfaces found"]
+        (x:xs) -> do
+          return $ Right $ PostPass x
+            $ fmap (Msg Warn . ("ignoring extra interface: " ++)) xs
+
 --------------------------------------------------------------------------------
 -- | DBus Dependency Testing
 

lib/Xmobar/Plugins/Bluetooth.hs

@@ -48,6 +48,7 @@ import           DBus
 import           DBus.Client
 import           DBus.Internal
 
+import           XMonad.Internal.DBus.Common
 import           XMonad.Internal.Dependency
 import           Xmobar
 import           Xmobar.Plugins.Common
@@ -158,9 +159,6 @@ splitPath = splitOn "/" . dropWhile (=='/') . formatObjectPath
 getBtObjectTree :: Client -> IO ObjectTree
 getBtObjectTree client = callGetManagedObjects client btBus btOMPath
 
-btBus :: BusName
-btBus = busName_ "org.bluez"
-
 btOMPath :: ObjectPath
 btOMPath = objectPath_ "/"