ENH make better error messages for features

This commit is contained in:
Nathan Dwarshuis 2021-11-20 19:35:24 -05:00
parent b28279794c
commit 81830a8e96
12 changed files with 272 additions and 185 deletions

View File

@ -40,12 +40,9 @@ import XMonad.Hooks.DynamicLog
)
import XMonad.Internal.Command.Power (hasBattery)
import XMonad.Internal.DBus.Brightness.IntelBacklight
( curFileDep
, maxFileDep
)
-- import XMonad.Internal.DBus.Common (xmonadBus)
-- import XMonad.Internal.DBus.Control (pathExists)
import XMonad.Internal.DBus.Screensaver (ssDep)
import XMonad.Internal.DBus.Screensaver (ssSignalDep)
import XMonad.Internal.Dependency
-- import XMonad.Internal.Shell (fmtCmd)
import qualified XMonad.Internal.Theme as T
@ -226,20 +223,8 @@ dateCmd = CmdSpec
-- some commands depend on the presence of interfaces that can only be
-- determined at runtime; define these checks here
-- noSetup :: Monad m => a -> m (Maybe a)
-- noSetup = return . Just
-- toJust :: a -> Bool -> Maybe a
-- toJust x b = if b then Just x else Nothing
dbusDep :: Bool -> BusName -> ObjectPath -> InterfaceName -> DBusMember -> Dependency
dbusDep usesys bus obj iface mem = DBusEndpoint
{ ddDbusBus = bus
, ddDbusSystem = usesys
, ddDbusObject = obj
, ddDbusInterface = iface
, ddDbusMember = mem
}
dbusDep usesys bus obj iface mem = DBusEndpoint (Bus usesys bus) (Endpoint obj iface mem)
-- in the case of network interfaces, assume that the system uses systemd in
-- which case ethernet interfaces always start with "en" and wireless
@ -303,14 +288,15 @@ getWireless = do
getEthernet :: IO (MaybeExe CmdSpec)
getEthernet = do
i <- readInterface isEthernet
evalFeature $ maybe BlankFeature (featureRun [dep] . ethernetCmd) i
evalFeature $ maybe BlankFeature (featureRun "ethernet status indicator" [dep] . ethernetCmd) i
where
dep = dbusDep True devBus devPath devInterface $ Method_ devGetByIP
getBattery :: BarFeature
getBattery = Feature
{ ftrAction = batteryCmd
, ftrSilent = False
, ftrName = "battery level indicator"
, ftrWarning = Default
, ftrChildren = [IOTest hasBattery]
}
@ -319,7 +305,8 @@ type BarFeature = Feature CmdSpec
getVPN :: BarFeature
getVPN = Feature
{ ftrAction = vpnCmd
, ftrSilent = False
, ftrName = "VPN status indicator"
, ftrWarning = Default
, ftrChildren = [d, v]
}
where
@ -329,7 +316,8 @@ getVPN = Feature
getBt :: BarFeature
getBt = Feature
{ ftrAction = btCmd
, ftrSilent = False
, ftrName = "bluetooth status indicator"
, ftrWarning = Default
, ftrChildren = [dep]
}
where
@ -338,22 +326,25 @@ getBt = Feature
getAlsa :: BarFeature
getAlsa = Feature
{ ftrAction = alsaCmd
, ftrSilent = False
, ftrChildren = [exe "alsactl"]
, ftrName = "volume level indicator"
, ftrWarning = Default
, ftrChildren = [Executable "alsactl"]
}
getBl :: BarFeature
getBl = Feature
{ ftrAction = blCmd
, ftrSilent = False
, ftrChildren = [curFileDep, maxFileDep]
, ftrName = "Intel backlight indicator"
, ftrWarning = Default
, ftrChildren = [intelBacklightSignalDep]
}
getSs :: BarFeature
getSs = Feature
{ ftrAction = ssCmd
, ftrSilent = False
, ftrChildren = [ssDep]
, ftrName = "screensaver indicator"
, ftrWarning = Default
, ftrChildren = [ssSignalDep]
}
getAllCommands :: [MaybeExe CmdSpec] -> IO BarRegions

View File

