ENH make a few more desktop dep trees more specific

This commit is contained in:
Nathan Dwarshuis 2022-07-07 19:20:21 -04:00
parent 3f4de9cf88
commit 8d495123dc
6 changed files with 92 additions and 72 deletions

View File

@ -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 =

View File

@ -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

View File

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

View File

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

View File

@ -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

View File

@ -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_ "/"