ADD package annotations for dependencies
This commit is contained in:
parent
c8109a9e66
commit
b8b058c78c
|
|
@ -34,7 +34,8 @@ import XMonad.Core
|
|||
, io
|
||||
)
|
||||
import XMonad.Hooks.DynamicLog (wrap)
|
||||
import XMonad.Internal.Command.Power (hasBattery)
|
||||
import XMonad.Internal.Command.Desktop
|
||||
import XMonad.Internal.Command.Power
|
||||
import XMonad.Internal.DBus.Brightness.ClevoKeyboard
|
||||
import XMonad.Internal.DBus.Brightness.IntelBacklight
|
||||
import XMonad.Internal.DBus.Control
|
||||
|
|
@ -75,7 +76,7 @@ evalConfig db = do
|
|||
|
||||
-- | The text font family
|
||||
textFont :: Always T.FontBuilder
|
||||
textFont = fontAlways "XMobar Text Font" "DejaVu Sans Mono"
|
||||
textFont = fontAlways "XMobar Text Font" "DejaVu Sans Mono" defFontPkgs
|
||||
|
||||
-- | Offset of the text in the bar
|
||||
textFontOffset :: Int
|
||||
|
|
@ -88,6 +89,7 @@ textFontData = T.defFontData { T.weight = Just T.Bold, T.size = Just 11 }
|
|||
-- | The icon font family
|
||||
iconFont :: Sometimes T.FontBuilder
|
||||
iconFont = fontSometimes "XMobar Icon Font" "Symbols Nerd Font"
|
||||
[Package True "ttf-nerd-fonts-symbols"]
|
||||
|
||||
-- | Offsets for the icons in the bar (relative to the text offset)
|
||||
iconOffset :: BarFont -> Int
|
||||
|
|
@ -191,20 +193,22 @@ getBattery :: BarFeature
|
|||
getBattery = iconIO_ "battery level indicator" xpfBattery root tree
|
||||
where
|
||||
root useIcon = IORoot_ (batteryCmd useIcon)
|
||||
tree = Only_ $ IOTest_ "Test if battery is present" $ fmap (Msg Error) <$> hasBattery
|
||||
tree = Only_ $ IOTest_ "Test if battery is present" []
|
||||
$ fmap (Msg Error) <$> hasBattery
|
||||
|
||||
getVPN :: Maybe Client -> BarFeature
|
||||
getVPN cl = iconDBus_ "VPN status indicator" xpfVPN root $ toAnd_ vpnDep test
|
||||
where
|
||||
root useIcon tree = DBusRoot_ (const $ vpnCmd useIcon) tree cl
|
||||
test = DBusIO $ IOTest_ "Use nmcli to test if VPN is present" vpnPresent
|
||||
test = DBusIO $ IOTest_ "Use nmcli to test if VPN is present"
|
||||
networkManagerPkgs vpnPresent
|
||||
|
||||
getBt :: Maybe Client -> BarFeature
|
||||
getBt = xmobarDBus "bluetooth status indicator" xpfBluetooth btDep btCmd
|
||||
|
||||
getAlsa :: BarFeature
|
||||
getAlsa = iconIO_ "volume level indicator" (const True) root
|
||||
$ Only_ $ sysExe "alsactl"
|
||||
$ Only_ $ sysExe [Package True "alsa-utils"] "alsactl"
|
||||
where
|
||||
root useIcon = IORoot_ (alsaCmd useIcon)
|
||||
|
||||
|
|
|
|||
|
|
@ -104,7 +104,7 @@ tabbedFeature :: Always Theme
|
|||
tabbedFeature = Always "theme for tabbed windows" $ Option sf fallback
|
||||
where
|
||||
sf = Subfeature niceTheme "theme with nice font"
|
||||
niceTheme = IORoot T.tabbedTheme $ fontTree T.defFontFamily
|
||||
niceTheme = IORoot T.tabbedTheme $ fontTree T.defFontFamily defFontPkgs
|
||||
fallback = Always_ $ FallbackAlone $ T.tabbedTheme T.fallbackFont
|
||||
|
||||
features :: Maybe Client -> FeatureSet
|
||||
|
|
@ -236,7 +236,7 @@ f5Tag = "F5VPN"
|
|||
gimpDynamicWorkspace :: Sometimes DynWorkspace
|
||||
gimpDynamicWorkspace = sometimesIO_ "gimp workspace" "gimp" tree dw
|
||||
where
|
||||
tree = Only_ $ sysExe "gimp"
|
||||
tree = Only_ $ sysExe [Package True "gimp"] "gimp"
|
||||
dw = DynWorkspace
|
||||
{ dwName = "Gimp"
|
||||
, dwTag = gimpTag
|
||||
|
|
@ -258,8 +258,8 @@ vmDynamicWorkspace :: Sometimes DynWorkspace
|
|||
vmDynamicWorkspace = Sometimes "virtualbox workspace" xpfVirtualBox
|
||||
[Subfeature root "windows 8 VM"]
|
||||
where
|
||||
root = IORoot_ dw $ toAnd_ (sysExe "VBoxManage")
|
||||
$ IOTest_ name $ vmExists vm
|
||||
root = IORoot_ dw $ toAnd_ (sysExe [Package True "virtualbox"] "VBoxManage")
|
||||
$ IOTest_ name [] $ vmExists vm
|
||||
name = unwords ["test if", vm, "exists"]
|
||||
c = "VirtualBoxVM"
|
||||
vm = "win8raw"
|
||||
|
|
@ -276,7 +276,7 @@ xsaneDynamicWorkspace :: Sometimes DynWorkspace
|
|||
xsaneDynamicWorkspace = Sometimes "scanner workspace" xpfXSANE
|
||||
[Subfeature (IORoot_ dw tree) "xsane"]
|
||||
where
|
||||
tree = Only_ $ sysExe "xsane"
|
||||
tree = Only_ $ sysExe [Package True "xsane"] "xsane"
|
||||
dw = DynWorkspace
|
||||
{ dwName = "XSane"
|
||||
, dwTag = xsaneTag
|
||||
|
|
@ -290,7 +290,7 @@ xsaneDynamicWorkspace = Sometimes "scanner workspace" xpfXSANE
|
|||
f5vpnDynamicWorkspace :: Sometimes DynWorkspace
|
||||
f5vpnDynamicWorkspace = sometimesIO_ "F5 VPN workspace" "f5vpn" tree dw
|
||||
where
|
||||
tree = Only_ $ sysExe "f5vpn"
|
||||
tree = Only_ $ sysExe [Package False "f5vpn"] "f5vpn"
|
||||
dw = DynWorkspace
|
||||
{ dwName = "F5Vpn"
|
||||
, dwTag = f5Tag
|
||||
|
|
@ -666,8 +666,6 @@ externalBindings ts db =
|
|||
-- M-<F1> reserved for showing the keymap
|
||||
, KeyBinding "M-<F2>" "restart xmonad" restartf
|
||||
, KeyBinding "M-<F3>" "recompile xmonad" recompilef
|
||||
, KeyBinding "M-<F7>" "start Isync Service" $ Left runStartISyncService
|
||||
, 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 sys
|
||||
|
|
|
|||
|
|
@ -29,6 +29,7 @@ import System.Directory
|
|||
import System.IO
|
||||
|
||||
import XMonad.Core hiding (spawn)
|
||||
import XMonad.Internal.Command.Desktop
|
||||
import XMonad.Internal.DBus.Common
|
||||
import XMonad.Internal.Dependency
|
||||
import XMonad.Internal.Notify
|
||||
|
|
@ -63,11 +64,21 @@ myDmenuNetworks = "networkmanager_dmenu"
|
|||
myClipboardManager :: String
|
||||
myClipboardManager = "greenclip"
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- | Packages
|
||||
|
||||
dmenuPkgs :: [Fulfillment]
|
||||
dmenuPkgs = [Package True "rofi"]
|
||||
|
||||
clipboardPkgs :: [Fulfillment]
|
||||
clipboardPkgs = [Package False "rofi-greenclip"]
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- | Other internal functions
|
||||
|
||||
spawnDmenuCmd :: String -> [String] -> SometimesX
|
||||
spawnDmenuCmd n = sometimesExeArgs n "rofi preset" True myDmenuCmd
|
||||
spawnDmenuCmd n =
|
||||
sometimesExeArgs n "rofi preset" dmenuPkgs True myDmenuCmd
|
||||
|
||||
themeArgs :: String -> [String]
|
||||
themeArgs hexColor =
|
||||
|
|
@ -78,6 +89,12 @@ themeArgs hexColor =
|
|||
myDmenuMatchingArgs :: [String]
|
||||
myDmenuMatchingArgs = ["-i"] -- case insensitivity
|
||||
|
||||
dmenuTree :: IOTree_ -> IOTree_
|
||||
dmenuTree = And_ $ Only_ dmenuDep
|
||||
|
||||
dmenuDep :: IODependency_
|
||||
dmenuDep = sysExe dmenuPkgs myDmenuCmd
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- | Exported Commands
|
||||
|
||||
|
|
@ -85,7 +102,7 @@ myDmenuMatchingArgs = ["-i"] -- case insensitivity
|
|||
runDevMenu :: SometimesX
|
||||
runDevMenu = sometimesIO_ "device manager" "rofi devices" t x
|
||||
where
|
||||
t = Only_ $ localExe myDmenuDevices
|
||||
t = dmenuTree $ Only_ (localExe [] myDmenuDevices)
|
||||
x = do
|
||||
c <- io $ getXdgDirectory XdgConfig "rofi/devices.yml"
|
||||
spawnCmd myDmenuDevices
|
||||
|
|
@ -99,7 +116,7 @@ runBTMenu = Sometimes "bluetooth selector" xpfBluetooth
|
|||
[Subfeature (IORoot_ cmd tree) "rofi bluetooth"]
|
||||
where
|
||||
cmd = spawnCmd myDmenuBluetooth $ "-c":themeArgs "#0044bb"
|
||||
tree = Only_ $ sysExe myDmenuBluetooth
|
||||
tree = dmenuTree $ Only_ $ sysExe [] myDmenuBluetooth
|
||||
|
||||
runVPNMenu :: SometimesX
|
||||
runVPNMenu = Sometimes "VPN selector" xpfVPN
|
||||
|
|
@ -107,7 +124,8 @@ runVPNMenu = Sometimes "VPN selector" xpfVPN
|
|||
where
|
||||
cmd = spawnCmd myDmenuVPN
|
||||
$ ["-c"] ++ themeArgs "#007766" ++ myDmenuMatchingArgs
|
||||
tree = toAnd_ (localExe myDmenuVPN) $ socketExists "expressVPN"
|
||||
tree = dmenuTree $ toAnd_ (localExe [] myDmenuVPN)
|
||||
$ socketExists "expressVPN" []
|
||||
$ return "/var/lib/expressvpn/expressvpnd.socket"
|
||||
|
||||
runCmdMenu :: SometimesX
|
||||
|
|
@ -124,11 +142,15 @@ runNetMenu cl =
|
|||
sometimesDBus cl "network control menu" "rofi NetworkManager" tree cmd
|
||||
where
|
||||
cmd _ = spawnCmd myDmenuNetworks $ themeArgs "#ff3333"
|
||||
tree = toAnd_ (DBusIO $ localExe myDmenuNetworks) $ Bus networkManagerBus
|
||||
tree = And_ (Only_ $ Bus networkManagerPkgs networkManagerBus)
|
||||
$ toAnd_ (DBusIO dmenuDep) $ DBusIO
|
||||
$ sysExe [Package False "networkmanager-dmenu-git"] myDmenuNetworks
|
||||
|
||||
runAutorandrMenu :: SometimesX
|
||||
runAutorandrMenu = sometimesExeArgs "autorandr menu" "rofi autorandr"
|
||||
True myDmenuMonitors $ themeArgs "#ff0066"
|
||||
runAutorandrMenu = sometimesIO_ "autorandr menu" "rofi autorandr" tree cmd
|
||||
where
|
||||
cmd = spawnCmd myDmenuMonitors $ themeArgs "#ff0066"
|
||||
tree = dmenuTree $ Only_ $ localExe [] myDmenuMonitors
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- | Password manager
|
||||
|
|
@ -138,8 +160,8 @@ runBwMenu cl = sometimesDBus cl "password manager" "rofi bitwarden" tree cmd
|
|||
where
|
||||
cmd _ = spawnCmd myDmenuPasswords
|
||||
$ ["-c"] ++ themeArgs "#bb6600" ++ myDmenuMatchingArgs
|
||||
tree = toAnd_ (DBusIO $ localExe myDmenuPasswords)
|
||||
$ Bus $ busName_ "org.rofi.bitwarden"
|
||||
tree = And_ (Only_ $ Bus [] $ busName_ "org.rofi.bitwarden")
|
||||
$ toAnd_ (DBusIO dmenuDep) (DBusIO $ localExe [] myDmenuPasswords)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- | Clipboard
|
||||
|
|
@ -148,8 +170,9 @@ runClipMenu :: SometimesX
|
|||
runClipMenu = sometimesIO_ "clipboard manager" "rofi greenclip" tree act
|
||||
where
|
||||
act = spawnCmd myDmenuCmd args
|
||||
tree = listToAnds (process myClipboardManager)
|
||||
$ sysExe <$> [myDmenuCmd, myClipboardManager]
|
||||
tree = listToAnds dmenuDep [ sysExe clipboardPkgs myClipboardManager
|
||||
, process [] myClipboardManager
|
||||
]
|
||||
args = [ "-modi", "\"clipboard:greenclip print\""
|
||||
, "-show", "clipboard"
|
||||
, "-run-command", "'{cmd}'"
|
||||
|
|
@ -169,7 +192,7 @@ runShowKeys = Always "keyboard menu" $ Option showKeysDMenu $ Always_
|
|||
showKeysDMenu :: SubfeatureRoot ([((KeyMask, KeySym), NamedAction)] -> X ())
|
||||
showKeysDMenu = Subfeature
|
||||
{ sfName = "keyboard shortcut menu"
|
||||
, sfData = IORoot_ showKeys $ Only_ $ sysExe myDmenuCmd
|
||||
, sfData = IORoot_ showKeys $ Only_ dmenuDep
|
||||
}
|
||||
|
||||
showKeys :: [((KeyMask, KeySym), NamedAction)] -> X ()
|
||||
|
|
|
|||
|
|
@ -27,8 +27,6 @@ module XMonad.Internal.Command.Desktop
|
|||
, runScreenCapture
|
||||
, runDesktopCapture
|
||||
, runCaptureBrowser
|
||||
, runStartISyncTimer
|
||||
, runStartISyncService
|
||||
, runNotificationClose
|
||||
, runNotificationCloseAll
|
||||
, runNotificationHistory
|
||||
|
|
@ -36,6 +34,9 @@ module XMonad.Internal.Command.Desktop
|
|||
|
||||
-- daemons
|
||||
, runNetAppDaemon
|
||||
|
||||
-- packages
|
||||
, networkManagerPkgs
|
||||
) where
|
||||
|
||||
import Control.Monad (void)
|
||||
|
|
@ -65,6 +66,9 @@ import XMonad.Operations
|
|||
myTerm :: String
|
||||
myTerm = "urxvt"
|
||||
|
||||
myCalc :: String
|
||||
myCalc = "bc"
|
||||
|
||||
myBrowser :: String
|
||||
myBrowser = "brave-accel"
|
||||
|
||||
|
|
@ -89,6 +93,26 @@ myImageBrowser = "feh"
|
|||
myNotificationCtrl :: String
|
||||
myNotificationCtrl = "dunstctl"
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- | Packages
|
||||
|
||||
myTermPkgs :: [Fulfillment]
|
||||
myTermPkgs = [ Package True "rxvt-unicode"
|
||||
, Package True "urxvt-perls"
|
||||
]
|
||||
|
||||
myEditorPkgs :: [Fulfillment]
|
||||
myEditorPkgs = [Package True "emacs-nativecomp"]
|
||||
|
||||
notifyPkgs :: [Fulfillment]
|
||||
notifyPkgs = [Package True "dunst"]
|
||||
|
||||
bluetoothPkgs :: [Fulfillment]
|
||||
bluetoothPkgs = [Package True "bluez-utils"]
|
||||
|
||||
networkManagerPkgs :: [Fulfillment]
|
||||
networkManagerPkgs = [Package True "networkmanager"]
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- | Misc constants
|
||||
|
||||
|
|
@ -99,13 +123,13 @@ volumeChangeSound = "smb_fireball.wav"
|
|||
-- | Some nice apps
|
||||
|
||||
runTerm :: SometimesX
|
||||
runTerm = sometimesExe "terminal" "urxvt" True myTerm
|
||||
runTerm = sometimesExe "terminal" "urxvt" myTermPkgs True myTerm
|
||||
|
||||
runTMux :: SometimesX
|
||||
runTMux = sometimesIO_ "terminal multiplexer" "tmux" deps act
|
||||
where
|
||||
deps = listToAnds (socketExists "tmux" socketName)
|
||||
$ fmap sysExe [myTerm, "tmux", "bash"]
|
||||
deps = listToAnds (socketExists "tmux" [] socketName)
|
||||
$ fmap (sysExe myTermPkgs) [myTerm, "tmux", "bash"]
|
||||
act = spawn
|
||||
$ "tmux has-session"
|
||||
#!&& fmtCmd myTerm ["-e", "bash", "-c", singleQuote c]
|
||||
|
|
@ -120,30 +144,32 @@ runTMux = sometimesIO_ "terminal multiplexer" "tmux" deps act
|
|||
runCalc :: SometimesX
|
||||
runCalc = sometimesIO_ "calculator" "R" deps act
|
||||
where
|
||||
deps = toAnd_ (sysExe myTerm) (sysExe "R")
|
||||
act = spawnCmd myTerm ["-e", "R"]
|
||||
deps = toAnd_ (sysExe myTermPkgs myTerm) (sysExe [Package True "bc"] myCalc)
|
||||
act = spawnCmd myTerm ["-e", myCalc, "-l"]
|
||||
|
||||
runBrowser :: SometimesX
|
||||
runBrowser = sometimesExe "web browser" "brave" False myBrowser
|
||||
runBrowser = sometimesExe "web browser" "brave" [Package False "brave-bin"]
|
||||
False myBrowser
|
||||
|
||||
runEditor :: SometimesX
|
||||
runEditor = sometimesIO_ "text editor" "emacs" tree cmd
|
||||
where
|
||||
cmd = spawnCmd myEditor
|
||||
["-c", "-e", doubleQuote "(select-frame-set-input-focus (selected-frame))"]
|
||||
-- NOTE we could test if the emacs socket exists, but it won't come up
|
||||
-- NOTE 1: we could test if the emacs socket exists, but it won't come up
|
||||
-- before xmonad starts, so just check to see if the process has started
|
||||
tree = toAnd_ (sysExe myEditor) $ process myEditorServer
|
||||
tree = toAnd_ (sysExe myEditorPkgs myEditor) $ process [] myEditorServer
|
||||
|
||||
runFileManager :: SometimesX
|
||||
runFileManager = sometimesExe "file browser" "pcmanfm" True "pcmanfm"
|
||||
runFileManager = sometimesExe "file browser" "pcmanfm" [Package True "pcmanfm"]
|
||||
True "pcmanfm"
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- | Multimedia Commands
|
||||
|
||||
runMultimediaIfInstalled :: String -> String -> SometimesX
|
||||
runMultimediaIfInstalled n cmd = sometimesExeArgs (n ++ " multimedia control")
|
||||
"playerctl" True myMultimediaCtl [cmd]
|
||||
"playerctl" [Package True "playerctl"] True myMultimediaCtl [cmd]
|
||||
|
||||
runTogglePlay :: SometimesX
|
||||
runTogglePlay = runMultimediaIfInstalled "play/pause" "play-pause"
|
||||
|
|
@ -172,8 +198,10 @@ playSound file = do
|
|||
|
||||
featureSound :: String -> FilePath -> X () -> X () -> SometimesX
|
||||
featureSound n file pre post =
|
||||
sometimesIO_ ("volume " ++ n ++ " control") "paplay" (Only_ $ sysExe "paplay")
|
||||
sometimesIO_ ("volume " ++ n ++ " control") "paplay" tree
|
||||
$ pre >> playSound file >> post
|
||||
where
|
||||
tree = Only_ $ sysExe [Package True "libpulse"] "paplay"
|
||||
|
||||
runVolumeDown :: SometimesX
|
||||
runVolumeDown = featureSound "up" volumeChangeSound (return ()) $ void (lowerVolume 2)
|
||||
|
|
@ -192,8 +220,8 @@ runNotificationCmd n arg cl =
|
|||
sometimesDBus cl (n ++ " control") "dunstctl" tree cmd
|
||||
where
|
||||
cmd _ = spawnCmd myNotificationCtrl [arg]
|
||||
tree = toAnd_ (DBusIO $ sysExe myNotificationCtrl)
|
||||
$ Endpoint notifyBus notifyPath (interfaceName_ "org.dunstproject.cmd0")
|
||||
tree = toAnd_ (DBusIO $ sysExe notifyPkgs myNotificationCtrl)
|
||||
$ Endpoint [] notifyBus notifyPath (interfaceName_ "org.dunstproject.cmd0")
|
||||
$ Method_ $ memberName_ "NotificationAction"
|
||||
|
||||
runNotificationClose :: Maybe Client -> SometimesX
|
||||
|
|
@ -219,14 +247,15 @@ runNetAppDaemon :: Maybe Client -> Sometimes (IO ProcessHandle)
|
|||
runNetAppDaemon cl = Sometimes "network applet" xpfVPN
|
||||
[Subfeature (DBusRoot_ cmd tree cl) "NM-applet"]
|
||||
where
|
||||
tree = toAnd_ (DBusIO $ localExe "nm-applet") $ Bus networkManagerBus
|
||||
tree = toAnd_ app $ Bus networkManagerPkgs networkManagerBus
|
||||
app = DBusIO $ sysExe [Package True "network-manager-applet"] "nm-applet"
|
||||
cmd _ = snd <$> spawnPipe "nm-applet"
|
||||
|
||||
runToggleBluetooth :: Maybe Client -> SometimesX
|
||||
runToggleBluetooth cl = Sometimes "bluetooth toggle" xpfBluetooth
|
||||
[Subfeature (DBusRoot_ cmd tree cl) "bluetoothctl"]
|
||||
where
|
||||
tree = And_ (Only_ $ DBusIO $ sysExe myBluetooth) (Only_ $ Bus btBus)
|
||||
tree = And_ (Only_ $ DBusIO $ sysExe bluetoothPkgs myBluetooth) (Only_ $ Bus [] btBus)
|
||||
cmd _ = spawn
|
||||
$ myBluetooth ++ " show | grep -q \"Powered: no\""
|
||||
#!&& "a=on"
|
||||
|
|
@ -236,7 +265,7 @@ runToggleBluetooth cl = Sometimes "bluetooth toggle" xpfBluetooth
|
|||
|
||||
runToggleEthernet :: SometimesX
|
||||
runToggleEthernet = sometimes1 "ethernet toggle" "nmcli" $ IORoot (spawn . cmd) $
|
||||
And1 (Only readEthernet) (Only_ $ sysExe "nmcli")
|
||||
And1 (Only readEthernet) (Only_ $ sysExe networkManagerPkgs "nmcli")
|
||||
where
|
||||
-- TODO make this less noisy
|
||||
cmd iface =
|
||||
|
|
@ -246,22 +275,6 @@ runToggleEthernet = sometimes1 "ethernet toggle" "nmcli" $ IORoot (spawn . cmd)
|
|||
#!>> fmtCmd "nmcli" ["device", "$a", iface]
|
||||
#!&& fmtNotifyCmd defNoteInfo { body = Just $ Text "ethernet \"$a\"ed" }
|
||||
|
||||
runStartISyncTimer :: SometimesX
|
||||
runStartISyncTimer = sometimesIO_ "isync timer" "mbsync timer"
|
||||
(Only_ $ sysdUser "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 :: SometimesX
|
||||
runStartISyncService = sometimesIO_ "isync" "mbsync service"
|
||||
(Only_ $ sysdUser "mbsync.service")
|
||||
$ spawn
|
||||
$ "systemctl --user start mbsync.service"
|
||||
#!&& fmtNotifyCmd defNoteInfo { body = Just $ Text "Isync completed" }
|
||||
#!|| fmtNotifyCmd defNoteError { body = Just $ Text "Isync failed" }
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- | Configuration commands
|
||||
|
||||
|
|
@ -297,7 +310,8 @@ runFlameshot :: String -> String -> Maybe Client -> SometimesX
|
|||
runFlameshot n mode cl = sometimesDBus cl n myCapture tree cmd
|
||||
where
|
||||
cmd _ = spawnCmd myCapture [mode]
|
||||
tree = toAnd_ (DBusIO $ sysExe myCapture) $ Bus $ busName_ "org.flameshot.Flameshot"
|
||||
tree = toAnd_ (DBusIO $ sysExe [Package True "flameshot"] myCapture)
|
||||
$ Bus [] $ busName_ "org.flameshot.Flameshot"
|
||||
|
||||
-- TODO this will steal focus from the current window (and puts it
|
||||
-- in the root window?) ...need to fix
|
||||
|
|
@ -314,6 +328,6 @@ runScreenCapture = runFlameshot "screen capture" "screen"
|
|||
|
||||
runCaptureBrowser :: SometimesX
|
||||
runCaptureBrowser = sometimesIO_ "screen capture browser" "feh"
|
||||
(Only_ $ sysExe myImageBrowser) $ do
|
||||
(Only_ $ sysExe [Package True "feh"] myImageBrowser) $ do
|
||||
dir <- io getCaptureDir
|
||||
spawnCmd myImageBrowser [dir]
|
||||
|
|
|
|||
|
|
@ -21,6 +21,8 @@ module XMonad.Internal.Command.Power
|
|||
, suspendPrompt
|
||||
, quitPrompt
|
||||
, powerPrompt
|
||||
, defFontPkgs
|
||||
, promptFontDep
|
||||
) where
|
||||
|
||||
import Control.Arrow (first)
|
||||
|
|
@ -56,11 +58,18 @@ myOptimusManager = "optimus-manager"
|
|||
myPrimeOffload :: String
|
||||
myPrimeOffload = "prime-offload"
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- | Packages
|
||||
|
||||
optimusPackages :: [Fulfillment]
|
||||
optimusPackages = [Package False "optimus-manager"]
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- | Core commands
|
||||
|
||||
runScreenLock :: SometimesX
|
||||
runScreenLock = sometimesExe "screen locker" "i3lock script" False myScreenlock
|
||||
runScreenLock = sometimesExe "screen locker" "i3lock script"
|
||||
[Package False "i3lock-color"] False myScreenlock
|
||||
|
||||
runPowerOff :: X ()
|
||||
runPowerOff = spawn "systemctl poweroff"
|
||||
|
|
@ -80,12 +89,19 @@ runReboot = spawn "systemctl reboot"
|
|||
runAutolock :: Sometimes (IO ProcessHandle)
|
||||
runAutolock = sometimesIO_ "automatic screen lock" "xss-lock" tree cmd
|
||||
where
|
||||
tree = And_ (Only_ $ sysExe "xss-lock") (Only_ $ IOSometimes_ runScreenLock)
|
||||
tree = And_ (Only_ $ sysExe [Package True "xss-lock"] "xss-lock")
|
||||
$ Only_ $ IOSometimes_ runScreenLock
|
||||
cmd = snd <$> spawnPipeArgs "xss-lock" ["--ignore-sleep", "screenlock"]
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- | Confirmation prompts
|
||||
|
||||
promptFontDep :: IOTree T.FontBuilder
|
||||
promptFontDep = fontTreeAlt T.defFontFamily defFontPkgs
|
||||
|
||||
defFontPkgs :: [Fulfillment]
|
||||
defFontPkgs = [Package True "ttf-dejavu"]
|
||||
|
||||
confirmPrompt' :: String -> X () -> T.FontBuilder -> X ()
|
||||
confirmPrompt' s x fb = confirmPrompt (T.promptTheme fb) s x
|
||||
|
||||
|
|
@ -96,7 +112,7 @@ quitPrompt :: T.FontBuilder -> X ()
|
|||
quitPrompt = confirmPrompt' "quit?" $ io exitSuccess
|
||||
|
||||
sometimesPrompt :: String -> (T.FontBuilder -> X ()) -> SometimesX
|
||||
sometimesPrompt n = sometimesIO n (n ++ " command") $ fontTreeAlt T.defFontFamily
|
||||
sometimesPrompt n = sometimesIO n (n ++ " command") promptFontDep
|
||||
|
||||
-- TODO doesn't this need to also lock the screen?
|
||||
runSuspendPrompt :: SometimesX
|
||||
|
|
@ -141,9 +157,9 @@ runOptimusPrompt = Sometimes "graphics switcher"
|
|||
where
|
||||
s = Subfeature { sfData = r, sfName = "optimus manager" }
|
||||
r = IORoot runOptimusPrompt' t
|
||||
t = And1 (fontTreeAlt T.defFontFamily)
|
||||
$ listToAnds (socketExists "optimus-manager" socketName) $ sysExe
|
||||
<$> [myOptimusManager, myPrimeOffload]
|
||||
t = And1 promptFontDep
|
||||
$ listToAnds (socketExists "optimus-manager" [] socketName)
|
||||
$ sysExe optimusPackages <$> [myOptimusManager, myPrimeOffload]
|
||||
socketName = (</> "optimus-manager") <$> getTemporaryDirectory
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
|
@ -177,7 +193,7 @@ runPowerPrompt = Sometimes "power prompt" (const True) [sf]
|
|||
where
|
||||
sf = Subfeature withLock "prompt with lock"
|
||||
withLock = IORoot (uncurry powerPrompt) tree
|
||||
tree = And12 (,) lockTree (fontTreeAlt T.defFontFamily)
|
||||
tree = And12 (,) lockTree promptFontDep
|
||||
lockTree = Or (Only $ IOSometimes runScreenLock id) (Only $ IOConst skip)
|
||||
|
||||
powerPrompt :: X () -> T.FontBuilder -> X ()
|
||||
|
|
|
|||
|
|
@ -26,10 +26,7 @@ import XMonad.Internal.Command.Power
|
|||
import XMonad.Internal.Concurrent.ClientMessage
|
||||
import XMonad.Internal.Dependency
|
||||
import XMonad.Internal.Shell
|
||||
import XMonad.Internal.Theme
|
||||
( FontBuilder
|
||||
, defFontFamily
|
||||
)
|
||||
import XMonad.Internal.Theme (FontBuilder)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- | Data structure to hold the ACPI events I care about
|
||||
|
|
@ -94,7 +91,7 @@ acpiPath :: FilePath
|
|||
acpiPath = "/var/run/acpid.socket"
|
||||
|
||||
socketDep :: IOTree_
|
||||
socketDep = Only_ $ pathR acpiPath
|
||||
socketDep = Only_ $ pathR acpiPath [Package True "acpid"]
|
||||
|
||||
-- | Handle ClientMessage event containing and ACPI event (to be used in
|
||||
-- Xmonad's event hook)
|
||||
|
|
@ -123,6 +120,6 @@ runHandleACPI = Always "ACPI event handler" $ Option sf fallback
|
|||
where
|
||||
sf = Subfeature withLock "acpid prompt"
|
||||
withLock = IORoot (uncurry handleACPI)
|
||||
$ And12 (,) (fontTreeAlt defFontFamily) $ Only
|
||||
$ And12 (,) promptFontDep $ Only
|
||||
$ IOSometimes runScreenLock id
|
||||
fallback = Always_ $ FallbackAlone $ const skip
|
||||
|
|
|
|||
|
|
@ -108,16 +108,16 @@ clevoKeyboardConfig = BrightnessConfig
|
|||
-- | Exported haskell API
|
||||
|
||||
stateFileDep :: IODependency_
|
||||
stateFileDep = pathRW stateFile
|
||||
stateFileDep = pathRW stateFile [Package True "tuxedo-keyboard"]
|
||||
|
||||
brightnessFileDep :: IODependency_
|
||||
brightnessFileDep = pathR brightnessFile
|
||||
brightnessFileDep = pathR brightnessFile [Package True "tuxedo-keyboard"]
|
||||
|
||||
clevoKeyboardSignalDep :: DBusDependency_
|
||||
clevoKeyboardSignalDep = signalDep clevoKeyboardConfig
|
||||
|
||||
exportClevoKeyboard :: Maybe Client -> SometimesIO
|
||||
exportClevoKeyboard = brightnessExporter xpfClevoBacklight
|
||||
exportClevoKeyboard = brightnessExporter xpfClevoBacklight []
|
||||
[stateFileDep, brightnessFileDep] clevoKeyboardConfig
|
||||
|
||||
clevoKeyboardControls :: Maybe Client -> BrightnessControls
|
||||
|
|
|
|||
|
|
@ -71,7 +71,7 @@ callGetBrightness BrightnessConfig { bcPath = p, bcInterface = i } client =
|
|||
|
||||
signalDep :: BrightnessConfig a b -> DBusDependency_
|
||||
signalDep BrightnessConfig { bcPath = p, bcInterface = i } =
|
||||
Endpoint xmonadBusName p i $ Signal_ memCur
|
||||
Endpoint [] xmonadBusName p i $ Signal_ memCur
|
||||
|
||||
matchSignal :: Num c => BrightnessConfig a b -> (Maybe c -> IO ()) -> Client -> IO ()
|
||||
matchSignal BrightnessConfig { bcPath = p, bcInterface = i } cb =
|
||||
|
|
@ -87,13 +87,13 @@ matchSignal BrightnessConfig { bcPath = p, bcInterface = i } cb =
|
|||
--------------------------------------------------------------------------------
|
||||
-- | Internal DBus Crap
|
||||
|
||||
brightnessExporter :: RealFrac b => XPQuery -> [IODependency_]
|
||||
brightnessExporter :: RealFrac b => XPQuery -> [Fulfillment] -> [IODependency_]
|
||||
-> BrightnessConfig a b -> Maybe Client -> SometimesIO
|
||||
brightnessExporter q deps bc@BrightnessConfig { bcName = n } cl =
|
||||
brightnessExporter q ful deps bc@BrightnessConfig { bcName = n } cl =
|
||||
Sometimes (n ++ " DBus Interface") q [Subfeature root "exporter"]
|
||||
where
|
||||
root = DBusRoot_ (exportBrightnessControls' bc) tree cl
|
||||
tree = listToAnds (Bus xmonadBusName) $ fmap DBusIO deps
|
||||
tree = listToAnds (Bus ful xmonadBusName) $ fmap DBusIO deps
|
||||
|
||||
exportBrightnessControls' :: RealFrac b => BrightnessConfig a b -> Client -> IO ()
|
||||
exportBrightnessControls' bc client = do
|
||||
|
|
@ -137,7 +137,7 @@ callBacklight q cl BrightnessConfig { bcPath = p
|
|||
, bcName = n } controlName m =
|
||||
Sometimes (unwords [n, controlName]) q [Subfeature root "method call"]
|
||||
where
|
||||
root = DBusRoot_ cmd (Only_ $ Endpoint xmonadBusName p i $ Method_ m) cl
|
||||
root = DBusRoot_ cmd (Only_ $ Endpoint [] xmonadBusName p i $ Method_ m) cl
|
||||
cmd c = io $ void $ callMethod c xmonadBusName p i m
|
||||
|
||||
bodyGetBrightness :: Num a => [Variant] -> Maybe a
|
||||
|
|
|
|||
|
|
@ -90,16 +90,16 @@ intelBacklightConfig = BrightnessConfig
|
|||
-- | Exported haskell API
|
||||
|
||||
curFileDep :: IODependency_
|
||||
curFileDep = pathRW curFile
|
||||
curFileDep = pathRW curFile []
|
||||
|
||||
maxFileDep :: IODependency_
|
||||
maxFileDep = pathR maxFile
|
||||
maxFileDep = pathR maxFile []
|
||||
|
||||
intelBacklightSignalDep :: DBusDependency_
|
||||
intelBacklightSignalDep = signalDep intelBacklightConfig
|
||||
|
||||
exportIntelBacklight :: Maybe Client -> SometimesIO
|
||||
exportIntelBacklight = brightnessExporter xpfIntelBacklight
|
||||
exportIntelBacklight = brightnessExporter xpfIntelBacklight []
|
||||
[curFileDep, maxFileDep] intelBacklightConfig
|
||||
|
||||
intelBacklightControls :: Maybe Client -> BrightnessControls
|
||||
|
|
|
|||
|
|
@ -33,7 +33,7 @@ memRemoved :: MemberName
|
|||
memRemoved = memberName_ "InterfacesRemoved"
|
||||
|
||||
dbusDep :: MemberName -> DBusDependency_
|
||||
dbusDep m = Endpoint bus path interface $ Signal_ m
|
||||
dbusDep m = Endpoint [Package True "udisks2"] bus path interface $ Signal_ m
|
||||
|
||||
addedDep :: DBusDependency_
|
||||
addedDep = dbusDep memAdded
|
||||
|
|
|
|||
|
|
@ -116,12 +116,12 @@ exportScreensaver client =
|
|||
}
|
||||
]
|
||||
}
|
||||
bus = Bus xmonadBusName
|
||||
ssx = DBusIO $ sysExe ssExecutable
|
||||
bus = Bus [] xmonadBusName
|
||||
ssx = DBusIO $ sysExe [Package True "xorg-xset"] ssExecutable
|
||||
|
||||
callToggle :: Maybe Client -> SometimesIO
|
||||
callToggle = sometimesEndpoint "screensaver toggle" "dbus switch" xmonadBusName
|
||||
ssPath interface memToggle
|
||||
callToggle = sometimesEndpoint "screensaver toggle" "dbus switch" []
|
||||
xmonadBusName ssPath interface memToggle
|
||||
|
||||
callQuery :: Client -> IO (Maybe SSState)
|
||||
callQuery client = do
|
||||
|
|
@ -133,4 +133,4 @@ matchSignal cb =
|
|||
fmap void . addMatchCallback ruleCurrentState $ cb . bodyGetCurrentState
|
||||
|
||||
ssSignalDep :: DBusDependency_
|
||||
ssSignalDep = Endpoint xmonadBusName ssPath interface $ Signal_ memState
|
||||
ssSignalDep = Endpoint [] xmonadBusName ssPath interface $ Signal_ memState
|
||||
|
|
|
|||
|
|
@ -47,6 +47,7 @@ module XMonad.Internal.Dependency
|
|||
, DBusMember(..)
|
||||
, UnitType(..)
|
||||
, Result
|
||||
, Fulfillment(..)
|
||||
|
||||
-- dumping
|
||||
, dumpFeature
|
||||
|
|
@ -314,7 +315,7 @@ type DBusTree_ = Tree_ DBusDependency_
|
|||
-- | A dependency that only requires IO to evaluate (with payload)
|
||||
data IODependency p =
|
||||
-- a cachable IO action that yields a payload
|
||||
IORead String (FIO (Result p))
|
||||
IORead String [Fulfillment] (FIO (Result p))
|
||||
-- always yields a payload
|
||||
| IOConst p
|
||||
-- an always that yields a payload
|
||||
|
|
@ -323,33 +324,37 @@ data IODependency p =
|
|||
| forall a. IOSometimes (Sometimes a) (a -> p)
|
||||
|
||||
-- | A dependency pertaining to the DBus
|
||||
data DBusDependency_ = Bus BusName
|
||||
| Endpoint BusName ObjectPath InterfaceName DBusMember
|
||||
data DBusDependency_ = Bus [Fulfillment] BusName
|
||||
| Endpoint [Fulfillment] BusName ObjectPath InterfaceName DBusMember
|
||||
| DBusIO IODependency_
|
||||
deriving (Eq, Generic)
|
||||
|
||||
instance Hashable DBusDependency_ where
|
||||
hashWithSalt s (Bus b) = hashWithSalt s $ formatBusName b
|
||||
hashWithSalt s (Endpoint b o i m) = s `hashWithSalt` formatBusName b
|
||||
hashWithSalt s (Bus f b) = s `hashWithSalt` f
|
||||
`hashWithSalt` formatBusName b
|
||||
hashWithSalt s (Endpoint f b o i m) = s `hashWithSalt` f
|
||||
`hashWithSalt` formatBusName b
|
||||
`hashWithSalt` formatObjectPath o
|
||||
`hashWithSalt` formatInterfaceName i
|
||||
`hashWithSalt` m
|
||||
hashWithSalt s (DBusIO i) = hashWithSalt s i
|
||||
|
||||
-- | A dependency that only requires IO to evaluate (no payload)
|
||||
data IODependency_ = IOSystem_ SystemDependency
|
||||
| IOTest_ String (IO (Maybe Msg))
|
||||
data IODependency_ = IOSystem_ [Fulfillment] SystemDependency
|
||||
| IOTest_ String [Fulfillment] (IO (Maybe Msg))
|
||||
| forall a. IOSometimes_ (Sometimes a)
|
||||
|
||||
instance Eq IODependency_ where
|
||||
(==) (IOSystem_ s0) (IOSystem_ s1) = s0 == s1
|
||||
(==) (IOTest_ _ _) (IOTest_ _ _) = False
|
||||
(==) (IOSystem_ f0 s0) (IOSystem_ f1 s1) = f0 == f1 && s0 == s1
|
||||
(==) (IOTest_ {}) (IOTest_ {}) = False
|
||||
(==) (IOSometimes_ _) (IOSometimes_ _) = False
|
||||
(==) _ _ = False
|
||||
|
||||
instance Hashable IODependency_ where
|
||||
hashWithSalt s (IOSystem_ y) = hashWithSalt s y
|
||||
hashWithSalt s (IOTest_ n _) = hashWithSalt s n
|
||||
hashWithSalt s (IOSystem_ f y) = s `hashWithSalt` f
|
||||
`hashWithSalt` y
|
||||
hashWithSalt s (IOTest_ n f _) = s `hashWithSalt` n
|
||||
`hashWithSalt` f
|
||||
hashWithSalt s (IOSometimes_ (Sometimes n _ _)) = hashWithSalt s n
|
||||
|
||||
-- | A system component to an IODependency
|
||||
|
|
@ -379,6 +384,14 @@ instance Hashable DBusMember where
|
|||
hashWithSalt s (Signal_ m) = hashWithSalt s $ formatMemberName m
|
||||
hashWithSalt s (Property_ p) = hashWithSalt s p
|
||||
|
||||
-- TODO there is a third type of package: not in aur or official
|
||||
-- | A means to fulfill a dependency
|
||||
-- For now this is just the name of an Arch Linux package (AUR or official)
|
||||
data Fulfillment = Package Bool String deriving (Eq, Show)
|
||||
|
||||
instance Hashable Fulfillment where
|
||||
hashWithSalt s (Package a n) = s `hashWithSalt` a `hashWithSalt` n
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- | Tested dependency tree
|
||||
--
|
||||
|
|
@ -672,7 +685,7 @@ testTree test_ test = go
|
|||
liftRight = either (return . Left)
|
||||
|
||||
testIODependency :: IODependency p -> FIO (Result p)
|
||||
testIODependency (IORead _ t) = t
|
||||
testIODependency (IORead _ _ t) = t
|
||||
testIODependency (IOConst c) = return $ Right $ PostPass c []
|
||||
-- TODO this is a bit odd because this is a dependency that will always
|
||||
-- succeed, which kinda makes this pointless. The only reason I would want this
|
||||
|
|
@ -705,8 +718,8 @@ testIODependency_ :: IODependency_ -> FIO Result_
|
|||
testIODependency_ = memoizeIO_ testIODependency'_
|
||||
|
||||
testIODependency'_ :: IODependency_ -> FIO Result_
|
||||
testIODependency'_ (IOSystem_ s) = io $ readResult_ <$> testSysDependency s
|
||||
testIODependency'_ (IOTest_ _ t) = io $ readResult_ <$> t
|
||||
testIODependency'_ (IOSystem_ _ s) = io $ readResult_ <$> testSysDependency s
|
||||
testIODependency'_ (IOTest_ _ _ t) = io $ readResult_ <$> t
|
||||
testIODependency'_ (IOSometimes_ x) = bimap (fmap stripMsg) (fmap stripMsg . snd)
|
||||
<$> evalSometimesMsg x
|
||||
|
||||
|
|
@ -756,33 +769,33 @@ unitType UserUnit = "user"
|
|||
-- Make a special case for these since we end up testing the font alot, and it
|
||||
-- would be nice if I can cache them.
|
||||
|
||||
fontAlways :: String -> String -> Always FontBuilder
|
||||
fontAlways n fam = always1 n (fontFeatureName fam) root fallbackFont
|
||||
fontAlways :: String -> String -> [Fulfillment] -> Always FontBuilder
|
||||
fontAlways n fam ful = always1 n (fontFeatureName fam) root fallbackFont
|
||||
where
|
||||
root = IORoot id $ fontTree fam
|
||||
root = IORoot id $ fontTree fam ful
|
||||
|
||||
fontSometimes :: String -> String -> Sometimes FontBuilder
|
||||
fontSometimes n fam = sometimes1 n (fontFeatureName fam) root
|
||||
fontSometimes :: String -> String -> [Fulfillment]-> Sometimes FontBuilder
|
||||
fontSometimes n fam ful = sometimes1 n (fontFeatureName fam) root
|
||||
where
|
||||
root = IORoot id $ fontTree fam
|
||||
root = IORoot id $ fontTree fam ful
|
||||
|
||||
fontFeatureName :: String -> String
|
||||
fontFeatureName n = unwords ["Font family for", singleQuote n]
|
||||
|
||||
fontTreeAlt :: String -> Tree IODependency d_ FontBuilder
|
||||
fontTreeAlt fam = Or (fontTree fam) $ Only $ IOConst fallbackFont
|
||||
fontTreeAlt :: String -> [Fulfillment] -> Tree IODependency d_ FontBuilder
|
||||
fontTreeAlt fam ful = Or (fontTree fam ful) $ Only $ IOConst fallbackFont
|
||||
|
||||
fontTree :: String -> Tree IODependency d_ FontBuilder
|
||||
fontTree = Only . fontDependency
|
||||
fontTree :: String -> [Fulfillment] -> Tree IODependency d_ FontBuilder
|
||||
fontTree n = Only . fontDependency n
|
||||
|
||||
fontTree_ :: String -> IOTree_
|
||||
fontTree_ = Only_ . fontDependency_
|
||||
fontTree_ :: String -> [Fulfillment] -> IOTree_
|
||||
fontTree_ n = Only_ . fontDependency_ n
|
||||
|
||||
fontDependency :: String -> IODependency FontBuilder
|
||||
fontDependency fam = IORead (fontTestName fam) $ testFont fam
|
||||
fontDependency :: String -> [Fulfillment] -> IODependency FontBuilder
|
||||
fontDependency fam ful = IORead (fontTestName fam) ful $ testFont fam
|
||||
|
||||
fontDependency_ :: String -> IODependency_
|
||||
fontDependency_ fam = IOTest_ (fontTestName fam) $ voidRead <$> testFont' fam
|
||||
fontDependency_ :: String -> [Fulfillment] -> IODependency_
|
||||
fontDependency_ fam ful = IOTest_ (fontTestName fam) ful $ voidRead <$> testFont' fam
|
||||
|
||||
fontTestName :: String -> String
|
||||
fontTestName fam = unwords ["test if font", singleQuote fam, "exists"]
|
||||
|
|
@ -824,8 +837,10 @@ listInterfaces = fromRight [] <$> tryIOError (listDirectory sysfsNet)
|
|||
sysfsNet :: FilePath
|
||||
sysfsNet = "/sys/class/net"
|
||||
|
||||
-- ASSUME there are no (non-base) packages required to make these interfaces
|
||||
-- work (all at the kernel level)
|
||||
readInterface :: String -> (String -> Bool) -> IODependency String
|
||||
readInterface n f = IORead n go
|
||||
readInterface n f = IORead n [] go
|
||||
where
|
||||
go = io $ do
|
||||
ns <- filter f <$> listInterfaces
|
||||
|
|
@ -838,8 +853,9 @@ readInterface n f = IORead n go
|
|||
--------------------------------------------------------------------------------
|
||||
-- | Misc testers
|
||||
|
||||
socketExists :: String -> IO FilePath -> IODependency_
|
||||
socketExists n = IOTest_ ("test if " ++ n ++ " socket exists") . socketExists'
|
||||
socketExists :: String -> [Fulfillment] -> IO FilePath -> IODependency_
|
||||
socketExists n ful = IOTest_ ("test if " ++ n ++ " socket exists") ful
|
||||
. socketExists'
|
||||
|
||||
socketExists' :: IO FilePath -> IO (Maybe Msg)
|
||||
socketExists' getPath = do
|
||||
|
|
@ -864,8 +880,8 @@ testDBusDependency_ :: Client -> DBusDependency_ -> FIO Result_
|
|||
testDBusDependency_ cl = memoizeDBus_ (testDBusDependency'_ cl)
|
||||
|
||||
testDBusDependency'_ :: Client -> DBusDependency_ -> FIO Result_
|
||||
testDBusDependency'_ client (Bus bus) = io $ do
|
||||
ret <- callMethod client queryBus queryPath queryIface queryMem
|
||||
testDBusDependency'_ cl (Bus _ bus) = io $ do
|
||||
ret <- callMethod cl queryBus queryPath queryIface queryMem
|
||||
return $ case ret of
|
||||
Left e -> Left [Msg Error e]
|
||||
Right b -> let ns = bodyGetNames b in
|
||||
|
|
@ -882,8 +898,8 @@ testDBusDependency'_ client (Bus bus) = io $ do
|
|||
bodyGetNames [v] = fromMaybe [] $ fromVariant v :: [String]
|
||||
bodyGetNames _ = []
|
||||
|
||||
testDBusDependency'_ client (Endpoint busname objpath iface mem) = io $ do
|
||||
ret <- callMethod client busname objpath introspectInterface introspectMethod
|
||||
testDBusDependency'_ cl (Endpoint _ busname objpath iface mem) = io $ do
|
||||
ret <- callMethod cl busname objpath introspectInterface introspectMethod
|
||||
return $ case ret of
|
||||
Left e -> Left [Msg Error e]
|
||||
Right body -> procBody body
|
||||
|
|
@ -963,24 +979,26 @@ sometimesIO_ fn n t x = sometimes1 fn n $ IORoot_ x t
|
|||
sometimesIO :: String -> String -> IOTree p -> (p -> a) -> Sometimes a
|
||||
sometimesIO fn n t x = sometimes1 fn n $ IORoot x t
|
||||
|
||||
sometimesExe :: MonadIO m => String -> String -> Bool -> FilePath -> Sometimes (m ())
|
||||
sometimesExe fn n sys path = sometimesExeArgs fn n sys path []
|
||||
sometimesExe :: MonadIO m => String -> String -> [Fulfillment] -> Bool
|
||||
-> FilePath -> Sometimes (m ())
|
||||
sometimesExe fn n ful sys path = sometimesExeArgs fn n ful sys path []
|
||||
|
||||
sometimesExeArgs :: MonadIO m => String -> String -> Bool -> FilePath
|
||||
-> [String] -> Sometimes (m ())
|
||||
sometimesExeArgs fn n sys path args =
|
||||
sometimesIO_ fn n (Only_ (IOSystem_ $ Executable sys path)) $ spawnCmd path args
|
||||
sometimesExeArgs :: MonadIO m => String -> String -> [Fulfillment] -> Bool
|
||||
-> FilePath -> [String] -> Sometimes (m ())
|
||||
sometimesExeArgs fn n ful sys path args =
|
||||
sometimesIO_ fn n (Only_ (IOSystem_ ful $ Executable sys path)) $ spawnCmd path args
|
||||
|
||||
sometimesDBus :: Maybe Client -> String -> String -> Tree_ DBusDependency_
|
||||
-> (Client -> a) -> Sometimes a
|
||||
sometimesDBus c fn n t x = sometimes1 fn n $ DBusRoot_ x t c
|
||||
|
||||
sometimesEndpoint :: MonadIO m => String -> String -> BusName -> ObjectPath -> InterfaceName
|
||||
-> MemberName -> Maybe Client -> Sometimes (m ())
|
||||
sometimesEndpoint fn name busname path iface mem client =
|
||||
sometimesDBus client fn name deps cmd
|
||||
sometimesEndpoint :: MonadIO m => String -> String -> [Fulfillment]
|
||||
-> BusName -> ObjectPath -> InterfaceName -> MemberName -> Maybe Client
|
||||
-> Sometimes (m ())
|
||||
sometimesEndpoint fn name ful busname path iface mem cl =
|
||||
sometimesDBus cl fn name deps cmd
|
||||
where
|
||||
deps = Only_ $ Endpoint busname path iface $ Method_ mem
|
||||
deps = Only_ $ Endpoint ful busname path iface $ Method_ mem
|
||||
cmd c = io $ void $ callMethod c busname path iface mem
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
|
@ -1011,35 +1029,38 @@ readResult_ _ = Right []
|
|||
--------------------------------------------------------------------------------
|
||||
-- | IO Dependency Constructors
|
||||
|
||||
exe :: Bool -> String -> IODependency_
|
||||
exe b = IOSystem_ . Executable b
|
||||
exe :: Bool -> [Fulfillment] -> String -> IODependency_
|
||||
exe b ful = IOSystem_ ful . Executable b
|
||||
|
||||
sysExe :: String -> IODependency_
|
||||
sysExe :: [Fulfillment] -> String -> IODependency_
|
||||
sysExe = exe True
|
||||
|
||||
localExe :: String -> IODependency_
|
||||
localExe :: [Fulfillment] -> String -> IODependency_
|
||||
localExe = exe False
|
||||
|
||||
pathR :: String -> IODependency_
|
||||
pathR n = IOSystem_ $ AccessiblePath n True False
|
||||
path' :: Bool -> Bool -> String -> [Fulfillment] -> IODependency_
|
||||
path' r w n ful = IOSystem_ ful $ AccessiblePath n r w
|
||||
|
||||
pathW :: String -> IODependency_
|
||||
pathW n = IOSystem_ $ AccessiblePath n False True
|
||||
pathR :: String -> [Fulfillment] -> IODependency_
|
||||
pathR = path' True False
|
||||
|
||||
pathRW :: String -> IODependency_
|
||||
pathRW n = IOSystem_ $ AccessiblePath n True True
|
||||
pathW :: String -> [Fulfillment] -> IODependency_
|
||||
pathW = path' False True
|
||||
|
||||
sysd :: UnitType -> String -> IODependency_
|
||||
sysd u = IOSystem_ . Systemd u
|
||||
pathRW :: String -> [Fulfillment] -> IODependency_
|
||||
pathRW = path' True True
|
||||
|
||||
sysdUser :: String -> IODependency_
|
||||
sysd :: UnitType -> [Fulfillment] -> String -> IODependency_
|
||||
sysd u ful = IOSystem_ ful . Systemd u
|
||||
|
||||
sysdUser :: [Fulfillment] -> String -> IODependency_
|
||||
sysdUser = sysd UserUnit
|
||||
|
||||
sysdSystem :: String -> IODependency_
|
||||
sysdSystem :: [Fulfillment] -> String -> IODependency_
|
||||
sysdSystem = sysd SystemUnit
|
||||
|
||||
process :: String -> IODependency_
|
||||
process = IOSystem_ . Process
|
||||
process :: [Fulfillment] -> String -> IODependency_
|
||||
process ful = IOSystem_ ful . Process
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- | Printing
|
||||
|
|
@ -1140,7 +1161,10 @@ dataTree_ f_ = go
|
|||
|
||||
dataIODependency :: IODependency p -> DependencyData
|
||||
dataIODependency d = first Q $ case d of
|
||||
(IORead n _) -> ("ioread", [("desc", JSON_Q $ Q n)])
|
||||
(IORead n f _) -> ("ioread", [ ("desc", JSON_Q $ Q n)
|
||||
, ("fulfilment", JSON_UQ
|
||||
$ dataFulfillments f)
|
||||
])
|
||||
(IOConst _) -> ("const", [])
|
||||
-- TODO what if this isn't required?
|
||||
(IOSometimes (Sometimes n _ _) _) -> ("sometimes", [ ("name", JSON_Q $ Q n)])
|
||||
|
|
@ -1148,41 +1172,62 @@ dataIODependency d = first Q $ case d of
|
|||
|
||||
dataIODependency_ :: IODependency_ -> DependencyData
|
||||
dataIODependency_ d = case d of
|
||||
(IOSystem_ s) -> dataSysDependency s
|
||||
(IOSystem_ f s) -> dataSysDependency f s
|
||||
(IOSometimes_ _) -> (Q "sometimes", [])
|
||||
(IOTest_ desc _) -> (Q "iotest", [("desc", JSON_Q $ Q desc)])
|
||||
(IOTest_ desc f _) -> (Q "iotest", [ ("desc", JSON_Q $ Q desc)
|
||||
, ("fulfilment", JSON_UQ $ dataFulfillments f)
|
||||
])
|
||||
|
||||
dataSysDependency :: SystemDependency -> DependencyData
|
||||
dataSysDependency d = first Q $
|
||||
dataSysDependency :: [Fulfillment] -> SystemDependency -> DependencyData
|
||||
dataSysDependency f d = first Q $
|
||||
case d of
|
||||
(Executable sys path) -> ("executable", [ ("system", JSON_UQ $ jsonBool sys)
|
||||
, ("path", JSON_Q $ Q path)
|
||||
, f'
|
||||
])
|
||||
(AccessiblePath p r w) -> ("path", [ ("path", JSON_Q $ Q p)
|
||||
, ("readable", JSON_UQ $ jsonBool r)
|
||||
, ("writable", JSON_UQ $ jsonBool w)
|
||||
, f'
|
||||
])
|
||||
(Systemd t n) -> ("systemd", [ ("unittype", JSON_Q $ Q $ unitType t)
|
||||
, ("unit", JSON_Q $ Q n)])
|
||||
(Process n) -> ("process", [("name", JSON_Q $ Q n)])
|
||||
, ("unit", JSON_Q $ Q n)
|
||||
, f'
|
||||
])
|
||||
(Process n) -> ("process", [("name", JSON_Q $ Q n), f'])
|
||||
where
|
||||
f' = ("fulfilment", JSON_UQ $ dataFulfillments f)
|
||||
|
||||
|
||||
dataDBusDependency :: DBusDependency_ -> DependencyData
|
||||
dataDBusDependency d =
|
||||
case d of
|
||||
(DBusIO i) -> dataIODependency_ i
|
||||
(Bus b) -> (Q "bus", [("busname", JSON_Q $ Q $ formatBusName b)])
|
||||
(Endpoint b o i m) -> let (mt, mn) = memberData m
|
||||
(Bus f b) -> (Q "bus", [ ("busname", JSON_Q $ Q $ formatBusName b)
|
||||
, ("fulfilment", JSON_UQ $ dataFulfillments f)
|
||||
])
|
||||
(Endpoint f b o i m) -> let (mt, mn) = memberData m
|
||||
in (Q "endpoint", [ ("busname", JSON_Q $ Q $ formatBusName b)
|
||||
, ("objectpath", JSON_Q $ Q $ formatObjectPath o)
|
||||
, ("interface", JSON_Q $ Q $ formatInterfaceName i)
|
||||
, ("membertype", JSON_Q $ Q mt)
|
||||
, ("membername", JSON_Q $ Q mn)
|
||||
, ("fulfilment", JSON_UQ $ dataFulfillments f)
|
||||
])
|
||||
where
|
||||
memberData (Method_ n) = ("method", formatMemberName n)
|
||||
memberData (Signal_ n) = ("signal", formatMemberName n)
|
||||
memberData (Property_ n) = ("property", n)
|
||||
|
||||
dataFulfillments :: [Fulfillment] -> JSONUnquotable
|
||||
dataFulfillments = jsonArray . fmap (JSON_UQ . dataFulfillment)
|
||||
|
||||
dataFulfillment :: Fulfillment -> JSONUnquotable
|
||||
dataFulfillment (Package a n) = jsonObject [ ("type", JSON_Q $ Q "package")
|
||||
, ("official", JSON_UQ $ jsonBool a)
|
||||
, ("name", JSON_Q $ Q n)
|
||||
]
|
||||
|
||||
fromMsg :: Msg -> JSONUnquotable
|
||||
fromMsg (Msg e s) = jsonObject [ ("level", JSON_Q $ Q $ show e)
|
||||
, ("msg", JSON_Q $ Q s)
|
||||
|
|
|
|||
|
|
@ -57,7 +57,8 @@ btAlias :: String
|
|||
btAlias = "bluetooth"
|
||||
|
||||
btDep :: DBusDependency_
|
||||
btDep = Endpoint btBus btOMPath omInterface $ Method_ getManagedObjects
|
||||
btDep = Endpoint [Package True "bluez"] btBus btOMPath omInterface
|
||||
$ Method_ getManagedObjects
|
||||
|
||||
data Bluetooth = Bluetooth Icons Colors deriving (Read, Show)
|
||||
|
||||
|
|
|
|||
|
|
@ -17,6 +17,7 @@ import DBus
|
|||
import DBus.Client
|
||||
import DBus.Internal
|
||||
|
||||
import XMonad.Internal.Command.Desktop
|
||||
import XMonad.Internal.Dependency
|
||||
import Xmobar
|
||||
import Xmobar.Plugins.Common
|
||||
|
|
@ -42,7 +43,7 @@ devSignal :: String
|
|||
devSignal = "Ip4Connectivity"
|
||||
|
||||
devDep :: DBusDependency_
|
||||
devDep = Endpoint nmBus nmPath nmInterface $ Method_ getByIP
|
||||
devDep = Endpoint networkManagerPkgs nmBus nmPath nmInterface $ Method_ getByIP
|
||||
|
||||
getDevice :: Client -> String -> IO (Maybe ObjectPath)
|
||||
getDevice client iface = bodyToMaybe <$> callMethod' client mc
|
||||
|
|
|
|||
|
|
@ -22,6 +22,7 @@ import DBus
|
|||
import DBus.Client
|
||||
import DBus.Internal
|
||||
|
||||
import XMonad.Internal.Command.Desktop
|
||||
import XMonad.Internal.Dependency
|
||||
import Xmobar
|
||||
import Xmobar.Plugins.Common
|
||||
|
|
@ -119,4 +120,5 @@ vpnAlias :: String
|
|||
vpnAlias = "vpn"
|
||||
|
||||
vpnDep :: DBusDependency_
|
||||
vpnDep = Endpoint vpnBus vpnPath omInterface $ Method_ getManagedObjects
|
||||
vpnDep = Endpoint networkManagerPkgs vpnBus vpnPath omInterface
|
||||
$ Method_ getManagedObjects
|
||||
|
|
|
|||
Loading…
Reference in New Issue