@ -47,8 +47,8 @@ myDmenuNetworks = "networkmanager_dmenu"
--------------------------------------------------------------------------------
-- | Other internal functions
spawnDmenuCmd :: [String] -> FeatureX
spawnDmenuCmd = featureSpawnCmd myDmenuCmd
spawnDmenuCmd :: String -> [String] -> FeatureX
spawnDmenuCmd n = featureSpawnCmd n myDmenuCmd
themeArgs :: String -> [String]
themeArgs hexColor =
@ -63,7 +63,7 @@ myDmenuMatchingArgs = ["-i"] -- case insensitivity
-- | Exported Commands
runDevMenu :: FeatureX
runDevMenu = featureRun [exe myDmenuDevices] $ do
runDevMenu = featureRun "device manager" [Executable myDmenuDevices] $ do
c <- io $ getXdgDirectory XdgConfig "rofi/devices.yml"
spawnCmd myDmenuDevices
$ ["-c", c]
@ -71,7 +71,7 @@ runDevMenu = featureRun [exe myDmenuDevices] $ do
++ myDmenuMatchingArgs
runBwMenu :: FeatureX
runBwMenu = featureRun [exe myDmenuPasswords] $
runBwMenu = featureRun "password manager" [Executable myDmenuPasswords] $
spawnCmd myDmenuPasswords $ ["-c"] ++ themeArgs "#bb6600" ++ myDmenuMatchingArgs
-- TODO this is weirdly inverted
@ -83,7 +83,8 @@ runShowKeys x = addName "Show Keybindings" $ do
$ defNoteError { body = Just $ Text "could not display keymap" }
runDMenuShowKeys :: [((KeyMask, KeySym), NamedAction)] -> FeatureX
runDMenuShowKeys kbs = featureRun [exe myDmenuCmd] $ io $ do
runDMenuShowKeys kbs =
featureRun "keyboard shortcut menu" [Executable myDmenuCmd] $ io $ do
(h, _, _, _) <- createProcess' $ (shell' cmd) { std_in = CreatePipe }
forM_ h $ \h' -> hPutStr h' (unlines $ showKm kbs) >> hClose h'
where
@ -91,13 +92,14 @@ runDMenuShowKeys kbs = featureRun [exe myDmenuCmd] $ io $ do
++ themeArgs "#7f66ff" ++ myDmenuMatchingArgs
runCmdMenu :: FeatureX
runCmdMenu = spawnDmenuCmd ["-show", "run"]
runCmdMenu = spawnDmenuCmd "command menu" ["-show", "run"]
runAppMenu :: FeatureX
runAppMenu = spawnDmenuCmd ["-show", "drun"]
runAppMenu = spawnDmenuCmd "app launcher" ["-show", "drun"]
runClipMenu :: FeatureX
runClipMenu = featureRun [exe myDmenuCmd, exe "greenclip"]
runClipMenu =
featureRun "clipboard manager" [Executable myDmenuCmd, Executable "greenclip"]
$ spawnCmd myDmenuCmd args
where
args = [ "-modi", "\"clipboard:greenclip print\""
@ -106,10 +108,12 @@ runClipMenu = featureRun [exe myDmenuCmd, exe "greenclip"]
] ++ themeArgs "#00c44e"
runWinMenu :: FeatureX
runWinMenu = spawnDmenuCmd ["-show", "window"]
runWinMenu = spawnDmenuCmd "window switcher" ["-show", "window"]
runNetMenu :: FeatureX
runNetMenu = featureSpawnCmd myDmenuNetworks $ themeArgs "#ff3333"
runNetMenu =
featureSpawnCmd "network control menu" myDmenuNetworks $ themeArgs "#ff3333"
runAutorandrMenu :: FeatureX
runAutorandrMenu = featureSpawnCmd myDmenuMonitors $ themeArgs "#ff0066"
runAutorandrMenu =
featureSpawnCmd "autorandr menu" myDmenuMonitors $ themeArgs "#ff0066"

View File

