ndwarshuis
/
xmonad-config
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

ADD package annotations for dependencies

This commit is contained in:
Nathan Dwarshuis 2022-07-09 01:02:37 -04:00
parent c8109a9e66
commit b8b058c78c
15 changed files with 279 additions and 178 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

14
bin/xmobar.hs
View File

@ -34,7 +34,8 @@ import XMonad.Core
, io , io
) )
import XMonad.Hooks.DynamicLog (wrap) 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.ClevoKeyboard
import XMonad.Internal.DBus.Brightness.IntelBacklight import XMonad.Internal.DBus.Brightness.IntelBacklight
import XMonad.Internal.DBus.Control import XMonad.Internal.DBus.Control
@ -75,7 +76,7 @@ evalConfig db = do
-- | The text font family -- | The text font family
textFont :: Always T.FontBuilder 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 -- | Offset of the text in the bar
textFontOffset :: Int textFontOffset :: Int
@ -88,6 +89,7 @@ textFontData = T.defFontData { T.weight = Just T.Bold, T.size = Just 11 }
-- | The icon font family -- | The icon font family
iconFont :: Sometimes T.FontBuilder iconFont :: Sometimes T.FontBuilder
iconFont = fontSometimes "XMobar Icon Font" "Symbols Nerd Font" 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) -- | Offsets for the icons in the bar (relative to the text offset)
iconOffset :: BarFont -> Int iconOffset :: BarFont -> Int
@ -191,20 +193,22 @@ getBattery :: BarFeature
getBattery = iconIO_ "battery level indicator" xpfBattery root tree getBattery = iconIO_ "battery level indicator" xpfBattery root tree
where where
root useIcon = IORoot_ (batteryCmd useIcon) 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 :: Maybe Client -> BarFeature
getVPN cl = iconDBus_ "VPN status indicator" xpfVPN root $ toAnd_ vpnDep test getVPN cl = iconDBus_ "VPN status indicator" xpfVPN root $ toAnd_ vpnDep test
where where
root useIcon tree = DBusRoot_ (const $ vpnCmd useIcon) tree cl 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 :: Maybe Client -> BarFeature
getBt = xmobarDBus "bluetooth status indicator" xpfBluetooth btDep btCmd getBt = xmobarDBus "bluetooth status indicator" xpfBluetooth btDep btCmd
getAlsa :: BarFeature getAlsa :: BarFeature
getAlsa = iconIO_ "volume level indicator" (const True) root getAlsa = iconIO_ "volume level indicator" (const True) root
$ Only_ $ sysExe "alsactl" $ Only_ $ sysExe [Package True "alsa-utils"] "alsactl"
where where
root useIcon = IORoot_ (alsaCmd useIcon) root useIcon = IORoot_ (alsaCmd useIcon)

14
bin/xmonad.hs
View File

