From 8d495123dcd86243606c012d4a4ec675d02407a9 Mon Sep 17 00:00:00 2001 From: ndwarshuis Date: Thu, 7 Jul 2022 19:20:21 -0400 Subject: [PATCH] ENH make a few more desktop dep trees more specific --- bin/xmobar.hs | 37 +---------------- bin/xmonad.hs | 9 +++-- lib/XMonad/Internal/Command/Desktop.hs | 51 ++++++++++++----------- lib/XMonad/Internal/DBus/Common.hs | 5 +++ lib/XMonad/Internal/Dependency.hs | 56 +++++++++++++++++++++++--- lib/Xmobar/Plugins/Bluetooth.hs | 6 +-- 6 files changed, 92 insertions(+), 72 deletions(-) diff --git a/bin/xmobar.hs b/bin/xmobar.hs index 47d04a8..26fa57f 100644 --- a/bin/xmobar.hs +++ b/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 = diff --git a/bin/xmonad.hs b/bin/xmonad.hs index 99318a1..7ab21a4 100644 --- a/bin/xmonad.hs +++ b/bin/xmonad.hs @@ -678,14 +678,15 @@ externalBindings ts db = , KeyBinding "M-C-" "start Isync Timer" $ Left runStartISyncTimer , KeyBinding "M-" "select autorandr profile" $ Left runAutorandrMenu , KeyBinding "M-" "toggle ethernet" $ Left runToggleEthernet - , KeyBinding "M-" "toggle bluetooth" $ Left runToggleBluetooth - , KeyBinding "M-" "toggle screensaver" $ Left $ ioSometimes $ callToggle cl + , KeyBinding "M-" "toggle bluetooth" $ Left $ runToggleBluetooth sys + , KeyBinding "M-" "toggle screensaver" $ Left $ ioSometimes $ callToggle ses , KeyBinding "M-" "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 diff --git a/lib/XMonad/Internal/Command/Desktop.hs b/lib/XMonad/Internal/Command/Desktop.hs index a2160dd..850426b 100644 --- a/lib/XMonad/Internal/Command/Desktop.hs +++ b/lib/XMonad/Internal/Command/Desktop.hs @@ -38,9 +38,11 @@ module XMonad.Internal.Command.Desktop , runNetAppDaemon ) where -import Control.Monad (void) +import Control.Monad (void) import Control.Monad.IO.Class +import DBus.Client + import System.Directory ( createDirectoryIfMissing , getHomeDirectory @@ -48,9 +50,10 @@ import System.Directory import System.Environment import System.FilePath -import XMonad (asks) +import XMonad (asks) import XMonad.Actions.Volume -import XMonad.Core hiding (spawn) +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,25 +210,29 @@ 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 - $ myBluetooth ++ " show | grep -q \"Powered: no\"" - #!&& "a=on" - #!|| "a=off" - #!>> fmtCmd myBluetooth ["power", "$a", ">", "/dev/null"] - #!&& fmtNotifyCmd defNoteInfo { body = Just $ Text "bluetooth powered $a" } +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" + #!>> fmtCmd myBluetooth ["power", "$a", ">", "/dev/null"] + #!&& 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" - #!&& "a=connect" - #!|| "a=disconnect" - #!>> fmtCmd "nmcli" ["device", "$a", ethernetIface] - #!&& fmtNotifyCmd defNoteInfo { body = Just $ Text "ethernet \"$a\"ed" } +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", iface] + #!&& fmtNotifyCmd defNoteInfo { body = Just $ Text "ethernet \"$a\"ed" } runStartISyncTimer :: SometimesX runStartISyncTimer = sometimesIO_ "isync timer" "mbsync timer" diff --git a/lib/XMonad/Internal/DBus/Common.hs b/lib/XMonad/Internal/DBus/Common.hs index f4d707c..dd137b2 100644 --- a/lib/XMonad/Internal/DBus/Common.hs +++ b/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" + diff --git a/lib/XMonad/Internal/Dependency.hs b/lib/XMonad/Internal/Dependency.hs index fa270b6..fb7c8f3 100644 --- a/lib/XMonad/Internal/Dependency.hs +++ b/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 diff --git a/lib/Xmobar/Plugins/Bluetooth.hs b/lib/Xmobar/Plugins/Bluetooth.hs index 2b0d6db..be1e24c 100644 --- a/lib/Xmobar/Plugins/Bluetooth.hs +++ b/lib/Xmobar/Plugins/Bluetooth.hs @@ -41,13 +41,14 @@ import Control.Monad import Data.List import Data.List.Split -import qualified Data.Map as M +import qualified Data.Map as M import Data.Maybe 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_ "/"