@ -91,11 +91,12 @@ ethernetIface = "enp7s0f1"
-- | Some nice apps
runTerm :: FeatureX
runTerm = featureSpawn myTerm
runTerm = featureSpawn "terminal" myTerm
runTMux :: FeatureX
runTMux = featureRun [exe myTerm, exe "tmux", exe "bash"] cmd
runTMux = featureRun "terminal multiplexer" deps cmd
where
deps = [Executable myTerm, Executable "tmux", Executable "bash"]
cmd = spawn
$ "tmux has-session"
#!&& fmtCmd myTerm ["-e", "bash", "-c", singleQuote c]
@ -104,35 +105,37 @@ runTMux = featureRun [exe myTerm, exe "tmux", exe "bash"] cmd
msg = "could not connect to tmux session"
runCalc :: FeatureX
runCalc = featureRun [exe myTerm, exe "R"] $ spawnCmd myTerm ["-e", "R"]
runCalc = featureRun "calculator" [Executable myTerm, Executable "R"]
$ spawnCmd myTerm ["-e", "R"]
runBrowser :: FeatureX
runBrowser = featureSpawn myBrowser
runBrowser = featureSpawn "web browser" myBrowser
runEditor :: FeatureX
runEditor = featureSpawnCmd myEditor
runEditor = featureSpawnCmd "text editor" myEditor
["-c", "-e", doubleQuote "(select-frame-set-input-focus (selected-frame))"]
runFileManager :: FeatureX
runFileManager = featureSpawn "pcmanfm"
runFileManager = featureSpawn "file browser" "pcmanfm"
--------------------------------------------------------------------------------
-- | Multimedia Commands
runMultimediaIfInstalled :: String -> FeatureX
runMultimediaIfInstalled cmd = featureSpawnCmd myMultimediaCtl [cmd]
runMultimediaIfInstalled :: String -> String -> FeatureX
runMultimediaIfInstalled n cmd =
featureSpawnCmd (n ++ " multimedia control") myMultimediaCtl [cmd]
runTogglePlay :: FeatureX
runTogglePlay = runMultimediaIfInstalled "play-pause"
runTogglePlay = runMultimediaIfInstalled "play/pause" "play-pause"
runPrevTrack :: FeatureX
runPrevTrack = runMultimediaIfInstalled "previous"
runPrevTrack = runMultimediaIfInstalled "previous track" "previous"
runNextTrack :: FeatureX
runNextTrack = runMultimediaIfInstalled "next"
runNextTrack = runMultimediaIfInstalled "next track" "next"
runStopPlay :: FeatureX
runStopPlay = runMultimediaIfInstalled "stop"
runStopPlay = runMultimediaIfInstalled "stop playback" "stop"
--------------------------------------------------------------------------------
-- | Volume Commands
@ -146,42 +149,49 @@ playSound file = do
-- paplay seems to have less latency than aplay
spawnCmd "paplay" [p]
featureSound :: FilePath -> X () -> X () -> FeatureX
featureSound file pre post = featureRun [exe "paplay"]
featureSound :: String -> FilePath -> X () -> X () -> FeatureX
featureSound n file pre post =
featureRun ("volume " ++ n ++ " control") [Executable "paplay"]
$ pre >> playSound file >> post
runVolumeDown :: FeatureX
runVolumeDown = featureSound volumeChangeSound (return ()) $ void (lowerVolume 2)
runVolumeDown = featureSound "up" volumeChangeSound (return ()) $ void (lowerVolume 2)
runVolumeUp :: FeatureX
runVolumeUp = featureSound volumeChangeSound (return ()) $ void (raiseVolume 2)
runVolumeUp = featureSound "down" volumeChangeSound (return ()) $ void (raiseVolume 2)
runVolumeMute :: FeatureX
runVolumeMute = featureSound volumeChangeSound (void toggleMute) $ return ()
runVolumeMute = featureSound "mute" volumeChangeSound (void toggleMute) $ return ()
--------------------------------------------------------------------------------
-- | Notification control
runNotificationCmd :: String -> FeatureX
runNotificationCmd cmd = featureSpawnCmd myNotificationCtrl [cmd]
runNotificationCmd :: String -> String -> FeatureX
runNotificationCmd n cmd =
featureSpawnCmd (n ++ " control") myNotificationCtrl [cmd]
runNotificationClose :: FeatureX
runNotificationClose = runNotificationCmd "close"
runNotificationClose = runNotificationCmd "close notification" "close"
runNotificationCloseAll :: FeatureX
runNotificationCloseAll = runNotificationCmd "close-all"
runNotificationCloseAll =
runNotificationCmd "close all notifications" "close-all"
runNotificationHistory :: FeatureX
runNotificationHistory = runNotificationCmd "history-pop"
runNotificationHistory =
runNotificationCmd "see notification history" "history-pop"
runNotificationContext :: FeatureX
runNotificationContext = runNotificationCmd "context"
runNotificationContext =
runNotificationCmd "open notification context" "context"
--------------------------------------------------------------------------------
-- | System commands
runToggleBluetooth :: FeatureX
runToggleBluetooth = featureRun [exe myBluetooth] $ spawn
runToggleBluetooth =
featureRun "bluetooth toggle" [Executable myBluetooth]
$ spawn
$ myBluetooth ++ " show | grep -q \"Powered: no\""
#!&& "a=on"
#!|| "a=off"
@ -189,7 +199,8 @@ runToggleBluetooth = featureRun [exe myBluetooth] $ spawn
#!&& fmtNotifyCmd defNoteInfo { body = Just $ Text "bluetooth powered $a" }
runToggleEthernet :: FeatureX
runToggleEthernet = featureRun [exe "nmcli"] $ spawn
runToggleEthernet = featureRun "ethernet toggle" [Executable "nmcli"]
$ spawn
$ "nmcli -g GENERAL.STATE device show " ++ ethernetIface ++ " | grep -q disconnected"
#!&& "a=connect"
#!|| "a=disconnect"
@ -197,14 +208,14 @@ runToggleEthernet = featureRun [exe "nmcli"] $ spawn
#!&& fmtNotifyCmd defNoteInfo { body = Just $ Text "ethernet \"$a\"ed" }
runStartISyncTimer :: FeatureX
runStartISyncTimer = featureRun [userUnit "mbsync.timer"]
runStartISyncTimer = featureRun "isync timer" [userUnit "mbsync.timer"]
$ spawn
$ "systemctl --user start mbsync.timer"
#!&& fmtNotifyCmd defNoteInfo { body = Just $ Text "Isync timer started" }
#!|| fmtNotifyCmd defNoteError { body = Just $ Text "Isync timer failed to start" }
runStartISyncService :: FeatureX
runStartISyncService = featureRun [userUnit "mbsync.service"]
runStartISyncService = featureRun "isync" [userUnit "mbsync.service"]
$ spawn
$ "systemctl --user start mbsync.service"
#!&& fmtNotifyCmd defNoteInfo { body = Just $ Text "Isync completed" }
@ -248,25 +259,26 @@ getCaptureDir = do
where
fallback = (</> ".local/share") <$> getHomeDirectory
runFlameshot :: String -> FeatureX
runFlameshot mode = featureRun [exe myCapture] $ do
runFlameshot :: String -> String -> FeatureX
runFlameshot n mode = featureRun n [Executable myCapture] $ do
ssDir <- io getCaptureDir
spawnCmd myCapture $ mode : ["-p", ssDir]
-- TODO this will steal focus from the current window (and puts it
-- in the root window?) ...need to fix
runAreaCapture :: FeatureX
runAreaCapture = runFlameshot "gui"
runAreaCapture = runFlameshot "screen area capture" "gui"
-- myWindowCap = "screencap -w" --external script
runDesktopCapture :: FeatureX
runDesktopCapture = runFlameshot "full"
runDesktopCapture = runFlameshot "fullscreen capture" "full"
runScreenCapture :: FeatureX
runScreenCapture = runFlameshot "screen"
runScreenCapture = runFlameshot "screen capture" "screen"
runCaptureBrowser :: FeatureX
runCaptureBrowser = featureRun [exe myImageBrowser] $ do
runCaptureBrowser =
featureRun "screen capture browser" [Executable myImageBrowser] $ do
dir <- io getCaptureDir
spawnCmd myImageBrowser [dir]

