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) -- * Theme integration with xmonad (shared module imported below)
-- * A custom Locks plugin from my own forked repo -- * A custom Locks plugin from my own forked repo
import Data.Either
import Data.List import Data.List
import Data.Maybe import Data.Maybe
import DBus.Client import DBus.Client
import System.Directory
import System.Exit import System.Exit
import System.IO import System.IO
import System.IO.Error import System.IO.Error
@ -181,15 +179,13 @@ type BarFeature = Sometimes CmdSpec
-- TODO what if I don't have a wireless card? -- TODO what if I don't have a wireless card?
getWireless :: BarFeature getWireless :: BarFeature
getWireless = sometimes1 "wireless status indicator" "sysfs path" getWireless = sometimes1 "wireless status indicator" "sysfs path"
$ IORoot wirelessCmd $ IORoot wirelessCmd $ Only readWireless
$ Only $ readInterface "get wifi interface" isWireless
getEthernet :: Maybe Client -> BarFeature getEthernet :: Maybe Client -> BarFeature
getEthernet cl = iconDBus "ethernet status indicator" root tree getEthernet cl = iconDBus "ethernet status indicator" root tree
where where
root useIcon tree' = DBusRoot (const . ethernetCmd useIcon) tree' cl root useIcon tree' = DBusRoot (const . ethernetCmd useIcon) tree' cl
tree = And1 (Only readEth) (Only_ devDep) tree = And1 (Only readEthernet) (Only_ devDep)
readEth = readInterface "read ethernet interface" isEthernet
getBattery :: BarFeature getBattery :: BarFeature
getBattery = iconIO_ "battery level indicator" root tree getBattery = iconIO_ "battery level indicator" root tree
@ -389,35 +385,6 @@ dateCmd = CmdSpec
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | low-level testing functions -- | 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 :: IO (Maybe Msg)
vpnPresent = vpnPresent =

View File

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

View File

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

View File

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

View File

@ -65,6 +65,8 @@ module XMonad.Internal.Dependency
, fontTree_ , fontTree_
, fontAlways , fontAlways
, fontSometimes , fontSometimes
, readEthernet
, readWireless
-- lifting -- lifting
, ioSometimes , ioSometimes
@ -107,6 +109,7 @@ import Control.Monad.State
import Data.Aeson hiding (Error, Result) import Data.Aeson hiding (Error, Result)
import Data.Aeson.Key import Data.Aeson.Key
import Data.Bifunctor import Data.Bifunctor
import Data.Either
import qualified Data.HashMap.Strict as H import qualified Data.HashMap.Strict as H
import Data.Hashable import Data.Hashable
import Data.List import Data.List
@ -124,6 +127,7 @@ import System.Directory
import System.Environment import System.Environment
import System.Exit import System.Exit
import System.FilePath import System.FilePath
import System.IO.Error
import System.Posix.Files import System.Posix.Files
import XMonad.Core (X, io) import XMonad.Core (X, io)
@ -164,19 +168,24 @@ evalSometimes x = either goFail goPass =<< evalSometimesMsg x
where where
goPass (a, ws) = putErrors ws >> return (Just a) goPass (a, ws) = putErrors ws >> return (Just a)
goFail es = putErrors es >> return Nothing goFail es = putErrors es >> return Nothing
putErrors = io . mapM_ printMsg putErrors = mapM_ printMsg
-- | Return the action of an Always -- | Return the action of an Always
evalAlways :: Always a -> FIO a evalAlways :: Always a -> FIO a
evalAlways a = do evalAlways a = do
(x, ws) <- evalAlwaysMsg a (x, ws) <- evalAlwaysMsg a
io $ mapM_ printMsg ws mapM_ printMsg ws
return x return x
printMsg :: FMsg -> IO () printMsg :: FMsg -> FIO ()
printMsg (FMsg fn n (Msg ll m)) = do printMsg (FMsg fn n (Msg ll m)) = do
p <- getProgName xl <- asks xpLogLevel
putStrLn $ unwords [bracket p, bracket $ show ll, bracket fn, bracket n, m] p <- io getProgName
io $ when (ll >= xl) $ putStrLn $ unwords [ bracket p
, bracket $ show ll
, bracket fn
, bracket n, m
]
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Feature status -- | Feature status
@ -723,6 +732,43 @@ testFont' fam = maybe pass (Left . (:[])) <$> shellTest cmd msg
qFam = singleQuote fam qFam = singleQuote fam
pass = Right $ PostPass (buildFont $ Just 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 -- | DBus Dependency Testing

View File

@ -41,13 +41,14 @@ import Control.Monad
import Data.List import Data.List
import Data.List.Split import Data.List.Split
import qualified Data.Map as M import qualified Data.Map as M
import Data.Maybe import Data.Maybe
import DBus import DBus
import DBus.Client import DBus.Client
import DBus.Internal import DBus.Internal
import XMonad.Internal.DBus.Common
import XMonad.Internal.Dependency import XMonad.Internal.Dependency
import Xmobar import Xmobar
import Xmobar.Plugins.Common import Xmobar.Plugins.Common
@ -158,9 +159,6 @@ splitPath = splitOn "/" . dropWhile (=='/') . formatObjectPath
getBtObjectTree :: Client -> IO ObjectTree getBtObjectTree :: Client -> IO ObjectTree
getBtObjectTree client = callGetManagedObjects client btBus btOMPath getBtObjectTree client = callGetManagedObjects client btBus btOMPath
btBus :: BusName
btBus = busName_ "org.bluez"
btOMPath :: ObjectPath btOMPath :: ObjectPath
btOMPath = objectPath_ "/" btOMPath = objectPath_ "/"