@ -104,7 +104,7 @@ tabbedFeature :: Always Theme
tabbedFeature = Always "theme for tabbed windows" $ Option sf fallback tabbedFeature = Always "theme for tabbed windows" $ Option sf fallback
where where
sf = Subfeature niceTheme "theme with nice font" 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 fallback = Always_ $ FallbackAlone $ T.tabbedTheme T.fallbackFont
features :: Maybe Client -> FeatureSet features :: Maybe Client -> FeatureSet
@ -236,7 +236,7 @@ f5Tag = "F5VPN"
gimpDynamicWorkspace :: Sometimes DynWorkspace gimpDynamicWorkspace :: Sometimes DynWorkspace
gimpDynamicWorkspace = sometimesIO_ "gimp workspace" "gimp" tree dw gimpDynamicWorkspace = sometimesIO_ "gimp workspace" "gimp" tree dw
where where
tree = Only_ $ sysExe "gimp" tree = Only_ $ sysExe [Package True "gimp"] "gimp"
dw = DynWorkspace dw = DynWorkspace
{ dwName = "Gimp" { dwName = "Gimp"
, dwTag = gimpTag , dwTag = gimpTag
@ -258,8 +258,8 @@ vmDynamicWorkspace :: Sometimes DynWorkspace
vmDynamicWorkspace = Sometimes "virtualbox workspace" xpfVirtualBox vmDynamicWorkspace = Sometimes "virtualbox workspace" xpfVirtualBox
[Subfeature root "windows 8 VM"] [Subfeature root "windows 8 VM"]
where where
root = IORoot_ dw $ toAnd_ (sysExe "VBoxManage") root = IORoot_ dw $ toAnd_ (sysExe [Package True "virtualbox"] "VBoxManage")
$ IOTest_ name $ vmExists vm $ IOTest_ name [] $ vmExists vm
name = unwords ["test if", vm, "exists"] name = unwords ["test if", vm, "exists"]
c = "VirtualBoxVM" c = "VirtualBoxVM"
vm = "win8raw" vm = "win8raw"
@ -276,7 +276,7 @@ xsaneDynamicWorkspace :: Sometimes DynWorkspace
xsaneDynamicWorkspace = Sometimes "scanner workspace" xpfXSANE xsaneDynamicWorkspace = Sometimes "scanner workspace" xpfXSANE
[Subfeature (IORoot_ dw tree) "xsane"] [Subfeature (IORoot_ dw tree) "xsane"]
where where
tree = Only_ $ sysExe "xsane" tree = Only_ $ sysExe [Package True "xsane"] "xsane"
dw = DynWorkspace dw = DynWorkspace
{ dwName = "XSane" { dwName = "XSane"
, dwTag = xsaneTag , dwTag = xsaneTag
@ -290,7 +290,7 @@ xsaneDynamicWorkspace = Sometimes "scanner workspace" xpfXSANE
f5vpnDynamicWorkspace :: Sometimes DynWorkspace f5vpnDynamicWorkspace :: Sometimes DynWorkspace
f5vpnDynamicWorkspace = sometimesIO_ "F5 VPN workspace" "f5vpn" tree dw f5vpnDynamicWorkspace = sometimesIO_ "F5 VPN workspace" "f5vpn" tree dw
where where
tree = Only_ $ sysExe "f5vpn" tree = Only_ $ sysExe [Package False "f5vpn"] "f5vpn"
dw = DynWorkspace dw = DynWorkspace
{ dwName = "F5Vpn" { dwName = "F5Vpn"
, dwTag = f5Tag , dwTag = f5Tag
@ -666,8 +666,6 @@ externalBindings ts db =
-- M-<F1> reserved for showing the keymap -- M-<F1> reserved for showing the keymap
, KeyBinding "M-<F2>" "restart xmonad" restartf , KeyBinding "M-<F2>" "restart xmonad" restartf
, KeyBinding "M-<F3>" "recompile xmonad" recompilef , 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-<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 sys , KeyBinding "M-<F10>" "toggle bluetooth" $ Left $ runToggleBluetooth sys

47
lib/XMonad/Internal/Command/DMenu.hs
View File

@ -29,6 +29,7 @@ import System.Directory
import System.IO import System.IO
import XMonad.Core hiding (spawn) import XMonad.Core hiding (spawn)
import XMonad.Internal.Command.Desktop
import XMonad.Internal.DBus.Common import XMonad.Internal.DBus.Common
import XMonad.Internal.Dependency import XMonad.Internal.Dependency
import XMonad.Internal.Notify import XMonad.Internal.Notify
@ -63,11 +64,21 @@ myDmenuNetworks = "networkmanager_dmenu"
myClipboardManager :: String myClipboardManager :: String
myClipboardManager = "greenclip" myClipboardManager = "greenclip"
--------------------------------------------------------------------------------
-- | Packages
dmenuPkgs :: [Fulfillment]
dmenuPkgs = [Package True "rofi"]
clipboardPkgs :: [Fulfillment]
clipboardPkgs = [Package False "rofi-greenclip"]
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Other internal functions -- | Other internal functions
spawnDmenuCmd :: String -> [String] -> SometimesX 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 :: String -> [String]
themeArgs hexColor = themeArgs hexColor =
@ -78,6 +89,12 @@ themeArgs hexColor =
myDmenuMatchingArgs :: [String] myDmenuMatchingArgs :: [String]
myDmenuMatchingArgs = ["-i"] -- case insensitivity myDmenuMatchingArgs = ["-i"] -- case insensitivity
dmenuTree :: IOTree_ -> IOTree_
dmenuTree = And_ $ Only_ dmenuDep
dmenuDep :: IODependency_
dmenuDep = sysExe dmenuPkgs myDmenuCmd
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Exported Commands -- | Exported Commands
@ -85,7 +102,7 @@ myDmenuMatchingArgs = ["-i"] -- case insensitivity
runDevMenu :: SometimesX runDevMenu :: SometimesX
runDevMenu = sometimesIO_ "device manager" "rofi devices" t x runDevMenu = sometimesIO_ "device manager" "rofi devices" t x
where where
t = Only_ $ localExe myDmenuDevices t = dmenuTree $ Only_ (localExe [] myDmenuDevices)
x = do x = do
c <- io $ getXdgDirectory XdgConfig "rofi/devices.yml" c <- io $ getXdgDirectory XdgConfig "rofi/devices.yml"
spawnCmd myDmenuDevices spawnCmd myDmenuDevices
@ -99,7 +116,7 @@ runBTMenu = Sometimes "bluetooth selector" xpfBluetooth
[Subfeature (IORoot_ cmd tree) "rofi bluetooth"] [Subfeature (IORoot_ cmd tree) "rofi bluetooth"]
where where
cmd = spawnCmd myDmenuBluetooth $ "-c":themeArgs "#0044bb" cmd = spawnCmd myDmenuBluetooth $ "-c":themeArgs "#0044bb"
tree = Only_ $ sysExe myDmenuBluetooth tree = dmenuTree $ Only_ $ sysExe [] myDmenuBluetooth
runVPNMenu :: SometimesX runVPNMenu :: SometimesX
runVPNMenu = Sometimes "VPN selector" xpfVPN runVPNMenu = Sometimes "VPN selector" xpfVPN
@ -107,7 +124,8 @@ runVPNMenu = Sometimes "VPN selector" xpfVPN
where where
cmd = spawnCmd myDmenuVPN cmd = spawnCmd myDmenuVPN
$ ["-c"] ++ themeArgs "#007766" ++ myDmenuMatchingArgs $ ["-c"] ++ themeArgs "#007766" ++ myDmenuMatchingArgs
tree = toAnd_ (localExe myDmenuVPN) $ socketExists "expressVPN" tree = dmenuTree $ toAnd_ (localExe [] myDmenuVPN)
$ socketExists "expressVPN" []
$ return "/var/lib/expressvpn/expressvpnd.socket" $ return "/var/lib/expressvpn/expressvpnd.socket"
runCmdMenu :: SometimesX runCmdMenu :: SometimesX
@ -124,11 +142,15 @@ runNetMenu cl =
sometimesDBus cl "network control menu" "rofi NetworkManager" tree cmd sometimesDBus cl "network control menu" "rofi NetworkManager" tree cmd
where where
cmd _ = spawnCmd myDmenuNetworks $ themeArgs "#ff3333" 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 :: SometimesX
runAutorandrMenu = sometimesExeArgs "autorandr menu" "rofi autorandr" runAutorandrMenu = sometimesIO_ "autorandr menu" "rofi autorandr" tree cmd
True myDmenuMonitors $ themeArgs "#ff0066" where
cmd = spawnCmd myDmenuMonitors $ themeArgs "#ff0066"
tree = dmenuTree $ Only_ $ localExe [] myDmenuMonitors
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Password manager -- | Password manager
@ -138,8 +160,8 @@ runBwMenu cl = sometimesDBus cl "password manager" "rofi bitwarden" tree cmd
where where
cmd _ = spawnCmd myDmenuPasswords cmd _ = spawnCmd myDmenuPasswords
$ ["-c"] ++ themeArgs "#bb6600" ++ myDmenuMatchingArgs $ ["-c"] ++ themeArgs "#bb6600" ++ myDmenuMatchingArgs
tree = toAnd_ (DBusIO $ localExe myDmenuPasswords) tree = And_ (Only_ $ Bus [] $ busName_ "org.rofi.bitwarden")
$ Bus $ busName_ "org.rofi.bitwarden" $ toAnd_ (DBusIO dmenuDep) (DBusIO $ localExe [] myDmenuPasswords)
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Clipboard -- | Clipboard
@ -148,8 +170,9 @@ runClipMenu :: SometimesX
runClipMenu = sometimesIO_ "clipboard manager" "rofi greenclip" tree act runClipMenu = sometimesIO_ "clipboard manager" "rofi greenclip" tree act
where where
act = spawnCmd myDmenuCmd args act = spawnCmd myDmenuCmd args
tree = listToAnds (process myClipboardManager) tree = listToAnds dmenuDep [ sysExe clipboardPkgs myClipboardManager
$ sysExe <$> [myDmenuCmd, myClipboardManager] , process [] myClipboardManager
]
args = [ "-modi", "\"clipboard:greenclip print\"" args = [ "-modi", "\"clipboard:greenclip print\""
, "-show", "clipboard" , "-show", "clipboard"
, "-run-command", "'{cmd}'" , "-run-command", "'{cmd}'"
@ -169,7 +192,7 @@ runShowKeys = Always "keyboard menu" $ Option showKeysDMenu $ Always_
showKeysDMenu :: SubfeatureRoot ([((KeyMask, KeySym), NamedAction)] -> X ()) showKeysDMenu :: SubfeatureRoot ([((KeyMask, KeySym), NamedAction)] -> X ())
showKeysDMenu = Subfeature showKeysDMenu = Subfeature
{ sfName = "keyboard shortcut menu" { sfName = "keyboard shortcut menu"
, sfData = IORoot_ showKeys $ Only_ $ sysExe myDmenuCmd , sfData = IORoot_ showKeys $ Only_ dmenuDep
} }
showKeys :: [((KeyMask, KeySym), NamedAction)] -> X () showKeys :: [((KeyMask, KeySym), NamedAction)] -> X ()

86
lib/XMonad/Internal/Command/Desktop.hs
View File

@ -27,8 +27,6 @@ module XMonad.Internal.Command.Desktop
, runScreenCapture , runScreenCapture
, runDesktopCapture , runDesktopCapture
, runCaptureBrowser , runCaptureBrowser
, runStartISyncTimer
, runStartISyncService
, runNotificationClose , runNotificationClose
, runNotificationCloseAll , runNotificationCloseAll
, runNotificationHistory , runNotificationHistory
@ -36,6 +34,9 @@ module XMonad.Internal.Command.Desktop
-- daemons -- daemons
, runNetAppDaemon , runNetAppDaemon
-- packages
, networkManagerPkgs
) where ) where
import Control.Monad (void) import Control.Monad (void)
@ -65,6 +66,9 @@ import XMonad.Operations
myTerm :: String myTerm :: String
myTerm = "urxvt" myTerm = "urxvt"
myCalc :: String
myCalc = "bc"
myBrowser :: String myBrowser :: String
myBrowser = "brave-accel" myBrowser = "brave-accel"
@ -89,6 +93,26 @@ myImageBrowser = "feh"
myNotificationCtrl :: String myNotificationCtrl :: String
myNotificationCtrl = "dunstctl" 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 -- | Misc constants
@ -99,13 +123,13 @@ volumeChangeSound = "smb_fireball.wav"
-- | Some nice apps -- | Some nice apps
runTerm :: SometimesX runTerm :: SometimesX
runTerm = sometimesExe "terminal" "urxvt" True myTerm runTerm = sometimesExe "terminal" "urxvt" myTermPkgs True myTerm
runTMux :: SometimesX runTMux :: SometimesX
runTMux = sometimesIO_ "terminal multiplexer" "tmux" deps act runTMux = sometimesIO_ "terminal multiplexer" "tmux" deps act
where where
deps = listToAnds (socketExists "tmux" socketName) deps = listToAnds (socketExists "tmux" [] socketName)
$ fmap sysExe [myTerm, "tmux", "bash"] $ fmap (sysExe myTermPkgs) [myTerm, "tmux", "bash"]
act = spawn act = spawn
$ "tmux has-session" $ "tmux has-session"
#!&& fmtCmd myTerm ["-e", "bash", "-c", singleQuote c] #!&& fmtCmd myTerm ["-e", "bash", "-c", singleQuote c]
@ -120,30 +144,32 @@ runTMux = sometimesIO_ "terminal multiplexer" "tmux" deps act
runCalc :: SometimesX runCalc :: SometimesX
runCalc = sometimesIO_ "calculator" "R" deps act runCalc = sometimesIO_ "calculator" "R" deps act
where where
deps = toAnd_ (sysExe myTerm) (sysExe "R") deps = toAnd_ (sysExe myTermPkgs myTerm) (sysExe [Package True "bc"] myCalc)
act = spawnCmd myTerm ["-e", "R"] act = spawnCmd myTerm ["-e", myCalc, "-l"]
runBrowser :: SometimesX runBrowser :: SometimesX
runBrowser = sometimesExe "web browser" "brave" False myBrowser runBrowser = sometimesExe "web browser" "brave" [Package False "brave-bin"]
False myBrowser
runEditor :: SometimesX runEditor :: SometimesX
runEditor = sometimesIO_ "text editor" "emacs" tree cmd runEditor = sometimesIO_ "text editor" "emacs" tree cmd
where where
cmd = spawnCmd myEditor cmd = spawnCmd myEditor
["-c", "-e", doubleQuote "(select-frame-set-input-focus (selected-frame))"] ["-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 -- 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 :: SometimesX
runFileManager = sometimesExe "file browser" "pcmanfm" True "pcmanfm" runFileManager = sometimesExe "file browser" "pcmanfm" [Package True "pcmanfm"]
True "pcmanfm"
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Multimedia Commands -- | Multimedia Commands
runMultimediaIfInstalled :: String -> String -> SometimesX runMultimediaIfInstalled :: String -> String -> SometimesX
runMultimediaIfInstalled n cmd = sometimesExeArgs (n ++ " multimedia control") runMultimediaIfInstalled n cmd = sometimesExeArgs (n ++ " multimedia control")
"playerctl" True myMultimediaCtl [cmd] "playerctl" [Package True "playerctl"] True myMultimediaCtl [cmd]
runTogglePlay :: SometimesX runTogglePlay :: SometimesX
runTogglePlay = runMultimediaIfInstalled "play/pause" "play-pause" runTogglePlay = runMultimediaIfInstalled "play/pause" "play-pause"
@ -172,8 +198,10 @@ playSound file = do
featureSound :: String -> FilePath -> X () -> X () -> SometimesX featureSound :: String -> FilePath -> X () -> X () -> SometimesX
featureSound n file pre post = featureSound n file pre post =
sometimesIO_ ("volume " ++ n ++ " control") "paplay" (Only_ $ sysExe "paplay") sometimesIO_ ("volume " ++ n ++ " control") "paplay" tree
$ pre >> playSound file >> post $ pre >> playSound file >> post
where
tree = Only_ $ sysExe [Package True "libpulse"] "paplay"
runVolumeDown :: SometimesX runVolumeDown :: SometimesX
runVolumeDown = featureSound "up" volumeChangeSound (return ()) $ void (lowerVolume 2) runVolumeDown = featureSound "up" volumeChangeSound (return ()) $ void (lowerVolume 2)
@ -192,8 +220,8 @@ runNotificationCmd n arg cl =
sometimesDBus cl (n ++ " control") "dunstctl" tree cmd sometimesDBus cl (n ++ " control") "dunstctl" tree cmd
where where
cmd _ = spawnCmd myNotificationCtrl [arg] cmd _ = spawnCmd myNotificationCtrl [arg]
tree = toAnd_ (DBusIO $ sysExe myNotificationCtrl) tree = toAnd_ (DBusIO $ sysExe notifyPkgs myNotificationCtrl)
$ Endpoint notifyBus notifyPath (interfaceName_ "org.dunstproject.cmd0") $ Endpoint [] notifyBus notifyPath (interfaceName_ "org.dunstproject.cmd0")
$ Method_ $ memberName_ "NotificationAction" $ Method_ $ memberName_ "NotificationAction"
runNotificationClose :: Maybe Client -> SometimesX runNotificationClose :: Maybe Client -> SometimesX
@ -219,14 +247,15 @@ runNetAppDaemon :: Maybe Client -> Sometimes (IO ProcessHandle)
runNetAppDaemon cl = Sometimes "network applet" xpfVPN runNetAppDaemon cl = Sometimes "network applet" xpfVPN
[Subfeature (DBusRoot_ cmd tree cl) "NM-applet"] [Subfeature (DBusRoot_ cmd tree cl) "NM-applet"]
where 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" cmd _ = snd <$> spawnPipe "nm-applet"
runToggleBluetooth :: Maybe Client -> SometimesX runToggleBluetooth :: Maybe Client -> SometimesX
runToggleBluetooth cl = Sometimes "bluetooth toggle" xpfBluetooth runToggleBluetooth cl = Sometimes "bluetooth toggle" xpfBluetooth
[Subfeature (DBusRoot_ cmd tree cl) "bluetoothctl"] [Subfeature (DBusRoot_ cmd tree cl) "bluetoothctl"]
where where
tree = And_ (Only_ $ DBusIO $ sysExe myBluetooth) (Only_ $ Bus btBus) tree = And_ (Only_ $ DBusIO $ sysExe bluetoothPkgs myBluetooth) (Only_ $ Bus [] btBus)
cmd _ = spawn cmd _ = spawn
$ myBluetooth ++ " show | grep -q \"Powered: no\"" $ myBluetooth ++ " show | grep -q \"Powered: no\""
#!&& "a=on" #!&& "a=on"
@ -236,7 +265,7 @@ runToggleBluetooth cl = Sometimes "bluetooth toggle" xpfBluetooth
runToggleEthernet :: SometimesX runToggleEthernet :: SometimesX
runToggleEthernet = sometimes1 "ethernet toggle" "nmcli" $ IORoot (spawn . cmd) $ runToggleEthernet = sometimes1 "ethernet toggle" "nmcli" $ IORoot (spawn . cmd) $
And1 (Only readEthernet) (Only_ $ sysExe "nmcli") And1 (Only readEthernet) (Only_ $ sysExe networkManagerPkgs "nmcli")
where where
-- TODO make this less noisy -- TODO make this less noisy
cmd iface = cmd iface =
@ -246,22 +275,6 @@ runToggleEthernet = sometimes1 "ethernet toggle" "nmcli" $ IORoot (spawn . cmd)
#!>> fmtCmd "nmcli" ["device", "$a", iface] #!>> fmtCmd "nmcli" ["device", "$a", iface]
#!&& fmtNotifyCmd defNoteInfo { body = Just $ Text "ethernet \"$a\"ed" } #!&& 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 -- | Configuration commands
@ -297,7 +310,8 @@ runFlameshot :: String -> String -> Maybe Client -> SometimesX
runFlameshot n mode cl = sometimesDBus cl n myCapture tree cmd runFlameshot n mode cl = sometimesDBus cl n myCapture tree cmd
where where
cmd _ = spawnCmd myCapture [mode] 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 -- TODO this will steal focus from the current window (and puts it
-- in the root window?) ...need to fix -- in the root window?) ...need to fix
@ -314,6 +328,6 @@ runScreenCapture = runFlameshot "screen capture" "screen"
runCaptureBrowser :: SometimesX runCaptureBrowser :: SometimesX
runCaptureBrowser = sometimesIO_ "screen capture browser" "feh" runCaptureBrowser = sometimesIO_ "screen capture browser" "feh"
(Only_ $ sysExe myImageBrowser) $ do (Only_ $ sysExe [Package True "feh"] myImageBrowser) $ do
dir <- io getCaptureDir dir <- io getCaptureDir
spawnCmd myImageBrowser [dir] spawnCmd myImageBrowser [dir]

30
lib/XMonad/Internal/Command/Power.hs
View File

@ -21,6 +21,8 @@ module XMonad.Internal.Command.Power
, suspendPrompt , suspendPrompt
, quitPrompt , quitPrompt
, powerPrompt , powerPrompt
, defFontPkgs
, promptFontDep
) where ) where
import Control.Arrow (first) import Control.Arrow (first)
@ -56,11 +58,18 @@ myOptimusManager = "optimus-manager"
myPrimeOffload :: String myPrimeOffload :: String
myPrimeOffload = "prime-offload" myPrimeOffload = "prime-offload"
--------------------------------------------------------------------------------
-- | Packages
optimusPackages :: [Fulfillment]
optimusPackages = [Package False "optimus-manager"]
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Core commands -- | Core commands
runScreenLock :: SometimesX 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 :: X ()
runPowerOff = spawn "systemctl poweroff" runPowerOff = spawn "systemctl poweroff"
@ -80,12 +89,19 @@ runReboot = spawn "systemctl reboot"
runAutolock :: Sometimes (IO ProcessHandle) runAutolock :: Sometimes (IO ProcessHandle)
runAutolock = sometimesIO_ "automatic screen lock" "xss-lock" tree cmd runAutolock = sometimesIO_ "automatic screen lock" "xss-lock" tree cmd
where 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"] cmd = snd <$> spawnPipeArgs "xss-lock" ["--ignore-sleep", "screenlock"]
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Confirmation prompts -- | 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' :: String -> X () -> T.FontBuilder -> X ()
confirmPrompt' s x fb = confirmPrompt (T.promptTheme fb) s x confirmPrompt' s x fb = confirmPrompt (T.promptTheme fb) s x
@ -96,7 +112,7 @@ quitPrompt :: T.FontBuilder -> X ()
quitPrompt = confirmPrompt' "quit?" $ io exitSuccess quitPrompt = confirmPrompt' "quit?" $ io exitSuccess
sometimesPrompt :: String -> (T.FontBuilder -> X ()) -> SometimesX 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? -- TODO doesn't this need to also lock the screen?
runSuspendPrompt :: SometimesX runSuspendPrompt :: SometimesX
@ -141,9 +157,9 @@ runOptimusPrompt = Sometimes "graphics switcher"
where where
s = Subfeature { sfData = r, sfName = "optimus manager" } s = Subfeature { sfData = r, sfName = "optimus manager" }
r = IORoot runOptimusPrompt' t r = IORoot runOptimusPrompt' t
t = And1 (fontTreeAlt T.defFontFamily) t = And1 promptFontDep
$ listToAnds (socketExists "optimus-manager" socketName) $ sysExe $ listToAnds (socketExists "optimus-manager" [] socketName)
<$> [myOptimusManager, myPrimeOffload] $ sysExe optimusPackages <$> [myOptimusManager, myPrimeOffload]
socketName = (</> "optimus-manager") <$> getTemporaryDirectory socketName = (</> "optimus-manager") <$> getTemporaryDirectory
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
@ -177,7 +193,7 @@ runPowerPrompt = Sometimes "power prompt" (const True) [sf]
where where
sf = Subfeature withLock "prompt with lock" sf = Subfeature withLock "prompt with lock"
withLock = IORoot (uncurry powerPrompt) tree withLock = IORoot (uncurry powerPrompt) tree
tree = And12 (,) lockTree (fontTreeAlt T.defFontFamily) tree = And12 (,) lockTree promptFontDep
lockTree = Or (Only $ IOSometimes runScreenLock id) (Only $ IOConst skip) lockTree = Or (Only $ IOSometimes runScreenLock id) (Only $ IOConst skip)
powerPrompt :: X () -> T.FontBuilder -> X () powerPrompt :: X () -> T.FontBuilder -> X ()

9
lib/XMonad/Internal/Concurrent/ACPIEvent.hs
View File

@ -26,10 +26,7 @@ import XMonad.Internal.Command.Power
import XMonad.Internal.Concurrent.ClientMessage import XMonad.Internal.Concurrent.ClientMessage
import XMonad.Internal.Dependency import XMonad.Internal.Dependency
import XMonad.Internal.Shell import XMonad.Internal.Shell
import XMonad.Internal.Theme import XMonad.Internal.Theme (FontBuilder)
( FontBuilder
, defFontFamily
)
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Data structure to hold the ACPI events I care about -- | Data structure to hold the ACPI events I care about
@ -94,7 +91,7 @@ acpiPath :: FilePath
acpiPath = "/var/run/acpid.socket" acpiPath = "/var/run/acpid.socket"
socketDep :: IOTree_ socketDep :: IOTree_
socketDep = Only_ $ pathR acpiPath socketDep = Only_ $ pathR acpiPath [Package True "acpid"]
-- | Handle ClientMessage event containing and ACPI event (to be used in -- | Handle ClientMessage event containing and ACPI event (to be used in
-- Xmonad's event hook) -- Xmonad's event hook)
@ -123,6 +120,6 @@ runHandleACPI = Always "ACPI event handler" $ Option sf fallback
where where
sf = Subfeature withLock "acpid prompt" sf = Subfeature withLock "acpid prompt"
withLock = IORoot (uncurry handleACPI) withLock = IORoot (uncurry handleACPI)
$ And12 (,) (fontTreeAlt defFontFamily) $ Only $ And12 (,) promptFontDep $ Only
$ IOSometimes runScreenLock id $ IOSometimes runScreenLock id
fallback = Always_ $ FallbackAlone $ const skip fallback = Always_ $ FallbackAlone $ const skip

6
lib/XMonad/Internal/DBus/Brightness/ClevoKeyboard.hs
View File

@ -108,16 +108,16 @@ clevoKeyboardConfig = BrightnessConfig
-- | Exported haskell API -- | Exported haskell API
stateFileDep :: IODependency_ stateFileDep :: IODependency_
stateFileDep = pathRW stateFile stateFileDep = pathRW stateFile [Package True "tuxedo-keyboard"]
brightnessFileDep :: IODependency_ brightnessFileDep :: IODependency_
brightnessFileDep = pathR brightnessFile brightnessFileDep = pathR brightnessFile [Package True "tuxedo-keyboard"]
clevoKeyboardSignalDep :: DBusDependency_ clevoKeyboardSignalDep :: DBusDependency_
clevoKeyboardSignalDep = signalDep clevoKeyboardConfig clevoKeyboardSignalDep = signalDep clevoKeyboardConfig
exportClevoKeyboard :: Maybe Client -> SometimesIO exportClevoKeyboard :: Maybe Client -> SometimesIO
exportClevoKeyboard = brightnessExporter xpfClevoBacklight exportClevoKeyboard = brightnessExporter xpfClevoBacklight []
[stateFileDep, brightnessFileDep] clevoKeyboardConfig [stateFileDep, brightnessFileDep] clevoKeyboardConfig
clevoKeyboardControls :: Maybe Client -> BrightnessControls clevoKeyboardControls :: Maybe Client -> BrightnessControls

10
lib/XMonad/Internal/DBus/Brightness/Common.hs
View File

@ -71,7 +71,7 @@ callGetBrightness BrightnessConfig { bcPath = p, bcInterface = i } client =
signalDep :: BrightnessConfig a b -> DBusDependency_ signalDep :: BrightnessConfig a b -> DBusDependency_
signalDep BrightnessConfig { bcPath = p, bcInterface = i } = 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 :: Num c => BrightnessConfig a b -> (Maybe c -> IO ()) -> Client -> IO ()
matchSignal BrightnessConfig { bcPath = p, bcInterface = i } cb = matchSignal BrightnessConfig { bcPath = p, bcInterface = i } cb =
@ -87,13 +87,13 @@ matchSignal BrightnessConfig { bcPath = p, bcInterface = i } cb =
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Internal DBus Crap -- | Internal DBus Crap
brightnessExporter :: RealFrac b => XPQuery -> [IODependency_] brightnessExporter :: RealFrac b => XPQuery -> [Fulfillment] -> [IODependency_]
-> BrightnessConfig a b -> Maybe Client -> SometimesIO -> 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"] Sometimes (n ++ " DBus Interface") q [Subfeature root "exporter"]
where where
root = DBusRoot_ (exportBrightnessControls' bc) tree cl 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' :: RealFrac b => BrightnessConfig a b -> Client -> IO ()
exportBrightnessControls' bc client = do exportBrightnessControls' bc client = do
@ -137,7 +137,7 @@ callBacklight q cl BrightnessConfig { bcPath = p
, bcName = n } controlName m = , bcName = n } controlName m =
Sometimes (unwords [n, controlName]) q [Subfeature root "method call"] Sometimes (unwords [n, controlName]) q [Subfeature root "method call"]
where 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 cmd c = io $ void $ callMethod c xmonadBusName p i m
bodyGetBrightness :: Num a => [Variant] -> Maybe a bodyGetBrightness :: Num a => [Variant] -> Maybe a

6
lib/XMonad/Internal/DBus/Brightness/IntelBacklight.hs
View File

@ -90,16 +90,16 @@ intelBacklightConfig = BrightnessConfig
-- | Exported haskell API -- | Exported haskell API
curFileDep :: IODependency_ curFileDep :: IODependency_
curFileDep = pathRW curFile curFileDep = pathRW curFile []
maxFileDep :: IODependency_ maxFileDep :: IODependency_
maxFileDep = pathR maxFile maxFileDep = pathR maxFile []
intelBacklightSignalDep :: DBusDependency_ intelBacklightSignalDep :: DBusDependency_
intelBacklightSignalDep = signalDep intelBacklightConfig intelBacklightSignalDep = signalDep intelBacklightConfig
exportIntelBacklight :: Maybe Client -> SometimesIO exportIntelBacklight :: Maybe Client -> SometimesIO
exportIntelBacklight = brightnessExporter xpfIntelBacklight exportIntelBacklight = brightnessExporter xpfIntelBacklight []
[curFileDep, maxFileDep] intelBacklightConfig [curFileDep, maxFileDep] intelBacklightConfig
intelBacklightControls :: Maybe Client -> BrightnessControls intelBacklightControls :: Maybe Client -> BrightnessControls

2
lib/XMonad/Internal/DBus/Removable.hs
View File

@ -33,7 +33,7 @@ memRemoved :: MemberName
memRemoved = memberName_ "InterfacesRemoved" memRemoved = memberName_ "InterfacesRemoved"
dbusDep :: MemberName -> DBusDependency_ 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 :: DBusDependency_
addedDep = dbusDep memAdded addedDep = dbusDep memAdded

10
lib/XMonad/Internal/DBus/Screensaver.hs
View File

@ -116,12 +116,12 @@ exportScreensaver client =
} }
] ]
} }
bus = Bus xmonadBusName bus = Bus [] xmonadBusName
ssx = DBusIO $ sysExe ssExecutable ssx = DBusIO $ sysExe [Package True "xorg-xset"] ssExecutable
callToggle :: Maybe Client -> SometimesIO callToggle :: Maybe Client -> SometimesIO
callToggle = sometimesEndpoint "screensaver toggle" "dbus switch" xmonadBusName callToggle = sometimesEndpoint "screensaver toggle" "dbus switch" []
ssPath interface memToggle xmonadBusName ssPath interface memToggle
callQuery :: Client -> IO (Maybe SSState) callQuery :: Client -> IO (Maybe SSState)
callQuery client = do callQuery client = do
@ -133,4 +133,4 @@ matchSignal cb =
fmap void . addMatchCallback ruleCurrentState $ cb . bodyGetCurrentState fmap void . addMatchCallback ruleCurrentState $ cb . bodyGetCurrentState
ssSignalDep :: DBusDependency_ ssSignalDep :: DBusDependency_
ssSignalDep = Endpoint xmonadBusName ssPath interface $ Signal_ memState ssSignalDep = Endpoint [] xmonadBusName ssPath interface $ Signal_ memState