View File

@ -46,11 +46,7 @@ myOptimusManager = "optimus-manager"
-- | Core commands
runScreenLock :: Feature (X ())
runScreenLock = Feature
{ ftrAction = spawn myScreenlock
, ftrSilent = False
, ftrChildren = [exe myScreenlock]
}
runScreenLock = featureSpawn "screen locker" myScreenlock
runPowerOff :: X ()
runPowerOff = spawn "systemctl poweroff"
@ -105,7 +101,8 @@ runOptimusPrompt' = do
#!&& "killall xmonad"
runOptimusPrompt :: FeatureX
runOptimusPrompt = featureRun [exe myOptimusManager] runOptimusPrompt'
runOptimusPrompt = featureRun "graphics switcher" [Executable myOptimusManager]
runOptimusPrompt'
--------------------------------------------------------------------------------
-- | Universal power prompt

View File

@ -95,7 +95,7 @@ acpiPath = "/var/run/acpid.socket"
-- | Spawn a new thread that will listen for ACPI events on the acpid socket
-- and send ClientMessage events when it receives them
runPowermon :: FeatureIO
runPowermon = featureRun [pathR acpiPath] listenACPI
runPowermon = featureRun "ACPI event monitor" [pathR acpiPath] listenACPI
-- | Handle ClientMessage event containing and ACPI event (to be used in
-- Xmonad's event hook)

View File

@ -34,13 +34,7 @@ memRemoved :: MemberName
memRemoved = memberName_ "InterfacesRemoved"
dbusDep :: MemberName -> Dependency
dbusDep m = DBusEndpoint
{ ddDbusBus = bus
, ddDbusSystem = True
, ddDbusObject = path
, ddDbusInterface = interface
, ddDbusMember = Signal_ m
}
dbusDep m = DBusEndpoint (Bus True bus) (Endpoint path interface $ Signal_ m)
addedDep :: Dependency
addedDep = dbusDep memAdded
@ -91,4 +85,5 @@ listenDevices = do
$ playSoundMaybe p . f . signalBody
runRemovableMon :: FeatureIO
runRemovableMon = featureRun [addedDep, removedDep] listenDevices
runRemovableMon =
featureRun "removeable device monitor" [addedDep, removedDep] listenDevices

View File

@ -8,6 +8,7 @@ module XMonad.Internal.DBus.Brightness.Common
, brightnessExporter
, callGetBrightness
, matchSignal
, signalDep
) where
import Control.Monad (void)
@ -16,6 +17,7 @@ import Data.Int (Int32)
import DBus
import DBus.Client
import qualified DBus.Introspection as I
import XMonad.Internal.DBus.Common
import XMonad.Internal.Dependency
@ -37,6 +39,7 @@ data BrightnessConfig a b = BrightnessConfig
, bcGetMax :: IO a
, bcPath :: ObjectPath
, bcInterface :: InterfaceName
, bcName :: String
}
data BrightnessControls = BrightnessControls
@ -47,25 +50,30 @@ data BrightnessControls = BrightnessControls
}
brightnessControls :: BrightnessConfig a b -> BrightnessControls
brightnessControls BrightnessConfig { bcPath = p, bcInterface = i } =
brightnessControls bc =
BrightnessControls
{ bctlMax = cb memMax
, bctlMin = cb memMin
, bctlInc = cb memInc
, bctlDec = cb memDec
{ bctlMax = cb "max brightness" memMax
, bctlMin = cb "min brightness" memMin
, bctlInc = cb "increase brightness" memInc
, bctlDec = cb "decrease brightness" memDec
}
where
cb = callBacklight p i
cb = callBacklight bc
callGetBrightness :: Num c => BrightnessConfig a b -> IO (Maybe c)
callGetBrightness BrightnessConfig { bcPath = p, bcInterface = i } = do
reply <- callMethod $ methodCall p i memGet
return $ reply >>= bodyGetBrightness
signalDep :: BrightnessConfig a b -> Dependency
signalDep BrightnessConfig { bcPath = p, bcInterface = i } =
DBusEndpoint xmonadBus $ Endpoint p i $ Signal_ memCur
matchSignal :: Num c => BrightnessConfig a b -> (Maybe c -> IO ()) -> IO SignalHandler
matchSignal BrightnessConfig { bcPath = p, bcInterface = i } cb = do
client <- connectSession
addMatch client brMatcher $ cb . bodyGetBrightness . signalBody
-- TODO disconnect here?
where
brMatcher = matchAny
{ matchPath = Just p
@ -78,10 +86,11 @@ matchSignal BrightnessConfig { bcPath = p, bcInterface = i } cb = do
brightnessExporter :: RealFrac b => [Dependency] -> BrightnessConfig a b
-> Client -> FeatureIO
brightnessExporter deps bc client = Feature
brightnessExporter deps bc@BrightnessConfig { bcName = n } client = Feature
{ ftrAction = exportBrightnessControls' bc client
, ftrSilent = False
, ftrChildren = deps
, ftrName = n ++ " exporter"
, ftrWarning = Default
, ftrChildren = DBusBus xmonadBus:deps
}
exportBrightnessControls' :: RealFrac b => BrightnessConfig a b -> Client -> IO ()
@ -98,7 +107,19 @@ exportBrightnessControls' bc client = do
, autoMethod' memDec bcDec
, autoMethod memGet (round <$> funget maxval :: IO Int32)
]
, interfaceSignals = [sig]
}
where
sig = I.Signal
{ I.signalName = memCur
, I.signalArgs =
[
I.SignalArg
{ I.signalArgName = "brightness"
, I.signalArgType = TypeInt32
}
]
}
emitBrightness :: RealFrac b => BrightnessConfig a b -> Client -> b -> IO ()
emitBrightness BrightnessConfig{ bcPath = p, bcInterface = i } client cur =
@ -106,11 +127,12 @@ emitBrightness BrightnessConfig{ bcPath = p, bcInterface = i } client cur =
where
sig = signal p i memCur
callBacklight :: ObjectPath -> InterfaceName -> MemberName -> FeatureIO
callBacklight p i m =
callBacklight :: BrightnessConfig a b -> String -> MemberName -> FeatureIO
callBacklight BrightnessConfig { bcPath = p, bcInterface = i, bcName = n } controlName m =
Feature
{ ftrAction = void $ callMethod $ methodCall p i m
, ftrSilent = False
, ftrName = unwords [n, controlName]
, ftrWarning = Default
, ftrChildren = [xDbusDep p i $ Method_ m]
}

