ENH make a few more desktop dep trees more specific
This commit is contained in:
parent
3f4de9cf88
commit
8d495123dc
|
@ -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 =
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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"
|
||||||
|
|
|
@ -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"
|
||||||
|
|
||||||
|
|
|
@ -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
|
||||||
|
|
||||||
|
|
|
@ -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_ "/"
|
||||||
|
|
||||||
|
|
Loading…
Reference in New Issue