191
lib/XMonad/Internal/Dependency.hs
View File

@ -47,6 +47,7 @@ module XMonad.Internal.Dependency
, DBusMember(..) , DBusMember(..)
, UnitType(..) , UnitType(..)
, Result , Result
, Fulfillment(..)
-- dumping -- dumping
, dumpFeature , dumpFeature
@ -314,7 +315,7 @@ type DBusTree_ = Tree_ DBusDependency_
-- | A dependency that only requires IO to evaluate (with payload) -- | A dependency that only requires IO to evaluate (with payload)
data IODependency p = data IODependency p =
-- a cachable IO action that yields a payload -- a cachable IO action that yields a payload
IORead String (FIO (Result p)) IORead String [Fulfillment] (FIO (Result p))
-- always yields a payload -- always yields a payload
| IOConst p | IOConst p
-- an always that yields a payload -- an always that yields a payload
@ -323,33 +324,37 @@ data IODependency p =
| forall a. IOSometimes (Sometimes a) (a -> p) | forall a. IOSometimes (Sometimes a) (a -> p)
-- | A dependency pertaining to the DBus -- | A dependency pertaining to the DBus
data DBusDependency_ = Bus BusName data DBusDependency_ = Bus [Fulfillment] BusName
| Endpoint BusName ObjectPath InterfaceName DBusMember | Endpoint [Fulfillment] BusName ObjectPath InterfaceName DBusMember
| DBusIO IODependency_ | DBusIO IODependency_
deriving (Eq, Generic) deriving (Eq, Generic)
instance Hashable DBusDependency_ where instance Hashable DBusDependency_ where
hashWithSalt s (Bus b) = hashWithSalt s $ formatBusName b hashWithSalt s (Bus f b) = s `hashWithSalt` f
hashWithSalt s (Endpoint b o i m) = s `hashWithSalt` formatBusName b `hashWithSalt` formatBusName b
hashWithSalt s (Endpoint f b o i m) = s `hashWithSalt` f
`hashWithSalt` formatBusName b
`hashWithSalt` formatObjectPath o `hashWithSalt` formatObjectPath o
`hashWithSalt` formatInterfaceName i `hashWithSalt` formatInterfaceName i
`hashWithSalt` m `hashWithSalt` m
hashWithSalt s (DBusIO i) = hashWithSalt s i hashWithSalt s (DBusIO i) = hashWithSalt s i
-- | A dependency that only requires IO to evaluate (no payload) -- | A dependency that only requires IO to evaluate (no payload)
data IODependency_ = IOSystem_ SystemDependency data IODependency_ = IOSystem_ [Fulfillment] SystemDependency
| IOTest_ String (IO (Maybe Msg)) | IOTest_ String [Fulfillment] (IO (Maybe Msg))
| forall a. IOSometimes_ (Sometimes a) | forall a. IOSometimes_ (Sometimes a)
instance Eq IODependency_ where instance Eq IODependency_ where
(==) (IOSystem_ s0) (IOSystem_ s1) = s0 == s1 (==) (IOSystem_ f0 s0) (IOSystem_ f1 s1) = f0 == f1 && s0 == s1
(==) (IOTest_ _ _) (IOTest_ _ _) = False (==) (IOTest_ {}) (IOTest_ {}) = False
(==) (IOSometimes_ _) (IOSometimes_ _) = False (==) (IOSometimes_ _) (IOSometimes_ _) = False
(==) _ _ = False (==) _ _ = False
instance Hashable IODependency_ where instance Hashable IODependency_ where
hashWithSalt s (IOSystem_ y) = hashWithSalt s y hashWithSalt s (IOSystem_ f y) = s `hashWithSalt` f
hashWithSalt s (IOTest_ n _) = hashWithSalt s n `hashWithSalt` y
hashWithSalt s (IOTest_ n f _) = s `hashWithSalt` n
`hashWithSalt` f
hashWithSalt s (IOSometimes_ (Sometimes n _ _)) = hashWithSalt s n hashWithSalt s (IOSometimes_ (Sometimes n _ _)) = hashWithSalt s n
-- | A system component to an IODependency -- | A system component to an IODependency
@ -379,6 +384,14 @@ instance Hashable DBusMember where
hashWithSalt s (Signal_ m) = hashWithSalt s $ formatMemberName m hashWithSalt s (Signal_ m) = hashWithSalt s $ formatMemberName m
hashWithSalt s (Property_ p) = hashWithSalt s p 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 -- | Tested dependency tree
-- --
@ -672,7 +685,7 @@ testTree test_ test = go
liftRight = either (return . Left) liftRight = either (return . Left)
testIODependency :: IODependency p -> FIO (Result p) testIODependency :: IODependency p -> FIO (Result p)
testIODependency (IORead _ t) = t testIODependency (IORead _ _ t) = t
testIODependency (IOConst c) = return $ Right $ PostPass c [] testIODependency (IOConst c) = return $ Right $ PostPass c []
-- TODO this is a bit odd because this is a dependency that will always -- 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 -- 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_ = memoizeIO_ testIODependency'_
testIODependency'_ :: IODependency_ -> FIO Result_ testIODependency'_ :: IODependency_ -> FIO Result_
testIODependency'_ (IOSystem_ s) = io $ readResult_ <$> testSysDependency s testIODependency'_ (IOSystem_ _ s) = io $ readResult_ <$> testSysDependency s
testIODependency'_ (IOTest_ _ t) = io $ readResult_ <$> t testIODependency'_ (IOTest_ _ _ t) = io $ readResult_ <$> t
testIODependency'_ (IOSometimes_ x) = bimap (fmap stripMsg) (fmap stripMsg . snd) testIODependency'_ (IOSometimes_ x) = bimap (fmap stripMsg) (fmap stripMsg . snd)
<$> evalSometimesMsg x <$> 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 -- Make a special case for these since we end up testing the font alot, and it
-- would be nice if I can cache them. -- would be nice if I can cache them.
fontAlways :: String -> String -> Always FontBuilder fontAlways :: String -> String -> [Fulfillment] -> Always FontBuilder
fontAlways n fam = always1 n (fontFeatureName fam) root fallbackFont fontAlways n fam ful = always1 n (fontFeatureName fam) root fallbackFont
where where
root = IORoot id $ fontTree fam root = IORoot id $ fontTree fam ful
fontSometimes :: String -> String -> Sometimes FontBuilder fontSometimes :: String -> String -> [Fulfillment]-> Sometimes FontBuilder
fontSometimes n fam = sometimes1 n (fontFeatureName fam) root fontSometimes n fam ful = sometimes1 n (fontFeatureName fam) root
where where
root = IORoot id $ fontTree fam root = IORoot id $ fontTree fam ful
fontFeatureName :: String -> String fontFeatureName :: String -> String
fontFeatureName n = unwords ["Font family for", singleQuote n] fontFeatureName n = unwords ["Font family for", singleQuote n]
fontTreeAlt :: String -> Tree IODependency d_ FontBuilder fontTreeAlt :: String -> [Fulfillment] -> Tree IODependency d_ FontBuilder
fontTreeAlt fam = Or (fontTree fam) $ Only $ IOConst fallbackFont fontTreeAlt fam ful = Or (fontTree fam ful) $ Only $ IOConst fallbackFont
fontTree :: String -> Tree IODependency d_ FontBuilder fontTree :: String -> [Fulfillment] -> Tree IODependency d_ FontBuilder
fontTree = Only . fontDependency fontTree n = Only . fontDependency n
fontTree_ :: String -> IOTree_ fontTree_ :: String -> [Fulfillment] -> IOTree_
fontTree_ = Only_ . fontDependency_ fontTree_ n = Only_ . fontDependency_ n
fontDependency :: String -> IODependency FontBuilder fontDependency :: String -> [Fulfillment] -> IODependency FontBuilder
fontDependency fam = IORead (fontTestName fam) $ testFont fam fontDependency fam ful = IORead (fontTestName fam) ful $ testFont fam
fontDependency_ :: String -> IODependency_ fontDependency_ :: String -> [Fulfillment] -> IODependency_
fontDependency_ fam = IOTest_ (fontTestName fam) $ voidRead <$> testFont' fam fontDependency_ fam ful = IOTest_ (fontTestName fam) ful $ voidRead <$> testFont' fam
fontTestName :: String -> String fontTestName :: String -> String
fontTestName fam = unwords ["test if font", singleQuote fam, "exists"] fontTestName fam = unwords ["test if font", singleQuote fam, "exists"]
@ -824,8 +837,10 @@ listInterfaces = fromRight [] <$> tryIOError (listDirectory sysfsNet)
sysfsNet :: FilePath sysfsNet :: FilePath
sysfsNet = "/sys/class/net" 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 :: String -> (String -> Bool) -> IODependency String
readInterface n f = IORead n go readInterface n f = IORead n [] go
where where
go = io $ do go = io $ do
ns <- filter f <$> listInterfaces ns <- filter f <$> listInterfaces
@ -838,8 +853,9 @@ readInterface n f = IORead n go
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Misc testers -- | Misc testers
socketExists :: String -> IO FilePath -> IODependency_ socketExists :: String -> [Fulfillment] -> IO FilePath -> IODependency_
socketExists n = IOTest_ ("test if " ++ n ++ " socket exists") . socketExists' socketExists n ful = IOTest_ ("test if " ++ n ++ " socket exists") ful
. socketExists'
socketExists' :: IO FilePath -> IO (Maybe Msg) socketExists' :: IO FilePath -> IO (Maybe Msg)
socketExists' getPath = do socketExists' getPath = do
@ -864,8 +880,8 @@ testDBusDependency_ :: Client -> DBusDependency_ -> FIO Result_
testDBusDependency_ cl = memoizeDBus_ (testDBusDependency'_ cl) testDBusDependency_ cl = memoizeDBus_ (testDBusDependency'_ cl)
testDBusDependency'_ :: Client -> DBusDependency_ -> FIO Result_ testDBusDependency'_ :: Client -> DBusDependency_ -> FIO Result_
testDBusDependency'_ client (Bus bus) = io $ do testDBusDependency'_ cl (Bus _ bus) = io $ do
ret <- callMethod client queryBus queryPath queryIface queryMem ret <- callMethod cl queryBus queryPath queryIface queryMem
return $ case ret of return $ case ret of
Left e -> Left [Msg Error e] Left e -> Left [Msg Error e]
Right b -> let ns = bodyGetNames b in Right b -> let ns = bodyGetNames b in
@ -882,8 +898,8 @@ testDBusDependency'_ client (Bus bus) = io $ do
bodyGetNames [v] = fromMaybe [] $ fromVariant v :: [String] bodyGetNames [v] = fromMaybe [] $ fromVariant v :: [String]
bodyGetNames _ = [] bodyGetNames _ = []
testDBusDependency'_ client (Endpoint busname objpath iface mem) = io $ do testDBusDependency'_ cl (Endpoint _ busname objpath iface mem) = io $ do
ret <- callMethod client busname objpath introspectInterface introspectMethod ret <- callMethod cl busname objpath introspectInterface introspectMethod
return $ case ret of return $ case ret of
Left e -> Left [Msg Error e] Left e -> Left [Msg Error e]
Right body -> procBody body 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 :: String -> String -> IOTree p -> (p -> a) -> Sometimes a
sometimesIO fn n t x = sometimes1 fn n $ IORoot x t sometimesIO fn n t x = sometimes1 fn n $ IORoot x t
sometimesExe :: MonadIO m => String -> String -> Bool -> FilePath -> Sometimes (m ()) sometimesExe :: MonadIO m => String -> String -> [Fulfillment] -> Bool
sometimesExe fn n sys path = sometimesExeArgs fn n sys path [] -> FilePath -> Sometimes (m ())
sometimesExe fn n ful sys path = sometimesExeArgs fn n ful sys path []
sometimesExeArgs :: MonadIO m => String -> String -> Bool -> FilePath sometimesExeArgs :: MonadIO m => String -> String -> [Fulfillment] -> Bool
-> [String] -> Sometimes (m ()) -> FilePath -> [String] -> Sometimes (m ())
sometimesExeArgs fn n sys path args = sometimesExeArgs fn n ful sys path args =
sometimesIO_ fn n (Only_ (IOSystem_ $ Executable sys path)) $ spawnCmd path args sometimesIO_ fn n (Only_ (IOSystem_ ful $ Executable sys path)) $ spawnCmd path args
sometimesDBus :: Maybe Client -> String -> String -> Tree_ DBusDependency_ sometimesDBus :: Maybe Client -> String -> String -> Tree_ DBusDependency_
-> (Client -> a) -> Sometimes a -> (Client -> a) -> Sometimes a
sometimesDBus c fn n t x = sometimes1 fn n $ DBusRoot_ x t c sometimesDBus c fn n t x = sometimes1 fn n $ DBusRoot_ x t c
sometimesEndpoint :: MonadIO m => String -> String -> BusName -> ObjectPath -> InterfaceName sometimesEndpoint :: MonadIO m => String -> String -> [Fulfillment]
-> MemberName -> Maybe Client -> Sometimes (m ()) -> BusName -> ObjectPath -> InterfaceName -> MemberName -> Maybe Client
sometimesEndpoint fn name busname path iface mem client = -> Sometimes (m ())
sometimesDBus client fn name deps cmd sometimesEndpoint fn name ful busname path iface mem cl =
sometimesDBus cl fn name deps cmd
where 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 cmd c = io $ void $ callMethod c busname path iface mem
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
@ -1011,35 +1029,38 @@ readResult_ _ = Right []
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | IO Dependency Constructors -- | IO Dependency Constructors
exe :: Bool -> String -> IODependency_ exe :: Bool -> [Fulfillment] -> String -> IODependency_
exe b = IOSystem_ . Executable b exe b ful = IOSystem_ ful . Executable b
sysExe :: String -> IODependency_ sysExe :: [Fulfillment] -> String -> IODependency_
sysExe = exe True sysExe = exe True
localExe :: String -> IODependency_ localExe :: [Fulfillment] -> String -> IODependency_
localExe = exe False localExe = exe False
pathR :: String -> IODependency_ path' :: Bool -> Bool -> String -> [Fulfillment] -> IODependency_
pathR n = IOSystem_ $ AccessiblePath n True False path' r w n ful = IOSystem_ ful $ AccessiblePath n r w
pathW :: String -> IODependency_ pathR :: String -> [Fulfillment] -> IODependency_
pathW n = IOSystem_ $ AccessiblePath n False True pathR = path' True False
pathRW :: String -> IODependency_ pathW :: String -> [Fulfillment] -> IODependency_
pathRW n = IOSystem_ $ AccessiblePath n True True pathW = path' False True
sysd :: UnitType -> String -> IODependency_ pathRW :: String -> [Fulfillment] -> IODependency_
sysd u = IOSystem_ . Systemd u 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 sysdUser = sysd UserUnit
sysdSystem :: String -> IODependency_ sysdSystem :: [Fulfillment] -> String -> IODependency_
sysdSystem = sysd SystemUnit sysdSystem = sysd SystemUnit
process :: String -> IODependency_ process :: [Fulfillment] -> String -> IODependency_
process = IOSystem_ . Process process ful = IOSystem_ ful . Process
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Printing -- | Printing
@ -1140,7 +1161,10 @@ dataTree_ f_ = go
dataIODependency :: IODependency p -> DependencyData dataIODependency :: IODependency p -> DependencyData
dataIODependency d = first Q $ case d of 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", []) (IOConst _) -> ("const", [])
-- TODO what if this isn't required? -- TODO what if this isn't required?
(IOSometimes (Sometimes n _ _) _) -> ("sometimes", [ ("name", JSON_Q $ Q n)]) (IOSometimes (Sometimes n _ _) _) -> ("sometimes", [ ("name", JSON_Q $ Q n)])
@ -1148,41 +1172,62 @@ dataIODependency d = first Q $ case d of
dataIODependency_ :: IODependency_ -> DependencyData dataIODependency_ :: IODependency_ -> DependencyData
dataIODependency_ d = case d of dataIODependency_ d = case d of
(IOSystem_ s) -> dataSysDependency s (IOSystem_ f s) -> dataSysDependency f s
(IOSometimes_ _) -> (Q "sometimes", []) (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 :: [Fulfillment] -> SystemDependency -> DependencyData
dataSysDependency d = first Q $ dataSysDependency f d = first Q $
case d of case d of
(Executable sys path) -> ("executable", [ ("system", JSON_UQ $ jsonBool sys) (Executable sys path) -> ("executable", [ ("system", JSON_UQ $ jsonBool sys)
, ("path", JSON_Q $ Q path) , ("path", JSON_Q $ Q path)
, f'
]) ])
(AccessiblePath p r w) -> ("path", [ ("path", JSON_Q $ Q p) (AccessiblePath p r w) -> ("path", [ ("path", JSON_Q $ Q p)
, ("readable", JSON_UQ $ jsonBool r) , ("readable", JSON_UQ $ jsonBool r)
, ("writable", JSON_UQ $ jsonBool w) , ("writable", JSON_UQ $ jsonBool w)
, f'
]) ])
(Systemd t n) -> ("systemd", [ ("unittype", JSON_Q $ Q $ unitType t) (Systemd t n) -> ("systemd", [ ("unittype", JSON_Q $ Q $ unitType t)
, ("unit", JSON_Q $ Q n)]) , ("unit", JSON_Q $ Q n)
(Process n) -> ("process", [("name", 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 :: DBusDependency_ -> DependencyData
dataDBusDependency d = dataDBusDependency d =
case d of case d of
(DBusIO i) -> dataIODependency_ i (DBusIO i) -> dataIODependency_ i
(Bus b) -> (Q "bus", [("busname", JSON_Q $ Q $ formatBusName b)]) (Bus f b) -> (Q "bus", [ ("busname", JSON_Q $ Q $ formatBusName b)
(Endpoint b o i m) -> let (mt, mn) = memberData m , ("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) in (Q "endpoint", [ ("busname", JSON_Q $ Q $ formatBusName b)
, ("objectpath", JSON_Q $ Q $ formatObjectPath o) , ("objectpath", JSON_Q $ Q $ formatObjectPath o)
, ("interface", JSON_Q $ Q $ formatInterfaceName i) , ("interface", JSON_Q $ Q $ formatInterfaceName i)
, ("membertype", JSON_Q $ Q mt) , ("membertype", JSON_Q $ Q mt)
, ("membername", JSON_Q $ Q mn) , ("membername", JSON_Q $ Q mn)
, ("fulfilment", JSON_UQ $ dataFulfillments f)
]) ])
where where
memberData (Method_ n) = ("method", formatMemberName n) memberData (Method_ n) = ("method", formatMemberName n)
memberData (Signal_ n) = ("signal", formatMemberName n) memberData (Signal_ n) = ("signal", formatMemberName n)
memberData (Property_ n) = ("property", 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 -> JSONUnquotable
fromMsg (Msg e s) = jsonObject [ ("level", JSON_Q $ Q $ show e) fromMsg (Msg e s) = jsonObject [ ("level", JSON_Q $ Q $ show e)
, ("msg", JSON_Q $ Q s) , ("msg", JSON_Q $ Q s)

3
lib/Xmobar/Plugins/Bluetooth.hs
View File

@ -57,7 +57,8 @@ btAlias :: String
btAlias = "bluetooth" btAlias = "bluetooth"
btDep :: DBusDependency_ 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) data Bluetooth = Bluetooth Icons Colors deriving (Read, Show)

3
lib/Xmobar/Plugins/Device.hs
View File

@ -17,6 +17,7 @@ import DBus
import DBus.Client import DBus.Client
import DBus.Internal import DBus.Internal
import XMonad.Internal.Command.Desktop
import XMonad.Internal.Dependency import XMonad.Internal.Dependency
import Xmobar import Xmobar
import Xmobar.Plugins.Common import Xmobar.Plugins.Common
@ -42,7 +43,7 @@ devSignal :: String
devSignal = "Ip4Connectivity" devSignal = "Ip4Connectivity"
devDep :: DBusDependency_ 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 -> String -> IO (Maybe ObjectPath)
getDevice client iface = bodyToMaybe <$> callMethod' client mc getDevice client iface = bodyToMaybe <$> callMethod' client mc

4
lib/Xmobar/Plugins/VPN.hs
View File

@ -22,6 +22,7 @@ import DBus
import DBus.Client import DBus.Client
import DBus.Internal import DBus.Internal
import XMonad.Internal.Command.Desktop
import XMonad.Internal.Dependency import XMonad.Internal.Dependency
import Xmobar import Xmobar
import Xmobar.Plugins.Common import Xmobar.Plugins.Common
@ -119,4 +120,5 @@ vpnAlias :: String
vpnAlias = "vpn" vpnAlias = "vpn"
vpnDep :: DBusDependency_ vpnDep :: DBusDependency_
vpnDep = Endpoint vpnBus vpnPath omInterface $ Method_ getManagedObjects vpnDep = Endpoint networkManagerPkgs vpnBus vpnPath omInterface
$ Method_ getManagedObjects