View File

@ -6,8 +6,7 @@ module XMonad.Internal.DBus.Brightness.IntelBacklight
, matchSignalIB
, exportIntelBacklight
, intelBacklightControls
, curFileDep
, maxFileDep
, intelBacklightSignalDep
, blPath
) where
@ -78,6 +77,7 @@ intelBacklightConfig = BrightnessConfig
, bcGetMax = getMaxRawBrightness
, bcPath = blPath
, bcInterface = interface
, bcName = "Intel backlight"
}
--------------------------------------------------------------------------------
@ -89,6 +89,9 @@ curFileDep = pathRW curFile
maxFileDep :: Dependency
maxFileDep = pathR maxFile
intelBacklightSignalDep :: Dependency
intelBacklightSignalDep = signalDep intelBacklightConfig
exportIntelBacklight :: Client -> FeatureIO
exportIntelBacklight =
brightnessExporter [curFileDep, maxFileDep] intelBacklightConfig

View File

@ -6,8 +6,9 @@ module XMonad.Internal.DBus.Common
, callMethod'
, addMatchCallback
, xmonadBus
, xmonadBusName
, xDbusDep
, initControls
-- , initControls
) where
import DBus
@ -15,23 +16,22 @@ import DBus.Client
import XMonad.Internal.Dependency
xmonadBus :: BusName
xmonadBus = busName_ "org.xmonad"
xmonadBusName :: BusName
xmonadBusName = busName_ "org.xmonad"
xmonadBus :: Bus
xmonadBus = Bus False xmonadBusName
xDbusDep :: ObjectPath -> InterfaceName -> DBusMember -> Dependency
xDbusDep o i m = DBusEndpoint
{ ddDbusBus = xmonadBus
, ddDbusSystem = False
, ddDbusObject = o
, ddDbusInterface = i
, ddDbusMember = m
}
xDbusDep o i m = DBusEndpoint xmonadBus $ Endpoint o i m
-- connectBus :: Bus -> IO (Maybe Client)
-- | Call a method and return its result if successful
callMethod :: MethodCall -> IO (Maybe [Variant])
callMethod mc = do
client <- connectSession
r <- callMethod' client (Just xmonadBus) mc
r <- callMethod' client (Just xmonadBusName) mc
disconnect client
return r
@ -50,11 +50,11 @@ addMatchCallback rule cb = do
client <- connectSession
addMatch client rule $ cb . signalBody
initControls :: Client -> (Client -> FeatureIO) -> (FeatureIO -> a) -> IO a
initControls client exporter controls = do
let x = exporter client
e <- evalFeature x
case e of
(Right c) -> c
_ -> return ()
return $ controls x
-- initControls :: Client -> (Client -> FeatureIO) -> (FeatureIO -> a) -> IO a
-- initControls client exporter controls = do
-- let x = exporter client
-- e <- evalFeature x
-- case e of
-- (Right c) -> c
-- _ -> return ()
-- return $ controls x

View File

@ -19,7 +19,6 @@ import Data.Either
import DBus
import DBus.Client
-- import XMonad.Internal.DBus.Brightness.Common
import XMonad.Internal.DBus.Brightness.IntelBacklight
import XMonad.Internal.DBus.Common
import XMonad.Internal.DBus.Screensaver
@ -42,7 +41,7 @@ startXMonadService = do
stopXMonadService :: Client -> IO ()
stopXMonadService client = do
void $ releaseName client xmonadBus
void $ releaseName client xmonadBusName
disconnect client
getDBusClient :: IO (Maybe Client)
@ -54,7 +53,7 @@ getDBusClient = do
requestXMonadName :: Client -> IO ()
requestXMonadName client = do
res <- requestName client xmonadBus []
res <- requestName client xmonadBusName []
-- TODO if the client is not released on shutdown the owner will be
-- different
let msg | res == NamePrimaryOwner = Nothing
@ -64,7 +63,7 @@ requestXMonadName client = do
| otherwise = Just $ "unknown error when requesting " ++ xn
forM_ msg putStrLn
where
xn = "'" ++ formatBusName xmonadBus ++ "'"
xn = "'" ++ formatBusName xmonadBusName ++ "'"
pathExists :: Bool -> BusName -> ObjectPath -> IO Bool
pathExists sysbus n p = do

View File

@ -8,6 +8,7 @@ module XMonad.Internal.DBus.Screensaver
, matchSignal
, ssPath
, ssDep
, ssSignalDep
, SSControls(..)
) where
@ -15,6 +16,7 @@ import Control.Monad (void)
import DBus
import DBus.Client
import qualified DBus.Introspection as I
import Graphics.X11.XScreenSaver
import Graphics.X11.Xlib.Display
@ -34,6 +36,10 @@ ssExecutable = "xset"
ssDep :: Dependency
ssDep = Executable ssExecutable
ssSignalDep :: Dependency
ssSignalDep = DBusEndpoint xmonadBus $ Endpoint ssPath interface
$ Signal_ memState
toggle :: IO SSState
toggle = do
st <- query
@ -99,16 +105,12 @@ bodyGetCurrentState _ = Nothing
newtype SSControls = SSControls { ssToggle :: FeatureIO }
-- exportScreensaver :: Client -> IO SSControls
-- exportScreensaver client = initControls client exportScreensaver' controls
-- where
-- controls _ = SSControls { ssToggle = callToggle }
exportScreensaver :: Client -> FeatureIO
exportScreensaver client = Feature
{ ftrAction = cmd
, ftrSilent = False
, ftrChildren = [ssDep]
, ftrName = "screensaver interface"
, ftrWarning = Default
, ftrChildren = [ssDep, DBusBus xmonadBus]
}
where
cmd = export client ssPath defaultInterface
@ -117,12 +119,24 @@ exportScreensaver client = Feature
[ autoMethod memToggle $ emitState client =<< toggle
, autoMethod memQuery query
]
, interfaceSignals = [sig]
}
sig = I.Signal
{ I.signalName = memState
, I.signalArgs =
[
I.SignalArg
{ I.signalArgName = "enabled"
, I.signalArgType = TypeBoolean
}
]
}
callToggle :: FeatureIO
callToggle = Feature
{ ftrAction = cmd
, ftrSilent = False
, ftrName = "screensaver toggle"
, ftrWarning = Default
, ftrChildren = [xDbusDep ssPath interface $ Method_ memToggle]
}
where

View File

@ -5,14 +5,16 @@ module XMonad.Internal.Dependency
( MaybeExe
, UnitType(..)
, Dependency(..)
, Bus(..)
, Endpoint(..)
, DBusMember(..)
, Warning(..)
, MaybeX
, FeatureX
, FeatureIO
, Feature(..)
, ioFeature
, evalFeature
, exe
, systemUnit
, userUnit
, pathR
@ -34,14 +36,16 @@ module XMonad.Internal.Dependency
import Control.Monad.IO.Class
import Data.Bifunctor (bimap)
import Data.List (find)
import Data.Maybe (listToMaybe, maybeToList)
import Data.Maybe (catMaybes, fromMaybe, listToMaybe)
import DBus
import DBus.Client
import qualified DBus.Introspection as I
import System.Directory (findExecutable, readable, writable)
import System.Environment
import System.Exit
import XMonad.Core (X, io)
@ -59,21 +63,23 @@ data DBusMember = Method_ MemberName
| Property_ String
deriving (Eq, Show)
data Bus = Bus Bool BusName deriving (Eq, Show)
data Endpoint = Endpoint ObjectPath InterfaceName DBusMember deriving (Eq, Show)
data Dependency = Executable String
| AccessiblePath FilePath Bool Bool
| IOTest (IO (Maybe String))
| DBusEndpoint
{ ddDbusBus :: BusName
, ddDbusSystem :: Bool
, ddDbusObject :: ObjectPath
, ddDbusInterface :: InterfaceName
, ddDbusMember :: DBusMember
}
| DBusEndpoint Bus Endpoint
| DBusBus Bus
| Systemd UnitType String
data Warning = Silent | Default
data Feature a = Feature
{ ftrAction :: a
, ftrSilent :: Bool
, ftrName :: String
, ftrWarning :: Warning
, ftrChildren :: [Dependency]
}
| ConstFeature a
@ -91,16 +97,21 @@ ioFeature BlankFeature = BlankFeature
evalFeature :: Feature a -> IO (MaybeExe a)
evalFeature (ConstFeature x) = return $ Right x
evalFeature BlankFeature = return $ Left []
evalFeature Feature { ftrAction = a, ftrSilent = s, ftrChildren = c } = do
es <- mapM go c
return $ case concat es of
evalFeature Feature
{ ftrAction = a
, ftrName = n
, ftrWarning = w
, ftrChildren = c
} = do
procName <- getProgName
es <- catMaybes <$> mapM evalDependency c
return $ case es of
[] -> Right a
es' -> Left (if s then [] else es')
es' -> Left $ fmtWarnings procName es'
where
go = fmap maybeToList . depInstalled
exe :: String -> Dependency
exe = Executable
fmtWarnings procName es = case w of
Silent -> []
Default -> fmap (fmtMsg procName "WARNING" . ((n ++ " disabled; ") ++)) es
pathR :: String -> Dependency
pathR n = AccessiblePath n True False
@ -123,18 +134,19 @@ type MaybeExe a = Either [String] a
type MaybeX = MaybeExe (X ())
featureRun :: [Dependency] -> a -> Feature a
featureRun ds x = Feature
featureRun :: String -> [Dependency] -> a -> Feature a
featureRun n ds x = Feature
{ ftrAction = x
, ftrSilent = False
, ftrName = n
, ftrWarning = Default
, ftrChildren = ds
}
featureSpawnCmd :: MonadIO m => String -> [String] -> Feature (m ())
featureSpawnCmd cmd args = featureRun [exe cmd] $ spawnCmd cmd args
featureSpawnCmd :: MonadIO m => String -> String -> [String] -> Feature (m ())
featureSpawnCmd n cmd args = featureRun n [Executable cmd] $ spawnCmd cmd args
featureSpawn :: MonadIO m => String -> Feature (m ())
featureSpawn cmd = featureSpawnCmd cmd []
featureSpawn :: MonadIO m => String -> String -> Feature (m ())
featureSpawn n cmd = featureSpawnCmd n cmd []
exeInstalled :: String -> IO (Maybe String)
exeInstalled x = do
@ -177,37 +189,69 @@ introspectInterface = interfaceName_ "org.freedesktop.DBus.Introspectable"
introspectMethod :: MemberName
introspectMethod = memberName_ "Introspect"
dbusInstalled :: BusName -> Bool -> ObjectPath -> InterfaceName -> DBusMember
-> IO (Maybe String)
dbusInstalled bus usesystem objpath iface mem = do
client <- if usesystem then connectSystem else connectSession
reply <- call_ client (methodCall objpath introspectInterface introspectMethod)
callMethod :: Bus -> ObjectPath -> InterfaceName -> MemberName -> IO (Either String [Variant])
callMethod (Bus usesys bus) path iface mem = do
client <- if usesys then connectSystem else connectSession
reply <- call client (methodCall path iface mem)
{ methodCallDestination = Just bus }
let res = findMem =<< I.parseXML objpath =<< fromVariant
=<< listToMaybe (methodReturnBody reply)
disconnect client
return $ case res of
Just _ -> Nothing
_ -> Just "some random dbus interface not found"
where
findMem obj = fmap (matchMem mem)
$ find (\i -> I.interfaceName i == iface)
$ I.objectInterfaces obj
matchMem (Method_ n) = elem n . fmap I.methodName . I.interfaceMethods
matchMem (Signal_ n) = elem n . fmap I.signalName . I.interfaceSignals
matchMem (Property_ n) = elem n . fmap I.propertyName . I.interfaceProperties
return $ bimap methodErrorMessage methodReturnBody reply
depInstalled :: Dependency -> IO (Maybe String)
depInstalled (Executable n) = exeInstalled n
depInstalled (IOTest t) = t
depInstalled (Systemd t n) = unitInstalled t n
depInstalled (AccessiblePath p r w) = pathAccessible p r w
depInstalled DBusEndpoint { ddDbusBus = b
, ddDbusSystem = s
, ddDbusObject = o
, ddDbusInterface = i
, ddDbusMember = m
} = dbusInstalled b s o i m
dbusBusExists :: Bus -> IO (Maybe String)
dbusBusExists (Bus usesystem bus) = do
ret <- callMethod (Bus usesystem queryBus) queryPath queryIface queryMem
return $ case ret of
Left e -> Just e
Right b -> let ns = bodyGetNames b in
if bus' `elem` ns then Nothing
else Just $ unwords ["name", singleQuote bus', "not found on dbus"]
where
bus' = formatBusName bus
queryBus = busName_ "org.freedesktop.DBus"
queryIface = interfaceName_ "org.freedesktop.DBus"
queryPath = objectPath_ "/"
queryMem = memberName_ "ListNames"
bodyGetNames [v] = fromMaybe [] $ fromVariant v :: [String]
bodyGetNames _ = []
dbusEndpointExists :: Bus -> Endpoint -> IO (Maybe String)
dbusEndpointExists b@(Bus _ bus) (Endpoint objpath iface mem) = do
ret <- callMethod b objpath introspectInterface introspectMethod
return $ case ret of
Left e -> Just e
Right body -> procBody body
where
procBody body = let res = findMem =<< I.parseXML objpath =<< fromVariant
=<< listToMaybe body in
case res of
Just True -> Nothing
_ -> Just $ fmtMsg' mem
findMem = fmap (matchMem mem)
. find (\i -> I.interfaceName i == iface)
. I.objectInterfaces
matchMem (Method_ n) = elemMember n I.methodName I.interfaceMethods
matchMem (Signal_ n) = elemMember n I.signalName I.interfaceSignals
matchMem (Property_ n) = elemMember n I.propertyName I.interfaceProperties
elemMember n fname fmember = elem n . fmap fname . fmember
fmtMem (Method_ n) = "method " ++ singleQuote (formatMemberName n)
fmtMem (Signal_ n) = "signal " ++ singleQuote (formatMemberName n)
fmtMem (Property_ n) = "property " ++ singleQuote n
fmtMsg' m = unwords
[ "could not find"
, fmtMem m
, "on interface"
, singleQuote $ formatInterfaceName iface
, "on bus"
, formatBusName bus
]
evalDependency :: Dependency -> IO (Maybe String)
evalDependency (Executable n) = exeInstalled n
evalDependency (IOTest t) = t
evalDependency (Systemd t n) = unitInstalled t n
evalDependency (AccessiblePath p r w) = pathAccessible p r w
evalDependency (DBusEndpoint b e) = dbusEndpointExists b e
evalDependency (DBusBus b) = dbusBusExists b
whenInstalled :: Monad m => MaybeExe (m ()) -> m ()
whenInstalled = flip ifInstalled skip
@ -217,7 +261,7 @@ ifInstalled (Right x) _ = x
ifInstalled _ alt = alt
warnMissing :: [MaybeExe a] -> IO ()
warnMissing xs = warnMissing' $ fmap ("[WARNING] "++) $ concat $ [ m | (Left m) <- xs ]
warnMissing xs = warnMissing' $ concat $ [ m | (Left m) <- xs ]
warnMissing' :: [String] -> IO ()
warnMissing' = mapM_ putStrLn
@ -235,3 +279,9 @@ executeFeature = applyFeature id
executeFeature_ :: Feature (IO ()) -> IO ()
executeFeature_ = executeFeature ()
fmtMsg :: String -> String -> String -> String
fmtMsg procName level msg = unwords [bracket procName, bracket level, msg]
where
bracket s = "[" ++ s ++ "]"