Compare commits

..

98 Commits

Author SHA1 Message Date
Nathan Dwarshuis 51ebf01786 ENH use firefox 2024-07-07 10:28:24 -04:00
Nathan Dwarshuis c35be51dd4 FIX wifi password lookup fail 2024-03-30 17:58:24 -04:00
Nathan Dwarshuis 24430eaeb7 FIX typo 2024-03-17 18:33:15 -04:00
Nathan Dwarshuis 8a1345ae4b FIX make network toggles actually work 2024-03-17 11:15:03 -04:00
Nathan Dwarshuis a65cd669dc ENH replace urxvt with alacritty 2024-02-18 19:41:32 -05:00
Nathan Dwarshuis 3ab6ccf45b ENH don't ignore ethenet interfaces 2024-01-21 17:02:47 -05:00
Nathan Dwarshuis 8064b01c90 ENH move external scripts to this repo 2024-01-07 09:52:44 -05:00
Nathan Dwarshuis 80c3d33010 REF add note 2023-10-28 00:18:33 -04:00
Nathan Dwarshuis d9b1886db6 FIX actually the dbus client disconnect problem 2023-10-28 00:14:40 -04:00
Nathan Dwarshuis 841bf0b5c8 Merge branch 'fix_dbus' 2023-10-27 23:58:06 -04:00
Nathan Dwarshuis 87eee7a2b9 FIX dbus not closing callback connections 2023-10-27 23:57:40 -04:00
Nathan Dwarshuis cc5670f2f1 ENH use names for dbus connections 2023-10-27 23:12:22 -04:00
Nathan Dwarshuis 171fa489ca ENH update stack snapshot 2023-10-25 21:55:59 -04:00
Nathan Dwarshuis 78ba3173c3 WIP name dbus connections 2023-10-25 20:40:15 -04:00
Nathan Dwarshuis 58b68f298c FIX bluetooth being dumb 2023-10-15 21:50:46 -04:00
Nathan Dwarshuis 98e0a2943d ENH rejoice, F5 is dead 2023-10-01 01:06:02 -04:00
Nathan Dwarshuis 13ddeb3ba7 ENH use indiv logs for bluetooth devs 2023-10-01 01:02:06 -04:00
Nathan Dwarshuis 700f42d65c REF merge plugin environ 2023-10-01 00:24:33 -04:00
Nathan Dwarshuis 2f6eeb5cdb ENH use active connection plugin for both networkmanager and vpn connections 2023-09-30 23:52:52 -04:00
Nathan Dwarshuis f814ac9217 ENH show network connection names 2023-09-30 18:51:07 -04:00
Nathan Dwarshuis 0a4edb6bf2 FIX vpn not showing when no NM profiles exist 2023-09-30 12:22:30 -04:00
Nathan Dwarshuis 250d5c5eed ENH show VPN interface names 2023-09-29 23:44:08 -04:00
Nathan Dwarshuis 770f1dc1dd FIX icon fonts 2023-05-08 23:00:58 -04:00
Nathan Dwarshuis 09909ac779 ENH update fonts 2023-05-08 12:15:20 -04:00
Nathan Dwarshuis fe61b0192d ENH remove prelude from xio 2023-02-12 23:17:34 -05:00
Nathan Dwarshuis 96cb9298d7 ENH remove prelude from main bin 2023-02-12 23:13:46 -05:00
Nathan Dwarshuis 71e86f2233 REF update compiler flags 2023-02-12 23:08:05 -05:00
Nathan Dwarshuis 7d5a82bd07 ENH use new screenlocker 2023-01-17 22:46:22 -05:00
Nathan Dwarshuis 2712ebdf37 FIX file flushing errors 2023-01-04 23:47:21 -05:00
Nathan Dwarshuis 3cc7e02416 Merge branch 'fix_rio_run' 2023-01-04 13:55:31 -05:00
Nathan Dwarshuis 24f0f034f0 ENH make logger print to stderr when running test commands 2023-01-03 23:44:52 -05:00
Nathan Dwarshuis 1142732dca ENH log plugins in file 2023-01-03 23:33:08 -05:00
Nathan Dwarshuis 6c3d8c3eaf ENH use log file instead of stderr 2023-01-03 23:10:09 -05:00
Nathan Dwarshuis a61b17502d REF generalize typeclass 2023-01-03 22:32:43 -05:00
Nathan Dwarshuis 0d024ab649 REF clean up type alias 2023-01-03 22:31:29 -05:00
Nathan Dwarshuis 003b0ce937 FIX vpn state init 2023-01-03 22:28:34 -05:00
Nathan Dwarshuis a0cdcce146 ENH hold client in monad 2023-01-03 22:18:55 -05:00
Nathan Dwarshuis f95079ba5e REF undo homegrown pipe command 2023-01-02 22:20:43 -05:00
Nathan Dwarshuis f0451891b8 REF make spawnPipe clearer 2023-01-02 22:12:47 -05:00
Nathan Dwarshuis 5b2c66033a ENH fork env in child process (duh) 2023-01-02 21:39:49 -05:00
Nathan Dwarshuis 66550a08a6 WIP try dup-ing stderr from parent process 2023-01-02 21:01:12 -05:00
Nathan Dwarshuis bfa7f40818 WIP try dup-ing the read pipe to stderr 2023-01-02 20:57:07 -05:00
Nathan Dwarshuis 774fba0c71 WIP log output from child processes 2023-01-02 20:36:38 -05:00
Nathan Dwarshuis 6891238793 ENH add log contraints to spawnpipe 2023-01-02 19:55:44 -05:00
Nathan Dwarshuis 0895586cf7 FIX missed a spot 2023-01-02 19:50:44 -05:00
Nathan Dwarshuis 12b68f7377 ENH kinda generalize power prompts 2023-01-02 19:48:48 -05:00
Nathan Dwarshuis 1cf9e3e8bd ENH generalize showkyes 2023-01-02 19:44:17 -05:00
Nathan Dwarshuis 394eca3ad2 ENH generalize (most) dmenu commands 2023-01-02 19:32:12 -05:00
Nathan Dwarshuis adfbb92136 ENH generalize all desktop commands 2023-01-02 19:28:41 -05:00
Nathan Dwarshuis db7011bfd8 ENH generalize brightness exporters 2023-01-02 19:15:25 -05:00
Nathan Dwarshuis 6c23813693 REF don't derive generic unnecessarily 2023-01-02 19:15:12 -05:00
Nathan Dwarshuis 524818decf ENH generalize brightness controls 2023-01-02 18:30:17 -05:00
Nathan Dwarshuis 8eb97f3eec ENH use dbus lib for signals 2023-01-02 18:21:13 -05:00
Nathan Dwarshuis c1fef3c4c4 REF simplify 2023-01-02 18:21:09 -05:00
Nathan Dwarshuis 9ec24b63a0 ENH use rio in (one) interactive command 2023-01-02 12:33:37 -05:00
Nathan Dwarshuis b64742b925 ENH make features more mappable 2023-01-02 12:33:22 -05:00
Nathan Dwarshuis 27b32fb03e ENH use rio for vpn 2023-01-02 10:33:04 -05:00
Nathan Dwarshuis c29a43a024 ENH log when bluetooth adapter not found 2023-01-01 23:20:15 -05:00
Nathan Dwarshuis 097e4e19fc REF clean up state functions in bluetooth 2023-01-01 23:09:23 -05:00
Nathan Dwarshuis 37f607d817 REF use submonad for bluetooth state 2023-01-01 23:03:31 -05:00
Nathan Dwarshuis 9d7ca49357 ADD logger for device listener 2023-01-01 22:40:28 -05:00
Nathan Dwarshuis 69ed4839da ENH use plugin name in xmobar loggers 2023-01-01 22:29:29 -05:00
Nathan Dwarshuis cc094bb071 ADD logging for device init 2023-01-01 22:03:17 -05:00
Nathan Dwarshuis 2948610785 ADD error message for device init 2023-01-01 21:36:16 -05:00
Nathan Dwarshuis 7432a8f841 ENH log failures for bluetooth listeners 2023-01-01 21:30:07 -05:00
Nathan Dwarshuis 04a7a70747 ENH log errors when adding signal matchers 2023-01-01 20:37:06 -05:00
Nathan Dwarshuis 6848fbe01f ENH log errors when getting managed objects 2023-01-01 19:58:23 -05:00
Nathan Dwarshuis 5912e70526 ENH log errors for dbus property query 2023-01-01 19:52:01 -05:00
Nathan Dwarshuis e0913a461d ENH log internal dbus methods (kinda) 2023-01-01 19:41:46 -05:00
Nathan Dwarshuis 76011dc6d6 ENH use logging in dynamic workspace thread 2023-01-01 19:23:31 -05:00
Nathan Dwarshuis 1b4480ac3a REF rename a bunch of stuff 2023-01-01 18:33:02 -05:00
Nathan Dwarshuis 17ebd0137f ENH tweak logging 2023-01-01 18:06:48 -05:00
Nathan Dwarshuis 6b3cfd5857 REF use better naming for RIO monad 2023-01-01 15:00:40 -05:00
Nathan Dwarshuis 00f899ed9a ENH be more precise when logging child processes 2023-01-01 14:57:23 -05:00
Nathan Dwarshuis ac743daa32 ENH use exporter/unexporter for all interfaces 2023-01-01 13:32:46 -05:00
Nathan Dwarshuis b2416153e6 ENH standardize export/unexport pairs 2023-01-01 13:26:09 -05:00
Nathan Dwarshuis e0a186dd18 ENH clean up interfaces 2023-01-01 13:07:10 -05:00
Nathan Dwarshuis 2ef652ebe1 ENH don't hardcode interfaces 2023-01-01 12:49:56 -05:00
Nathan Dwarshuis 43345f8ce0 ENH use exporter/unexporter pairs 2023-01-01 12:43:54 -05:00
Nathan Dwarshuis 4afaf9af10 ENH log cleanup for xmobar and child processes 2023-01-01 12:07:43 -05:00
Nathan Dwarshuis 89eacd63aa ENH use rio logger for eventhook 2023-01-01 11:50:17 -05:00
Nathan Dwarshuis 335fa7b460 ENH use logger for usage in vbox script 2023-01-01 11:46:33 -05:00
Nathan Dwarshuis b3f07ba590 ENH use optparse for xmobar 2023-01-01 11:44:36 -05:00
Nathan Dwarshuis dea4ab6585 ENH use optparse for xmonad 2023-01-01 11:41:04 -05:00
Nathan Dwarshuis 0e1b117639 REF add comment 2023-01-01 11:20:15 -05:00
Nathan Dwarshuis 91ff25a8d2 ENH don't use putstrln for printing packages 2023-01-01 11:14:58 -05:00
Nathan Dwarshuis f875b7c71d REF remove extra theadstate 2023-01-01 00:01:06 -05:00
Nathan Dwarshuis 609048f6b6 ENH use logger in disconnect 2022-12-31 23:56:23 -05:00
Nathan Dwarshuis 4206893967 ENH log dbus name registration in function 2022-12-31 23:33:06 -05:00
Nathan Dwarshuis 745a548baf ENH enable line buffering in xmobar 2022-12-31 23:18:41 -05:00
Nathan Dwarshuis 8a217d08eb ENH don't use putstrln for errors on dbus startup 2022-12-31 23:02:50 -05:00
Nathan Dwarshuis fcb454bc29 ENH use dbus bracket with xmonad dep print 2022-12-31 22:55:32 -05:00
Nathan Dwarshuis 05f1165cc1 REF a bitty thingy 2022-12-31 22:49:46 -05:00
Nathan Dwarshuis 4951c2a35e ENH use bracket for request/release busname 2022-12-31 22:47:36 -05:00
Nathan Dwarshuis 8c20a4668d ENH use bracket dbus for xmobar tests 2022-12-31 22:33:33 -05:00
Nathan Dwarshuis 3b8c6b0f4f ENH use dbus bracket for xmobar 2022-12-31 22:31:23 -05:00
Nathan Dwarshuis a997cac7a3 ENH run all of xmobar in rio 2022-12-31 22:24:20 -05:00
Nathan Dwarshuis f6c0596716 ENH use rio for xmobar plugins 2022-12-31 22:22:36 -05:00
49 changed files with 1912 additions and 1315 deletions

View File

@ -1,6 +1,3 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
-- | Start a VirtualBox instance with a sentinel wrapper process. -- | Start a VirtualBox instance with a sentinel wrapper process.
-- --
-- The only reason why this is needed is because I want to manage virtualboxes -- The only reason why this is needed is because I want to manage virtualboxes
@ -43,7 +40,7 @@ runAndWait [n] = do
p <- vmPID i p <- vmPID i
liftIO $ mapM_ waitUntilExit p liftIO $ mapM_ waitUntilExit p
err = logError "Could not get machine ID" err = logError "Could not get machine ID"
runAndWait _ = liftIO $ putStrLn "Usage: vbox-start VBOXNAME" runAndWait _ = logInfo "Usage: vbox-start VBOXNAME"
vmLaunch :: T.Text -> RIO SimpleApp () vmLaunch :: T.Text -> RIO SimpleApp ()
vmLaunch i = do vmLaunch i = do

View File

@ -1,5 +1,3 @@
{-# LANGUAGE OverloadedStrings #-}
-- | Xmobar binary -- | Xmobar binary
-- --
-- Features: -- Features:
@ -12,16 +10,15 @@
module Main (main) where module Main (main) where
import Data.Internal.DBus import Data.Internal.DBus
import Data.Internal.Dependency import Data.Internal.XIO
import GHC.Enum (enumFrom)
import Options.Applicative
import RIO hiding (hFlush) import RIO hiding (hFlush)
import qualified RIO.ByteString.Lazy as BL import RIO.FilePath
import RIO.List import RIO.List
import RIO.Process import qualified RIO.NonEmpty as NE
import qualified RIO.Text as T import qualified RIO.Text as T
import System.IO
import UnliftIO.Environment
import XMonad.Core hiding (config) import XMonad.Core hiding (config)
import XMonad.Internal.Command.Desktop
import XMonad.Internal.Command.Power 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
@ -32,32 +29,58 @@ import Xmobar hiding
( iconOffset ( iconOffset
, run , run
) )
import Xmobar.Plugins.ActiveConnection
import Xmobar.Plugins.Bluetooth import Xmobar.Plugins.Bluetooth
import Xmobar.Plugins.ClevoKeyboard import Xmobar.Plugins.ClevoKeyboard
import Xmobar.Plugins.Common import Xmobar.Plugins.Common
import Xmobar.Plugins.Device
import Xmobar.Plugins.IntelBacklight import Xmobar.Plugins.IntelBacklight
import Xmobar.Plugins.Screensaver import Xmobar.Plugins.Screensaver
import Xmobar.Plugins.VPN
main :: IO () main :: IO ()
main = getArgs >>= parse main = parse >>= xio
parse :: [String] -> IO () parse :: IO XOpts
parse [] = run parse = execParser opts
parse ["--deps"] = withCache printDeps where
parse ["--test"] = withCache $ withDBus_ evalConfig parseOpts = parseDeps <|> parseTest <|> pure XRun
parse _ = usage opts =
info (parseOpts <**> helper) $
fullDesc <> header "xmobar: the best taskbar ever"
run :: IO () data XOpts = XDeps | XTest | XRun
run = withCache $ withDBus_ $ \db -> do
c <- evalConfig db
-- this is needed to see any printed messages
liftIO $ do
hFlush stdout
xmobar c
evalConfig :: DBusState -> FIO Config parseDeps :: Parser XOpts
parseDeps =
flag'
XDeps
(long "deps" <> short 'd' <> help "print dependencies")
parseTest :: Parser XOpts
parseTest =
flag'
XTest
(long "test" <> short 't' <> help "test dependencies without running")
xio :: XOpts -> IO ()
xio o = case o of
XDeps -> hRunXIO False stderr printDeps
XTest -> hRunXIO False stderr $ withDBus_ Nothing Nothing evalConfig
XRun -> runXIO "xmobar.log" run
run :: XIO ()
run = do
-- IDK why this is needed, I thought this was default
liftIO $ hSetBuffering stdout LineBuffering
-- this isn't totally necessary except for the fact that killing xmobar
-- will make it print something about catching SIGTERM, and without
-- linebuffering it usually only prints the first few characters (even then
-- it only prints 10-20% of the time)
liftIO $ hSetBuffering stderr LineBuffering
-- TODO do these dbus things really need to remain connected?
c <- withDBus Nothing Nothing evalConfig
liftIO $ xmobar c
evalConfig :: DBusState -> XIO Config
evalConfig db = do evalConfig db = do
cs <- getAllCommands <$> rightPlugins db cs <- getAllCommands <$> rightPlugins db
bf <- getTextFont bf <- getTextFont
@ -65,19 +88,14 @@ evalConfig db = do
d <- io $ cfgDir <$> getDirectories d <- io $ cfgDir <$> getDirectories
return $ config bf ifs ios cs d return $ config bf ifs ios cs d
printDeps :: FIO () printDeps :: XIO ()
printDeps = withDBus_ $ \db -> do printDeps = withDBus_ Nothing Nothing $ \db ->
let ps = sort $ nub $ fmap showFulfillment $ concatMap dumpFeature $ allFeatures db mapM_ logInfo $
io $ mapM_ (putStrLn . T.unpack) ps fmap showFulfillment $
sort $
usage :: IO () nub $
usage = concatMap dumpFeature $
putStrLn $ allFeatures db
intercalate
"\n"
[ "xmobar: run greatest taskbar"
, "xmobar --deps: print dependencies"
]
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- toplevel configuration -- toplevel configuration
@ -100,7 +118,7 @@ iconFont =
fontSometimes fontSometimes
"XMobar Icon Font" "XMobar Icon Font"
"Symbols Nerd Font" "Symbols Nerd Font"
[Package Official "ttf-nerd-fonts-symbols-2048-em"] [Package Official "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
@ -146,7 +164,7 @@ config bf ifs ios br confDir =
, pickBroadest = False , pickBroadest = False
, persistent = True , persistent = True
, -- store the icons with the xmonad/xmobar stack project , -- store the icons with the xmonad/xmobar stack project
iconRoot = confDir ++ "/icons" iconRoot = confDir </> "assets" </> "icons"
, commands = csRunnable <$> concatRegions br , commands = csRunnable <$> concatRegions br
} }
@ -169,7 +187,7 @@ getAllCommands right =
, brRight = catMaybes right , brRight = catMaybes right
} }
rightPlugins :: DBusState -> FIO [Maybe CmdSpec] rightPlugins :: DBusState -> XIO [Maybe CmdSpec]
rightPlugins db = rightPlugins db =
mapM evalFeature $ mapM evalFeature $
allFeatures db allFeatures db
@ -201,11 +219,11 @@ getWireless =
xpfWireless xpfWireless
[Subfeature (IORoot wirelessCmd $ Only readWireless) "sysfs path"] [Subfeature (IORoot wirelessCmd $ Only readWireless) "sysfs path"]
getEthernet :: Maybe SysClient -> BarFeature getEthernet :: Maybe NamedSysConnection -> BarFeature
getEthernet cl = iconDBus "ethernet status indicator" xpfEthernet root tree getEthernet cl = iconDBus_ "ethernet status indicator" xpfEthernet root (Only_ devDep)
where where
root useIcon tree' = DBusRoot (const . ethernetCmd useIcon) tree' cl root useIcon tree' =
tree = And1 (Only readEthernet) (Only_ devDep) DBusRoot_ (const $ ethernetCmd useIcon) tree' cl
getBattery :: BarFeature getBattery :: BarFeature
getBattery = iconIO_ "battery level indicator" xpfBattery root tree getBattery = iconIO_ "battery level indicator" xpfBattery root tree
@ -217,18 +235,12 @@ getBattery = iconIO_ "battery level indicator" xpfBattery root tree
io $ io $
fmap (Msg LevelError) <$> hasBattery fmap (Msg LevelError) <$> hasBattery
getVPN :: Maybe SysClient -> BarFeature getVPN :: Maybe NamedSysConnection -> BarFeature
getVPN cl = iconDBus_ "VPN status indicator" xpfVPN root $ toAnd_ vpnDep test getVPN cl = iconDBus_ "VPN status indicator" xpfVPN root (Only_ devDep)
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"
networkManagerPkgs
vpnPresent
getBt :: Maybe SysClient -> BarFeature getBt :: Maybe NamedSysConnection -> BarFeature
getBt = xmobarDBus "bluetooth status indicator" xpfBluetooth btDep btCmd getBt = xmobarDBus "bluetooth status indicator" xpfBluetooth btDep btCmd
getAlsa :: BarFeature getAlsa :: BarFeature
@ -239,7 +251,7 @@ getAlsa =
where where
root useIcon = IORoot_ (alsaCmd useIcon) root useIcon = IORoot_ (alsaCmd useIcon)
getBl :: Maybe SesClient -> BarFeature getBl :: Maybe NamedSesConnection -> BarFeature
getBl = getBl =
xmobarDBus xmobarDBus
"Intel backlight indicator" "Intel backlight indicator"
@ -247,7 +259,7 @@ getBl =
intelBacklightSignalDep intelBacklightSignalDep
blCmd blCmd
getCk :: Maybe SesClient -> BarFeature getCk :: Maybe NamedSesConnection -> BarFeature
getCk = getCk =
xmobarDBus xmobarDBus
"Clevo keyboard indicator" "Clevo keyboard indicator"
@ -255,7 +267,7 @@ getCk =
clevoKeyboardSignalDep clevoKeyboardSignalDep
ckCmd ckCmd
getSs :: Maybe SesClient -> BarFeature getSs :: Maybe NamedSesConnection -> BarFeature
getSs = xmobarDBus "screensaver indicator" (const True) ssSignalDep ssCmd getSs = xmobarDBus "screensaver indicator" (const True) ssSignalDep ssCmd
getLock :: Always CmdSpec getLock :: Always CmdSpec
@ -272,7 +284,7 @@ xmobarDBus
-> XPQuery -> XPQuery
-> DBusDependency_ c -> DBusDependency_ c
-> (Fontifier -> CmdSpec) -> (Fontifier -> CmdSpec)
-> Maybe c -> Maybe (NamedConnection c)
-> BarFeature -> BarFeature
xmobarDBus n q dep cmd cl = iconDBus_ n q root (Only_ dep) xmobarDBus n q dep cmd cl = iconDBus_ n q root (Only_ dep)
where where
@ -286,18 +298,16 @@ iconIO_
-> BarFeature -> BarFeature
iconIO_ = iconSometimes' And_ Only_ iconIO_ = iconSometimes' And_ Only_
iconDBus -- iconDBus
:: SafeClient c -- :: T.Text
=> T.Text -- -> XPQuery
-> XPQuery -- -> (Fontifier -> DBusTree c p -> Root CmdSpec)
-> (Fontifier -> DBusTree c p -> Root CmdSpec) -- -> DBusTree c p
-> DBusTree c p -- -> BarFeature
-> BarFeature -- iconDBus = iconSometimes' And1 $ Only_ . DBusIO
iconDBus = iconSometimes' And1 $ Only_ . DBusIO
iconDBus_ iconDBus_
:: SafeClient c :: T.Text
=> T.Text
-> XPQuery -> XPQuery
-> (Fontifier -> DBusTree_ c -> Root CmdSpec) -> (Fontifier -> DBusTree_ c -> Root CmdSpec)
-> DBusTree_ c -> DBusTree_ c
@ -359,13 +369,19 @@ wirelessCmd iface =
, "<icon=wifi_%%.xpm/>" , "<icon=wifi_%%.xpm/>"
] ]
ethernetCmd :: Fontifier -> T.Text -> CmdSpec ethernetCmd :: Fontifier -> CmdSpec
ethernetCmd fontify iface = ethernetCmd = connCmd "\xf0e8" "ETH" ("vlan" :| ["802-3-ethernet"])
vpnCmd :: Fontifier -> CmdSpec
vpnCmd = connCmd "\xf023" "VPN" ("tun" :| [])
connCmd :: T.Text -> T.Text -> NE.NonEmpty T.Text -> Fontifier -> CmdSpec
connCmd icon abbr contypes fontify =
CmdSpec CmdSpec
{ csAlias = iface { csAlias = connAlias contypes
, csRunnable = , csRunnable =
Run $ Run $
Device (iface, fontify IconMedium "\xf0e8" "ETH", colors) ActiveConnection (contypes, fontify IconMedium icon abbr, colors)
} }
batteryCmd :: Fontifier -> CmdSpec batteryCmd :: Fontifier -> CmdSpec
@ -401,20 +417,13 @@ batteryCmd fontify =
, fontify' "\xf1e6" "AC" , fontify' "\xf1e6" "AC"
] ]
vpnCmd :: Fontifier -> CmdSpec
vpnCmd fontify =
CmdSpec
{ csAlias = vpnAlias
, csRunnable = Run $ VPN (fontify IconMedium "\xf023" "VPN", colors)
}
btCmd :: Fontifier -> CmdSpec btCmd :: Fontifier -> CmdSpec
btCmd fontify = btCmd fontify =
CmdSpec CmdSpec
{ csAlias = btAlias { csAlias = btAlias
, csRunnable = , csRunnable =
Run $ Run $
Bluetooth (fontify' "\xf5b0" "+", fontify' "\xf5ae" "-") colors Bluetooth (fontify' "\x0f00b1" "+", fontify' "\x0f00af" "-") colors
} }
where where
fontify' i = fontify IconLarge i . T.append "BT" fontify' i = fontify IconLarge i . T.append "BT"
@ -455,7 +464,7 @@ ckCmd :: Fontifier -> CmdSpec
ckCmd fontify = ckCmd fontify =
CmdSpec CmdSpec
{ csAlias = ckAlias { csAlias = ckAlias
, csRunnable = Run $ ClevoKeyboard $ fontify IconSmall "\xf40b" "KB: " , csRunnable = Run $ ClevoKeyboard $ fontify IconSmall "\xf11c" "KB: "
} }
ssCmd :: Fontifier -> CmdSpec ssCmd :: Fontifier -> CmdSpec
@ -491,8 +500,8 @@ lockCmd fontify =
] ]
} }
where where
numIcon = fontify' "\xf8a5" "N" numIcon = fontify' "\x0f03a6" "N"
capIcon = fontify' "\xf657" "C" capIcon = fontify' "\x0f0bf1" "C"
fontify' = fontify IconXLarge fontify' = fontify IconXLarge
disabledColor = xmobarFGColor XT.backdropFgColor disabledColor = xmobarFGColor XT.backdropFgColor
@ -503,36 +512,13 @@ dateCmd =
, csRunnable = Run $ Date "%Y-%m-%d %H:%M:%S " "date" 10 , csRunnable = Run $ Date "%Y-%m-%d %H:%M:%S " "date" 10
} }
--------------------------------------------------------------------------------
-- low-level testing functions
vpnPresent :: FIO (Maybe Msg)
vpnPresent = do
res <- proc "nmcli" args readProcess
return $ case res of
(ExitSuccess, out, _)
| "vpn" `elem` BL.split 10 out -> Nothing
| otherwise -> Just $ Msg LevelError "vpn not found"
(ExitFailure c, _, err) ->
Just $
Msg LevelError $
T.concat
[ "vpn search exited with code "
, T.pack $ show c
, ": "
, T.decodeUtf8With T.lenientDecode $
BL.toStrict err
]
where
args = ["-c", "no", "-t", "-f", "TYPE", "c", "show"]
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- text font -- text font
-- --
-- ASSUME there is only one text font for this entire configuration. This -- ASSUME there is only one text font for this entire configuration. This
-- will correspond to the first font/offset parameters in the config record. -- will correspond to the first font/offset parameters in the config record.
getTextFont :: FIO T.Text getTextFont :: XIO T.Text
getTextFont = do getTextFont = do
fb <- evalAlways textFont fb <- evalAlways textFont
return $ fb textFontData return $ fb textFontData
@ -540,7 +526,7 @@ getTextFont = do
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- icon fonts -- icon fonts
getIconFonts :: FIO ([T.Text], [Int]) getIconFonts :: XIO ([T.Text], [Int])
getIconFonts = do getIconFonts = do
fb <- evalSometimes iconFont fb <- evalSometimes iconFont
return $ maybe ([], []) apply fb return $ maybe ([], []) apply fb

View File

@ -1,20 +1,16 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- XMonad binary -- XMonad binary
module Main (main) where module Main (main) where
import Data.Internal.DBus import Data.Internal.DBus
import Data.Internal.Dependency import Data.Internal.XIO
import Data.Monoid import Data.Monoid
import Data.Text.IO (hPutStrLn) import Data.Text.IO (hPutStrLn)
import Graphics.X11.Types import Graphics.X11.Types
import Graphics.X11.Xlib.Atom import Graphics.X11.Xlib.Atom
import Graphics.X11.Xlib.Extras import Graphics.X11.Xlib.Extras
import Options.Applicative hiding (action)
import RIO import RIO
import RIO.Directory import RIO.Directory
import RIO.List import RIO.List
@ -25,8 +21,7 @@ import System.Process
( getPid ( getPid
, getProcessExitCode , getProcessExitCode
) )
import UnliftIO.Environment import XMonad hiding (display)
import XMonad
import XMonad.Actions.CopyWindow import XMonad.Actions.CopyWindow
import XMonad.Actions.CycleWS import XMonad.Actions.CycleWS
import XMonad.Actions.PhysicalScreens import XMonad.Actions.PhysicalScreens
@ -50,6 +45,7 @@ import XMonad.Internal.DBus.Removable
import XMonad.Internal.DBus.Screensaver import XMonad.Internal.DBus.Screensaver
import XMonad.Internal.Shell hiding (proc) import XMonad.Internal.Shell hiding (proc)
import qualified XMonad.Internal.Theme as XT import qualified XMonad.Internal.Theme as XT
import XMonad.Layout.Decoration
import XMonad.Layout.MultiToggle import XMonad.Layout.MultiToggle
import XMonad.Layout.NoBorders import XMonad.Layout.NoBorders
import XMonad.Layout.NoFrillsDecoration import XMonad.Layout.NoFrillsDecoration
@ -65,15 +61,37 @@ import XMonad.Util.NamedActions
import XMonad.Util.WorkspaceCompare import XMonad.Util.WorkspaceCompare
main :: IO () main :: IO ()
main = getArgs >>= parse main = parse >>= xio
parse :: [String] -> IO () parse :: IO XOpts
parse [] = run parse = execParser opts
parse ["--deps"] = withCache printDeps where
-- parse ["--test"] = void $ withCache . evalConf =<< connectDBusX parseOpts = parseDeps <|> parseTest <|> pure XRun
parse _ = usage opts =
info (parseOpts <**> helper) $
fullDesc <> header "xmonad: the best window manager ever"
run :: IO () data XOpts = XDeps | XTest | XRun
parseDeps :: Parser XOpts
parseDeps =
flag'
XDeps
(long "deps" <> short 'd' <> help "print dependencies")
parseTest :: Parser XOpts
parseTest =
flag'
XTest
(long "test" <> short 't' <> help "test dependencies without running")
xio :: XOpts -> IO ()
xio o = case o of
XDeps -> hRunXIO False stderr printDeps
XTest -> undefined
XRun -> runXIO "xmonad.log" run
run :: XIO ()
run = do run = do
-- These first two commands are only significant when xmonad is restarted. -- These first two commands are only significant when xmonad is restarted.
-- The 'launch' function below this will turn off buffering (so flushes are -- The 'launch' function below this will turn off buffering (so flushes are
@ -88,31 +106,31 @@ run = do
-- signal handlers to carry over to the top. -- signal handlers to carry over to the top.
uninstallSignalHandlers uninstallSignalHandlers
hSetBuffering stdout LineBuffering hSetBuffering stdout LineBuffering
withCache $ do withDBusX_ $ \db -> do
withDBusX_ $ \db -> do let fs = features $ dbSysClient db
let sys = dbSysClient db withDBusInterfaces db (fsDBusExporters fs) $ \unexporters -> do
let fs = features sys
startDBusInterfaces db fs
withXmobar $ \xmobarP -> do withXmobar $ \xmobarP -> do
withChildDaemons fs $ \ds -> do withChildDaemons fs $ \ds -> do
let ts = ThreadState ds (Just xmobarP) let toClean = Cleanup ds (Just xmobarP) unexporters
startRemovableMon db fs void $ executeSometimes $ fsRemovableMon fs $ dbSysClient db
startPowerMon fs void $ async $ void $ executeSometimes $ fsPowerMon fs
dws <- startDynWorkspaces fs dws <- startDynWorkspaces fs
kbs <- filterExternal <$> evalExternal (fsKeys fs ts db) runIO <- askRunInIO
let cleanup = runCleanup runIO toClean db
kbs <- filterExternal <$> evalExternal (fsKeys fs runIO cleanup db)
sk <- evalAlways $ fsShowKeys fs sk <- evalAlways $ fsShowKeys fs
ha <- evalAlways $ fsACPIHandler fs ha <- evalAlways $ fsACPIHandler fs
tt <- evalAlways $ fsTabbedTheme fs tt <- evalAlways $ fsTabbedTheme fs
let conf = let conf =
ewmh $ ewmh $
addKeymap dws sk kbs $ addKeymap dws (liftIO . runIO . sk) kbs $
docks $ docks $
def def
{ terminal = myTerm { terminal = myTerm
, modMask = myModMask , modMask = myModMask
, layoutHook = myLayouts tt , layoutHook = myLayouts tt
, manageHook = myManageHook dws , manageHook = myManageHook dws
, handleEventHook = myEventHook ha , handleEventHook = myEventHook runIO ha
, startupHook = myStartupHook , startupHook = myStartupHook
, workspaces = myWorkspaces , workspaces = myWorkspaces
, logHook = myLoghook xmobarP , logHook = myLoghook xmobarP
@ -121,32 +139,21 @@ run = do
, normalBorderColor = T.unpack XT.bordersColor , normalBorderColor = T.unpack XT.bordersColor
, focusedBorderColor = T.unpack XT.selectedBordersColor , focusedBorderColor = T.unpack XT.selectedBordersColor
} }
io $ runXMonad conf runXMonad conf
where where
startRemovableMon db fs =
void $
executeSometimes $
fsRemovableMon fs $
dbSysClient db
startPowerMon fs = void $ async $ void $ executeSometimes $ fsPowerMon fs
startDynWorkspaces fs = do startDynWorkspaces fs = do
dws <- catMaybes <$> mapM evalSometimes (fsDynWorkspaces fs) dws <- catMaybes <$> mapM evalSometimes (fsDynWorkspaces fs)
void $ io $ async $ runWorkspaceMon dws void $ async $ runWorkspaceMon dws
return dws return dws
runXMonad :: (LayoutClass l Window, Read (l Window)) => XConfig l -> IO () runXMonad :: (LayoutClass l Window, Read (l Window)) => XConfig l -> XIO ()
runXMonad conf = do runXMonad conf = do
dirs <- getCreateDirectories dirs <- getCreateDirectories
launch conf dirs liftIO $ launch conf dirs
startDBusInterfaces :: DBusState -> FeatureSet -> FIO () getCreateDirectories :: XIO Directories
startDBusInterfaces db fs =
mapM_ (\f -> executeSometimes $ f $ dbSesClient db) $
fsDBusExporters fs
getCreateDirectories :: IO Directories
getCreateDirectories = do getCreateDirectories = do
ds <- getDirectories ds <- liftIO getDirectories
mapM_ (createIfMissing ds) [dataDir, cfgDir, cacheDir] mapM_ (createIfMissing ds) [dataDir, cfgDir, cacheDir]
return ds return ds
where where
@ -154,19 +161,19 @@ getCreateDirectories = do
let d = f ds let d = f ds
r <- tryIO $ createDirectoryIfMissing True d r <- tryIO $ createDirectoryIfMissing True d
case r of case r of
(Left e) -> print e (Left e) -> logError $ display e
_ -> return () _ -> return ()
data FeatureSet = FeatureSet data FeatureSet = FeatureSet
{ fsKeys :: ThreadState -> DBusState -> [KeyGroup FeatureX] { fsKeys :: (XIO () -> IO ()) -> X () -> DBusState -> [KeyGroup FeatureX]
, fsDBusExporters :: [Maybe SesClient -> SometimesIO] , fsDBusExporters :: [Maybe NamedSesConnection -> Sometimes (XIO (), XIO ())]
, fsPowerMon :: SometimesIO , fsPowerMon :: SometimesIO
, fsRemovableMon :: Maybe SysClient -> SometimesIO , fsRemovableMon :: Maybe NamedSysConnection -> SometimesIO
, fsDaemons :: [Sometimes (FIO (Process () () ()))] , fsDaemons :: [Sometimes (XIO (Process () () ()))]
, fsACPIHandler :: Always (String -> X ()) , fsACPIHandler :: Always (String -> X ())
, fsTabbedTheme :: Always Theme , fsTabbedTheme :: Always Theme
, fsDynWorkspaces :: [Sometimes DynWorkspace] , fsDynWorkspaces :: [Sometimes DynWorkspace]
, fsShowKeys :: Always ([((KeyMask, KeySym), NamedAction)] -> X ()) , fsShowKeys :: Always ([((KeyMask, KeySym), NamedAction)] -> XIO ())
} }
tabbedFeature :: Always Theme tabbedFeature :: Always Theme
@ -176,7 +183,7 @@ tabbedFeature = Always "theme for tabbed windows" $ Option sf fallback
niceTheme = IORoot XT.tabbedTheme $ fontTree XT.defFontFamily defFontPkgs niceTheme = IORoot XT.tabbedTheme $ fontTree XT.defFontFamily defFontPkgs
fallback = Always_ $ FallbackAlone $ XT.tabbedTheme XT.fallbackFont fallback = Always_ $ FallbackAlone $ XT.tabbedTheme XT.fallbackFont
features :: Maybe SysClient -> FeatureSet features :: Maybe NamedSysConnection -> FeatureSet
features cl = features cl =
FeatureSet FeatureSet
{ fsKeys = externalBindings { fsKeys = externalBindings
@ -190,8 +197,12 @@ features cl =
, fsDaemons = [runNetAppDaemon cl, runAutolock] , fsDaemons = [runNetAppDaemon cl, runAutolock]
} }
startXmobar :: FIO (Process Handle () ()) withXmobar :: (Process Handle () () -> XIO a) -> XIO a
withXmobar = bracket startXmobar stopXmobar
startXmobar :: XIO (Process Handle () ())
startXmobar = do startXmobar = do
logInfo "starting xmobar child process"
p <- proc "xmobar" [] start p <- proc "xmobar" [] start
io $ hSetBuffering (getStdin p) LineBuffering io $ hSetBuffering (getStdin p) LineBuffering
return p return p
@ -201,66 +212,87 @@ startXmobar = do
. setStdin createPipe . setStdin createPipe
. setCreateGroup True . setCreateGroup True
startChildDaemons :: FeatureSet -> FIO [Process () () ()] stopXmobar
startChildDaemons fs = catMaybes <$> mapM executeSometimes (fsDaemons fs) :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
=> Process Handle () ()
-> m ()
stopXmobar p = do
logInfo "stopping xmobar child process"
io $ killNoWait p
withChildDaemons :: FeatureSet -> ([Process () () ()] -> FIO a) -> FIO a withChildDaemons
withChildDaemons fs = bracket (startChildDaemons fs) cleanup :: FeatureSet
-> ([(Utf8Builder, Process () () ())] -> XIO a)
-> XIO a
withChildDaemons fs = bracket (startChildDaemons fs) stopChildDaemons
startChildDaemons :: FeatureSet -> XIO [(Utf8Builder, Process () () ())]
startChildDaemons fs = catMaybes <$> mapM start (fsDaemons fs)
where where
cleanup ps = do start s@(Sometimes sname _ _) = do
logInfo "stopping child processes" let sname_ = Utf8Builder $ encodeUtf8Builder sname
mapM_ (io . killNoWait) ps res <- executeSometimes s
case res of
Just p -> do
logInfo $ "starting child process: " <> sname_
return $ Just (sname_, p)
-- don't log anything here since presumably the feature itself will log
-- an error if it fails during execution
_ -> return Nothing
withXmobar :: (Process Handle () () -> FIO a) -> FIO a stopChildDaemons
withXmobar = bracket startXmobar cleanup :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
=> [(Utf8Builder, Process () () ())]
-> m ()
stopChildDaemons = mapM_ stop
where where
cleanup p = do stop (n, p) = do
logInfo "stopping xmobar child process" logInfo $ "stopping child process: " <> n
io $ killNoWait p liftIO $ killNoWait p
printDeps :: FIO () printDeps :: XIO ()
printDeps = withDBus_ $ \db -> do printDeps = withDBus_ Nothing Nothing $ \db -> do
(i, f, d) <- allFeatures db runIO <- askRunInIO
mapM_ (liftIO . putStrLn . T.unpack) $ let mockCleanup = runCleanup runIO mockClean db
let bfs =
concatMap (fmap kbMaybeAction . kgBindings) $
externalBindings runIO mockCleanup db
let dbus =
fmap (\f -> f $ dbSesClient db) dbusExporters
:: [Sometimes (XIO (), XIO ())]
let others = [runRemovableMon $ dbSysClient db, runPowermon]
-- TODO might be better to use glog for this?
mapM_ logInfo $
fmap showFulfillment $ fmap showFulfillment $
sort $ sort $
nub $ nub $
concat $ concat $
fmap dumpFeature f ++ fmap dumpSometimes i ++ fmap dumpSometimes d fmap dumpSometimes dbus
++ fmap dumpSometimes others
allFeatures :: DBusState -> FIO ([SometimesIO], [FeatureX], [Sometimes DynWorkspace]) ++ fmap dumpSometimes allDWs'
allFeatures db = do ++ fmap dumpFeature bfs
let bfs =
concatMap (fmap kbMaybeAction . kgBindings) $
externalBindings ts db
let dbus = fmap (\f -> f $ dbSesClient db) dbusExporters
let others = [runRemovableMon $ dbSysClient db, runPowermon]
return (dbus ++ others, Left runScreenLock : bfs, allDWs')
where where
ts = ThreadState {tsChildPIDs = [], tsXmobar = Nothing} mockClean = Cleanup {clChildren = [], clXmobar = Nothing, clDBusUnexporters = []}
usage :: IO ()
usage =
putStrLn $
intercalate
"\n"
[ "xmonad: run greatest window manager"
, "xmonad --deps: print dependencies"
]
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- Concurrency configuration -- Concurrency configuration
data ThreadState = ThreadState data Cleanup = Cleanup
{ tsChildPIDs :: [Process () () ()] { clChildren :: [(Utf8Builder, Process () () ())]
, tsXmobar :: Maybe (Process Handle () ()) , clXmobar :: Maybe (Process Handle () ())
, clDBusUnexporters :: [XIO ()]
} }
runCleanup :: ThreadState -> DBusState -> X () runCleanup
runCleanup ts db = io $ do :: (XIO () -> IO ())
mapM_ killNoWait $ tsXmobar ts -> Cleanup
mapM_ killNoWait $ tsChildPIDs ts -> DBusState
disconnectDBusX db -> X ()
runCleanup runIO ts db = liftIO $ runIO $ do
mapM_ stopXmobar $ clXmobar ts
stopChildDaemons $ clChildren ts
sequence_ $ clDBusUnexporters ts
disconnectDBus db
-- | Kill a process (group) after xmonad has already started -- | Kill a process (group) after xmonad has already started
-- This is necessary (as opposed to 'stopProcess' from rio) because a) xmonad -- This is necessary (as opposed to 'stopProcess' from rio) because a) xmonad
@ -313,9 +345,6 @@ vmTag = "VM"
xsaneTag :: String xsaneTag :: String
xsaneTag = "XSANE" xsaneTag = "XSANE"
f5Tag :: String
f5Tag = "F5VPN"
gimpDynamicWorkspace :: Sometimes DynWorkspace gimpDynamicWorkspace :: Sometimes DynWorkspace
gimpDynamicWorkspace = sometimesIO_ "gimp workspace" "gimp" tree dw gimpDynamicWorkspace = sometimesIO_ "gimp workspace" "gimp" tree dw
where where
@ -388,31 +417,11 @@ xsaneDynamicWorkspace =
} }
c = "Xsane" c = "Xsane"
f5vpnDynamicWorkspace :: Sometimes DynWorkspace
f5vpnDynamicWorkspace =
Sometimes
"F5 VPN workspace"
xpfF5VPN
[Subfeature (IORoot_ dw tree) "f5vpn"]
where
tree = Only_ $ sysExe [Package AUR "f5vpn"] "f5vpn"
dw =
DynWorkspace
{ dwName = "F5Vpn"
, dwTag = f5Tag
, dwClass = c
, dwHook = [className =? c -?> appendShift f5Tag]
, dwKey = 'i'
, dwCmd = Just skip
}
c = "F5 VPN"
allDWs' :: [Sometimes DynWorkspace] allDWs' :: [Sometimes DynWorkspace]
allDWs' = allDWs' =
[ xsaneDynamicWorkspace [ xsaneDynamicWorkspace
, vmDynamicWorkspace , vmDynamicWorkspace
, gimpDynamicWorkspace , gimpDynamicWorkspace
, f5vpnDynamicWorkspace
] ]
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
@ -427,6 +436,10 @@ myLayouts tt =
mkToggle (single HIDE) $ mkToggle (single HIDE) $
tall ||| fulltab ||| full tall ||| fulltab ||| full
where where
addTopBar
:: (Eq a)
=> l a
-> ModifiedLayout (Decoration NoFrillsDecoration DefaultShrinker) l a
addTopBar = noFrillsDeco shrinkText tt addTopBar = noFrillsDeco shrinkText tt
tall = tall =
renamed [Replace "Tall"] $ renamed [Replace "Tall"] $
@ -609,20 +622,30 @@ manageApps dws =
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- Eventhook configuration -- Eventhook configuration
myEventHook :: (String -> X ()) -> Event -> X All myEventHook
myEventHook handler = xMsgEventHook handler <+> handleEventHook def :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
=> (m () -> IO ())
-> (String -> X ())
-> Event
-> X All
myEventHook runIO handler = xMsgEventHook runIO handler <+> handleEventHook def
-- | React to ClientMessage events from concurrent threads -- | React to ClientMessage events from concurrent threads
xMsgEventHook :: (String -> X ()) -> Event -> X All xMsgEventHook
xMsgEventHook handler ClientMessageEvent {ev_message_type = t, ev_data = d} :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
=> (m () -> IO ())
-> (String -> X ())
-> Event
-> X All
xMsgEventHook runIO handler ClientMessageEvent {ev_message_type = t, ev_data = d}
| t == bITMAP = do | t == bITMAP = do
let (xtype, tag) = splitXMsg d let (xtype, tag) = splitXMsg d
case xtype of case xtype of
Workspace -> removeDynamicWorkspace tag Workspace -> removeDynamicWorkspace tag
ACPI -> handler tag ACPI -> handler tag
Unknown -> io $ putStrLn "WARNING: unknown concurrent message" Unknown -> liftIO $ runIO $ logWarn "unknown concurrent message"
return (All True) return (All True)
xMsgEventHook _ _ = return (All True) xMsgEventHook _ _ _ = return (All True)
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- Keymap configuration -- Keymap configuration
@ -725,13 +748,13 @@ data KeyGroup a = KeyGroup
, kgBindings :: [KeyBinding a] , kgBindings :: [KeyBinding a]
} }
evalExternal :: [KeyGroup FeatureX] -> FIO [KeyGroup MaybeX] evalExternal :: [KeyGroup FeatureX] -> XIO [KeyGroup MaybeX]
evalExternal = mapM go evalExternal = mapM go
where where
go k@KeyGroup {kgBindings = bs} = go k@KeyGroup {kgBindings = bs} =
(\bs' -> k {kgBindings = bs'}) <$> mapM evalKeyBinding bs (\bs' -> k {kgBindings = bs'}) <$> mapM evalKeyBinding bs
evalKeyBinding :: KeyBinding FeatureX -> FIO (KeyBinding MaybeX) evalKeyBinding :: KeyBinding FeatureX -> XIO (KeyBinding MaybeX)
evalKeyBinding k@KeyBinding {kbMaybeAction = a} = evalKeyBinding k@KeyBinding {kbMaybeAction = a} =
(\f -> k {kbMaybeAction = f}) <$> evalFeature a (\f -> k {kbMaybeAction = f}) <$> evalFeature a
@ -746,52 +769,52 @@ filterExternal = fmap go
] ]
} }
externalBindings :: ThreadState -> DBusState -> [KeyGroup FeatureX] externalBindings :: (XIO () -> IO ()) -> X () -> DBusState -> [KeyGroup FeatureX]
externalBindings ts db = externalBindings runIO cleanup db =
[ KeyGroup [ KeyGroup
"Launchers" "Launchers"
[ KeyBinding "<XF86Search>" "select/launch app" $ Left runAppMenu [ KeyBinding "<XF86Search>" "select/launch app" $ Left $ toX runAppMenu
, KeyBinding "M-g" "launch clipboard manager" $ Left runClipMenu , KeyBinding "M-g" "launch clipboard manager" $ Left $ toX runClipMenu
, KeyBinding "M-a" "launch network selector" $ Left $ runNetMenu sys , KeyBinding "M-a" "launch network selector" $ Left $ toX $ runNetMenu sys
, KeyBinding "M-w" "launch window selector" $ Left runWinMenu , KeyBinding "M-w" "launch window selector" $ Left $ toX runWinMenu
, KeyBinding "M-u" "launch device selector" $ Left runDevMenu , KeyBinding "M-u" "launch device selector" $ Left $ toX runDevMenu
, KeyBinding "M-b" "launch bitwarden selector" $ Left $ runBwMenu ses , KeyBinding "M-b" "launch bitwarden selector" $ Left $ toX $ runBwMenu ses
, KeyBinding "M-v" "launch ExpressVPN selector" $ Left runVPNMenu , KeyBinding "M-v" "launch ExpressVPN selector" $ Left $ toX runVPNMenu
, KeyBinding "M-e" "launch bluetooth selector" $ Left runBTMenu , KeyBinding "M-e" "launch bluetooth selector" $ Left $ toX runBTMenu
, KeyBinding "M-C-e" "launch editor" $ Left runEditor , KeyBinding "M-C-e" "launch editor" $ Left $ toX runEditor
, KeyBinding "M-C-w" "launch browser" $ Left runBrowser , KeyBinding "M-C-w" "launch browser" $ Left $ toX runBrowser
, KeyBinding "M-C-t" "launch terminal with tmux" $ Left runTMux , KeyBinding "M-C-t" "launch terminal with tmux" $ Left $ toX runTMux
, KeyBinding "M-C-S-t" "launch terminal" $ Left runTerm , KeyBinding "M-C-S-t" "launch terminal" $ Left $ toX runTerm
, KeyBinding "M-C-q" "launch calc" $ Left runCalc , KeyBinding "M-C-q" "launch calc" $ Left $ toX runCalc
, KeyBinding "M-C-f" "launch file manager" $ Left runFileManager , KeyBinding "M-C-f" "launch file manager" $ Left $ toX runFileManager
] ]
, KeyGroup , KeyGroup
"Actions" "Actions"
[ KeyBinding "M-q" "close window" $ ftrAlways "kill window function" kill1 [ KeyBinding "M-q" "close window" $ ftrAlways "kill window function" kill1
, KeyBinding "M-r" "run program" $ Left runCmdMenu , KeyBinding "M-r" "run program" $ Left $ toX runCmdMenu
, KeyBinding "M-<Space>" "warp pointer" $ ftrAlways "warp function" $ warpToWindow 0.5 0.5 , KeyBinding "M-<Space>" "warp pointer" $ ftrAlways "warp function" $ warpToWindow 0.5 0.5
, KeyBinding "M-C-s" "capture area" $ Left $ runAreaCapture ses , KeyBinding "M-C-s" "capture area" $ Left $ toX $ runAreaCapture ses
, KeyBinding "M-C-S-s" "capture screen" $ Left $ runScreenCapture ses , KeyBinding "M-C-S-s" "capture screen" $ Left $ toX $ runScreenCapture ses
, KeyBinding "M-C-d" "capture desktop" $ Left $ runDesktopCapture ses , KeyBinding "M-C-d" "capture desktop" $ Left $ toX $ runDesktopCapture ses
, KeyBinding "M-C-b" "browse captures" $ Left runCaptureBrowser , KeyBinding "M-C-b" "browse captures" $ Left $ toX runCaptureBrowser
-- , ("M-C-S-s", "capture focused window", spawn myWindowCap) -- , ("M-C-S-s", "capture focused window", spawn myWindowCap)
] ]
, KeyGroup , KeyGroup
"Multimedia" "Multimedia"
[ KeyBinding "<XF86AudioPlay>" "toggle play/pause" $ Left runTogglePlay [ KeyBinding "<XF86AudioPlay>" "toggle play/pause" $ Left $ toX runTogglePlay
, KeyBinding "<XF86AudioPrev>" "previous track" $ Left runPrevTrack , KeyBinding "<XF86AudioPrev>" "previous track" $ Left $ toX runPrevTrack
, KeyBinding "<XF86AudioNext>" "next track" $ Left runNextTrack , KeyBinding "<XF86AudioNext>" "next track" $ Left $ toX runNextTrack
, KeyBinding "<XF86AudioStop>" "stop" $ Left runStopPlay , KeyBinding "<XF86AudioStop>" "stop" $ Left $ toX runStopPlay
, KeyBinding "<XF86AudioLowerVolume>" "volume down" $ Left runVolumeDown , KeyBinding "<XF86AudioLowerVolume>" "volume down" $ Left $ toX runVolumeDown
, KeyBinding "<XF86AudioRaiseVolume>" "volume up" $ Left runVolumeUp , KeyBinding "<XF86AudioRaiseVolume>" "volume up" $ Left $ toX runVolumeUp
, KeyBinding "<XF86AudioMute>" "volume mute" $ Left runVolumeMute , KeyBinding "<XF86AudioMute>" "volume mute" $ Left $ toX runVolumeMute
] ]
, KeyGroup , KeyGroup
"Dunst" "Dunst"
[ KeyBinding "M-`" "dunst history" $ Left $ runNotificationHistory ses [ KeyBinding "M-`" "dunst history" $ Left $ toX $ runNotificationHistory ses
, KeyBinding "M-S-`" "dunst close" $ Left $ runNotificationClose ses , KeyBinding "M-S-`" "dunst close" $ Left $ toX $ runNotificationClose ses
, KeyBinding "M-M1-`" "dunst context menu" $ Left $ runNotificationContext ses , KeyBinding "M-M1-`" "dunst context menu" $ Left $ toX $ runNotificationContext ses
, KeyBinding "M-C-`" "dunst close all" $ Left $ runNotificationCloseAll ses , KeyBinding "M-C-`" "dunst close all" $ Left $ toX $ runNotificationCloseAll ses
] ]
, KeyGroup , KeyGroup
"System" "System"
@ -809,22 +832,25 @@ 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-<F8>" "select autorandr profile" $ Left runAutorandrMenu , KeyBinding "M-<F7>" "select autorandr profile" $ Left $ toX runAutorandrMenu
, KeyBinding "M-<F9>" "toggle ethernet" $ Left runToggleEthernet , KeyBinding "M-<F8>" "toggle wifi" $ Left $ toX runToggleWifi
, KeyBinding "M-<F10>" "toggle bluetooth" $ Left $ runToggleBluetooth sys , KeyBinding "M-<F9>" "toggle network" $ Left $ toX runToggleNetworking
, KeyBinding "M-<F11>" "toggle screensaver" $ Left $ callToggle ses , KeyBinding "M-<F10>" "toggle bluetooth" $ Left $ toX $ runToggleBluetooth sys
, KeyBinding "M-<F11>" "toggle screensaver" $ Left $ toX $ callToggle ses
, KeyBinding "M-<F12>" "switch gpu" $ Left runOptimusPrompt , KeyBinding "M-<F12>" "switch gpu" $ Left runOptimusPrompt
] ]
] ]
where where
ses = dbSesClient db ses = dbSesClient db
sys = dbSysClient db sys = dbSysClient db
brightessControls ctl getter = (getter . ctl) ses brightessControls ctl getter = (toX . getter . ctl) ses
ib = Left . brightessControls intelBacklightControls ib = Left . brightessControls intelBacklightControls
ck = Left . brightessControls clevoKeyboardControls ck = Left . brightessControls clevoKeyboardControls
ftrAlways n = Right . Always n . Always_ . FallbackAlone ftrAlways n = Right . Always n . Always_ . FallbackAlone
restartf = ftrAlways "restart function" (runCleanup ts db >> runRestart) restartf = ftrAlways "restart function" (cleanup >> runRestart)
recompilef = ftrAlways "recompile function" runRecompile recompilef = ftrAlways "recompile function" runRecompile
toX_ = liftIO . runIO
toX = fmap toX_
type MaybeX = Maybe (X ()) type MaybeX = Maybe (X ())

View File

@ -5,7 +5,17 @@ module Data.Internal.DBus
( SafeClient (..) ( SafeClient (..)
, SysClient (..) , SysClient (..)
, SesClient (..) , SesClient (..)
, NamedConnection (..)
, NamedSesConnection
, NamedSysConnection
, DBusEnv (..)
, DIO
, HasClient (..)
, releaseBusName
, withDIO
, addMatchCallback , addMatchCallback
, addMatchCallbackSignal
, matchSignalFull
, matchProperty , matchProperty
, matchPropertyFull , matchPropertyFull
, matchPropertyChanged , matchPropertyChanged
@ -25,93 +35,218 @@ module Data.Internal.DBus
, addInterfaceRemovedListener , addInterfaceRemovedListener
, fromSingletonVariant , fromSingletonVariant
, bodyToMaybe , bodyToMaybe
, exportPair
, displayBusName
, displayObjectPath
, displayMemberName
, displayInterfaceName
, displayWrapQuote
, busNameT
, interfaceNameT
, memberNameT
, objectPathT
) )
where where
import DBus import DBus
import DBus.Client import DBus.Client
import qualified Data.ByteString.Char8 as BC
import RIO import RIO
import RIO.List
import qualified RIO.Map as M import qualified RIO.Map as M
import qualified RIO.Text as T import qualified RIO.Text as T
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- Type-safe client -- Type-safe client
class SafeClient c where data NamedConnection c = NamedConnection
toClient :: c -> Client { ncClient :: !Client
, ncHumanName :: !(Maybe BusName)
--, ncUniqueName :: !BusName
, ncType :: !c
}
type NamedSesConnection = NamedConnection SesClient
type NamedSysConnection = NamedConnection SysClient
class SafeClient c where
getDBusClient getDBusClient
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m) :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
=> m (Maybe c) => Maybe BusName
-> m (Maybe (NamedConnection c))
disconnectDBusClient :: MonadUnliftIO m => c -> m () disconnectDBusClient
disconnectDBusClient = liftIO . disconnect . toClient :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
=> NamedConnection c
-> m ()
disconnectDBusClient c = do
releaseBusName c
liftIO $ disconnect $ ncClient c
withDBusClient withDBusClient
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m) :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
=> (c -> m a) => Maybe BusName
-> (NamedConnection c -> m a)
-> m (Maybe a) -> m (Maybe a)
withDBusClient f = withDBusClient n f =
bracket getDBusClient (mapM (liftIO . disconnect . toClient)) $ mapM f bracket (getDBusClient n) (mapM (liftIO . disconnect . ncClient)) $ mapM f
withDBusClient_ withDBusClient_
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m) :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
=> (c -> m ()) => Maybe BusName
-> (NamedConnection c -> m ())
-> m () -> m ()
withDBusClient_ = void . withDBusClient withDBusClient_ n = void . withDBusClient n
fromDBusClient fromDBusClient
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m) :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
=> (c -> a) => Maybe BusName
-> (NamedConnection c -> a)
-> m (Maybe a) -> m (Maybe a)
fromDBusClient f = withDBusClient (return . f) fromDBusClient n f = withDBusClient n (return . f)
newtype SysClient = SysClient Client data SysClient = SysClient
instance SafeClient SysClient where instance SafeClient SysClient where
toClient (SysClient cl) = cl getDBusClient = connectToDBusWithName True SysClient
getDBusClient = fmap SysClient <$> getSomeDBusClient True data SesClient = SesClient
newtype SesClient = SesClient Client
instance SafeClient SesClient where instance SafeClient SesClient where
toClient (SesClient cl) = cl -- TODO wet
getDBusClient = connectToDBusWithName False SesClient
getDBusClient = fmap SesClient <$> getSomeDBusClient False connectToDBusWithName
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
=> Bool
-> c
-> Maybe BusName
-> m (Maybe (NamedConnection c))
connectToDBusWithName sys t n = do
clRes <- getDBusClient' sys
case clRes of
Nothing -> do
logError "could not get client"
return Nothing
Just cl -> do
--helloRes <- liftIO $ callHello cl
--case helloRes of
-- Nothing -> do
-- logError "count not get unique name"
-- return Nothing
-- Just unique -> do
n' <- maybe (return Nothing) (`requestBusName` cl) n
return $
Just $
NamedConnection
{ ncClient = cl
, ncHumanName = n'
-- , ncUniqueName = unique
, ncType = t
}
getSomeDBusClient releaseBusName
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
=> NamedConnection c
-> m ()
releaseBusName NamedConnection {ncClient, ncHumanName} = do
-- TODO this might error?
case ncHumanName of
Just n -> do
liftIO $ void $ releaseName ncClient n
logInfo $ "released bus name: " <> displayBusName n
Nothing -> return ()
requestBusName
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
=> BusName
-> Client
-> m (Maybe BusName)
requestBusName n cl = do
res <- try $ liftIO $ requestName cl n []
case res of
Left e -> do
logError $ displayBytesUtf8 $ BC.pack $ clientErrorMessage e
return Nothing
Right r -> do
let msg
| r == NamePrimaryOwner = "registering name"
| r == NameAlreadyOwner = "this process already owns name"
| r == NameInQueue
|| r == NameExists =
"another process owns name"
-- this should never happen
| otherwise = "unknown error when requesting name"
logInfo $ msg <> ": " <> displayBusName n
case r of
NamePrimaryOwner -> return $ Just n
_ -> return Nothing
getDBusClient'
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m) :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
=> Bool => Bool
-> m (Maybe Client) -> m (Maybe Client)
getSomeDBusClient sys = do getDBusClient' sys = do
res <- try $ liftIO $ if sys then connectSystem else connectSession res <- try $ liftIO $ if sys then connectSystem else connectSession
case res of case res of
Left e -> do Left e -> do
logError $ Utf8Builder $ encodeUtf8Builder $ T.pack $ clientErrorMessage e logInfo $ displayBytesUtf8 $ BC.pack $ clientErrorMessage e
return Nothing return Nothing
Right c -> return $ Just c Right c -> return $ Just c
--callHello :: Client -> IO (Maybe BusName)
--callHello cl = do
-- reply <- call_ cl $ methodCallBus dbusName dbusPath dbusInterface "Hello"
-- case methodReturnBody reply of
-- [name] | Just nameStr <- fromVariant name -> do
-- busName <- parseBusName nameStr
-- return $ Just busName
-- _ -> return Nothing
--
data DBusEnv env c = DBusEnv {dClient :: !(NamedConnection c), dEnv :: !env}
type DIO env c = RIO (DBusEnv env c)
instance HasClient (DBusEnv SimpleApp) where
clientL = lens dClient (\x y -> x {dClient = y})
instance HasLogFunc (DBusEnv SimpleApp c) where
logFuncL = lens dEnv (\x y -> x {dEnv = y}) . logFuncL
withDIO
:: (MonadUnliftIO m, MonadReader env m)
=> NamedConnection c
-> DIO env c a
-> m a
withDIO cl x = do
env <- ask
runRIO (DBusEnv cl env) x
class HasClient env where
clientL :: SafeClient c => Lens' (env c) (NamedConnection c)
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- Methods -- Methods
type MethodBody = Either T.Text [Variant] type MethodBody = Either T.Text [Variant]
callMethod' :: (MonadUnliftIO m, SafeClient c) => c -> MethodCall -> m MethodBody callMethod'
callMethod' cl = :: (SafeClient c, MonadUnliftIO m, MonadReader (env c) m, HasClient env)
liftIO => MethodCall
. fmap (bimap (T.pack . methodErrorMessage) methodReturnBody) -> m MethodBody
. call (toClient cl) callMethod' mc = do
cl <- ncClient <$> view clientL
liftIO $ bimap (T.pack . methodErrorMessage) methodReturnBody <$> call cl mc
callMethod callMethod
:: (MonadUnliftIO m, SafeClient c) :: (SafeClient c, MonadUnliftIO m, MonadReader (env c) m, HasClient env)
=> c => BusName
-> BusName
-> ObjectPath -> ObjectPath
-> InterfaceName -> InterfaceName
-> MemberName -> MemberName
-> m MethodBody -> m MethodBody
callMethod client bus path iface = callMethod' client . methodCallBus bus path iface callMethod bus path iface = callMethod' . methodCallBus bus path iface
methodCallBus :: BusName -> ObjectPath -> InterfaceName -> MemberName -> MethodCall methodCallBus :: BusName -> ObjectPath -> InterfaceName -> MemberName -> MethodCall
methodCallBus b p i m = methodCallBus b p i m =
@ -125,8 +260,22 @@ methodCallBus b p i m =
dbusInterface :: InterfaceName dbusInterface :: InterfaceName
dbusInterface = interfaceName_ "org.freedesktop.DBus" dbusInterface = interfaceName_ "org.freedesktop.DBus"
callGetNameOwner :: (MonadUnliftIO m, SafeClient c) => c -> BusName -> m (Maybe BusName) callGetNameOwner
callGetNameOwner cl name = bodyToMaybe <$> callMethod' cl mc :: ( SafeClient c
, MonadUnliftIO m
, MonadReader (env c) m
, HasClient env
, HasLogFunc (env c)
)
=> BusName
-> m (Maybe BusName)
callGetNameOwner name = do
res <- callMethod' mc
case res of
Left err -> do
logError $ Utf8Builder $ encodeUtf8Builder err
return Nothing
Right body -> return $ fromSingletonVariant body
where where
mc = mc =
(methodCallBus dbusName dbusPath dbusInterface mem) (methodCallBus dbusName dbusPath dbusInterface mem)
@ -137,6 +286,7 @@ callGetNameOwner cl name = bodyToMaybe <$> callMethod' cl mc
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- Variant parsing -- Variant parsing
-- TODO log failures here?
fromSingletonVariant :: IsVariant a => [Variant] -> Maybe a fromSingletonVariant :: IsVariant a => [Variant] -> Maybe a
fromSingletonVariant = fromVariant <=< listToMaybe fromSingletonVariant = fromVariant <=< listToMaybe
@ -148,14 +298,29 @@ bodyToMaybe = either (const Nothing) fromSingletonVariant
type SignalCallback m = [Variant] -> m () type SignalCallback m = [Variant] -> m ()
addMatchCallbackSignal
:: ( MonadReader (env c) m
, MonadUnliftIO m
, SafeClient c
, HasClient env
)
=> MatchRule
-> (Signal -> m ())
-> m SignalHandler
addMatchCallbackSignal rule cb = do
cl <- ncClient <$> view clientL
withRunInIO $ \run -> addMatch cl rule $ run . cb
addMatchCallback addMatchCallback
:: (MonadUnliftIO m, SafeClient c) :: ( MonadReader (env c) m
, MonadUnliftIO m
, SafeClient c
, HasClient env
)
=> MatchRule => MatchRule
-> SignalCallback m -> SignalCallback m
-> c
-> m SignalHandler -> m SignalHandler
addMatchCallback rule cb cl = withRunInIO $ \run -> do addMatchCallback rule cb = addMatchCallbackSignal rule (cb . signalBody)
addMatch (toClient cl) rule $ run . cb . signalBody
matchSignal matchSignal
:: Maybe BusName :: Maybe BusName
@ -172,15 +337,35 @@ matchSignal b p i m =
} }
matchSignalFull matchSignalFull
:: (MonadUnliftIO m, SafeClient c) :: ( MonadReader (env c) m
=> c , HasLogFunc (env c)
-> BusName , MonadUnliftIO m
, SafeClient c
, HasClient env
)
=> BusName
-> Maybe ObjectPath -> Maybe ObjectPath
-> Maybe InterfaceName -> Maybe InterfaceName
-> Maybe MemberName -> Maybe MemberName
-> m (Maybe MatchRule) -> m (Maybe MatchRule)
matchSignalFull client b p i m = matchSignalFull b p i m = do
fmap (\o -> matchSignal (Just o) p i m) <$> callGetNameOwner client b res <- callGetNameOwner b
case res of
Just o -> return $ Just $ matchSignal (Just o) p i m
Nothing -> do
logError msg
return Nothing
where
bus_ = displayWrapQuote $ displayBusName b
iface_ = displayWrapQuote . displayInterfaceName <$> i
path_ = displayWrapQuote . displayObjectPath <$> p
mem_ = displayWrapQuote . displayMemberName <$> m
match =
intersperse ", " $
mapMaybe (\(k, v) -> fmap ((k <> "=") <>) v) $
zip ["interface", "path", "member"] [iface_, path_, mem_]
stem = "could not get match rule for bus " <> bus_
msg = if null match then stem else stem <> " where " <> mconcat match
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- Properties -- Properties
@ -192,31 +377,42 @@ propertySignal :: MemberName
propertySignal = memberName_ "PropertiesChanged" propertySignal = memberName_ "PropertiesChanged"
callPropertyGet callPropertyGet
:: (MonadUnliftIO m, SafeClient c) :: ( HasClient env
, MonadReader (env c) m
, HasLogFunc (env c)
, MonadUnliftIO m
, SafeClient c
)
=> BusName => BusName
-> ObjectPath -> ObjectPath
-> InterfaceName -> InterfaceName
-> MemberName -> MemberName
-> c
-> m [Variant] -> m [Variant]
callPropertyGet bus path iface property cl = callPropertyGet bus path iface property = do
liftIO $ cl <- ncClient <$> view clientL
fmap (either (const []) (: [])) $ res <- liftIO $ getProperty cl $ methodCallBus bus path iface property
getProperty (toClient cl) $ case res of
methodCallBus bus path iface property Left err -> do
logError $ displayBytesUtf8 $ BC.pack $ methodErrorMessage err
return []
Right v -> return [v]
matchProperty :: Maybe BusName -> Maybe ObjectPath -> MatchRule matchProperty :: Maybe BusName -> Maybe ObjectPath -> MatchRule
matchProperty b p = matchProperty b p =
matchSignal b p (Just propertyInterface) (Just propertySignal) matchSignal b p (Just propertyInterface) (Just propertySignal)
matchPropertyFull matchPropertyFull
:: (MonadUnliftIO m, SafeClient c) :: ( MonadReader (env c) m
=> c , HasLogFunc (env c)
-> BusName , MonadUnliftIO m
, SafeClient c
, HasClient env
)
=> BusName
-> Maybe ObjectPath -> Maybe ObjectPath
-> m (Maybe MatchRule) -> m (Maybe MatchRule)
matchPropertyFull cl b p = matchPropertyFull b p =
matchSignalFull cl b p (Just propertyInterface) (Just propertySignal) matchSignalFull b p (Just propertyInterface) (Just propertySignal)
data SignalMatch a = Match a | NoMatch | Failure deriving (Eq, Show) data SignalMatch a = Match a | NoMatch | Failure deriving (Eq, Show)
@ -228,26 +424,26 @@ withSignalMatch _ NoMatch = return ()
matchPropertyChanged matchPropertyChanged
:: IsVariant a :: IsVariant a
=> InterfaceName => InterfaceName
-> T.Text -> MemberName
-> [Variant] -> [Variant]
-> SignalMatch a -> SignalMatch a
matchPropertyChanged iface property [i, body, _] = matchPropertyChanged iface property [sigIface, sigValues, _] =
let i' = (fromVariant i :: Maybe T.Text) let i = fromVariant sigIface :: Maybe T.Text
b = toMap body v = fromVariant sigValues :: Maybe (M.Map T.Text Variant)
in case (i', b) of in case (i, v) of
(Just i'', Just b') -> (Just i', Just v') ->
if i'' == T.pack (formatInterfaceName iface) if i' == interfaceNameT iface
then maybe NoMatch Match $ fromVariant =<< M.lookup property b' then
maybe NoMatch Match $
fromVariant =<< M.lookup (memberNameT property) v'
else NoMatch else NoMatch
_ -> Failure _ -> Failure
where
toMap v = fromVariant v :: Maybe (M.Map T.Text Variant)
matchPropertyChanged _ _ _ = Failure matchPropertyChanged _ _ _ = Failure
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- Object Manager -- Object Manager
type ObjectTree = M.Map ObjectPath (M.Map T.Text (M.Map T.Text Variant)) type ObjectTree = M.Map ObjectPath (M.Map InterfaceName (M.Map T.Text Variant))
omInterface :: InterfaceName omInterface :: InterfaceName
omInterface = interfaceName_ "org.freedesktop.DBus.ObjectManager" omInterface = interfaceName_ "org.freedesktop.DBus.ObjectManager"
@ -262,43 +458,132 @@ omInterfacesRemoved :: MemberName
omInterfacesRemoved = memberName_ "InterfacesRemoved" omInterfacesRemoved = memberName_ "InterfacesRemoved"
callGetManagedObjects callGetManagedObjects
:: (MonadUnliftIO m, SafeClient c) :: ( MonadReader (env c) m
=> c , HasLogFunc (env c)
-> BusName , MonadUnliftIO m
, SafeClient c
, HasClient env
)
=> BusName
-> ObjectPath -> ObjectPath
-> m ObjectTree -> m ObjectTree
callGetManagedObjects cl bus path = callGetManagedObjects bus path = do
either (const M.empty) (fromMaybe M.empty . fromSingletonVariant) res <- callMethod bus path omInterface getManagedObjects
<$> callMethod cl bus path omInterface getManagedObjects case res of
Left err -> do
logError $ Utf8Builder $ encodeUtf8Builder err
return M.empty
Right v ->
return $
fmap (M.mapKeys interfaceName_) $
fromMaybe M.empty $
fromSingletonVariant v
addInterfaceChangedListener addInterfaceChangedListener
:: (MonadUnliftIO m, SafeClient c) :: ( MonadReader (env c) m
, HasLogFunc (env c)
, MonadUnliftIO m
, SafeClient c
, HasClient env
)
=> BusName => BusName
-> MemberName -> MemberName
-> ObjectPath -> ObjectPath
-> SignalCallback m -> SignalCallback m
-> c
-> m (Maybe SignalHandler) -> m (Maybe SignalHandler)
addInterfaceChangedListener bus prop path sc cl = do addInterfaceChangedListener bus prop path sc = do
rule <- matchSignalFull cl bus (Just path) (Just omInterface) (Just prop) res <- matchSignalFull bus (Just path) (Just omInterface) (Just prop)
forM rule $ \r -> addMatchCallback r sc cl case res of
Nothing -> do
logError $
"could not add listener for property"
<> prop_
<> " at path "
<> path_
<> " on bus "
<> bus_
return Nothing
Just rule -> Just <$> addMatchCallback rule sc
where
bus_ = "'" <> displayBusName bus <> "'"
path_ = "'" <> displayObjectPath path <> "'"
prop_ = "'" <> displayMemberName prop <> "'"
addInterfaceAddedListener addInterfaceAddedListener
:: (MonadUnliftIO m, SafeClient c) :: ( MonadReader (env c) m
, HasLogFunc (env c)
, MonadUnliftIO m
, SafeClient c
, HasClient env
)
=> BusName => BusName
-> ObjectPath -> ObjectPath
-> SignalCallback m -> SignalCallback m
-> c
-> m (Maybe SignalHandler) -> m (Maybe SignalHandler)
addInterfaceAddedListener bus = addInterfaceAddedListener bus =
addInterfaceChangedListener bus omInterfacesAdded addInterfaceChangedListener bus omInterfacesAdded
addInterfaceRemovedListener addInterfaceRemovedListener
:: (MonadUnliftIO m, SafeClient c) :: ( MonadReader (env c) m
, HasLogFunc (env c)
, MonadUnliftIO m
, SafeClient c
, HasClient env
)
=> BusName => BusName
-> ObjectPath -> ObjectPath
-> SignalCallback m -> SignalCallback m
-> c
-> m (Maybe SignalHandler) -> m (Maybe SignalHandler)
addInterfaceRemovedListener bus = addInterfaceRemovedListener bus =
addInterfaceChangedListener bus omInterfacesRemoved addInterfaceChangedListener bus omInterfacesRemoved
--------------------------------------------------------------------------------
-- Interface export/unexport
exportPair
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
=> ObjectPath
-> (Client -> m Interface)
-> NamedConnection c
-> (m (), m ())
exportPair path toIface cl = (up, down)
where
cl_ = ncClient cl
up = do
logInfo $ "adding interface: " <> path_
i <- toIface cl_
liftIO $ export cl_ path i
down = do
logInfo $ "removing interface: " <> path_
liftIO $ unexport cl_ path
path_ = displayObjectPath path
--------------------------------------------------------------------------------
-- logging helpers
busNameT :: BusName -> T.Text
busNameT = T.pack . formatBusName
objectPathT :: ObjectPath -> T.Text
objectPathT = T.pack . formatObjectPath
interfaceNameT :: InterfaceName -> T.Text
interfaceNameT = T.pack . formatInterfaceName
memberNameT :: MemberName -> T.Text
memberNameT = T.pack . formatMemberName
displayBusName :: BusName -> Utf8Builder
displayBusName = displayBytesUtf8 . BC.pack . formatBusName
displayObjectPath :: ObjectPath -> Utf8Builder
displayObjectPath = displayBytesUtf8 . BC.pack . formatObjectPath
displayMemberName :: MemberName -> Utf8Builder
displayMemberName = displayBytesUtf8 . BC.pack . formatMemberName
displayInterfaceName :: InterfaceName -> Utf8Builder
displayInterfaceName = displayBytesUtf8 . BC.pack . formatInterfaceName
displayWrapQuote :: Utf8Builder -> Utf8Builder
displayWrapQuote x = "'" <> x <> "'"

View File

@ -1,14 +1,7 @@
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- Functions for handling dependencies -- Functions for handling dependencies
module Data.Internal.Dependency module Data.Internal.XIO
-- feature types -- feature types
( Feature ( Feature
, Always (..) , Always (..)
@ -26,6 +19,7 @@ module Data.Internal.Dependency
, SubfeatureRoot , SubfeatureRoot
, Msg (..) , Msg (..)
-- configuration -- configuration
, XEnv (..)
, XParams (..) , XParams (..)
, XPFeatures (..) , XPFeatures (..)
, XPQuery , XPQuery
@ -53,8 +47,9 @@ module Data.Internal.Dependency
, dumpSometimes , dumpSometimes
, showFulfillment , showFulfillment
-- testing -- testing
, FIO , XIO
, withCache , runXIO
, hRunXIO
, evalFeature , evalFeature
, executeSometimes , executeSometimes
, executeAlways , executeAlways
@ -96,6 +91,7 @@ module Data.Internal.Dependency
, process , process
-- misc -- misc
, shellTest , shellTest
, withLogFile
) )
where where
@ -104,6 +100,7 @@ import qualified DBus.Introspection as I
import Data.Aeson hiding (Error, Result) import Data.Aeson hiding (Error, Result)
import Data.Aeson.Key import Data.Aeson.Key
import Data.Internal.DBus import Data.Internal.DBus
import qualified Data.Text.IO as TI
import Data.Yaml import Data.Yaml
import GHC.IO.Exception (ioe_description) import GHC.IO.Exception (ioe_description)
import RIO hiding (bracket, fromString) import RIO hiding (bracket, fromString)
@ -115,7 +112,7 @@ import qualified RIO.Text as T
import System.Posix.Files import System.Posix.Files
import System.Process.Typed (nullStream) import System.Process.Typed (nullStream)
import UnliftIO.Environment import UnliftIO.Environment
import XMonad.Core (X, io) import XMonad.Core (X, dataDir, getDirectories, io)
import XMonad.Internal.IO import XMonad.Internal.IO
import XMonad.Internal.Shell hiding (proc, runProcess) import XMonad.Internal.Shell hiding (proc, runProcess)
import XMonad.Internal.Theme import XMonad.Internal.Theme
@ -128,30 +125,47 @@ import XMonad.Internal.Theme
-- | Run feature evaluation(s) with the cache -- | Run feature evaluation(s) with the cache
-- Currently there is no easy way to not use this (oh well) -- Currently there is no easy way to not use this (oh well)
withCache :: FIO a -> IO a runXIO :: FilePath -> XIO a -> IO a
withCache x = do runXIO logfile x = withLogFile logfile $ \h -> hRunXIO True h x
logOpts <- logOptionsHandle stderr False
-- TODO use dhall to encode config file and log here to control the loglevel
withLogFile :: MonadUnliftIO m => FilePath -> (Handle -> m a) -> m a
withLogFile logfile f = do
p <- (</> logfile) . dataDir <$> liftIO getDirectories
catchIO (withBinaryFile p AppendMode f) $ \e -> do
liftIO $ TI.putStrLn $ T.pack $ show e
liftIO $ TI.putStrLn "could not open log file, falling back to stderr"
f stderr
hRunXIO :: Bool -> Handle -> XIO a -> IO a
hRunXIO verbose h x = do
hSetBuffering h LineBuffering
logOpts <- logOptionsHandle_ verbose h
pc <- mkDefaultProcessContext pc <- mkDefaultProcessContext
withLogFunc logOpts $ \f -> do withLogFunc logOpts $ \f -> do
p <- getParams p <- getParams
let s = DepStage f pc p let s = XEnv f pc p
runRIO s x runRIO s x
logOptionsHandle_ :: MonadUnliftIO m => Bool -> Handle -> m LogOptions
logOptionsHandle_ v h =
setLogVerboseFormat v . setLogUseTime v <$> logOptionsHandle h False
-- | Execute an Always immediately -- | Execute an Always immediately
executeAlways :: Always (IO a) -> FIO a executeAlways :: Always (IO a) -> XIO a
executeAlways = io <=< evalAlways executeAlways = io <=< evalAlways
-- | Execute a Sometimes immediately (or do nothing if failure) -- | Execute a Sometimes immediately (or do nothing if failure)
executeSometimes :: Sometimes (FIO a) -> FIO (Maybe a) executeSometimes :: Sometimes (XIO a) -> XIO (Maybe a)
executeSometimes a = maybe (return Nothing) (fmap Just) =<< evalSometimes a executeSometimes a = maybe (return Nothing) (fmap Just) =<< evalSometimes a
-- | Possibly return the action of an Always/Sometimes -- | Possibly return the action of an Always/Sometimes
evalFeature :: Feature a -> FIO (Maybe a) evalFeature :: Feature a -> XIO (Maybe a)
evalFeature (Right a) = Just <$> evalAlways a evalFeature (Right a) = Just <$> evalAlways a
evalFeature (Left s) = evalSometimes s evalFeature (Left s) = evalSometimes s
-- | Possibly return the action of a Sometimes -- | Possibly return the action of a Sometimes
evalSometimes :: Sometimes a -> FIO (Maybe a) evalSometimes :: Sometimes a -> XIO (Maybe a)
evalSometimes x = either goFail goPass =<< evalSometimesMsg x evalSometimes x = either goFail goPass =<< evalSometimesMsg x
where where
goPass (a, ws) = putErrors ws >> return (Just a) goPass (a, ws) = putErrors ws >> return (Just a)
@ -159,13 +173,13 @@ evalSometimes x = either goFail goPass =<< evalSometimesMsg x
putErrors = mapM_ logMsg putErrors = mapM_ logMsg
-- | Return the action of an Always -- | Return the action of an Always
evalAlways :: Always a -> FIO a evalAlways :: Always a -> XIO a
evalAlways a = do evalAlways a = do
(x, ws) <- evalAlwaysMsg a (x, ws) <- evalAlwaysMsg a
mapM_ logMsg ws mapM_ logMsg ws
return x return x
logMsg :: FMsg -> FIO () logMsg :: FMsg -> XIO ()
logMsg (FMsg fn n (Msg ll m)) = do logMsg (FMsg fn n (Msg ll m)) = do
p <- io getProgName p <- io getProgName
f $ Utf8Builder $ encodeUtf8Builder $ T.unwords $ fmt s (T.pack p) f $ Utf8Builder $ encodeUtf8Builder $ T.unwords $ fmt s (T.pack p)
@ -186,8 +200,9 @@ logMsg (FMsg fn n (Msg ll m)) = do
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- Package status -- Package status
showFulfillment :: Fulfillment -> T.Text showFulfillment :: Fulfillment -> Utf8Builder
showFulfillment (Package t n) = T.concat [T.pack $ show t, "\t", n] showFulfillment (Package t n) =
displayShow t <> "\t" <> Utf8Builder (encodeUtf8Builder n)
dumpFeature :: Feature a -> [Fulfillment] dumpFeature :: Feature a -> [Fulfillment]
dumpFeature = either dumpSometimes dumpAlways dumpFeature = either dumpSometimes dumpAlways
@ -209,7 +224,7 @@ type AlwaysIO = Always (IO ())
type SometimesX = Sometimes (X ()) type SometimesX = Sometimes (X ())
type SometimesIO = Sometimes (FIO ()) type SometimesIO = Sometimes (XIO ())
type Feature a = Either (Sometimes a) (Always a) type Feature a = Either (Sometimes a) (Always a)
@ -219,12 +234,13 @@ type Feature a = Either (Sometimes a) (Always a)
-- | Feature that is guaranteed to work -- | Feature that is guaranteed to work
-- This is composed of sub-features that are tested in order, and if all fail -- This is composed of sub-features that are tested in order, and if all fail
-- the fallback is a monadic action (eg a plain haskell function) -- the fallback is a monadic action (eg a plain haskell function)
data Always a = Always T.Text (Always_ a) data Always a = Always T.Text (Always_ a) deriving (Functor)
-- | Feature that is guaranteed to work (inner data) -- | Feature that is guaranteed to work (inner data)
data Always_ a data Always_ a
= Option (SubfeatureRoot a) (Always_ a) = Option (SubfeatureRoot a) (Always_ a)
| Always_ (FallbackRoot a) | Always_ (FallbackRoot a)
deriving (Functor)
-- | Root of a fallback action for an always -- | Root of a fallback action for an always
-- This may either be a lone action or a function that depends on the results -- This may either be a lone action or a function that depends on the results
@ -233,15 +249,23 @@ data FallbackRoot a
= FallbackAlone a = FallbackAlone a
| forall p. FallbackTree (p -> a) (FallbackStack p) | forall p. FallbackTree (p -> a) (FallbackStack p)
instance Functor FallbackRoot where
fmap f (FallbackAlone a) = FallbackAlone (f a)
fmap f (FallbackTree g s) = FallbackTree (f . g) s
-- | Always features that are used as a payload for a fallback action -- | Always features that are used as a payload for a fallback action
data FallbackStack p data FallbackStack p
= FallbackBottom (Always p) = FallbackBottom (Always p)
| forall x y. FallbackStack (x -> y -> p) (Always x) (FallbackStack y) | forall x y. FallbackStack (x -> y -> p) (Always x) (FallbackStack y)
instance Functor FallbackStack where
fmap f (FallbackBottom a) = FallbackBottom $ fmap f a
fmap f (FallbackStack g a s) = FallbackStack (\x -> f . g x) a s
-- | Feature that might not be present -- | Feature that might not be present
-- This is like an Always except it doesn't fall back on a guaranteed monadic -- This is like an Always except it doesn't fall back on a guaranteed monadic
-- action -- action
data Sometimes a = Sometimes T.Text XPQuery (Sometimes_ a) data Sometimes a = Sometimes T.Text XPQuery (Sometimes_ a) deriving (Functor)
-- | Feature that might not be present (inner data) -- | Feature that might not be present (inner data)
type Sometimes_ a = [SubfeatureRoot a] type Sometimes_ a = [SubfeatureRoot a]
@ -254,6 +278,7 @@ data Subfeature f = Subfeature
{ sfData :: f { sfData :: f
, sfName :: T.Text , sfName :: T.Text
} }
deriving (Functor)
type SubfeatureRoot a = Subfeature (Root a) type SubfeatureRoot a = Subfeature (Root a)
@ -263,8 +288,24 @@ type SubfeatureRoot a = Subfeature (Root a)
data Root a data Root a
= forall p. IORoot (p -> a) (IOTree p) = forall p. IORoot (p -> a) (IOTree p)
| IORoot_ a IOTree_ | IORoot_ a IOTree_
| forall c p. SafeClient c => DBusRoot (p -> c -> a) (DBusTree c p) (Maybe c) | forall c p.
| forall c. SafeClient c => DBusRoot_ (c -> a) (DBusTree_ c) (Maybe c) SafeClient c =>
DBusRoot
(p -> NamedConnection c -> a)
(DBusTree c p)
(Maybe (NamedConnection c))
| forall c.
SafeClient c =>
DBusRoot_
(NamedConnection c -> a)
(DBusTree_ c)
(Maybe (NamedConnection c))
instance Functor Root where
fmap f (IORoot a t) = IORoot (f . a) t
fmap f (IORoot_ a t) = IORoot_ (f a) t
fmap f (DBusRoot a t cl) = DBusRoot (\p c -> f $ a p c) t cl
fmap f (DBusRoot_ a t cl) = DBusRoot_ (f . a) t cl
-- | The dependency tree with rule to merge results when needed -- | The dependency tree with rule to merge results when needed
data Tree d d_ p data Tree d d_ p
@ -289,7 +330,7 @@ type DBusTree_ c = Tree_ (DBusDependency_ c)
-- | 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
= -- an IO action that yields a payload = -- an IO action that yields a payload
IORead T.Text [Fulfillment] (FIO (Result p)) IORead T.Text [Fulfillment] (XIO (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
@ -302,12 +343,11 @@ data DBusDependency_ c
= Bus [Fulfillment] BusName = Bus [Fulfillment] BusName
| Endpoint [Fulfillment] BusName ObjectPath InterfaceName DBusMember | Endpoint [Fulfillment] BusName ObjectPath InterfaceName DBusMember
| DBusIO IODependency_ | DBusIO IODependency_
deriving (Generic)
-- | A dependency that only requires IO to evaluate (no payload) -- | A dependency that only requires IO to evaluate (no payload)
data IODependency_ data IODependency_
= IOSystem_ [Fulfillment] SystemDependency = IOSystem_ [Fulfillment] SystemDependency
| IOTest_ T.Text [Fulfillment] (FIO (Maybe Msg)) | IOTest_ T.Text [Fulfillment] (XIO (Maybe Msg))
| forall a. IOSometimes_ (Sometimes a) | forall a. IOSometimes_ (Sometimes a)
-- | A system component to an IODependency -- | A system component to an IODependency
@ -317,23 +357,23 @@ data SystemDependency
| AccessiblePath FilePath Bool Bool | AccessiblePath FilePath Bool Bool
| Systemd UnitType T.Text | Systemd UnitType T.Text
| Process T.Text | Process T.Text
deriving (Eq, Show, Generic) deriving (Eq, Show)
-- | The type of a systemd service -- | The type of a systemd service
data UnitType = SystemUnit | UserUnit deriving (Eq, Show, Generic) data UnitType = SystemUnit | UserUnit deriving (Eq, Show)
-- | Wrapper type to describe and endpoint -- | Wrapper type to describe and endpoint
data DBusMember data DBusMember
= Method_ MemberName = Method_ MemberName
| Signal_ MemberName | Signal_ MemberName
| Property_ T.Text | Property_ T.Text
deriving (Eq, Show, Generic) deriving (Eq, Show)
-- | A means to fulfill a dependency -- | A means to fulfill a dependency
-- For now this is just the name of an Arch Linux package (AUR or official) -- For now this is just the name of an Arch Linux package (AUR or official)
data Fulfillment = Package ArchPkg T.Text deriving (Eq, Show, Ord) data Fulfillment = Package ArchPkg T.Text deriving (Eq, Show, Ord)
data ArchPkg = Official | AUR | Custom deriving (Eq, Show, Generic, Ord) data ArchPkg = Official | AUR | Custom deriving (Eq, Show, Ord)
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- Tested dependency tree -- Tested dependency tree
@ -376,19 +416,25 @@ data PostFail = PostFail [Msg] | PostMissing Msg
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- Configuration -- Configuration
type FIO a = RIO DepStage a type XIO a = RIO XEnv a
data DepStage = DepStage data XEnv = XEnv
{ dsLogFun :: !LogFunc { xLogFun :: !LogFunc
, dsProcCxt :: !ProcessContext , xProcCxt :: !ProcessContext
, dsParams :: !XParams , xParams :: !XParams
} }
instance HasLogFunc DepStage where instance HasLogFunc XEnv where
logFuncL = lens dsLogFun (\x y -> x {dsLogFun = y}) logFuncL = lens xLogFun (\x y -> x {xLogFun = y})
instance HasProcessContext DepStage where instance HasLogFunc (DBusEnv XEnv c) where
processContextL = lens dsProcCxt (\x y -> x {dsProcCxt = y}) logFuncL = lens dEnv (\x y -> x {dEnv = y}) . logFuncL
instance HasProcessContext XEnv where
processContextL = lens xProcCxt (\x y -> x {xProcCxt = y})
instance HasClient (DBusEnv XEnv) where
clientL = lens dClient (\x y -> x {dClient = y})
data XParams = XParams data XParams = XParams
{ xpLogLevel :: LogLevel { xpLogLevel :: LogLevel
@ -422,7 +468,8 @@ data XPFeatures = XPFeatures
, xpfIntelBacklight :: Bool , xpfIntelBacklight :: Bool
, xpfClevoBacklight :: Bool , xpfClevoBacklight :: Bool
, xpfBattery :: Bool , xpfBattery :: Bool
, xpfF5VPN :: Bool , xpfEthPrefix :: Maybe Text
, xpfWifiPrefix :: Maybe Text
} }
instance FromJSON XPFeatures where instance FromJSON XPFeatures where
@ -449,7 +496,9 @@ instance FromJSON XPFeatures where
<*> o <*> o
.:+ "battery" .:+ "battery"
<*> o <*> o
.:+ "f5vpn" .:? "ethPrefix"
<*> o
.:? "wifiPrefix"
defParams :: XParams defParams :: XParams
defParams = defParams =
@ -472,7 +521,8 @@ defXPFeatures =
, xpfIntelBacklight = False , xpfIntelBacklight = False
, xpfClevoBacklight = False , xpfClevoBacklight = False
, xpfBattery = False , xpfBattery = False
, xpfF5VPN = False , xpfEthPrefix = Nothing
, xpfWifiPrefix = Nothing
} }
type XPQuery = XPFeatures -> Bool type XPQuery = XPFeatures -> Bool
@ -483,7 +533,7 @@ getParams = do
maybe (return defParams) (liftIO . decodeYaml) p maybe (return defParams) (liftIO . decodeYaml) p
where where
decodeYaml p = decodeYaml p =
either (\e -> print e >> return defParams) return either (\e -> TI.putStrLn (T.pack $ show e) >> return defParams) return
=<< decodeFileEither p =<< decodeFileEither p
getParamFile :: MonadIO m => m (Maybe FilePath) getParamFile :: MonadIO m => m (Maybe FilePath)
@ -507,9 +557,9 @@ infix 9 .:+
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- Testing pipeline -- Testing pipeline
evalSometimesMsg :: Sometimes a -> FIO (Either [FMsg] (a, [FMsg])) evalSometimesMsg :: Sometimes a -> XIO (Either [FMsg] (a, [FMsg]))
evalSometimesMsg (Sometimes n u xs) = do evalSometimesMsg (Sometimes n u xs) = do
r <- asks (u . xpFeatures . dsParams) r <- asks (u . xpFeatures . xParams)
if not r if not r
then return $ Left [dis n] then return $ Left [dis n]
else do else do
@ -521,7 +571,7 @@ evalSometimesMsg (Sometimes n u xs) = do
where where
dis name = FMsg name Nothing (Msg LevelDebug "feature disabled") dis name = FMsg name Nothing (Msg LevelDebug "feature disabled")
evalAlwaysMsg :: Always a -> FIO (a, [FMsg]) evalAlwaysMsg :: Always a -> XIO (a, [FMsg])
evalAlwaysMsg (Always n x) = do evalAlwaysMsg (Always n x) = do
r <- testAlways x r <- testAlways x
return $ case r of return $ case r of
@ -541,7 +591,7 @@ failedMsg fn Subfeature {sfData = d, sfName = n} = case d of
where where
f = fmap (FMsg fn (Just n)) f = fmap (FMsg fn (Just n))
testAlways :: Always_ a -> FIO (PostAlways a) testAlways :: Always_ a -> XIO (PostAlways a)
testAlways = go [] testAlways = go []
where where
go failed (Option fd next) = do go failed (Option fd next) = do
@ -551,18 +601,18 @@ testAlways = go []
(Right pass) -> return $ Primary pass failed next (Right pass) -> return $ Primary pass failed next
go failed (Always_ ar) = (`Fallback` failed) <$> evalFallbackRoot ar go failed (Always_ ar) = (`Fallback` failed) <$> evalFallbackRoot ar
evalFallbackRoot :: FallbackRoot a -> FIO a evalFallbackRoot :: FallbackRoot a -> XIO a
evalFallbackRoot (FallbackAlone a) = return a evalFallbackRoot (FallbackAlone a) = return a
evalFallbackRoot (FallbackTree a s) = a <$> evalFallbackStack s evalFallbackRoot (FallbackTree a s) = a <$> evalFallbackStack s
evalFallbackStack :: FallbackStack p -> FIO p evalFallbackStack :: FallbackStack p -> XIO p
evalFallbackStack (FallbackBottom a) = evalAlways a evalFallbackStack (FallbackBottom a) = evalAlways a
evalFallbackStack (FallbackStack f a as) = do evalFallbackStack (FallbackStack f a as) = do
ps <- evalFallbackStack as ps <- evalFallbackStack as
p <- evalAlways a p <- evalAlways a
return $ f p ps return $ f p ps
testSometimes :: Sometimes_ a -> FIO (PostSometimes a) testSometimes :: Sometimes_ a -> XIO (PostSometimes a)
testSometimes = go (PostSometimes Nothing []) testSometimes = go (PostSometimes Nothing [])
where where
go ts [] = return ts go ts [] = return ts
@ -572,13 +622,13 @@ testSometimes = go (PostSometimes Nothing [])
(Left l) -> go (ts {psFailed = l : psFailed ts}) xs (Left l) -> go (ts {psFailed = l : psFailed ts}) xs
(Right pass) -> return $ ts {psSuccess = Just pass} (Right pass) -> return $ ts {psSuccess = Just pass}
testSubfeature :: SubfeatureRoot a -> FIO (Either SubfeatureFail (SubfeaturePass a)) testSubfeature :: SubfeatureRoot a -> XIO (Either SubfeatureFail (SubfeaturePass a))
testSubfeature sf@Subfeature {sfData = t} = do testSubfeature sf@Subfeature {sfData = t} = do
t' <- testRoot t t' <- testRoot t
-- monomorphism restriction :( -- monomorphism restriction :(
return $ bimap (\n -> sf {sfData = n}) (\n -> sf {sfData = n}) t' return $ bimap (\n -> sf {sfData = n}) (\n -> sf {sfData = n}) t'
testRoot :: Root a -> FIO (Either PostFail (PostPass a)) testRoot :: Root a -> XIO (Either PostFail (PostPass a))
testRoot r = do testRoot r = do
case r of case r of
(IORoot a t) -> go a testIODep_ testIODep t (IORoot a t) -> go a testIODep_ testIODep t
@ -592,7 +642,7 @@ testRoot r = do
Msg LevelError "client not available" Msg LevelError "client not available"
where where
-- rank N polymorphism is apparently undecidable...gross -- rank N polymorphism is apparently undecidable...gross
go a f_ (f :: forall q. d q -> FIO (MResult q)) t = go a f_ (f :: forall q. d q -> XIO (MResult q)) t =
bimap PostFail (fmap a) <$> testTree f_ f t bimap PostFail (fmap a) <$> testTree f_ f t
go_ a f_ t = bimap PostFail (PostPass a) <$> testTree_ f_ t go_ a f_ t = bimap PostFail (PostPass a) <$> testTree_ f_ t
@ -605,13 +655,13 @@ type MResult p = Memoized (Result p)
testTree testTree
:: forall d d_ p :: forall d d_ p
. (d_ -> FIO MResult_) . (d_ -> XIO MResult_)
-> (forall q. d q -> FIO (MResult q)) -> (forall q. d q -> XIO (MResult q))
-> Tree d d_ p -> Tree d d_ p
-> FIO (Either [Msg] (PostPass p)) -> XIO (Either [Msg] (PostPass p))
testTree test_ test = go testTree test_ test = go
where where
go :: forall q. Tree d d_ q -> FIO (Result q) go :: forall q. Tree d d_ q -> XIO (Result q)
go (And12 f a b) = do go (And12 f a b) = do
ra <- go a ra <- go a
liftRight (\pa -> (and2nd f pa =<<) <$> go b) ra liftRight (\pa -> (and2nd f pa =<<) <$> go b) ra
@ -628,7 +678,7 @@ testTree test_ test = go
and2nd f (PostPass pa wa) (PostPass pb wb) = Right $ PostPass (f pa pb) $ wa ++ wb and2nd f (PostPass pa wa) (PostPass pb wb) = Right $ PostPass (f pa pb) $ wa ++ wb
liftRight = either (return . Left) liftRight = either (return . Left)
testIODep :: IODependency p -> FIO (MResult p) testIODep :: IODependency p -> XIO (MResult p)
testIODep d = memoizeMVar $ case d of testIODep d = memoizeMVar $ case d of
IORead _ _ t -> t IORead _ _ t -> t
IOConst c -> return $ Right $ PostPass c [] IOConst c -> return $ Right $ PostPass c []
@ -656,7 +706,7 @@ type Result_ = Either [Msg] [Msg]
type MResult_ = Memoized Result_ type MResult_ = Memoized Result_
testTree_ :: (d -> FIO MResult_) -> Tree_ d -> FIO Result_ testTree_ :: (d -> XIO MResult_) -> Tree_ d -> XIO Result_
testTree_ test = go testTree_ test = go
where where
go (And_ a b) = either (return . Left) (`test2nd` b) =<< go a go (And_ a b) = either (return . Left) (`test2nd` b) =<< go a
@ -664,10 +714,10 @@ testTree_ test = go
go (Only_ a) = runMemoized =<< test a go (Only_ a) = runMemoized =<< test a
test2nd ws = fmap ((Right . (ws ++)) =<<) . go test2nd ws = fmap ((Right . (ws ++)) =<<) . go
testIODep_ :: IODependency_ -> FIO MResult_ testIODep_ :: IODependency_ -> XIO MResult_
testIODep_ d = memoizeMVar $ testIODepNoCache_ d testIODep_ d = memoizeMVar $ testIODepNoCache_ d
testIODepNoCache_ :: IODependency_ -> FIO Result_ testIODepNoCache_ :: IODependency_ -> XIO Result_
testIODepNoCache_ (IOSystem_ _ s) = readResult_ <$> testSysDependency s testIODepNoCache_ (IOSystem_ _ s) = readResult_ <$> testSysDependency s
testIODepNoCache_ (IOTest_ _ _ t) = readResult_ <$> t testIODepNoCache_ (IOTest_ _ _ t) = readResult_ <$> t
testIODepNoCache_ (IOSometimes_ x) = testIODepNoCache_ (IOSometimes_ x) =
@ -762,7 +812,7 @@ fontDependency_ fam ful = IOTest_ (fontTestName fam) ful $ voidRead <$> testFont
fontTestName :: T.Text -> T.Text fontTestName :: T.Text -> T.Text
fontTestName fam = T.unwords ["test if font", singleQuote fam, "exists"] fontTestName fam = T.unwords ["test if font", singleQuote fam, "exists"]
-- testFont :: T.Text -> FIO (Result FontBuilder) -- testFont :: T.Text -> XIO (Result FontBuilder)
-- testFont = liftIO . testFont' -- testFont = liftIO . testFont'
testFont testFont
@ -783,16 +833,16 @@ testFont fam = maybe pass (Left . (: [])) <$> shellTest "fc-list" args msg
-- start with "en" and wireless interfaces always start with "wl" -- start with "en" and wireless interfaces always start with "wl"
readEthernet :: IODependency T.Text readEthernet :: IODependency T.Text
readEthernet = readInterface "get ethernet interface" isEthernet readEthernet = readInterface "get ethernet interface" (fromMaybe "en" . xpfEthPrefix)
readWireless :: IODependency T.Text readWireless :: IODependency T.Text
readWireless = readInterface "get wireless interface" isWireless readWireless = readInterface "get wireless interface" (fromMaybe "wl" . xpfWifiPrefix)
isWireless :: T.Text -> Bool -- isWireless :: T.Text -> Bool
isWireless = T.isPrefixOf "wl" -- isWireless = T.isPrefixOf "wl"
isEthernet :: T.Text -> Bool -- isEthernet :: T.Text -> Bool
isEthernet = T.isPrefixOf "en" -- isEthernet = T.isPrefixOf "en"
listInterfaces :: MonadUnliftIO m => m [T.Text] listInterfaces :: MonadUnliftIO m => m [T.Text]
listInterfaces = listInterfaces =
@ -804,11 +854,12 @@ sysfsNet = "/sys/class/net"
-- ASSUME there are no (non-base) packages required to make these interfaces -- ASSUME there are no (non-base) packages required to make these interfaces
-- work (all at the kernel level) -- work (all at the kernel level)
readInterface :: T.Text -> (T.Text -> Bool) -> IODependency T.Text readInterface :: T.Text -> (XPFeatures -> Text) -> IODependency T.Text
readInterface n f = IORead n [] go readInterface n f = IORead n [] go
where where
go = io $ do go = do
ns <- filter f <$> listInterfaces p <- asks (f . xpFeatures . xParams)
ns <- filter (T.isPrefixOf p) <$> listInterfaces
case ns of case ns of
[] -> return $ Left [Msg LevelError "no interfaces found"] [] -> return $ Left [Msg LevelError "no interfaces found"]
(x : xs) -> do (x : xs) -> do
@ -820,7 +871,7 @@ readInterface n f = IORead n [] go
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- Misc testers -- Misc testers
socketExists :: T.Text -> [Fulfillment] -> FIO FilePath -> IODependency_ socketExists :: T.Text -> [Fulfillment] -> XIO FilePath -> IODependency_
socketExists n ful = socketExists n ful =
IOTest_ (T.unwords ["test if", n, "socket exists"]) ful . socketExists' IOTest_ (T.unwords ["test if", n, "socket exists"]) ful . socketExists'
@ -844,12 +895,12 @@ introspectInterface = interfaceName_ "org.freedesktop.DBus.Introspectable"
introspectMethod :: MemberName introspectMethod :: MemberName
introspectMethod = memberName_ "Introspect" introspectMethod = memberName_ "Introspect"
testDBusDep_ :: SafeClient c => c -> DBusDependency_ c -> FIO MResult_ testDBusDep_ :: SafeClient c => NamedConnection c -> DBusDependency_ c -> XIO MResult_
testDBusDep_ c d = memoizeMVar $ testDBusDepNoCache_ c d testDBusDep_ c d = memoizeMVar $ testDBusDepNoCache_ c d
testDBusDepNoCache_ :: SafeClient c => c -> DBusDependency_ c -> FIO Result_ testDBusDepNoCache_ :: SafeClient c => NamedConnection c -> DBusDependency_ c -> XIO Result_
testDBusDepNoCache_ cl (Bus _ bus) = io $ do testDBusDepNoCache_ cl (Bus _ bus) = do
ret <- callMethod cl queryBus queryPath queryIface queryMem ret <- withDIO cl $ callMethod queryBus queryPath queryIface queryMem
return $ case ret of return $ case ret of
Left e -> Left [Msg LevelError e] Left e -> Left [Msg LevelError e]
Right b -> Right b ->
@ -868,8 +919,10 @@ testDBusDepNoCache_ cl (Bus _ bus) = io $ do
queryMem = memberName_ "ListNames" queryMem = memberName_ "ListNames"
bodyGetNames [v] = fromMaybe [] $ fromVariant v :: [T.Text] bodyGetNames [v] = fromMaybe [] $ fromVariant v :: [T.Text]
bodyGetNames _ = [] bodyGetNames _ = []
testDBusDepNoCache_ cl (Endpoint _ busname objpath iface mem) = io $ do testDBusDepNoCache_ cl (Endpoint _ busname objpath iface mem) = do
ret <- callMethod cl busname objpath introspectInterface introspectMethod ret <-
withDIO cl $
callMethod busname objpath introspectInterface introspectMethod
return $ case ret of return $ case ret of
Left e -> Left [Msg LevelError e] Left e -> Left [Msg LevelError e]
Right body -> procBody body Right body -> procBody body
@ -925,12 +978,6 @@ testDBusDepNoCache_ _ (DBusIO i) = testIODepNoCache_ i
-- ioSubfeature :: MonadIO m => SubfeatureRoot (IO a) -> SubfeatureRoot (m a) -- ioSubfeature :: MonadIO m => SubfeatureRoot (IO a) -> SubfeatureRoot (m a)
-- ioSubfeature sf = sf {sfData = ioRoot $ sfData sf} -- ioSubfeature sf = sf {sfData = ioRoot $ sfData sf}
-- ioRoot :: MonadIO m => Root (IO a) -> Root (m a)
-- ioRoot (IORoot a t) = IORoot (io . a) t
-- ioRoot (IORoot_ a t) = IORoot_ (io a) t
-- ioRoot (DBusRoot a t cl) = DBusRoot (\p c -> io $ a p c) t cl
-- ioRoot (DBusRoot_ a t cl) = DBusRoot_ (io . a) t cl
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- Feature constructors -- Feature constructors
@ -982,16 +1029,17 @@ sometimesExeArgs fn n ful sys path args =
sometimesDBus sometimesDBus
:: SafeClient c :: SafeClient c
=> Maybe c => Maybe (NamedConnection c)
-> T.Text -> T.Text
-> T.Text -> T.Text
-> Tree_ (DBusDependency_ c) -> Tree_ (DBusDependency_ c)
-> (c -> a) -> (NamedConnection c -> a)
-> Sometimes 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
-- TODO do I need to hardcode XEnv?
sometimesEndpoint sometimesEndpoint
:: (SafeClient c, MonadIO m) :: (HasClient (DBusEnv env), SafeClient c, MonadReader env m, MonadUnliftIO m)
=> T.Text => T.Text
-> T.Text -> T.Text
-> [Fulfillment] -> [Fulfillment]
@ -999,13 +1047,13 @@ sometimesEndpoint
-> ObjectPath -> ObjectPath
-> InterfaceName -> InterfaceName
-> MemberName -> MemberName
-> Maybe c -> Maybe (NamedConnection c)
-> Sometimes (m ()) -> Sometimes (m ())
sometimesEndpoint fn name ful busname path iface mem cl = sometimesEndpoint fn name ful busname path iface mem cl =
sometimesDBus cl fn name deps cmd sometimesDBus cl fn name deps cmd
where where
deps = Only_ $ Endpoint ful 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 = void $ withDIO c $ callMethod busname path iface mem
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- Dependency Tree Constructors -- Dependency Tree Constructors

View File

@ -1,5 +1,3 @@
{-# LANGUAGE OverloadedStrings #-}
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- Dmenu (Rofi) Commands -- Dmenu (Rofi) Commands
@ -19,15 +17,18 @@ module XMonad.Internal.Command.DMenu
where where
import DBus import DBus
import qualified Data.ByteString.Char8 as BC
import Data.Internal.DBus import Data.Internal.DBus
import Data.Internal.Dependency import Data.Internal.XIO
import Graphics.X11.Types import Graphics.X11.Types
import RIO
import qualified RIO.ByteString as B
import RIO.Directory import RIO.Directory
( XdgDirectory (..) ( XdgDirectory (..)
, getXdgDirectory , getXdgDirectory
) )
import qualified RIO.Text as T import qualified RIO.Text as T
import System.IO -- import System.IO
import XMonad.Core hiding (spawn) import XMonad.Core hiding (spawn)
import XMonad.Internal.Command.Desktop import XMonad.Internal.Command.Desktop
import XMonad.Internal.DBus.Common import XMonad.Internal.DBus.Common
@ -74,7 +75,7 @@ clipboardPkgs = [Package AUR "rofi-greenclip"]
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- Other internal functions -- Other internal functions
spawnDmenuCmd :: T.Text -> [T.Text] -> SometimesX spawnDmenuCmd :: MonadUnliftIO m => T.Text -> [T.Text] -> Sometimes (m ())
spawnDmenuCmd n = spawnDmenuCmd n =
sometimesExeArgs n "rofi preset" dmenuPkgs True myDmenuCmd sometimesExeArgs n "rofi preset" dmenuPkgs True myDmenuCmd
@ -97,7 +98,7 @@ dmenuDep = sysExe dmenuPkgs myDmenuCmd
-- Exported Commands -- Exported Commands
-- TODO test that veracrypt and friends are installed -- TODO test that veracrypt and friends are installed
runDevMenu :: SometimesX runDevMenu :: MonadUnliftIO m => Sometimes (m ())
runDevMenu = sometimesIO_ "device manager" "rofi devices" t x runDevMenu = sometimesIO_ "device manager" "rofi devices" t x
where where
t = dmenuTree $ Only_ (localExe [] myDmenuDevices) t = dmenuTree $ Only_ (localExe [] myDmenuDevices)
@ -110,7 +111,7 @@ runDevMenu = sometimesIO_ "device manager" "rofi devices" t x
++ myDmenuMatchingArgs ++ myDmenuMatchingArgs
-- TODO test that bluetooth interface exists -- TODO test that bluetooth interface exists
runBTMenu :: SometimesX runBTMenu :: MonadUnliftIO m => Sometimes (m ())
runBTMenu = runBTMenu =
Sometimes Sometimes
"bluetooth selector" "bluetooth selector"
@ -120,7 +121,7 @@ runBTMenu =
cmd = spawnCmd myDmenuBluetooth $ "-c" : themeArgs "#0044bb" cmd = spawnCmd myDmenuBluetooth $ "-c" : themeArgs "#0044bb"
tree = dmenuTree $ Only_ $ sysExe [] myDmenuBluetooth tree = dmenuTree $ Only_ $ sysExe [] myDmenuBluetooth
runVPNMenu :: SometimesX runVPNMenu :: MonadUnliftIO m => Sometimes (m ())
runVPNMenu = runVPNMenu =
Sometimes Sometimes
"VPN selector" "VPN selector"
@ -136,16 +137,16 @@ runVPNMenu =
socketExists "expressVPN" [] $ socketExists "expressVPN" [] $
return "/var/lib/expressvpn/expressvpnd.socket" return "/var/lib/expressvpn/expressvpnd.socket"
runCmdMenu :: SometimesX runCmdMenu :: MonadUnliftIO m => Sometimes (m ())
runCmdMenu = spawnDmenuCmd "command menu" ["-show", "run"] runCmdMenu = spawnDmenuCmd "command menu" ["-show", "run"]
runAppMenu :: SometimesX runAppMenu :: MonadUnliftIO m => Sometimes (m ())
runAppMenu = spawnDmenuCmd "app launcher" ["-show", "drun"] runAppMenu = spawnDmenuCmd "app launcher" ["-show", "drun"]
runWinMenu :: SometimesX runWinMenu :: MonadUnliftIO m => Sometimes (m ())
runWinMenu = spawnDmenuCmd "window switcher" ["-show", "window"] runWinMenu = spawnDmenuCmd "window switcher" ["-show", "window"]
runNetMenu :: Maybe SysClient -> SometimesX runNetMenu :: MonadUnliftIO m => Maybe NamedSysConnection -> Sometimes (m ())
runNetMenu cl = runNetMenu cl =
Sometimes Sometimes
"network control menu" "network control menu"
@ -161,7 +162,7 @@ runNetMenu cl =
DBusIO $ DBusIO $
sysExe [Package AUR "networkmanager-dmenu-git"] myDmenuNetworks sysExe [Package AUR "networkmanager-dmenu-git"] myDmenuNetworks
runAutorandrMenu :: SometimesX runAutorandrMenu :: MonadUnliftIO m => Sometimes (m ())
runAutorandrMenu = sometimesIO_ "autorandr menu" "rofi autorandr" tree cmd runAutorandrMenu = sometimesIO_ "autorandr menu" "rofi autorandr" tree cmd
where where
cmd = spawnCmd myDmenuMonitors $ themeArgs "#ff0066" cmd = spawnCmd myDmenuMonitors $ themeArgs "#ff0066"
@ -170,7 +171,7 @@ runAutorandrMenu = sometimesIO_ "autorandr menu" "rofi autorandr" tree cmd
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- Password manager -- Password manager
runBwMenu :: Maybe SesClient -> SometimesX runBwMenu :: MonadUnliftIO m => Maybe NamedSesConnection -> Sometimes (m ())
runBwMenu cl = sometimesDBus cl "password manager" "rofi bitwarden" tree cmd runBwMenu cl = sometimesDBus cl "password manager" "rofi bitwarden" tree cmd
where where
cmd _ = cmd _ =
@ -183,7 +184,7 @@ runBwMenu cl = sometimesDBus cl "password manager" "rofi bitwarden" tree cmd
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- Clipboard -- Clipboard
runClipMenu :: SometimesX runClipMenu :: MonadUnliftIO m => Sometimes (m ())
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
@ -206,7 +207,9 @@ runClipMenu = sometimesIO_ "clipboard manager" "rofi greenclip" tree act
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- Shortcut menu -- Shortcut menu
runShowKeys :: Always ([((KeyMask, KeySym), NamedAction)] -> X ()) runShowKeys
:: (MonadReader env m, MonadUnliftIO m)
=> Always ([((KeyMask, KeySym), NamedAction)] -> m ())
runShowKeys = runShowKeys =
Always "keyboard menu" $ Always "keyboard menu" $
Option showKeysDMenu $ Option showKeysDMenu $
@ -219,18 +222,23 @@ runShowKeys =
spawnNotify $ spawnNotify $
defNoteError {body = Just $ Text "could not display keymap"} defNoteError {body = Just $ Text "could not display keymap"}
showKeysDMenu :: SubfeatureRoot ([((KeyMask, KeySym), NamedAction)] -> X ()) showKeysDMenu
:: (MonadReader env m, MonadUnliftIO m)
=> SubfeatureRoot ([((KeyMask, KeySym), NamedAction)] -> m ())
showKeysDMenu = showKeysDMenu =
Subfeature Subfeature
{ sfName = "keyboard shortcut menu" { sfName = "keyboard shortcut menu"
, sfData = IORoot_ showKeys $ Only_ dmenuDep , sfData = IORoot_ showKeys $ Only_ dmenuDep
} }
showKeys :: [((KeyMask, KeySym), NamedAction)] -> X () showKeys
:: (MonadReader env m, MonadUnliftIO m)
=> [((KeyMask, KeySym), NamedAction)]
-> m ()
showKeys kbs = do showKeys kbs = do
h <- spawnPipe cmd h <- spawnPipe cmd
io $ hPutStr h $ unlines $ showKm kbs B.hPut h $ BC.unlines $ BC.pack <$> showKm kbs
io $ hClose h hClose h
where where
cmd = cmd =
fmtCmd myDmenuCmd $ fmtCmd myDmenuCmd $

View File

@ -1,5 +1,3 @@
{-# LANGUAGE OverloadedStrings #-}
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- General commands -- General commands
@ -21,7 +19,8 @@ module XMonad.Internal.Command.Desktop
, runVolumeUp , runVolumeUp
, runVolumeMute , runVolumeMute
, runToggleBluetooth , runToggleBluetooth
, runToggleEthernet , runToggleNetworking
, runToggleWifi
, runRestart , runRestart
, runRecompile , runRecompile
, runAreaCapture , runAreaCapture
@ -41,7 +40,7 @@ where
import DBus import DBus
import Data.Internal.DBus import Data.Internal.DBus
import Data.Internal.Dependency import Data.Internal.XIO
import RIO import RIO
import RIO.Directory import RIO.Directory
import RIO.FilePath import RIO.FilePath
@ -60,13 +59,13 @@ import XMonad.Operations
-- My Executables -- My Executables
myTerm :: FilePath myTerm :: FilePath
myTerm = "urxvt" myTerm = "alacritty"
myCalc :: FilePath myCalc :: FilePath
myCalc = "bc" myCalc = "bc"
myBrowser :: FilePath myBrowser :: FilePath
myBrowser = "brave" myBrowser = "firefox"
myEditor :: FilePath myEditor :: FilePath
myEditor = "emacsclient" myEditor = "emacsclient"
@ -94,8 +93,7 @@ myNotificationCtrl = "dunstctl"
myTermPkgs :: [Fulfillment] myTermPkgs :: [Fulfillment]
myTermPkgs = myTermPkgs =
[ Package Official "rxvt-unicode" [ Package Official "alacritty"
, Package Official "urxvt-perls"
] ]
myEditorPkgs :: [Fulfillment] myEditorPkgs :: [Fulfillment]
@ -110,6 +108,9 @@ bluetoothPkgs = [Package Official "bluez-utils"]
networkManagerPkgs :: [Fulfillment] networkManagerPkgs :: [Fulfillment]
networkManagerPkgs = [Package Official "networkmanager"] networkManagerPkgs = [Package Official "networkmanager"]
nmcli :: IODependency_
nmcli = sysExe networkManagerPkgs "nmcli"
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- Misc constants -- Misc constants
@ -119,10 +120,10 @@ volumeChangeSound = "smb_fireball.wav"
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- Some nice apps -- Some nice apps
runTerm :: SometimesX runTerm :: MonadUnliftIO m => Sometimes (m ())
runTerm = sometimesExe "terminal" "urxvt" myTermPkgs True myTerm runTerm = sometimesExe "terminal" "alacritty" myTermPkgs True myTerm
runTMux :: SometimesX runTMux :: MonadUnliftIO m => Sometimes (m ())
runTMux = sometimesIO_ "terminal multiplexer" "tmux" deps act runTMux = sometimesIO_ "terminal multiplexer" "tmux" deps act
where where
deps = deps =
@ -140,13 +141,13 @@ runTMux = sometimesIO_ "terminal multiplexer" "tmux" deps act
t <- getTemporaryDirectory t <- getTemporaryDirectory
return $ t </> "tmux-" ++ show u </> "default" return $ t </> "tmux-" ++ show u </> "default"
runCalc :: SometimesX runCalc :: MonadUnliftIO m => Sometimes (m ())
runCalc = sometimesIO_ "calculator" "bc" deps act runCalc = sometimesIO_ "calculator" "bc" deps act
where where
deps = toAnd_ (sysExe myTermPkgs myTerm) (sysExe [Package Official "bc"] myCalc) deps = toAnd_ (sysExe myTermPkgs myTerm) (sysExe [Package Official "bc"] myCalc)
act = spawnCmd myTerm ["-e", T.pack myCalc, "-l"] act = spawnCmd myTerm ["-e", T.pack myCalc, "-l"]
runBrowser :: SometimesX runBrowser :: MonadUnliftIO m => Sometimes (m ())
runBrowser = runBrowser =
sometimesExe sometimesExe
"web browser" "web browser"
@ -155,7 +156,7 @@ runBrowser =
False False
myBrowser myBrowser
runEditor :: SometimesX runEditor :: MonadUnliftIO m => Sometimes (m ())
runEditor = sometimesIO_ "text editor" "emacs" tree cmd runEditor = sometimesIO_ "text editor" "emacs" tree cmd
where where
cmd = cmd =
@ -166,7 +167,7 @@ runEditor = sometimesIO_ "text editor" "emacs" tree cmd
-- 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 myEditorPkgs myEditor) $ process [] $ T.pack myEditorServer tree = toAnd_ (sysExe myEditorPkgs myEditor) $ process [] $ T.pack myEditorServer
runFileManager :: SometimesX runFileManager :: MonadUnliftIO m => Sometimes (m ())
runFileManager = runFileManager =
sometimesExe sometimesExe
"file browser" "file browser"
@ -178,7 +179,11 @@ runFileManager =
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- Multimedia Commands -- Multimedia Commands
runMultimediaIfInstalled :: T.Text -> T.Text -> SometimesX runMultimediaIfInstalled
:: MonadUnliftIO m
=> T.Text
-> T.Text
-> Sometimes (m ())
runMultimediaIfInstalled n cmd = runMultimediaIfInstalled n cmd =
sometimesExeArgs sometimesExeArgs
(T.append n " multimedia control") (T.append n " multimedia control")
@ -188,23 +193,23 @@ runMultimediaIfInstalled n cmd =
myMultimediaCtl myMultimediaCtl
[cmd] [cmd]
runTogglePlay :: SometimesX runTogglePlay :: MonadUnliftIO m => Sometimes (m ())
runTogglePlay = runMultimediaIfInstalled "play/pause" "play-pause" runTogglePlay = runMultimediaIfInstalled "play/pause" "play-pause"
runPrevTrack :: SometimesX runPrevTrack :: MonadUnliftIO m => Sometimes (m ())
runPrevTrack = runMultimediaIfInstalled "previous track" "previous" runPrevTrack = runMultimediaIfInstalled "previous track" "previous"
runNextTrack :: SometimesX runNextTrack :: MonadUnliftIO m => Sometimes (m ())
runNextTrack = runMultimediaIfInstalled "next track" "next" runNextTrack = runMultimediaIfInstalled "next track" "next"
runStopPlay :: SometimesX runStopPlay :: MonadUnliftIO m => Sometimes (m ())
runStopPlay = runMultimediaIfInstalled "stop playback" "stop" runStopPlay = runMultimediaIfInstalled "stop playback" "stop"
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- Volume Commands -- Volume Commands
soundDir :: FilePath soundDir :: FilePath
soundDir = "sound" soundDir = "assets" </> "sound"
playSound :: MonadIO m => FilePath -> m () playSound :: MonadIO m => FilePath -> m ()
playSound file = do playSound file = do
@ -213,7 +218,13 @@ playSound file = do
-- paplay seems to have less latency than aplay -- paplay seems to have less latency than aplay
spawnCmd "paplay" [T.pack p] spawnCmd "paplay" [T.pack p]
featureSound :: T.Text -> FilePath -> X () -> X () -> SometimesX featureSound
:: MonadUnliftIO m
=> T.Text
-> FilePath
-> m ()
-> m ()
-> Sometimes (m ())
featureSound n file pre post = featureSound n file pre post =
sometimesIO_ (T.unwords ["volume", n, " control"]) "paplay" tree $ sometimesIO_ (T.unwords ["volume", n, " control"]) "paplay" tree $
pre >> playSound file >> post pre >> playSound file >> post
@ -222,19 +233,24 @@ featureSound n file pre post =
-- to play sound (duh) but libpulse is the package with the paplay binary -- to play sound (duh) but libpulse is the package with the paplay binary
tree = Only_ $ sysExe [Package Official "pulseaudio"] "paplay" tree = Only_ $ sysExe [Package Official "pulseaudio"] "paplay"
runVolumeDown :: SometimesX runVolumeDown :: MonadUnliftIO m => Sometimes (m ())
runVolumeDown = featureSound "up" volumeChangeSound (return ()) $ void (lowerVolume 2) runVolumeDown = featureSound "up" volumeChangeSound (return ()) $ void (lowerVolume 2)
runVolumeUp :: SometimesX runVolumeUp :: MonadUnliftIO m => Sometimes (m ())
runVolumeUp = featureSound "down" volumeChangeSound (return ()) $ void (raiseVolume 2) runVolumeUp = featureSound "down" volumeChangeSound (return ()) $ void (raiseVolume 2)
runVolumeMute :: SometimesX runVolumeMute :: MonadUnliftIO m => Sometimes (m ())
runVolumeMute = featureSound "mute" volumeChangeSound (void toggleMute) $ return () runVolumeMute = featureSound "mute" volumeChangeSound (void toggleMute) $ return ()
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- Notification control -- Notification control
runNotificationCmd :: T.Text -> T.Text -> Maybe SesClient -> SometimesX runNotificationCmd
:: MonadUnliftIO m
=> T.Text
-> T.Text
-> Maybe NamedSesConnection
-> Sometimes (m ())
runNotificationCmd n arg cl = runNotificationCmd n arg cl =
sometimesDBus cl (T.unwords [n, "control"]) "dunstctl" tree cmd sometimesDBus cl (T.unwords [n, "control"]) "dunstctl" tree cmd
where where
@ -245,37 +261,37 @@ runNotificationCmd n arg cl =
Method_ $ Method_ $
memberName_ "NotificationAction" memberName_ "NotificationAction"
runNotificationClose :: Maybe SesClient -> SometimesX runNotificationClose :: MonadUnliftIO m => Maybe NamedSesConnection -> Sometimes (m ())
runNotificationClose = runNotificationCmd "close notification" "close" runNotificationClose = runNotificationCmd "close notification" "close"
runNotificationCloseAll :: Maybe SesClient -> SometimesX runNotificationCloseAll :: MonadUnliftIO m => Maybe NamedSesConnection -> Sometimes (m ())
runNotificationCloseAll = runNotificationCloseAll =
runNotificationCmd "close all notifications" "close-all" runNotificationCmd "close all notifications" "close-all"
runNotificationHistory :: Maybe SesClient -> SometimesX runNotificationHistory :: MonadUnliftIO m => Maybe NamedSesConnection -> Sometimes (m ())
runNotificationHistory = runNotificationHistory =
runNotificationCmd "see notification history" "history-pop" runNotificationCmd "see notification history" "history-pop"
runNotificationContext :: Maybe SesClient -> SometimesX runNotificationContext :: MonadUnliftIO m => Maybe NamedSesConnection -> Sometimes (m ())
runNotificationContext = runNotificationContext =
runNotificationCmd "open notification context" "context" runNotificationCmd "open notification context" "context"
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- System commands -- System commands
-- this is required for some vpn's to work properly with network-manager -- needed to lookup/prompt for passwords/keys for wifi connections and some VPNs
runNetAppDaemon :: Maybe SysClient -> Sometimes (FIO (P.Process () () ())) runNetAppDaemon :: Maybe NamedSysConnection -> Sometimes (XIO (P.Process () () ()))
runNetAppDaemon cl = runNetAppDaemon cl =
Sometimes Sometimes
"network applet" "network applet"
xpfVPN (\x -> xpfVPN x || xpfWireless x)
[Subfeature (DBusRoot_ cmd tree cl) "NM-applet"] [Subfeature (DBusRoot_ cmd tree cl) "NM-applet"]
where where
tree = toAnd_ app $ Bus networkManagerPkgs networkManagerBus tree = toAnd_ app $ Bus networkManagerPkgs networkManagerBus
app = DBusIO $ sysExe [Package Official "network-manager-applet"] "nm-applet" app = DBusIO $ sysExe [Package Official "network-manager-applet"] "nm-applet"
cmd _ = P.proc "nm-applet" [] (P.startProcess . P.setCreateGroup True) cmd _ = P.proc "nm-applet" [] (P.startProcess . P.setCreateGroup True)
runToggleBluetooth :: Maybe SysClient -> SometimesX runToggleBluetooth :: MonadUnliftIO m => Maybe NamedSysConnection -> Sometimes (m ())
runToggleBluetooth cl = runToggleBluetooth cl =
Sometimes Sometimes
"bluetooth toggle" "bluetooth toggle"
@ -292,27 +308,35 @@ runToggleBluetooth cl =
#!>> fmtCmd myBluetooth ["power", "$a", ">", "/dev/null"] #!>> fmtCmd myBluetooth ["power", "$a", ">", "/dev/null"]
#!&& fmtNotifyCmd defNoteInfo {body = Just $ Text "bluetooth powered $a"} #!&& fmtNotifyCmd defNoteInfo {body = Just $ Text "bluetooth powered $a"}
runToggleEthernet :: SometimesX runToggleNetworking :: MonadUnliftIO m => Sometimes (m ())
runToggleEthernet = runToggleNetworking =
Sometimes Sometimes
"ethernet toggle" "network toggle"
xpfEthernet (\x -> xpfEthernet x || xpfWireless x)
[Subfeature root "nmcli"] [Subfeature root "nmcli"]
where where
root = root = IORoot_ cmd $ Only_ nmcli
IORoot cmd $ cmd =
And1 (Only readEthernet) $
Only_ $
sysExe networkManagerPkgs "nmcli"
-- TODO make this less noisy
cmd iface =
S.spawn $ S.spawn $
fmtCmd "nmcli" ["-g", "GENERAL.STATE", "device", "show", iface] fmtCmd "nmcli" ["networking"]
#!| "grep -q disconnected" #!| "grep -q enabled"
#!&& "a=connect" #!&& "a=off"
#!|| "a=disconnect" #!|| "a=on"
#!>> fmtCmd "nmcli" ["device", "$a", iface] #!>> fmtCmd "nmcli" ["networking", "$a"]
#!&& fmtNotifyCmd defNoteInfo {body = Just $ Text "ethernet \"$a\"ed"} #!&& fmtNotifyCmd defNoteInfo {body = Just $ Text "networking switched $a"}
runToggleWifi :: MonadUnliftIO m => Sometimes (m ())
runToggleWifi = Sometimes "wifi toggle" xpfWireless [Subfeature root "nmcli"]
where
root = IORoot_ cmd $ Only_ nmcli
cmd =
S.spawn $
fmtCmd "nmcli" ["radio", "wifi"]
#!| "grep -q enabled"
#!&& "a=off"
#!|| "a=on"
#!>> fmtCmd "nmcli" ["radio", "wifi", "$a"]
#!&& fmtNotifyCmd defNoteInfo {body = Just $ Text "wifi switched $a"}
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- Configuration commands -- Configuration commands
@ -320,6 +344,7 @@ runToggleEthernet =
runRestart :: X () runRestart :: X ()
runRestart = restart "xmonad" True runRestart = restart "xmonad" True
-- TODO use rio in here so I don't have to fill my xinit log with stack poop
-- TODO only recompile the VM binary if we have virtualbox enabled -- TODO only recompile the VM binary if we have virtualbox enabled
runRecompile :: X () runRecompile :: X ()
runRecompile = do runRecompile = do
@ -348,7 +373,12 @@ getCaptureDir = do
where where
fallback = (</> ".local/share") <$> getHomeDirectory fallback = (</> ".local/share") <$> getHomeDirectory
runFlameshot :: T.Text -> T.Text -> Maybe SesClient -> SometimesX runFlameshot
:: MonadUnliftIO m
=> T.Text
-> T.Text
-> Maybe NamedSesConnection
-> Sometimes (m ())
runFlameshot n mode cl = sometimesDBus cl n (T.pack myCapture) tree cmd runFlameshot n mode cl = sometimesDBus cl n (T.pack myCapture) tree cmd
where where
cmd _ = spawnCmd myCapture [mode] cmd _ = spawnCmd myCapture [mode]
@ -359,18 +389,18 @@ runFlameshot n mode cl = sometimesDBus cl n (T.pack myCapture) tree cmd
-- 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
runAreaCapture :: Maybe SesClient -> SometimesX runAreaCapture :: MonadUnliftIO m => Maybe NamedSesConnection -> Sometimes (m ())
runAreaCapture = runFlameshot "screen area capture" "gui" runAreaCapture = runFlameshot "screen area capture" "gui"
-- myWindowCap = "screencap -w" --external script -- myWindowCap = "screencap -w" --external script
runDesktopCapture :: Maybe SesClient -> SometimesX runDesktopCapture :: MonadUnliftIO m => Maybe NamedSesConnection -> Sometimes (m ())
runDesktopCapture = runFlameshot "fullscreen capture" "full" runDesktopCapture = runFlameshot "fullscreen capture" "full"
runScreenCapture :: Maybe SesClient -> SometimesX runScreenCapture :: MonadUnliftIO m => Maybe NamedSesConnection -> Sometimes (m ())
runScreenCapture = runFlameshot "screen capture" "screen" runScreenCapture = runFlameshot "screen capture" "screen"
runCaptureBrowser :: SometimesX runCaptureBrowser :: MonadUnliftIO m => Sometimes (m ())
runCaptureBrowser = sometimesIO_ runCaptureBrowser = sometimesIO_
"screen capture browser" "screen capture browser"
"feh" "feh"

View File

@ -1,5 +1,3 @@
{-# LANGUAGE OverloadedStrings #-}
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- Commands for controlling power -- Commands for controlling power
@ -26,7 +24,7 @@ module XMonad.Internal.Command.Power
) )
where where
import Data.Internal.Dependency import Data.Internal.XIO
import Graphics.X11.Types import Graphics.X11.Types
import RIO import RIO
import RIO.Directory import RIO.Directory
@ -69,29 +67,30 @@ runScreenLock =
False False
myScreenlock myScreenlock
runPowerOff :: X () runPowerOff :: MonadUnliftIO m => m ()
runPowerOff = spawn "systemctl poweroff" runPowerOff = spawn "systemctl poweroff"
runSuspend :: X () runSuspend :: MonadUnliftIO m => m ()
runSuspend = spawn "systemctl suspend" runSuspend = spawn "systemctl suspend"
runHibernate :: X () runHibernate :: MonadUnliftIO m => m ()
runHibernate = spawn "systemctl hibernate" runHibernate = spawn "systemctl hibernate"
runReboot :: X () runReboot :: MonadUnliftIO m => m ()
runReboot = spawn "systemctl reboot" runReboot = spawn "systemctl reboot"
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- Autolock -- Autolock
runAutolock :: Sometimes (FIO (P.Process () () ())) runAutolock :: Sometimes (XIO (P.Process () () ()))
runAutolock = sometimesIO_ "automatic screen lock" "xss-lock" tree cmd runAutolock = sometimesIO_ "automatic screen lock" "xss-lock" tree cmd
where where
tree = tree =
And_ (Only_ $ sysExe [Package Official "xss-lock"] "xss-lock") $ And_ (Only_ $ sysExe [Package Official "xss-lock"] "xss-lock") $
Only_ $ Only_ $
IOSometimes_ runScreenLock IOSometimes_ runScreenLock
cmd = P.proc "xss-lock" ["--ignore-sleep", "screenlock"] (P.startProcess . P.setCreateGroup True) cmd = P.proc "xss-lock" args (P.startProcess . P.setCreateGroup True)
args = ["--ignore-sleep", "--", "screenlock", "true"]
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- Confirmation prompts -- Confirmation prompts
@ -106,7 +105,7 @@ confirmPrompt' :: T.Text -> X () -> XT.FontBuilder -> X ()
confirmPrompt' s x fb = confirmPrompt (XT.promptTheme fb) (T.unpack s) x confirmPrompt' s x fb = confirmPrompt (XT.promptTheme fb) (T.unpack s) x
suspendPrompt :: XT.FontBuilder -> X () suspendPrompt :: XT.FontBuilder -> X ()
suspendPrompt = confirmPrompt' "suspend?" runSuspend suspendPrompt = confirmPrompt' "suspend?" $ liftIO runSuspend
quitPrompt :: XT.FontBuilder -> X () quitPrompt :: XT.FontBuilder -> X ()
quitPrompt = confirmPrompt' "quit?" $ io exitSuccess quitPrompt = confirmPrompt' "quit?" $ io exitSuccess
@ -180,17 +179,20 @@ data PowerMaybeAction
| Reboot | Reboot
deriving (Eq) deriving (Eq)
instance Enum PowerMaybeAction where fromPMA :: PowerMaybeAction -> Int
toEnum 0 = Poweroff fromPMA a = case a of
toEnum 1 = Shutdown Poweroff -> 0
toEnum 2 = Hibernate Shutdown -> 1
toEnum 3 = Reboot Hibernate -> 2
toEnum _ = errorWithoutStackTrace "Main.Enum.PowerMaybeAction.toEnum: bad argument" Reboot -> 3
fromEnum Poweroff = 0 toPMA :: Int -> Maybe PowerMaybeAction
fromEnum Shutdown = 1 toPMA x = case x of
fromEnum Hibernate = 2 0 -> Just Poweroff
fromEnum Reboot = 3 1 -> Just Shutdown
2 -> Just Hibernate
3 -> Just Reboot
_ -> Nothing
data PowerPrompt = PowerPrompt data PowerPrompt = PowerPrompt
@ -222,9 +224,11 @@ powerPrompt lock fb = mkXPrompt PowerPrompt theme comp executeMaybeAction
, (xK_Return, quit) , (xK_Return, quit)
, (xK_Escape, quit) , (xK_Escape, quit)
] ]
sendMaybeAction a = setInput (show $ fromEnum a) >> setSuccess True >> setDone True sendMaybeAction a = setInput (show $ fromPMA a) >> setSuccess True >> setDone True
executeMaybeAction a = case toEnum $ read a of executeMaybeAction a = case toPMA =<< readMaybe a of
Poweroff -> runPowerOff Just Poweroff -> liftIO runPowerOff
Shutdown -> lock >> runSuspend Just Shutdown -> lock >> liftIO runSuspend
Hibernate -> lock >> runHibernate Just Hibernate -> lock >> liftIO runHibernate
Reboot -> runReboot Just Reboot -> liftIO runReboot
-- TODO log an error here since this should never happen
Nothing -> skip

View File

@ -1,6 +1,3 @@
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- Concurrent module to handle events from acpid -- Concurrent module to handle events from acpid
@ -10,7 +7,7 @@ module XMonad.Internal.Concurrent.ACPIEvent
) )
where where
import Data.Internal.Dependency import Data.Internal.XIO
import Network.Socket import Network.Socket
import Network.Socket.ByteString import Network.Socket.ByteString
import RIO import RIO
@ -33,15 +30,18 @@ data ACPIEvent
| LidClose | LidClose
deriving (Eq) deriving (Eq)
instance Enum ACPIEvent where fromACPIEvent :: ACPIEvent -> Int
toEnum 0 = Power fromACPIEvent x = case x of
toEnum 1 = Sleep Power -> 0
toEnum 2 = LidClose Sleep -> 1
toEnum _ = errorWithoutStackTrace "ACPI.Enum.ACPIEvent.toEnum: bad argument" LidClose -> 2
fromEnum Power = 0 toACPIEvent :: Int -> Maybe ACPIEvent
fromEnum Sleep = 1 toACPIEvent x = case x of
fromEnum LidClose = 2 0 -> Just Power
1 -> Just Sleep
2 -> Just LidClose
_ -> Nothing
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- Internal functions -- Internal functions
@ -64,7 +64,7 @@ parseLine line =
-- | Send an ACPIEvent to the X server as a ClientMessage -- | Send an ACPIEvent to the X server as a ClientMessage
sendACPIEvent :: ACPIEvent -> IO () sendACPIEvent :: ACPIEvent -> IO ()
sendACPIEvent = sendXMsg ACPI . show . fromEnum sendACPIEvent = sendXMsg ACPI . show . fromACPIEvent
isDischarging :: IO (Maybe Bool) isDischarging :: IO (Maybe Bool)
isDischarging = do isDischarging = do
@ -91,14 +91,14 @@ socketDep = Only_ $ pathR acpiPath [Package Official "acpid"]
-- Xmonad's event hook) -- Xmonad's event hook)
handleACPI :: FontBuilder -> X () -> String -> X () handleACPI :: FontBuilder -> X () -> String -> X ()
handleACPI fb lock tag = do handleACPI fb lock tag = do
let acpiTag = toEnum <$> readMaybe tag :: Maybe ACPIEvent let acpiTag = toACPIEvent =<< readMaybe tag :: Maybe ACPIEvent
forM_ acpiTag $ \case forM_ acpiTag $ \case
Power -> powerPrompt lock fb Power -> powerPrompt lock fb
Sleep -> suspendPrompt fb Sleep -> suspendPrompt fb
LidClose -> do LidClose -> do
status <- io isDischarging status <- io isDischarging
-- only run suspend if battery exists and is discharging -- only run suspend if battery exists and is discharging
forM_ status $ flip when runSuspend forM_ status $ flip when $ liftIO runSuspend
lock lock
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------

View File

@ -28,6 +28,7 @@ import Graphics.X11.Xlib.Atom
import Graphics.X11.Xlib.Display import Graphics.X11.Xlib.Display
import Graphics.X11.Xlib.Event import Graphics.X11.Xlib.Event
import Graphics.X11.Xlib.Extras import Graphics.X11.Xlib.Extras
import RIO
import XMonad.Internal.IO import XMonad.Internal.IO
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
@ -42,14 +43,18 @@ data XMsgType
| Unknown | Unknown
deriving (Eq, Show) deriving (Eq, Show)
instance Enum XMsgType where fromXMsgType :: XMsgType -> Int
toEnum 0 = ACPI fromXMsgType x = case x of
toEnum 1 = Workspace ACPI -> 0
toEnum _ = errorWithoutStackTrace "ACPI.Enum.ACPIEvent.toEnum: bad argument" Workspace -> 1
Unknown -> 2
fromEnum ACPI = 0 toXMsgType :: Int -> Maybe XMsgType
fromEnum Workspace = 1 toXMsgType x = case x of
fromEnum Unknown = 2 0 -> Just ACPI
1 -> Just Workspace
2 -> Just Unknown
_ -> Nothing
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- Exported API -- Exported API
@ -58,9 +63,9 @@ instance Enum XMsgType where
-- type and payload -- type and payload
splitXMsg :: (Integral a) => [a] -> (XMsgType, String) splitXMsg :: (Integral a) => [a] -> (XMsgType, String)
splitXMsg [] = (Unknown, "") splitXMsg [] = (Unknown, "")
splitXMsg (x : xs) = (xtype, tag) splitXMsg (x : xs) = (fromMaybe Unknown xtype, tag)
where where
xtype = toEnum $ fromIntegral x xtype = toXMsgType $ fromIntegral x
tag = chr . fromIntegral <$> takeWhile (/= 0) xs tag = chr . fromIntegral <$> takeWhile (/= 0) xs
-- | Emit a ClientMessage event to the X server with the given type and payloud -- | Emit a ClientMessage event to the X server with the given type and payloud
@ -86,5 +91,5 @@ sendXMsg xtype tag = withOpenDisplay $ \dpy -> do
setClientMessageEvent' e root bITMAP 8 (x : t) setClientMessageEvent' e root bITMAP 8 (x : t)
sendEvent dpy root False substructureNotifyMask e sendEvent dpy root False substructureNotifyMask e
where where
x = fromIntegral $ fromEnum xtype x = fromIntegral $ fromXMsgType xtype
t = fmap (fromIntegral . fromEnum) tag t = fmap (fromIntegral . fromEnum) tag

View File

@ -34,6 +34,8 @@ module XMonad.Internal.Concurrent.DynamicWorkspaces
) )
where where
import qualified Data.ByteString.Char8 as BC
import Data.Internal.XIO
import Graphics.X11.Types import Graphics.X11.Types
import Graphics.X11.Xlib.Atom import Graphics.X11.Xlib.Atom
import Graphics.X11.Xlib.Display import Graphics.X11.Xlib.Display
@ -88,38 +90,49 @@ data DynWorkspace = DynWorkspace
-- the same as that in XMonad itself (eg with Query types) -- the same as that in XMonad itself (eg with Query types)
-- type MatchTags = M.Map String String -- type MatchTags = M.Map String String
data WConf = WConf data WEnv = WEnv
{ display :: Display { wDisplay :: !Display
, dynWorkspaces :: [DynWorkspace] , wDynWorkspaces :: ![DynWorkspace]
, curPIDs :: MVar (S.Set Pid) , wCurPIDs :: !(MVar (S.Set Pid))
, wXEnv :: !XEnv
} }
type W a = RIO WConf () instance HasLogFunc WEnv where
logFuncL = lens wXEnv (\x y -> x {wXEnv = y}) . logFuncL
runWorkspaceMon :: [DynWorkspace] -> IO () type WIO a = RIO WEnv a
runWorkspaceMon :: [DynWorkspace] -> XIO ()
runWorkspaceMon dws = withOpenDisplay $ \dpy -> do runWorkspaceMon dws = withOpenDisplay $ \dpy -> do
root <- rootWindow dpy $ defaultScreen dpy root <- liftIO $ rootWindow dpy $ defaultScreen dpy
-- listen only for substructure change events (which includes MapNotify) -- listen only for substructure change events (which includes MapNotify)
allocaSetWindowAttributes $ \a -> do liftIO $ allocaSetWindowAttributes $ \a -> do
set_event_mask a substructureNotifyMask set_event_mask a substructureNotifyMask
changeWindowAttributes dpy root cWEventMask a changeWindowAttributes dpy root cWEventMask a
void $ allocaXEvent $ withEvents dpy withRunInIO $ \runIO -> do
void $ allocaXEvent $ runIO . withEvents dpy
where where
wrapEnv dpy ps x =
WEnv
{ wDisplay = dpy
, wDynWorkspaces = dws
, wCurPIDs = ps
, wXEnv = x
}
withEvents dpy e = do withEvents dpy e = do
ps <- newMVar S.empty ps <- newMVar S.empty
let c = WConf {display = dpy, dynWorkspaces = dws, curPIDs = ps} mapRIO (wrapEnv dpy ps) $ do
runRIO c $
forever $ forever $
handleEvent =<< io (nextEvent dpy e >> getEvent e) handleEvent =<< io (nextEvent dpy e >> getEvent e)
handleEvent :: Event -> W () handleEvent :: Event -> WIO ()
-- | assume this fires at least once when a new window is created (also could -- | assume this fires at least once when a new window is created (also could
-- use CreateNotify but that is really noisy) -- use CreateNotify but that is really noisy)
handleEvent MapNotifyEvent {ev_window = w} = do handleEvent MapNotifyEvent {ev_window = w} = do
dpy <- asks display dpy <- asks wDisplay
hint <- io $ getClassHint dpy w hint <- io $ getClassHint dpy w
dws <- asks dynWorkspaces dws <- asks wDynWorkspaces
let tag = let tag =
M.lookup (resClass hint) $ M.lookup (resClass hint) $
M.fromList $ M.fromList $
@ -133,21 +146,28 @@ handleEvent MapNotifyEvent {ev_window = w} = do
_ -> return () _ -> return ()
handleEvent _ = return () handleEvent _ = return ()
withUniquePid :: Pid -> String -> W () withUniquePid :: Pid -> String -> WIO ()
withUniquePid pid tag = do withUniquePid pid tag = do
ps <- asks curPIDs ps <- asks wCurPIDs
pids <- readMVar ps pids <- readMVar ps
io unless (pid `elem` pids)
$ unless (pid `elem` pids)
$ bracket_ $ bracket_
(modifyMVar_ ps (return . S.insert pid)) (modifyMVar_ ps (return . S.insert pid))
(modifyMVar_ ps (return . S.delete pid)) (modifyMVar_ ps (return . S.delete pid))
$ waitUntilExit pid >> sendXMsg Workspace tag $ do
logInfo $ "waiting for pid " <> pid_ <> " to exit on workspace " <> tag_
waitUntilExit pid
logInfo $ "pid " <> pid_ <> " exited on workspace " <> tag_
liftIO $ sendXMsg Workspace tag
where
pid_ = "'" <> displayShow pid <> "'"
tag_ = "'" <> displayBytesUtf8 (BC.pack tag) <> "'"
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- Launching apps -- Launching apps
-- When launching apps on dymamic workspaces, first check if they are running -- When launching apps on dymamic workspaces, first check if they are running
-- and launch if not, then switch to their workspace -- and launch if not, then switch to their workspace
wsOccupied :: Eq a1 => a1 -> W.StackSet a1 l a2 sid sd -> Bool wsOccupied :: Eq a1 => a1 -> W.StackSet a1 l a2 sid sd -> Bool
wsOccupied tag ws = wsOccupied tag ws =
elem tag $ elem tag $

View File

@ -1,6 +1,3 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- VirtualBox-specific functions -- VirtualBox-specific functions
@ -11,7 +8,7 @@ module XMonad.Internal.Concurrent.VirtualBox
) )
where where
import Data.Internal.Dependency import Data.Internal.XIO
import RIO hiding (try) import RIO hiding (try)
import RIO.Directory import RIO.Directory
import RIO.FilePath import RIO.FilePath
@ -36,7 +33,7 @@ vmInstanceConfig vmName = do
vmDirectory :: IO (Either String String) vmDirectory :: IO (Either String String)
vmDirectory = do vmDirectory = do
p <- vmConfig p <- vmConfig
s <- tryIO $ readFile p s <- tryIO $ readFileUtf8 p
return $ case s of return $ case s of
(Left _) -> Left "could not read VirtualBox config file" (Left _) -> Left "could not read VirtualBox config file"
(Right x) -> (Right x) ->

View File

@ -1,5 +1,3 @@
{-# LANGUAGE OverloadedStrings #-}
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- DBus module for Clevo Keyboard control -- DBus module for Clevo Keyboard control
@ -15,7 +13,7 @@ where
import DBus import DBus
import Data.Internal.DBus import Data.Internal.DBus
import Data.Internal.Dependency import Data.Internal.XIO
import RIO import RIO
import RIO.FilePath import RIO.FilePath
import XMonad.Internal.DBus.Brightness.Common import XMonad.Internal.DBus.Brightness.Common
@ -46,34 +44,34 @@ backlightDir = "/sys/devices/platform/tuxedo_keyboard"
stateFile :: FilePath stateFile :: FilePath
stateFile = backlightDir </> "state" stateFile = backlightDir </> "state"
stateChange :: Bool -> IO () stateChange :: MonadUnliftIO m => Bool -> m ()
stateChange = writeBool stateFile stateChange = writeBool stateFile
stateOn :: IO () stateOn :: MonadUnliftIO m => m ()
stateOn = stateChange True stateOn = stateChange True
stateOff :: IO () stateOff :: MonadUnliftIO m => m ()
stateOff = stateChange False stateOff = stateChange False
brightnessFile :: FilePath brightnessFile :: FilePath
brightnessFile = backlightDir </> "brightness" brightnessFile = backlightDir </> "brightness"
getBrightness :: RawBounds -> IO Brightness getBrightness :: MonadUnliftIO m => RawBounds -> m Brightness
getBrightness bounds = readPercent bounds brightnessFile getBrightness bounds = readPercent bounds brightnessFile
minBrightness :: RawBounds -> IO Brightness minBrightness :: MonadUnliftIO m => RawBounds -> m Brightness
minBrightness bounds = do minBrightness bounds = do
b <- writePercentMin bounds brightnessFile b <- writePercentMin bounds brightnessFile
stateOff stateOff
return b return b
maxBrightness :: RawBounds -> IO Brightness maxBrightness :: MonadUnliftIO m => RawBounds -> m Brightness
maxBrightness bounds = stateOn >> writePercentMax bounds brightnessFile maxBrightness bounds = stateOn >> writePercentMax bounds brightnessFile
incBrightness :: RawBounds -> IO Brightness incBrightness :: MonadUnliftIO m => RawBounds -> m Brightness
incBrightness bounds = stateOn >> incPercent steps brightnessFile bounds incBrightness bounds = stateOn >> incPercent steps brightnessFile bounds
decBrightness :: RawBounds -> IO Brightness decBrightness :: MonadUnliftIO m => RawBounds -> m Brightness
decBrightness bounds = do decBrightness bounds = do
b <- decPercent steps brightnessFile bounds b <- decPercent steps brightnessFile bounds
when (b == 0) stateOff when (b == 0) stateOff
@ -88,7 +86,7 @@ blPath = objectPath_ "/clevo_keyboard"
interface :: InterfaceName interface :: InterfaceName
interface = interfaceName_ "org.xmonad.Brightness" interface = interfaceName_ "org.xmonad.Brightness"
clevoKeyboardConfig :: BrightnessConfig RawBrightness Brightness clevoKeyboardConfig :: MonadUnliftIO m => BrightnessConfig m RawBrightness Brightness
clevoKeyboardConfig = clevoKeyboardConfig =
BrightnessConfig BrightnessConfig
{ bcMin = minBrightness { bcMin = minBrightness
@ -113,9 +111,14 @@ brightnessFileDep :: IODependency_
brightnessFileDep = pathR brightnessFile [Package AUR "tuxedo-keyboard"] brightnessFileDep = pathR brightnessFile [Package AUR "tuxedo-keyboard"]
clevoKeyboardSignalDep :: DBusDependency_ SesClient clevoKeyboardSignalDep :: DBusDependency_ SesClient
clevoKeyboardSignalDep = signalDep clevoKeyboardConfig clevoKeyboardSignalDep =
-- TODO do I need to get rid of the IO here?
signalDep (clevoKeyboardConfig :: BrightnessConfig IO RawBrightness Brightness)
exportClevoKeyboard :: Maybe SesClient -> SometimesIO exportClevoKeyboard
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
=> Maybe NamedSesConnection
-> Sometimes (m (), m ())
exportClevoKeyboard = exportClevoKeyboard =
brightnessExporter brightnessExporter
xpfClevoBacklight xpfClevoBacklight
@ -123,15 +126,23 @@ exportClevoKeyboard =
[stateFileDep, brightnessFileDep] [stateFileDep, brightnessFileDep]
clevoKeyboardConfig clevoKeyboardConfig
clevoKeyboardControls :: Maybe SesClient -> BrightnessControls clevoKeyboardControls
:: (HasClient (DBusEnv env), MonadReader env m, MonadUnliftIO m)
=> Maybe NamedSesConnection
-> BrightnessControls m
clevoKeyboardControls = brightnessControls xpfClevoBacklight clevoKeyboardConfig clevoKeyboardControls = brightnessControls xpfClevoBacklight clevoKeyboardConfig
callGetBrightnessCK :: MonadUnliftIO m => SesClient -> m (Maybe Brightness) callGetBrightnessCK
:: (SafeClient c, HasClient env, MonadReader (env c) m, MonadUnliftIO m)
=> m (Maybe Brightness)
callGetBrightnessCK = callGetBrightness clevoKeyboardConfig callGetBrightnessCK = callGetBrightness clevoKeyboardConfig
matchSignalCK matchSignalCK
:: MonadUnliftIO m :: ( SafeClient c
, HasClient env
, MonadReader (env c) m
, MonadUnliftIO m
)
=> (Maybe Brightness -> m ()) => (Maybe Brightness -> m ())
-> SesClient
-> m () -> m ()
matchSignalCK = matchSignal clevoKeyboardConfig matchSignalCK = matchSignal clevoKeyboardConfig

View File

@ -1,5 +1,3 @@
{-# LANGUAGE OverloadedStrings #-}
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- DBus module for DBus brightness controls -- DBus module for DBus brightness controls
@ -18,10 +16,9 @@ import DBus
import DBus.Client import DBus.Client
import qualified DBus.Introspection as I import qualified DBus.Introspection as I
import Data.Internal.DBus import Data.Internal.DBus
import Data.Internal.Dependency import Data.Internal.XIO
import RIO import RIO
import qualified RIO.Text as T import qualified RIO.Text as T
import XMonad.Core (io)
import XMonad.Internal.DBus.Common import XMonad.Internal.DBus.Common
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
@ -32,31 +29,32 @@ import XMonad.Internal.DBus.Common
-- integer and emit a signal with the same brightness value. Additionally, there -- integer and emit a signal with the same brightness value. Additionally, there
-- is one method to get the current brightness. -- is one method to get the current brightness.
data BrightnessConfig a b = BrightnessConfig data BrightnessConfig m a b = BrightnessConfig
{ bcMin :: (a, a) -> IO b { bcMin :: (a, a) -> m b
, bcMax :: (a, a) -> IO b , bcMax :: (a, a) -> m b
, bcDec :: (a, a) -> IO b , bcDec :: (a, a) -> m b
, bcInc :: (a, a) -> IO b , bcInc :: (a, a) -> m b
, bcGet :: (a, a) -> IO b , bcGet :: (a, a) -> m b
, bcMinRaw :: a , bcMinRaw :: a
, bcGetMax :: IO a , bcGetMax :: m a
, bcPath :: ObjectPath , bcPath :: ObjectPath
, bcInterface :: InterfaceName , bcInterface :: InterfaceName
, bcName :: T.Text , bcName :: T.Text
} }
data BrightnessControls = BrightnessControls data BrightnessControls m = BrightnessControls
{ bctlMax :: SometimesX { bctlMax :: Sometimes (m ())
, bctlMin :: SometimesX , bctlMin :: Sometimes (m ())
, bctlInc :: SometimesX , bctlInc :: Sometimes (m ())
, bctlDec :: SometimesX , bctlDec :: Sometimes (m ())
} }
brightnessControls brightnessControls
:: XPQuery :: (HasClient (DBusEnv env), MonadReader env m, MonadUnliftIO m)
-> BrightnessConfig a b => XPQuery
-> Maybe SesClient -> BrightnessConfig m a b
-> BrightnessControls -> Maybe NamedSesConnection
-> BrightnessControls m
brightnessControls q bc cl = brightnessControls q bc cl =
BrightnessControls BrightnessControls
{ bctlMax = cb "max brightness" memMax { bctlMax = cb "max brightness" memMax
@ -68,26 +66,34 @@ brightnessControls q bc cl =
cb = callBacklight q cl bc cb = callBacklight q cl bc
callGetBrightness callGetBrightness
:: (MonadUnliftIO m, SafeClient c, Num n) :: ( HasClient env
=> BrightnessConfig a b , MonadReader (env c) m
-> c , MonadUnliftIO m
, SafeClient c
, Num n
)
=> BrightnessConfig m a b
-> m (Maybe n) -> m (Maybe n)
callGetBrightness BrightnessConfig {bcPath = p, bcInterface = i} client = callGetBrightness BrightnessConfig {bcPath = p, bcInterface = i} =
either (const Nothing) bodyGetBrightness either (const Nothing) bodyGetBrightness
<$> callMethod client xmonadBusName p i memGet <$> callMethod xmonadSesBusName p i memGet
signalDep :: BrightnessConfig a b -> DBusDependency_ SesClient signalDep :: BrightnessConfig m a b -> DBusDependency_ c
signalDep BrightnessConfig {bcPath = p, bcInterface = i} = signalDep BrightnessConfig {bcPath = p, bcInterface = i} =
Endpoint [] xmonadBusName p i $ Signal_ memCur Endpoint [] xmonadSesBusName p i $ Signal_ memCur
matchSignal matchSignal
:: (MonadUnliftIO m, SafeClient c, Num n) :: ( HasClient env
=> BrightnessConfig a b , MonadReader (env c) m
, MonadUnliftIO m
, SafeClient c
, Num n
)
=> BrightnessConfig m a b
-> (Maybe n -> m ()) -> (Maybe n -> m ())
-> c
-> m () -> m ()
matchSignal BrightnessConfig {bcPath = p, bcInterface = i} cb = matchSignal BrightnessConfig {bcPath = p, bcInterface = i} cb =
void . addMatchCallback brMatcher (cb . bodyGetBrightness) void $ addMatchCallback brMatcher (cb . bodyGetBrightness)
where where
-- TODO add busname to this -- TODO add busname to this
brMatcher = brMatcher =
@ -101,45 +107,46 @@ matchSignal BrightnessConfig {bcPath = p, bcInterface = i} cb =
-- Internal DBus Crap -- Internal DBus Crap
brightnessExporter brightnessExporter
:: RealFrac b :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m, RealFrac b)
=> XPQuery => XPQuery
-> [Fulfillment] -> [Fulfillment]
-> [IODependency_] -> [IODependency_]
-> BrightnessConfig a b -> BrightnessConfig m a b
-> Maybe SesClient -> Maybe NamedSesConnection
-> SometimesIO -> Sometimes (m (), m ())
brightnessExporter q ful deps bc@BrightnessConfig {bcName = n} cl = brightnessExporter q ful deps bc@BrightnessConfig {bcName = n} cl =
Sometimes (T.append n " DBus Interface") q [Subfeature root "exporter"] Sometimes (T.append n " DBus Interface") q [Subfeature root "exporter"]
where where
root = DBusRoot_ (exportBrightnessControls' bc) tree cl root = DBusRoot_ (exportBrightnessControlsInner bc) tree cl
tree = listToAnds (Bus ful xmonadBusName) $ fmap DBusIO deps tree = listToAnds (Bus ful xmonadSesBusName) $ fmap DBusIO deps
exportBrightnessControls' exportBrightnessControlsInner
:: (MonadUnliftIO m, RealFrac b) :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m, RealFrac b)
=> BrightnessConfig a b => BrightnessConfig m a b
-> SesClient -> NamedSesConnection
-> m () -> (m (), m ())
exportBrightnessControls' bc cl = io $ do exportBrightnessControlsInner bc = cmd
let ses = toClient cl
maxval <- bcGetMax bc -- assume the max value will never change
let bounds = (bcMinRaw bc, maxval)
let autoMethod' m f = autoMethod m $ emitBrightness bc ses =<< f bc bounds
let funget = bcGet bc
export
ses
(bcPath bc)
defaultInterface
{ interfaceName = bcInterface bc
, interfaceMethods =
[ autoMethod' memMax bcMax
, autoMethod' memMin bcMin
, autoMethod' memInc bcInc
, autoMethod' memDec bcDec
, autoMethod memGet (round <$> funget bounds :: IO Int32)
]
, interfaceSignals = [sig]
}
where where
cmd = exportPair (bcPath bc) $ \cl_ -> do
-- assume the max value will never change
bounds <- (bcMinRaw bc,) <$> bcGetMax bc
runIO <- askRunInIO
let autoMethod' m f = autoMethod m $ runIO $ do
val <- f bc bounds
emitBrightness bc cl_ val
funget <- toIO $ bcGet bc bounds
return $
defaultInterface
{ interfaceName = bcInterface bc
, interfaceMethods =
[ autoMethod' memMax bcMax
, autoMethod' memMin bcMin
, autoMethod' memInc bcInc
, autoMethod' memDec bcDec
, autoMethod memGet (round <$> funget :: IO Int32)
]
, interfaceSignals = [sig]
}
sig = sig =
I.Signal I.Signal
{ I.signalName = memCur { I.signalName = memCur
@ -153,7 +160,7 @@ exportBrightnessControls' bc cl = io $ do
emitBrightness emitBrightness
:: (MonadUnliftIO m, RealFrac b) :: (MonadUnliftIO m, RealFrac b)
=> BrightnessConfig a b => BrightnessConfig m a b
-> Client -> Client
-> b -> b
-> m () -> m ()
@ -163,26 +170,18 @@ emitBrightness BrightnessConfig {bcPath = p, bcInterface = i} client cur =
sig = signal p i memCur sig = signal p i memCur
callBacklight callBacklight
:: XPQuery :: (MonadReader env m, HasClient (DBusEnv env), MonadUnliftIO m)
-> Maybe SesClient => XPQuery
-> BrightnessConfig a b -> Maybe NamedSesConnection
-> BrightnessConfig m a b
-> T.Text -> T.Text
-> MemberName -> MemberName
-> SometimesX -> Sometimes (m ())
callBacklight callBacklight q cl BrightnessConfig {bcPath = p, bcInterface = i, bcName = n} controlName m =
q Sometimes (T.unwords [n, controlName]) q [Subfeature root "method call"]
cl where
BrightnessConfig root = DBusRoot_ cmd (Only_ $ Endpoint [] xmonadSesBusName p i $ Method_ m) cl
{ bcPath = p cmd c = void $ withDIO c $ callMethod xmonadSesBusName p i m
, bcInterface = i
, bcName = n
}
controlName
m =
Sometimes (T.unwords [n, controlName]) q [Subfeature root "method call"]
where
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 bodyGetBrightness :: Num a => [Variant] -> Maybe a
bodyGetBrightness [b] = fromIntegral <$> (fromVariant b :: Maybe Int32) bodyGetBrightness [b] = fromIntegral <$> (fromVariant b :: Maybe Int32)

View File

@ -1,5 +1,3 @@
{-# LANGUAGE OverloadedStrings #-}
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- DBus module for Intel Backlight control -- DBus module for Intel Backlight control
@ -15,7 +13,7 @@ where
import DBus import DBus
import Data.Internal.DBus import Data.Internal.DBus
import Data.Internal.Dependency import Data.Internal.XIO
import RIO import RIO
import RIO.FilePath import RIO.FilePath
import XMonad.Internal.DBus.Brightness.Common import XMonad.Internal.DBus.Brightness.Common
@ -45,22 +43,22 @@ maxFile = backlightDir </> "max_brightness"
curFile :: FilePath curFile :: FilePath
curFile = backlightDir </> "brightness" curFile = backlightDir </> "brightness"
getMaxRawBrightness :: IO RawBrightness getMaxRawBrightness :: MonadUnliftIO m => m RawBrightness
getMaxRawBrightness = readInt maxFile getMaxRawBrightness = readInt maxFile
getBrightness :: RawBounds -> IO Brightness getBrightness :: MonadUnliftIO m => RawBounds -> m Brightness
getBrightness bounds = readPercent bounds curFile getBrightness bounds = readPercent bounds curFile
minBrightness :: RawBounds -> IO Brightness minBrightness :: MonadUnliftIO m => RawBounds -> m Brightness
minBrightness bounds = writePercentMin bounds curFile minBrightness bounds = writePercentMin bounds curFile
maxBrightness :: RawBounds -> IO Brightness maxBrightness :: MonadUnliftIO m => RawBounds -> m Brightness
maxBrightness bounds = writePercentMax bounds curFile maxBrightness bounds = writePercentMax bounds curFile
incBrightness :: RawBounds -> IO Brightness incBrightness :: MonadUnliftIO m => RawBounds -> m Brightness
incBrightness = incPercent steps curFile incBrightness = incPercent steps curFile
decBrightness :: RawBounds -> IO Brightness decBrightness :: MonadUnliftIO m => RawBounds -> m Brightness
decBrightness = decPercent steps curFile decBrightness = decPercent steps curFile
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
@ -72,7 +70,9 @@ blPath = objectPath_ "/intelbacklight"
interface :: InterfaceName interface :: InterfaceName
interface = interfaceName_ "org.xmonad.Brightness" interface = interfaceName_ "org.xmonad.Brightness"
intelBacklightConfig :: BrightnessConfig RawBrightness Brightness intelBacklightConfig
:: MonadUnliftIO m
=> BrightnessConfig m RawBrightness Brightness
intelBacklightConfig = intelBacklightConfig =
BrightnessConfig BrightnessConfig
{ bcMin = minBrightness { bcMin = minBrightness
@ -97,9 +97,14 @@ maxFileDep :: IODependency_
maxFileDep = pathR maxFile [] maxFileDep = pathR maxFile []
intelBacklightSignalDep :: DBusDependency_ SesClient intelBacklightSignalDep :: DBusDependency_ SesClient
intelBacklightSignalDep = signalDep intelBacklightConfig intelBacklightSignalDep =
-- TODO do I need to get rid of the IO here?
signalDep (intelBacklightConfig :: BrightnessConfig IO RawBrightness Brightness)
exportIntelBacklight :: Maybe SesClient -> SometimesIO exportIntelBacklight
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
=> Maybe NamedSesConnection
-> Sometimes (m (), m ())
exportIntelBacklight = exportIntelBacklight =
brightnessExporter brightnessExporter
xpfIntelBacklight xpfIntelBacklight
@ -107,15 +112,23 @@ exportIntelBacklight =
[curFileDep, maxFileDep] [curFileDep, maxFileDep]
intelBacklightConfig intelBacklightConfig
intelBacklightControls :: Maybe SesClient -> BrightnessControls intelBacklightControls
:: (HasClient (DBusEnv env), MonadReader env m, MonadUnliftIO m)
=> Maybe NamedSesConnection
-> BrightnessControls m
intelBacklightControls = brightnessControls xpfIntelBacklight intelBacklightConfig intelBacklightControls = brightnessControls xpfIntelBacklight intelBacklightConfig
callGetBrightnessIB :: MonadUnliftIO m => SesClient -> m (Maybe Brightness) callGetBrightnessIB
:: (SafeClient c, HasClient env, MonadReader (env c) m, MonadUnliftIO m)
=> m (Maybe Brightness)
callGetBrightnessIB = callGetBrightness intelBacklightConfig callGetBrightnessIB = callGetBrightness intelBacklightConfig
matchSignalIB matchSignalIB
:: MonadUnliftIO m :: ( SafeClient c
, HasClient env
, MonadReader (env c) m
, MonadUnliftIO m
)
=> (Maybe Brightness -> m ()) => (Maybe Brightness -> m ())
-> SesClient
-> m () -> m ()
matchSignalIB = matchSignal intelBacklightConfig matchSignalIB = matchSignal intelBacklightConfig

View File

@ -2,7 +2,8 @@
-- High-level interface for managing XMonad's DBus -- High-level interface for managing XMonad's DBus
module XMonad.Internal.DBus.Common module XMonad.Internal.DBus.Common
( xmonadBusName ( xmonadSesBusName
, xmonadSysBusName
, btBus , btBus
, notifyBus , notifyBus
, notifyPath , notifyPath
@ -12,8 +13,11 @@ where
import DBus import DBus
xmonadBusName :: BusName xmonadSesBusName :: BusName
xmonadBusName = busName_ "org.xmonad" xmonadSesBusName = busName_ "org.xmonad.session"
xmonadSysBusName :: BusName
xmonadSysBusName = busName_ "org.xmonad.system"
btBus :: BusName btBus :: BusName
btBus = busName_ "org.bluez" btBus = busName_ "org.bluez"

View File

@ -1,20 +1,17 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- High-level interface for managing XMonad's DBus -- High-level interface for managing XMonad's DBus
module XMonad.Internal.DBus.Control module XMonad.Internal.DBus.Control
( Client ( Client
, DBusState (..) , DBusState (..)
, withDBus , withDBusInterfaces
, withDBus_
, withDBusX , withDBusX
, withDBusX_ , withDBusX_
, withDBus
, withDBus_
, connectDBus , connectDBus
, connectDBusX
, disconnectDBus , disconnectDBus
, disconnectDBusX -- , disconnectDBusX
, getDBusClient , getDBusClient
, withDBusClient , withDBusClient
, withDBusClient_ , withDBusClient_
@ -26,7 +23,7 @@ where
import DBus import DBus
import DBus.Client import DBus.Client
import Data.Internal.DBus import Data.Internal.DBus
import Data.Internal.Dependency import Data.Internal.XIO
import RIO import RIO
import XMonad.Internal.DBus.Brightness.ClevoKeyboard import XMonad.Internal.DBus.Brightness.ClevoKeyboard
import XMonad.Internal.DBus.Brightness.IntelBacklight import XMonad.Internal.DBus.Brightness.IntelBacklight
@ -35,90 +32,157 @@ import XMonad.Internal.DBus.Screensaver
-- | Current connections to the DBus (session and system buses) -- | Current connections to the DBus (session and system buses)
data DBusState = DBusState data DBusState = DBusState
{ dbSesClient :: Maybe SesClient { dbSesClient :: Maybe NamedSesConnection
, dbSysClient :: Maybe SysClient , dbSysClient :: Maybe NamedSysConnection
} }
withDBusX_ withDBusX_
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m) :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
=> (DBusState -> m a) => (DBusState -> m a)
-> m () -> m ()
withDBusX_ = void . withDBusX_ withDBusX_ = void . withDBusX
withDBusX withDBusX
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m) :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
=> (DBusState -> m a) => (DBusState -> m a)
-> m (Maybe a) -> m a
withDBusX f = withDBus $ \db -> withDBusX = withDBus (Just xmonadSesBusName) Nothing
-- TODO log error if this fails
forM (dbSesClient db) $ \ses ->
bracket_ (requestXMonadName ses) (releaseXMonadName ses) (f db)
withDBus_ withDBus_
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m) :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
=> (DBusState -> m a) => Maybe BusName
-> Maybe BusName
-> (DBusState -> m a)
-> m () -> m ()
withDBus_ = void . withDBus withDBus_ sesname sysname = void . withDBus sesname sysname
withDBus withDBus
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m) :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
=> (DBusState -> m a) => Maybe BusName
-> Maybe BusName
-> (DBusState -> m a)
-> m a -> m a
withDBus = bracket connectDBus disconnectDBus withDBus sesname sysname = bracket (connectDBus sesname sysname) disconnectDBus
-- | Connect to the DBus -- | Connect to the DBus
connectDBus connectDBus
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m) :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
=> m DBusState => Maybe BusName
connectDBus = do -> Maybe BusName
ses <- getDBusClient -> m DBusState
sys <- getDBusClient connectDBus sesname sysname = do
ses <- getDBusClient sesname
sys <- getDBusClient sysname
return DBusState {dbSesClient = ses, dbSysClient = sys} return DBusState {dbSesClient = ses, dbSysClient = sys}
-- | Disconnect from the DBus -- | Disconnect from the DBus
disconnectDBus :: MonadUnliftIO m => DBusState -> m () disconnectDBus
disconnectDBus db = disc dbSesClient >> disc dbSysClient :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
where
disc f = maybe (return ()) disconnectDBusClient $ f db
-- | Connect to the DBus and request the XMonad name
connectDBusX :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m) => m DBusState
connectDBusX = do
db <- connectDBus
forM_ (dbSesClient db) requestXMonadName
return db
-- | Disconnect from DBus and release the XMonad name
disconnectDBusX
:: MonadUnliftIO m
=> DBusState => DBusState
-> m () -> m ()
disconnectDBusX db = do disconnectDBus db = disc dbSesClient >> disc dbSysClient
forM_ (dbSesClient db) releaseXMonadName where
disconnectDBus db disc
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m, SafeClient c)
=> (DBusState -> Maybe (NamedConnection c))
-> m ()
disc f = maybe (return ()) disconnectDBusClient $ f db
-- -- | Connect to the DBus and request the XMonad name
-- connectDBusX
-- :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
-- => m DBusState
-- connectDBusX = do
-- db <- connectDBus
-- requestXMonadName2 db
-- return db
-- -- | Disconnect from DBus and release the XMonad name
-- disconnectDBusX
-- :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
-- => DBusState
-- -> m ()
-- disconnectDBusX db = do
-- forM_ (dbSesClient db) releaseBusName
-- forM_ (dbSysClient db) releaseBusName
-- disconnectDBus db
-- requestXMonadName2
-- :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
-- => DBusState
-- -> m ()
-- requestXMonadName2 db = do
-- forM_ (dbSesClient db) requestXMonadName
-- forM_ (dbSysClient db) requestXMonadName
withDBusInterfaces
:: DBusState
-> [Maybe NamedSesConnection -> Sometimes (XIO (), XIO ())]
-> ([XIO ()] -> XIO a)
-> XIO a
withDBusInterfaces db interfaces = bracket up sequence
where
up = do
pairs <- catMaybes <$> mapM (\f -> evalSometimes $ f $ dbSesClient db) interfaces
mapM_ fst pairs
return $ snd <$> pairs
-- | All exporter features to be assigned to the DBus -- | All exporter features to be assigned to the DBus
dbusExporters :: [Maybe SesClient -> SometimesIO] dbusExporters
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
=> [Maybe NamedSesConnection -> Sometimes (m (), m ())]
dbusExporters = [exportScreensaver, exportIntelBacklight, exportClevoKeyboard] dbusExporters = [exportScreensaver, exportIntelBacklight, exportClevoKeyboard]
releaseXMonadName -- releaseXMonadName
:: MonadUnliftIO m -- :: (SafeClient c, MonadReader env m, HasLogFunc env, MonadUnliftIO m)
=> SesClient -- => c
-> m () -- -> m ()
releaseXMonadName ses = do -- releaseXMonadName cl = do
liftIO $ void $ releaseName (toClient ses) xmonadBusName -- -- TODO this might error?
-- liftIO $ void $ releaseName (toClient cl) xmonadBusName
-- logInfo "released xmonad name"
requestXMonadName :: MonadUnliftIO m => SesClient -> m () -- releaseBusName
requestXMonadName ses = do -- :: (SafeClient c, MonadReader env m, HasLogFunc env, MonadUnliftIO m)
res <- liftIO $ requestName (toClient ses) xmonadBusName [] -- => BusName
-- TODO if the client is not released on shutdown the owner will be different -- -> c
let msg -- -> m ()
| res == NamePrimaryOwner = Nothing -- releaseBusName n cl = do
| res == NameAlreadyOwner = Just $ "this process already owns " ++ xn -- -- TODO this might error?
| res == NameInQueue -- liftIO $ void $ releaseName (toClient cl) n
|| res == NameExists = -- logInfo $ "released bus name: " <> displayBusName n
Just $ "another process owns " ++ xn
| otherwise = Just $ "unknown error when requesting " ++ xn -- requestBusName
liftIO $ forM_ msg putStrLn -- :: (SafeClient c, MonadReader env m, HasLogFunc env, MonadUnliftIO m)
where -- => BusName
xn = "'" ++ formatBusName xmonadBusName ++ "'" -- -> c
-- -> m ()
-- requestBusName n cl = do
-- res <- try $ liftIO $ requestName (toClient cl) n []
-- case res of
-- Left e -> logError $ displayBytesUtf8 $ BC.pack $ clientErrorMessage e
-- Right r -> do
-- let msg
-- | r == NamePrimaryOwner = "registering name"
-- | r == NameAlreadyOwner = "this process already owns name"
-- | r == NameInQueue
-- || r == NameExists =
-- "another process owns name"
-- -- this should never happen
-- | otherwise = "unknown error when requesting name"
-- logInfo $ msg <> ": " <> displayBusName n
-- requestXMonadName
-- :: (SafeClient c, MonadReader env m, HasLogFunc env, MonadUnliftIO m)
-- => c
-- -> m ()
-- requestXMonadName cl = do
-- res <- liftIO $ requestName (toClient cl) xmonadBusName []
-- let msg
-- | res == NamePrimaryOwner = "registering name"
-- | res == NameAlreadyOwner = "this process already owns name"
-- | res == NameInQueue
-- || res == NameExists =
-- "another process owns name"
-- | otherwise = "unknown error when requesting name"
-- logInfo $ msg <> ": " <> displayBusName xmonadBusName

View File

@ -1,5 +1,3 @@
{-# LANGUAGE OverloadedStrings #-}
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- Module for monitoring removable drive events -- Module for monitoring removable drive events
-- --
@ -11,7 +9,7 @@ module XMonad.Internal.DBus.Removable (runRemovableMon) where
import DBus import DBus
import DBus.Client import DBus.Client
import Data.Internal.DBus import Data.Internal.DBus
import Data.Internal.Dependency import Data.Internal.XIO
import RIO import RIO
import qualified RIO.Map as M import qualified RIO.Map as M
import XMonad.Core (io) import XMonad.Core (io)
@ -73,25 +71,36 @@ removedHasDrive [_, a] =
(fromVariant a :: Maybe [String]) (fromVariant a :: Maybe [String])
removedHasDrive _ = False removedHasDrive _ = False
playSoundMaybe :: FilePath -> Bool -> IO () playSoundMaybe :: MonadUnliftIO m => FilePath -> Bool -> m ()
playSoundMaybe p b = when b $ io $ playSound p playSoundMaybe p b = when b $ io $ playSound p
-- NOTE: the udisks2 service should be already running for this module to work. -- NOTE: the udisks2 service should be already running for this module to work.
-- If it not already, we won't see any signals from the dbus until it is -- If it not already, we won't see any signals from the dbus until it is
-- started (it will work after it is started however). It seems safe to simply -- started (it will work after it is started however). It seems safe to simply
-- enable the udisks2 service at boot; however this is not default behavior. -- enable the udisks2 service at boot; however this is not default behavior.
listenDevices :: SysClient -> IO () listenDevices
:: ( HasClient (DBusEnv env)
, MonadReader env m
, MonadUnliftIO m
)
=> NamedSysConnection
-> m ()
listenDevices cl = do listenDevices cl = do
addMatch' memAdded driveInsertedSound addedHasDrive addMatch' memAdded driveInsertedSound addedHasDrive
addMatch' memRemoved driveRemovedSound removedHasDrive addMatch' memRemoved driveRemovedSound removedHasDrive
where where
addMatch' m p f = addMatch' m p f = do
void $ let rule = ruleUdisks {matchMember = Just m}
addMatch (toClient cl) ruleUdisks {matchMember = Just m} $ void $ withDIO cl $ addMatchCallback rule (playSoundMaybe p . f)
playSoundMaybe p . f . signalBody
runRemovableMon :: Maybe SysClient -> SometimesIO runRemovableMon
:: ( HasClient (DBusEnv env)
, MonadReader env m
, MonadUnliftIO m
)
=> Maybe NamedSysConnection
-> Sometimes (m ())
runRemovableMon cl = runRemovableMon cl =
sometimesDBus cl "removeable device monitor" "dbus monitor" deps $ io . listenDevices sometimesDBus cl "removeable device monitor" "dbus monitor" deps listenDevices
where where
deps = toAnd_ addedDep removedDep deps = toAnd_ addedDep removedDep

View File

@ -1,5 +1,3 @@
{-# LANGUAGE OverloadedStrings #-}
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- DBus module for X11 screensave/DPMS control -- DBus module for X11 screensave/DPMS control
@ -16,7 +14,7 @@ import DBus
import DBus.Client import DBus.Client
import qualified DBus.Introspection as I import qualified DBus.Introspection as I
import Data.Internal.DBus import Data.Internal.DBus
import Data.Internal.Dependency import Data.Internal.XIO
import Graphics.X11.XScreenSaver import Graphics.X11.XScreenSaver
import RIO import RIO
import XMonad.Internal.DBus.Common import XMonad.Internal.DBus.Common
@ -93,24 +91,24 @@ bodyGetCurrentState _ = Nothing
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- Exported haskell API -- Exported haskell API
exportScreensaver :: Maybe SesClient -> SometimesIO exportScreensaver
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
=> Maybe NamedSesConnection
-> Sometimes (m (), m ())
exportScreensaver ses = exportScreensaver ses =
sometimesDBus ses "screensaver toggle" "xset" (toAnd_ bus ssx) cmd sometimesDBus ses "screensaver toggle" "xset" (toAnd_ bus ssx) cmd
where where
cmd cl = cmd = exportPair ssPath $ \cl_ -> do
let cl' = toClient cl liftIO $ withRunInIO $ \run ->
in withRunInIO $ \run -> return $
export defaultInterface
cl' { interfaceName = interface
ssPath , interfaceMethods =
defaultInterface [ autoMethod memToggle $ run $ emitState cl_ =<< toggle
{ interfaceName = interface , autoMethod memQuery (run query)
, interfaceMethods = ]
[ autoMethod memToggle $ run $ emitState cl' =<< toggle , interfaceSignals = [sig]
, autoMethod memQuery (run query) }
]
, interfaceSignals = [sig]
}
sig = sig =
I.Signal I.Signal
{ I.signalName = memState { I.signalName = memState
@ -121,32 +119,42 @@ exportScreensaver ses =
} }
] ]
} }
bus = Bus [] xmonadBusName bus = Bus [] xmonadSesBusName
ssx = DBusIO $ sysExe [Package Official "xorg-xset"] ssExecutable ssx = DBusIO $ sysExe [Package Official "xorg-xset"] ssExecutable
callToggle :: Maybe SesClient -> SometimesX callToggle
:: (HasClient (DBusEnv env), MonadReader env m, MonadUnliftIO m)
=> Maybe NamedSesConnection
-> Sometimes (m ())
callToggle = callToggle =
sometimesEndpoint sometimesEndpoint
"screensaver toggle" "screensaver toggle"
"dbus switch" "dbus switch"
[] []
xmonadBusName xmonadSesBusName
ssPath ssPath
interface interface
memToggle memToggle
callQuery :: MonadUnliftIO m => SesClient -> m (Maybe SSState) callQuery
callQuery ses = do :: (HasClient env, MonadReader (env SesClient) m, MonadUnliftIO m)
reply <- callMethod ses xmonadBusName ssPath interface memQuery => m (Maybe SSState)
callQuery = do
reply <- callMethod xmonadSesBusName ssPath interface memQuery
return $ either (const Nothing) bodyGetCurrentState reply return $ either (const Nothing) bodyGetCurrentState reply
matchSignal :: MonadUnliftIO m => (Maybe SSState -> m ()) -> SesClient -> m () matchSignal
matchSignal cb ses = :: ( HasClient env
, MonadReader (env SesClient) m
, MonadUnliftIO m
)
=> (Maybe SSState -> m ())
-> m ()
matchSignal cb =
void $ void $
addMatchCallback addMatchCallback
ruleCurrentState ruleCurrentState
(cb . bodyGetCurrentState) (cb . bodyGetCurrentState)
ses
ssSignalDep :: DBusDependency_ SesClient ssSignalDep :: DBusDependency_ SesClient
ssSignalDep = Endpoint [] xmonadBusName ssPath interface $ Signal_ memState ssSignalDep = Endpoint [] xmonadSesBusName ssPath interface $ Signal_ memState

View File

@ -1,5 +1,3 @@
{-# LANGUAGE ViewPatterns #-}
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- Random IO-ish functions used throughtout xmonad -- Random IO-ish functions used throughtout xmonad
-- --
@ -41,7 +39,7 @@ import System.Process
-- read -- read
readInt :: MonadIO m => (Read a, Integral a) => FilePath -> m a readInt :: MonadIO m => (Read a, Integral a) => FilePath -> m a
readInt = fmap (read . takeWhile isDigit . T.unpack) . readFileUtf8 readInt = fmap (fromMaybe 0 . readMaybe . takeWhile isDigit . T.unpack) . readFileUtf8
readBool :: MonadIO m => FilePath -> m Bool readBool :: MonadIO m => FilePath -> m Bool
readBool = fmap (== (1 :: Int)) . readInt readBool = fmap (== (1 :: Int)) . readInt
@ -49,7 +47,7 @@ readBool = fmap (== (1 :: Int)) . readInt
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- write -- write
writeInt :: MonadIO m => (Show a, Integral a) => FilePath -> a -> m () writeInt :: (MonadIO m, Show a) => FilePath -> a -> m ()
writeInt f = writeFileUtf8 f . T.pack . show writeInt f = writeFileUtf8 f . T.pack . show
writeBool :: MonadIO m => FilePath -> Bool -> m () writeBool :: MonadIO m => FilePath -> Bool -> m ()
@ -62,7 +60,7 @@ writeBool f b = writeInt f ((if b then 1 else 0) :: Int)
-- value. Assume that the file being read has a min of 0 and an unchanging max -- value. Assume that the file being read has a min of 0 and an unchanging max
-- given by a runtime argument, which is scaled linearly to the range 0-100 -- given by a runtime argument, which is scaled linearly to the range 0-100
-- (percent). -- (percent).
rawToPercent :: (Integral a, Integral b, Read b, RealFrac c) => (a, a) -> b -> c rawToPercent :: (Integral a, Integral b, RealFrac c) => (a, a) -> b -> c
rawToPercent (lower, upper) raw = rawToPercent (lower, upper) raw =
100 * (fromIntegral raw - fromIntegral lower) / fromIntegral (upper - lower) 100 * (fromIntegral raw - fromIntegral lower) / fromIntegral (upper - lower)
@ -166,7 +164,7 @@ getPermissionsSafe f = do
-- | Block until a PID has exited. -- | Block until a PID has exited.
-- Use this to control flow based on a process that was not explicitly started -- Use this to control flow based on a process that was not explicitly started
-- by the Haskell runtime itself, and thus has no data structures to query. -- by the Haskell runtime itself, and thus has no data structures to query.
waitUntilExit :: (MonadIO m) => Pid -> m () waitUntilExit :: (MonadUnliftIO m) => Pid -> m ()
waitUntilExit pid = do waitUntilExit pid = do
res <- doesDirectoryExist $ "/proc" </> show pid res <- doesDirectoryExist $ "/proc" </> show pid
when res $ do when res $ do

View File

@ -1,5 +1,3 @@
{-# LANGUAGE OverloadedStrings #-}
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- Functions for formatting and sending notifications -- Functions for formatting and sending notifications
-- --

View File

@ -1,5 +1,3 @@
{-# LANGUAGE OverloadedStrings #-}
-- Functions for formatting and spawning shell commands -- Functions for formatting and spawning shell commands
module XMonad.Internal.Shell module XMonad.Internal.Shell
@ -85,8 +83,31 @@ spawn :: MonadIO m => T.Text -> m ()
spawn = X.spawn . T.unpack spawn = X.spawn . T.unpack
-- | Run 'XMonad.Run.Utils.spawnPipe' with 'Text' input. -- | Run 'XMonad.Run.Utils.spawnPipe' with 'Text' input.
spawnPipe :: MonadIO m => T.Text -> m Handle spawnPipe :: MonadUnliftIO m => T.Text -> m Handle
spawnPipe = XR.spawnPipe . T.unpack spawnPipe = liftIO . XR.spawnPipe . T.unpack
-- spawnPipeRW
-- :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
-- => T.Text
-- -> m Handle
-- spawnPipeRW x = do
-- (r, h) <- liftIO mkPipe
-- child r
-- liftIO $ closeFd r
-- return h
-- where
-- mkPipe = do
-- (r, w) <- createPipe
-- setFdOption w CloseOnExec True
-- h <- fdToHandle w
-- -- ASSUME we are using utf8 everywhere
-- hSetEncoding h utf8
-- hSetBuffering h LineBuffering
-- return (r, h)
-- child r = void $ withRunInIO $ \runIO -> do
-- X.xfork $ runIO $ do
-- void $ liftIO $ dupTo r stdInput
-- liftIO $ executeFile "/bin/sh" False ["-c", T.unpack x] Nothing
-- | Run 'XMonad.Core.spawn' with a command and arguments -- | Run 'XMonad.Core.spawn' with a command and arguments
spawnCmd :: MonadIO m => FilePath -> [T.Text] -> m () spawnCmd :: MonadIO m => FilePath -> [T.Text] -> m ()

View File

@ -1,5 +1,3 @@
{-# LANGUAGE OverloadedStrings #-}
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- Theme for XMonad and Xmobar -- Theme for XMonad and Xmobar
@ -33,6 +31,7 @@ where
import Data.Colour import Data.Colour
import Data.Colour.SRGB import Data.Colour.SRGB
import RIO
import qualified RIO.Text as T import qualified RIO.Text as T
import qualified XMonad.Layout.Decoration as D import qualified XMonad.Layout.Decoration as D
import qualified XMonad.Prompt as P import qualified XMonad.Prompt as P

View File

@ -0,0 +1,155 @@
--------------------------------------------------------------------------------
-- NetworkManager Connection plugin
--
-- Show active connections of varying types.
--
-- This plugin exclusively monitors the */ActiveConnection/* paths in the
-- NetworkManager DBus path for state changes. It does not pin these to any
-- particular interface but instead looks at all connections equally and filters
-- based on their Type (ethernet, wifi, VPN, etc). For many use cases this will
-- track well enough with either one or a collection of similar interfaces (ie
-- all ethernet or all wifi).
module Xmobar.Plugins.ActiveConnection
( ActiveConnection (..)
, devDep
, connAlias
)
where
import DBus
import Data.Internal.DBus
import Data.Internal.XIO
import RIO
import qualified RIO.Map as M
import qualified RIO.NonEmpty as NE
import qualified RIO.Text as T
import XMonad.Internal.Command.Desktop
import XMonad.Internal.DBus.Common
import Xmobar
import Xmobar.Plugins.Common
newtype ActiveConnection
= ActiveConnection (NE.NonEmpty T.Text, T.Text, Colors)
deriving (Read, Show)
connAlias :: NE.NonEmpty T.Text -> T.Text
connAlias = T.intercalate "_" . NE.toList
instance Exec ActiveConnection where
alias (ActiveConnection (contypes, _, _)) = T.unpack $ connAlias contypes
start (ActiveConnection (contypes, text, colors)) cb =
withDBusClientConnection cb Nothing (Just "ethernet.log") $ \c -> do
let dpy cb' = displayMaybe cb' formatter . Just =<< readState
i <- withDIO c $ initialState contypes
s <- newMVar i
let mapEnv c' = mapRIO (PluginEnv c' s dpy cb)
mapEnv c $ addListener mapEnv >> pluginDisplay
where
formatter names = return $ case names of
[] -> colorText colors False text
xs -> T.unwords [colorText colors True text, T.intercalate "|" xs]
addListener mapEnv = do
res <- matchSignalFull nmBus Nothing (Just nmActiveInterface) (Just stateChanged)
case res of
Nothing -> logError "could not start listener"
Just rule ->
-- Start a new connection and RIO process since the parent thread
-- will have died before these callbacks fire, therefore the logging
-- file descriptor will be closed. This makes a new one
-- TODO can I recycle the client?
void $
addMatchCallbackSignal rule $ \sig ->
withDBusClientConnection cb Nothing (Just "ethernet-cb.log") $ \c' ->
mapEnv c' $
testActiveType contypes sig
nmBus :: BusName
nmBus = "org.freedesktop.NetworkManager"
nmPath :: ObjectPath
nmPath = "/org/freedesktop/NetworkManager"
nmInterface :: InterfaceName
nmInterface = "org.freedesktop.NetworkManager"
nmObjectTreePath :: ObjectPath
nmObjectTreePath = "/org/freedesktop"
nmActiveInterface :: InterfaceName
nmActiveInterface = "org.freedesktop.NetworkManager.Connection.Active"
stateChanged :: MemberName
stateChanged = "StateChanged"
-- semi-random method to test to ensure that NetworkManager is up and on DBus
devDep :: DBusDependency_ SysClient
devDep =
Endpoint networkManagerPkgs networkManagerBus nmPath nmInterface $
Method_ "GetDeviceByIpIface"
type EthIO = PluginIO EthState SysClient
type EthState = M.Map ObjectPath T.Text
getConnectionProp :: MemberName -> ObjectPath -> EthIO [Variant]
getConnectionProp prop path = callPropertyGet nmBus path nmActiveInterface prop
getConnectionId :: ObjectPath -> EthIO (Maybe T.Text)
getConnectionId = fmap fromSingletonVariant . getConnectionProp "Id"
getConnectionType :: ObjectPath -> EthIO (Maybe T.Text)
getConnectionType = fmap fromSingletonVariant . getConnectionProp "Type"
updateConnected :: NE.NonEmpty T.Text -> ObjectPath -> EthIO ()
updateConnected contypes path = do
typeRes <- getConnectionType path
logMaybe "type" getId typeRes
where
path' = displayBytesUtf8 $ T.encodeUtf8 $ T.pack $ formatObjectPath path
logMaybe what = maybe (logError ("could not get " <> what <> " for " <> path'))
getId contype = do
when (contype `elem` contypes) $ do
idRes <- getConnectionId path
logMaybe "ID" insertId idRes
insertId i = do
s <- asks plugState
modifyMVar_ s $ return . M.insert path i
updateDisconnected :: ObjectPath -> EthIO ()
updateDisconnected path = do
s <- asks plugState
modifyMVar_ s $ return . M.delete path
testActiveType :: NE.NonEmpty T.Text -> Signal -> EthIO ()
testActiveType contypes sig = do
case signalBody sig of
[state, _] -> case fromVariant state of
Just (2 :: Word32) -> updateConnected contypes path >> pluginDisplay
Just 4 -> updateDisconnected path >> pluginDisplay
_ -> return ()
_ -> return ()
where
path = signalPath sig
initialState
:: ( SafeClient c
, MonadUnliftIO m
, MonadReader (env c) m
, HasClient env
, HasLogFunc (env c)
)
=> NE.NonEmpty T.Text
-> m EthState
initialState contypes =
M.mapMaybe go <$> callGetManagedObjects nmBus nmObjectTreePath
where
go = getId <=< M.lookup nmActiveInterface
getId m =
fromVariant
=<< (\t -> if t `elem` contypes then M.lookup "Id" m else Nothing)
=<< fromVariant
=<< M.lookup "Type" m
readState :: EthIO [T.Text]
readState = M.elems <$> (readMVar =<< asks plugState)

View File

@ -1,11 +1,10 @@
{-# LANGUAGE OverloadedStrings #-}
-- Common backlight plugin bits -- Common backlight plugin bits
-- --
-- Use the custom DBus interface exported by the XMonad process so I can react -- Use the custom DBus interface exported by the XMonad process so I can react
-- to signals spawned by commands -- to signals spawned by commands
module Xmobar.Plugins.BacklightCommon (startBacklight) where module Xmobar.Plugins.BacklightCommon (startBacklight) where
import DBus
import Data.Internal.DBus import Data.Internal.DBus
import RIO import RIO
import qualified RIO.Text as T import qualified RIO.Text as T
@ -13,15 +12,17 @@ import Xmobar.Plugins.Common
startBacklight startBacklight
:: (MonadUnliftIO m, RealFrac a) :: (MonadUnliftIO m, RealFrac a)
=> ((Maybe a -> RIO SimpleApp ()) -> SesClient -> RIO SimpleApp ()) => Maybe BusName
-> (SesClient -> RIO SimpleApp (Maybe a)) -> Maybe FilePath
-> ((Maybe a -> DIO SimpleApp SesClient ()) -> DIO SimpleApp SesClient ())
-> DIO SimpleApp SesClient (Maybe a)
-> T.Text -> T.Text
-> Callback -> Callback
-> m () -> m ()
startBacklight matchSignal callGetBrightness icon cb = do startBacklight n name matchSignal callGetBrightness icon cb = do
withDBusClientConnection cb $ \c -> do withDBusClientConnection cb n name $ \c -> withDIO c $ do
matchSignal dpy c matchSignal dpy
dpy =<< callGetBrightness c dpy =<< callGetBrightness
where where
formatBrightness b = return $ T.concat [icon, T.pack $ show (round b :: Integer), "%"] formatBrightness b = return $ T.concat [icon, T.pack $ show (round b :: Integer), "%"]
dpy = displayMaybe cb formatBrightness dpy = displayMaybe cb formatBrightness

View File

@ -1,5 +1,3 @@
{-# LANGUAGE OverloadedStrings #-}
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- Bluetooth plugin -- Bluetooth plugin
-- --
@ -9,28 +7,18 @@
-- Manager. The adapter is located at path "/org/bluez/hci<X>" where X is -- Manager. The adapter is located at path "/org/bluez/hci<X>" where X is
-- usually 0, and each device is "/org/bluez/hci<X>/<MAC_ADDRESS>". -- usually 0, and each device is "/org/bluez/hci<X>/<MAC_ADDRESS>".
-- --
-- This plugin will reflect if the adapter is powered and if any device is -- Simple and somewhat crude way to do this is to have two monitors, one
-- connected to it. The rough outline for this procedure: -- watching the powered state of the adaptor and one listening for connection
-- 1) get the adapter from the object manager -- changes. The former is easy since this is just one /org/bluez/hciX. For the
-- 2) get all devices associated with the adapter using the object interface -- latter, each 'Connected' property is embedded in each individual device path
-- 3) determine if the adapter is powered -- on `org.bluez.Device1', so just watch the entire bluez bus for property
-- 4) determine if any devices are connected -- changes and filter those that correspond to the aforementioned
-- 5) format the icon; powered vs not powered controls the color and connected -- interface/property. Track all this in a state which keeps the powered
-- vs not connected controls the icon (connected bluetooth symbol has two -- property and a running list of connected devices.
-- dots flanking it)
--
-- Step 3 can be accomplished using the "org.bluez.Adapter1" interface and
-- querying the "Powered" property. Step 4 can be done using the
-- "org.bluez.Device1" interface and the "Connected" property for each device
-- path. Since these are properties, we can asynchronously read changes to them
-- via the "PropertiesChanged" signal.
--
-- If any devices are added/removed, steps 2-4 will need to be redone and any
-- listeners will need to be updated. (TODO not sure which signals to use in
-- determining if a device is added)
-- --
-- TODO also not sure if I need to care about multiple adapters and/or the -- TODO also not sure if I need to care about multiple adapters and/or the
-- adapter changing. -- adapter changing. For now it should just get the first adaptor and only pay
-- attention to devices associated with it.
module Xmobar.Plugins.Bluetooth module Xmobar.Plugins.Bluetooth
( Bluetooth (..) ( Bluetooth (..)
@ -42,11 +30,12 @@ where
import DBus import DBus
import DBus.Client import DBus.Client
import Data.Internal.DBus import Data.Internal.DBus
import Data.Internal.Dependency import Data.Internal.XIO
import RIO import RIO
import RIO.FilePath import RIO.FilePath
import RIO.List import RIO.List
import qualified RIO.Map as M import qualified RIO.Map as M
import qualified RIO.Set as S
import qualified RIO.Text as T import qualified RIO.Text as T
import XMonad.Internal.DBus.Common import XMonad.Internal.DBus.Common
import Xmobar import Xmobar
@ -65,31 +54,28 @@ data Bluetooth = Bluetooth Icons Colors deriving (Read, Show)
instance Exec Bluetooth where instance Exec Bluetooth where
alias (Bluetooth _ _) = T.unpack btAlias alias (Bluetooth _ _) = T.unpack btAlias
start (Bluetooth icons colors) cb = start (Bluetooth icons colors) cb =
withDBusClientConnection cb $ startAdapter icons colors cb withDBusClientConnection cb Nothing (Just "bluetooth.log") $
startAdapter icons colors cb
startAdapter startAdapter
:: MonadUnliftIO m :: Icons
=> Icons
-> Colors -> Colors
-> Callback -> Callback
-> SysClient -> NamedSysConnection
-> m () -> RIO SimpleApp ()
startAdapter is cs cb cl = do startAdapter is cs cb cl = do
ot <- getBtObjectTree cl
state <- newMVar emptyState state <- newMVar emptyState
let dpy = displayIcon cb (iconFormatter is cs) state let dpy cb' = displayIcon cb' (iconFormatter is cs)
forM_ (findAdapter ot) $ \adapter -> do mapRIO (PluginEnv cl state dpy cb) $ do
-- set up adapter ot <- getBtObjectTree
initAdapter state adapter cl case findAdaptor ot of
-- TODO this step could fail; at least warn the user... Nothing -> logError "could not find bluetooth adapter"
void $ addAdaptorListener state dpy adapter cl Just adaptor -> do
-- set up devices on the adapter (and listeners for adding/removing devices) initAdapterState adaptor
let devices = findDevices adapter ot initDevicesState adaptor ot
addDeviceAddedListener state dpy adapter cl startAdaptorListener adaptor
addDeviceRemovedListener state dpy adapter cl startConnectedListener adaptor
forM_ devices $ \d -> addAndInitDevice state dpy d cl pluginDisplay
-- after setting things up, show the icon based on the initialized state
dpy
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- Icon Display -- Icon Display
@ -101,9 +87,9 @@ type IconFormatter = (Maybe Bool -> Bool -> T.Text)
type Icons = (T.Text, T.Text) type Icons = (T.Text, T.Text)
displayIcon :: MonadUnliftIO m => Callback -> IconFormatter -> MutableBtState -> m () displayIcon :: Callback -> IconFormatter -> BTIO ()
displayIcon callback formatter = displayIcon callback formatter =
liftIO . callback . T.unpack . uncurry formatter <=< readState liftIO . callback . T.unpack . uncurry formatter =<< readState
-- TODO maybe I want this to fail when any of the device statuses are Nothing -- TODO maybe I want this to fail when any of the device statuses are Nothing
iconFormatter :: Icons -> Colors -> IconFormatter iconFormatter :: Icons -> Colors -> IconFormatter
@ -114,47 +100,52 @@ iconFormatter (iconConn, iconDisc) cs powered connected =
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- Connection State -- Connection State
--
-- The signal handlers all run on separate threads, yet the icon depends on
-- the state reflected by all these signals. The best (only?) way to do this is
-- is to track the shared state of the bluetooth adaptor and its devices using
-- an MVar.
data BTDevice = BTDevice type BTIO = PluginIO BtState SysClient
{ btDevConnected :: Maybe Bool
, btDevSigHandler :: SignalHandler
}
type ConnectedDevices = M.Map ObjectPath BTDevice
data BtState = BtState data BtState = BtState
{ btDevices :: ConnectedDevices { btDevices :: S.Set ObjectPath
, btPowered :: Maybe Bool , btPowered :: Maybe Bool
} }
type MutableBtState = MVar BtState
emptyState :: BtState emptyState :: BtState
emptyState = emptyState =
BtState BtState
{ btDevices = M.empty { btDevices = S.empty
, btPowered = Nothing , btPowered = Nothing
} }
readState :: MonadUnliftIO m => MutableBtState -> m (Maybe Bool, Bool) readState :: BTIO (Maybe Bool, Bool)
readState state = do readState = do
p <- readPowered state p <- readPowered
c <- readDevices state c <- readDevices
return (p, anyDevicesConnected c) return (p, not $ null c)
modifyState :: (BtState -> BTIO (BtState, a)) -> BTIO a
modifyState f = do
m <- asks plugState
modifyMVar m f
beforeDisplay :: BTIO () -> BTIO ()
beforeDisplay f = f >> pluginDisplay
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- Object manager -- Object manager
findAdapter :: ObjectTree -> Maybe ObjectPath findAdaptor :: ObjectTree -> Maybe ObjectPath
findAdapter = find (("/org/bluez/hci" `isPrefixOf`) . formatObjectPath) . M.keys findAdaptor = find (("/org/bluez/hci" `isPrefixOf`) . formatObjectPath) . M.keys
findDevices :: ObjectPath -> ObjectTree -> [ObjectPath] -- | Search the object tree for devices which are in a connected state.
findDevices adapter = filter (adaptorHasDevice adapter) . M.keys -- Return the object path for said devices.
findConnectedDevices :: ObjectPath -> ObjectTree -> [ObjectPath]
findConnectedDevices adaptor =
filter (adaptorHasDevice adaptor) . M.keys . M.filter isConnectedDev
where
isConnectedDev m = Just True == lookupState m
lookupState =
fromVariant
<=< M.lookup (memberNameT devConnected)
<=< M.lookup devInterface
adaptorHasDevice :: ObjectPath -> ObjectPath -> Bool adaptorHasDevice :: ObjectPath -> ObjectPath -> Bool
adaptorHasDevice adaptor device = case splitPathNoRoot device of adaptorHasDevice adaptor device = case splitPathNoRoot device of
@ -164,190 +155,120 @@ adaptorHasDevice adaptor device = case splitPathNoRoot device of
splitPathNoRoot :: ObjectPath -> [FilePath] splitPathNoRoot :: ObjectPath -> [FilePath]
splitPathNoRoot = dropWhile (== "/") . splitDirectories . formatObjectPath splitPathNoRoot = dropWhile (== "/") . splitDirectories . formatObjectPath
getBtObjectTree :: MonadUnliftIO m => SysClient -> m ObjectTree getBtObjectTree
getBtObjectTree sys = callGetManagedObjects sys btBus btOMPath :: ( HasClient env
, SafeClient c
, MonadReader (env c) m
, HasLogFunc (env c)
, MonadUnliftIO m
)
=> m ObjectTree
getBtObjectTree = callGetManagedObjects btBus btOMPath
btOMPath :: ObjectPath btOMPath :: ObjectPath
btOMPath = objectPath_ "/" btOMPath = objectPath_ "/"
addBtOMListener :: MonadUnliftIO m => SignalCallback m -> SysClient -> m ()
addBtOMListener sc = void . addInterfaceAddedListener btBus btOMPath sc
addDeviceAddedListener
:: MonadUnliftIO m
=> MutableBtState
-> m ()
-> ObjectPath
-> SysClient
-> m ()
addDeviceAddedListener state dpy adapter client =
addBtOMListener addDevice client
where
addDevice = pathCallback adapter dpy $ \d ->
addAndInitDevice state dpy d client
addDeviceRemovedListener
:: (MonadUnliftIO m)
=> MutableBtState
-> m ()
-> ObjectPath
-> SysClient
-> m ()
addDeviceRemovedListener state dpy adapter sys =
addBtOMListener remDevice sys
where
remDevice = pathCallback adapter dpy $ \d -> do
old <- removeDevice state d
forM_ old $ liftIO . removeMatch (toClient sys) . btDevSigHandler
pathCallback :: MonadUnliftIO m => ObjectPath -> m () -> (ObjectPath -> m ()) -> SignalCallback m
pathCallback adapter dpy f [device, _] = forM_ (fromVariant device) $ \d ->
when (adaptorHasDevice adapter d) $ f d >> dpy
pathCallback _ _ _ _ = return ()
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- Adapter -- Adapter
initAdapter -- | Get powered state of adaptor and log the result
:: (MonadUnliftIO m) initAdapterState :: ObjectPath -> BTIO ()
=> MutableBtState initAdapterState adapter = do
-> ObjectPath reply <- callGetPowered adapter
-> SysClient putPowered $ fromSingletonVariant reply
-> m ()
initAdapter state adapter client = do
reply <- callGetPowered adapter client
putPowered state $ fromSingletonVariant reply
matchBTProperty matchBTProperty
:: (MonadUnliftIO m) :: ( SafeClient c
=> SysClient , HasClient env
-> ObjectPath , MonadReader (env c) m
, HasLogFunc (env c)
, MonadUnliftIO m
)
=> ObjectPath
-> m (Maybe MatchRule) -> m (Maybe MatchRule)
matchBTProperty sys p = matchPropertyFull sys btBus (Just p) matchBTProperty p = matchPropertyFull btBus (Just p)
addAdaptorListener -- | Start a listener that monitors changes to the powered state of an adaptor
:: MonadUnliftIO m startAdaptorListener :: ObjectPath -> BTIO ()
=> MutableBtState startAdaptorListener adaptor = do
-> m () res <- matchBTProperty adaptor
-> ObjectPath case res of
-> SysClient Just rule -> void $ addMatchCallback rule callback
-> m (Maybe SignalHandler) Nothing -> do
addAdaptorListener state dpy adaptor sys = do logError $
rule <- matchBTProperty sys adaptor "could not add listener for prop "
forM rule $ \r -> addMatchCallback r (procMatch . matchPowered) sys <> displayMemberName adaptorPowered
<> " on path "
<> displayObjectPath adaptor
where where
procMatch = withSignalMatch $ \b -> putPowered state b >> dpy callback sig =
withNestedDBusClientConnection Nothing Nothing $
withSignalMatch procMatch $
matchPropertyChanged adaptorInterface adaptorPowered sig
procMatch = beforeDisplay . putPowered
callGetPowered :: MonadUnliftIO m => ObjectPath -> SysClient -> m [Variant] callGetPowered
:: ( HasClient env
, MonadReader (env c) m
, HasLogFunc (env c)
, SafeClient c
, MonadUnliftIO m
)
=> ObjectPath
-> m [Variant]
callGetPowered adapter = callGetPowered adapter =
callPropertyGet btBus adapter adapterInterface $ callPropertyGet btBus adapter adaptorInterface adaptorPowered
memberName_ $
T.unpack adaptorPowered
matchPowered :: [Variant] -> SignalMatch Bool putPowered :: Maybe Bool -> BTIO ()
matchPowered = matchPropertyChanged adapterInterface adaptorPowered putPowered ds = modifyState $ \s -> return (s {btPowered = ds}, ())
putPowered :: MonadUnliftIO m => MutableBtState -> Maybe Bool -> m () readPowered :: BTIO (Maybe Bool)
putPowered m ds = modifyMVar_ m (\s -> return s {btPowered = ds}) readPowered = fmap btPowered $ readMVar =<< asks plugState
readPowered :: MonadUnliftIO m => MutableBtState -> m (Maybe Bool) adaptorInterface :: InterfaceName
readPowered = fmap btPowered . readMVar adaptorInterface = interfaceName_ "org.bluez.Adapter1"
adapterInterface :: InterfaceName adaptorPowered :: MemberName
adapterInterface = interfaceName_ "org.bluez.Adapter1"
adaptorPowered :: T.Text
adaptorPowered = "Powered" adaptorPowered = "Powered"
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- Devices -- Devices
addAndInitDevice initDevicesState :: ObjectPath -> ObjectTree -> BTIO ()
:: MonadUnliftIO m initDevicesState adaptor ot = do
=> MutableBtState let devices = findConnectedDevices adaptor ot
-> m () modifyState $ \s -> return (s {btDevices = S.fromList devices}, ())
-> ObjectPath
-> SysClient
-> m ()
addAndInitDevice state dpy device client = do
sh <- addDeviceListener state dpy device client
-- TODO add some intelligent error messages here
forM_ sh $ \s -> initDevice state s device client
initDevice startConnectedListener :: ObjectPath -> BTIO ()
:: MonadUnliftIO m startConnectedListener adaptor = do
=> MutableBtState reply <- matchPropertyFull btBus Nothing
-> SignalHandler case reply of
-> ObjectPath Just rule -> do
-> SysClient void $ addMatchCallbackSignal rule callback
-> m () logInfo $ "Started listening for device connections on " <> adaptor_
initDevice state sh device sys = do Nothing -> logError "Could not listen for connection changes"
reply <- callGetConnected device sys
void $
insertDevice state device $
BTDevice
{ btDevConnected = fromVariant =<< listToMaybe reply
, btDevSigHandler = sh
}
addDeviceListener
:: MonadUnliftIO m
=> MutableBtState
-> m ()
-> ObjectPath
-> SysClient
-> m (Maybe SignalHandler)
addDeviceListener state dpy device sys = do
rule <- matchBTProperty sys device
forM rule $ \r -> addMatchCallback r (procMatch . matchConnected) sys
where where
procMatch = withSignalMatch $ \c -> updateDevice state device c >> dpy adaptor_ = displayWrapQuote $ displayObjectPath adaptor
callback sig =
withNestedDBusClientConnection Nothing Nothing $ do
let devpath = signalPath sig
when (adaptorHasDevice adaptor devpath) $
withSignalMatch (update devpath) $
matchConnected $
signalBody sig
matchConnected = matchPropertyChanged devInterface devConnected
update _ Nothing = return ()
update devpath (Just x) = do
let f = if x then S.insert else S.delete
beforeDisplay $
modifyState $
\s -> return (s {btDevices = f devpath $ btDevices s}, ())
matchConnected :: [Variant] -> SignalMatch Bool readDevices :: BTIO (S.Set ObjectPath)
matchConnected = matchPropertyChanged devInterface devConnected readDevices = fmap btDevices $ readMVar =<< asks plugState
callGetConnected :: MonadUnliftIO m => ObjectPath -> SysClient -> m [Variant]
callGetConnected p =
callPropertyGet btBus p devInterface $
memberName_ (T.unpack devConnected)
insertDevice
:: MonadUnliftIO m
=> MutableBtState
-> ObjectPath
-> BTDevice
-> m Bool
insertDevice m device dev = modifyMVar m $ \s -> do
let new = M.insert device dev $ btDevices s
return (s {btDevices = new}, anyDevicesConnected new)
updateDevice
:: MonadUnliftIO m
=> MutableBtState
-> ObjectPath
-> Maybe Bool
-> m Bool
updateDevice m device status = modifyMVar m $ \s -> do
let new = M.update (\d -> Just d {btDevConnected = status}) device $ btDevices s
return (s {btDevices = new}, anyDevicesConnected new)
anyDevicesConnected :: ConnectedDevices -> Bool
anyDevicesConnected = or . mapMaybe btDevConnected . M.elems
removeDevice
:: MonadUnliftIO m
=> MutableBtState
-> ObjectPath
-> m (Maybe BTDevice)
removeDevice m device = modifyMVar m $ \s -> do
let devs = btDevices s
return (s {btDevices = M.delete device devs}, M.lookup device devs)
readDevices :: MonadUnliftIO m => MutableBtState -> m ConnectedDevices
readDevices = fmap btDevices . readMVar
devInterface :: InterfaceName devInterface :: InterfaceName
devInterface = interfaceName_ "org.bluez.Device1" devInterface = interfaceName_ "org.bluez.Device1"
devConnected :: T.Text devConnected :: MemberName
devConnected = "Connected" devConnected = "Connected"

View File

@ -1,5 +1,3 @@
{-# LANGUAGE OverloadedStrings #-}
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- Clevo Keyboard plugin -- Clevo Keyboard plugin
-- --
@ -12,6 +10,7 @@ module Xmobar.Plugins.ClevoKeyboard
) )
where where
import RIO
import qualified RIO.Text as T import qualified RIO.Text as T
import XMonad.Internal.DBus.Brightness.ClevoKeyboard import XMonad.Internal.DBus.Brightness.ClevoKeyboard
import Xmobar import Xmobar
@ -25,4 +24,9 @@ ckAlias = "clevokeyboard"
instance Exec ClevoKeyboard where instance Exec ClevoKeyboard where
alias (ClevoKeyboard _) = T.unpack ckAlias alias (ClevoKeyboard _) = T.unpack ckAlias
start (ClevoKeyboard icon) = start (ClevoKeyboard icon) =
startBacklight matchSignalCK callGetBrightnessCK icon startBacklight
(Just "org.xmobar.clevo")
(Just "clevo_kbd.log")
matchSignalCK
callGetBrightnessCK
icon

View File

@ -1,27 +1,52 @@
{-# LANGUAGE OverloadedStrings #-}
module Xmobar.Plugins.Common module Xmobar.Plugins.Common
( colorText ( colorText
, startListener , startListener
, procSignalMatch , procSignalMatch
, na , na
, fromSingletonVariant , fromSingletonVariant
, withNestedDBusClientConnection
, withDBusClientConnection , withDBusClientConnection
, Callback , Callback
, Colors (..) , Colors (..)
, displayMaybe , displayMaybe
, displayMaybe' , displayMaybe'
, xmobarFGColor , xmobarFGColor
, PluginEnv (..)
, PluginIO
, pluginDisplay
) )
where where
import DBus import DBus
import DBus.Client import DBus.Client
import Data.Internal.DBus import Data.Internal.DBus
import Data.Internal.XIO
import RIO import RIO
import qualified RIO.Text as T import qualified RIO.Text as T
import XMonad.Hooks.DynamicLog (xmobarColor) import XMonad.Hooks.DynamicLog (xmobarColor)
data PluginEnv s c = PluginEnv
{ plugClient :: !(NamedConnection c)
, plugState :: !(MVar s)
, plugDisplay :: !(Callback -> PluginIO s c ())
, plugCallback :: !Callback
, plugEnv :: !SimpleApp
}
pluginDisplay :: PluginIO s c ()
pluginDisplay = do
cb <- asks plugCallback
dpy <- asks plugDisplay
dpy cb
type PluginIO s c = RIO (PluginEnv s c)
instance HasClient (PluginEnv s) where
clientL = lens plugClient (\x y -> x {plugClient = y})
instance HasLogFunc (PluginEnv s c) where
logFuncL = lens plugEnv (\x y -> x {plugEnv = y}) . logFuncL
-- use string here since all the callbacks in xmobar use strings :( -- use string here since all the callbacks in xmobar use strings :(
type Callback = String -> IO () type Callback = String -> IO ()
@ -32,18 +57,22 @@ data Colors = Colors
deriving (Eq, Show, Read) deriving (Eq, Show, Read)
startListener startListener
:: (MonadUnliftIO m, SafeClient c, IsVariant a) :: ( HasClient env
, MonadReader (env c) m
, MonadUnliftIO m
, SafeClient c
, IsVariant a
)
=> MatchRule => MatchRule
-> (c -> m [Variant]) -> m [Variant]
-> ([Variant] -> SignalMatch a) -> ([Variant] -> SignalMatch a)
-> (a -> m T.Text) -> (a -> m T.Text)
-> Callback -> Callback
-> c
-> m () -> m ()
startListener rule getProp fromSignal toColor cb client = do startListener rule getProp fromSignal toColor cb = do
reply <- getProp client reply <- getProp
displayMaybe cb toColor $ fromSingletonVariant reply displayMaybe cb toColor $ fromSingletonVariant reply
void $ addMatchCallback rule (procMatch . fromSignal) client void $ addMatchCallback rule (procMatch . fromSignal)
where where
procMatch = procSignalMatch cb toColor procMatch = procSignalMatch cb toColor
@ -70,6 +99,42 @@ displayMaybe' cb = maybe (liftIO $ cb $ T.unpack na)
withDBusClientConnection withDBusClientConnection
:: (MonadUnliftIO m, SafeClient c) :: (MonadUnliftIO m, SafeClient c)
=> Callback => Callback
-> (c -> RIO SimpleApp ()) -> Maybe BusName
-> Maybe FilePath
-> (NamedConnection c -> RIO SimpleApp ())
-> m () -> m ()
withDBusClientConnection cb f = runSimpleApp $ displayMaybe' cb f =<< getDBusClient withDBusClientConnection cb n logfile f =
maybe (run stderr) (`withLogFile` run) logfile
where
run h = do
logOpts <- setLogVerboseFormat True . setLogUseTime True <$> logOptionsHandle h False
withLogFunc logOpts $ \lf -> do
env <- mkSimpleApp lf Nothing
runRIO env $ displayMaybe' cb f =<< getDBusClient n
-- | Run a plugin action with a new DBus client and logfile path. This is
-- necessary for DBus callbacks which run in separate threads, which will
-- usually fire when the parent thread already exited and killed off its DBus
-- connection and closed its logfile. NOTE: unlike 'withDBusClientConnection'
-- this function will open and new logfile and client connection and close both
-- on completion. 'withDBusClientConnection' will only close the log file but
-- keep the client connection active upon termination; this client will only be
-- killed when the entire process is killed. This distinction is important
-- because callbacks only need ephemeral connections, while listeners (started
-- with 'withDBusClientConnection') need long-lasting connections.
withNestedDBusClientConnection
:: (MonadUnliftIO m, SafeClient c, MonadReader (PluginEnv s c) m)
=> Maybe BusName
-> Maybe FilePath
-> PluginIO s c ()
-> m ()
withNestedDBusClientConnection n logfile f = do
dpy <- asks plugDisplay
s <- asks plugState
cb <- asks plugCallback
let run h = do
logOpts <- setLogVerboseFormat True . setLogUseTime True <$> logOptionsHandle h False
withLogFunc logOpts $ \lf -> do
env <- mkSimpleApp lf Nothing
runRIO env $ withDBusClient_ n $ \cl -> mapRIO (PluginEnv cl s dpy cb) f
maybe (run stderr) (`withLogFile` run) logfile

View File

@ -1,76 +0,0 @@
{-# LANGUAGE OverloadedStrings #-}
--------------------------------------------------------------------------------
-- Device plugin
--
-- Display different text depending on whether or not the interface has
-- connectivity
module Xmobar.Plugins.Device
( Device (..)
, devDep
)
where
import DBus
import Data.Internal.DBus
import Data.Internal.Dependency
import RIO
import qualified RIO.Text as T
import XMonad.Internal.Command.Desktop
import XMonad.Internal.DBus.Common
import Xmobar
import Xmobar.Plugins.Common
newtype Device = Device (T.Text, T.Text, Colors) deriving (Read, Show)
nmPath :: ObjectPath
nmPath = objectPath_ "/org/freedesktop/NetworkManager"
nmInterface :: InterfaceName
nmInterface = interfaceName_ "org.freedesktop.NetworkManager"
nmDeviceInterface :: InterfaceName
nmDeviceInterface = interfaceName_ "org.freedesktop.NetworkManager.Device"
getByIP :: MemberName
getByIP = memberName_ "GetDeviceByIpIface"
devSignal :: T.Text
devSignal = "Ip4Connectivity"
devDep :: DBusDependency_ SysClient
devDep =
Endpoint networkManagerPkgs networkManagerBus nmPath nmInterface $
Method_ getByIP
getDevice :: MonadUnliftIO m => SysClient -> T.Text -> m (Maybe ObjectPath)
getDevice sys iface = bodyToMaybe <$> callMethod' sys mc
where
mc =
(methodCallBus networkManagerBus nmPath nmInterface getByIP)
{ methodCallBody = [toVariant iface]
}
getDeviceConnected :: MonadUnliftIO m => ObjectPath -> SysClient -> m [Variant]
getDeviceConnected path =
callPropertyGet networkManagerBus path nmDeviceInterface $
memberName_ $
T.unpack devSignal
matchStatus :: [Variant] -> SignalMatch Word32
matchStatus = matchPropertyChanged nmDeviceInterface devSignal
instance Exec Device where
alias (Device (iface, _, _)) = T.unpack iface
start (Device (iface, text, colors)) cb = do
withDBusClientConnection cb $ \sys -> do
path <- getDevice sys iface
displayMaybe' cb (listener sys) path
where
listener sys path = do
rule <- matchPropertyFull sys networkManagerBus (Just path)
-- TODO warn the user here rather than silently drop the listener
forM_ rule $ \r ->
startListener r (getDeviceConnected path) matchStatus chooseColor' cb sys
chooseColor' = return . (\s -> colorText colors s text) . (> 1)

View File

@ -1,5 +1,3 @@
{-# LANGUAGE OverloadedStrings #-}
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- Intel backlight plugin -- Intel backlight plugin
-- --
@ -12,6 +10,7 @@ module Xmobar.Plugins.IntelBacklight
) )
where where
import RIO
import qualified RIO.Text as T import qualified RIO.Text as T
import XMonad.Internal.DBus.Brightness.IntelBacklight import XMonad.Internal.DBus.Brightness.IntelBacklight
import Xmobar import Xmobar
@ -25,4 +24,9 @@ blAlias = "intelbacklight"
instance Exec IntelBacklight where instance Exec IntelBacklight where
alias (IntelBacklight _) = T.unpack blAlias alias (IntelBacklight _) = T.unpack blAlias
start (IntelBacklight icon) = start (IntelBacklight icon) =
startBacklight matchSignalIB callGetBrightnessIB icon startBacklight
(Just "org.xmobar.intelbacklight")
(Just "intel_backlight.log")
matchSignalIB
callGetBrightnessIB
icon

View File

@ -1,5 +1,3 @@
{-# LANGUAGE OverloadedStrings #-}
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- Screensaver plugin -- Screensaver plugin
-- --
@ -12,6 +10,8 @@ module Xmobar.Plugins.Screensaver
) )
where where
import Data.Internal.DBus
import RIO
import qualified RIO.Text as T import qualified RIO.Text as T
import XMonad.Internal.DBus.Screensaver import XMonad.Internal.DBus.Screensaver
import Xmobar import Xmobar
@ -24,9 +24,13 @@ ssAlias = "screensaver"
instance Exec Screensaver where instance Exec Screensaver where
alias (Screensaver _) = T.unpack ssAlias alias (Screensaver _) = T.unpack ssAlias
start (Screensaver (text, colors)) cb = do start (Screensaver (text, colors)) cb =
withDBusClientConnection cb $ \sys -> do withDBusClientConnection
matchSignal display sys cb
display =<< callQuery sys (Just "org.xmobar.screensaver")
(Just "screensaver.log")
$ \cl -> withDIO cl $ do
matchSignal dpy
dpy =<< callQuery
where where
display = displayMaybe cb $ return . (\s -> colorText colors s text) dpy = displayMaybe cb $ return . (\s -> colorText colors s text)

View File

@ -1,133 +0,0 @@
{-# LANGUAGE OverloadedStrings #-}
--------------------------------------------------------------------------------
-- VPN plugin
--
-- Use the networkmanager to detect when a VPN interface is added or removed.
-- Specifically, monitor the object tree to detect paths with the interface
-- "org.freedesktop.NetworkManager.Device.Tun".
module Xmobar.Plugins.VPN
( VPN (..)
, vpnAlias
, vpnDep
)
where
import DBus
import Data.Internal.DBus
import Data.Internal.Dependency
import RIO
import qualified RIO.Map as M
import qualified RIO.Set as S
import qualified RIO.Text as T
import XMonad.Internal.Command.Desktop
import XMonad.Internal.DBus.Common
import Xmobar
import Xmobar.Plugins.Common
newtype VPN = VPN (T.Text, Colors) deriving (Read, Show)
instance Exec VPN where
alias (VPN _) = T.unpack vpnAlias
start (VPN (text, colors)) cb =
withDBusClientConnection cb $ \c -> do
state <- initState c
let dpy = displayMaybe cb iconFormatter . Just =<< readState state
let signalCallback' f = f state dpy
vpnAddedListener (signalCallback' addedCallback) c
vpnRemovedListener (signalCallback' removedCallback) c
dpy
where
iconFormatter b = return $ colorText colors b text
--------------------------------------------------------------------------------
-- VPN State
--
-- Maintain a set of paths which are the currently active VPNs. Most of the time
-- this will be a null or singleton set, but this setup could handle the edge
-- case of multiple VPNs being active at once without puking.
type VPNState = S.Set ObjectPath
type MutableVPNState = MVar VPNState
initState :: MonadUnliftIO m => SysClient -> m MutableVPNState
initState client = do
ot <- getVPNObjectTree client
newMVar $ findTunnels ot
readState :: MonadUnliftIO m => MutableVPNState -> m Bool
readState = fmap (not . null) . readMVar
updateState
:: MonadUnliftIO m
=> (ObjectPath -> VPNState -> VPNState)
-> MutableVPNState
-> ObjectPath
-> m ()
updateState f state op = modifyMVar_ state $ return . f op
--------------------------------------------------------------------------------
-- Tunnel Device Detection
getVPNObjectTree :: MonadUnliftIO m => SysClient -> m ObjectTree
getVPNObjectTree sys = callGetManagedObjects sys vpnBus vpnPath
findTunnels :: ObjectTree -> VPNState
findTunnels = S.fromList . M.keys . M.filter (elem vpnDeviceTun . M.keys)
vpnAddedListener :: MonadUnliftIO m => SignalCallback m -> SysClient -> m ()
vpnAddedListener cb = void . addInterfaceAddedListener vpnBus vpnPath cb
vpnRemovedListener :: MonadUnliftIO m => SignalCallback m -> SysClient -> m ()
vpnRemovedListener cb = void . addInterfaceRemovedListener vpnBus vpnPath cb
addedCallback :: MonadUnliftIO m => MutableVPNState -> m () -> SignalCallback m
addedCallback state dpy [device, added] = update >> dpy
where
added' = fromVariant added :: Maybe (M.Map T.Text (M.Map T.Text Variant))
is = M.keys $ fromMaybe M.empty added'
update = updateDevice S.insert state device is
addedCallback _ _ _ = return ()
removedCallback :: MonadUnliftIO m => MutableVPNState -> m () -> SignalCallback m
removedCallback state dpy [device, interfaces] = update >> dpy
where
is = fromMaybe [] $ fromVariant interfaces :: [T.Text]
update = updateDevice S.delete state device is
removedCallback _ _ _ = return ()
updateDevice
:: MonadUnliftIO m
=> (ObjectPath -> VPNState -> VPNState)
-> MutableVPNState
-> Variant
-> [T.Text]
-> m ()
updateDevice f state device interfaces =
when (vpnDeviceTun `elem` interfaces) $
forM_ d $
updateState f state
where
d = fromVariant device :: Maybe ObjectPath
--------------------------------------------------------------------------------
-- DBus Interface
vpnBus :: BusName
vpnBus = busName_ "org.freedesktop.NetworkManager"
vpnPath :: ObjectPath
vpnPath = objectPath_ "/org/freedesktop"
vpnDeviceTun :: T.Text
vpnDeviceTun = "org.freedesktop.NetworkManager.Device.Tun"
vpnAlias :: T.Text
vpnAlias = "vpn"
vpnDep :: DBusDependency_ SysClient
vpnDep =
Endpoint networkManagerPkgs networkManagerBus vpnPath omInterface $
Method_ getManagedObjects

View File

@ -9,9 +9,47 @@ extra-source-files:
- README.md - README.md
- fourmolu.yaml - fourmolu.yaml
- make_pkgs - make_pkgs
- icons/* - runtime_pkgs
- assets/icons/*
- assets/sound/*
- scripts/* - scripts/*
- sound/*
default-extensions:
- OverloadedStrings
- FlexibleContexts
- FlexibleInstances
- InstanceSigs
- MultiParamTypeClasses
- EmptyCase
- LambdaCase
- MultiWayIf
- NamedFieldPuns
- TupleSections
- DeriveFoldable
- DeriveFunctor
- DeriveGeneric
- DeriveLift
- DeriveTraversable
- DerivingStrategies
- DeriveDataTypeable
- EmptyDataDecls
- PartialTypeSignatures
- GeneralizedNewtypeDeriving
- StandaloneDeriving
- BangPatterns
- TypeOperators
- ScopedTypeVariables
- TypeApplications
- ConstraintKinds
- RankNTypes
- GADTs
- DefaultSignatures
- NoImplicitPrelude
- FunctionalDependencies
- DataKinds
- TypeFamilies
- BinaryLiterals
- ViewPatterns
dependencies: dependencies:
- rio >= 0.1.21.0 - rio >= 0.1.21.0
@ -35,14 +73,21 @@ dependencies:
- typed-process >= 0.2.8.0 - typed-process >= 0.2.8.0
- network >= 3.1.2.7 - network >= 3.1.2.7
- unliftio >= 0.2.21.0 - unliftio >= 0.2.21.0
- optparse-applicative >= 0.16.1.0
ghc-options:
- -Wall
- -Wcompat
- -Widentities
- -Wincomplete-record-updates
- -Wincomplete-uni-patterns
- -Wredundant-constraints
- -Wpartial-fields
- -Werror
- -O2
library: library:
source-dirs: lib/ source-dirs: lib/
ghc-options:
- -Wall
- -Werror
- -Wpartial-fields
- -O2
executables: executables:
xmobar: &bin xmobar: &bin
@ -52,21 +97,15 @@ executables:
- xmonad-config - xmonad-config
ghc-options: ghc-options:
- -threaded - -threaded
- -Wall
- -Werror
- -Wpartial-fields
- -O2
xmonad: xmonad:
<<: *bin <<: *bin
main: xmonad.hs main: xmonad.hs
ghc-options: ghc-options:
- -threaded - -threaded
- -Wall
- -Werror
- -Wpartial-fields
- -O2
# this is needed to avoid writing super complex layout types # this is needed to avoid writing super complex layout types
- -fno-warn-missing-signatures - -fno-warn-missing-signatures
vbox-start: vbox-start:
<<: *bin <<: *bin
main: vbox-start.hs main: vbox-start.hs
ghc-options:
- -threaded

22
scripts/screencap Executable file
View File

@ -0,0 +1,22 @@
#! /bin/bash
## capture a screenshot using scrot
SS_DIR="$XDG_CACHE_HOME/screenshots"
while getopts ":sw" opt; do
case ${opt} in
s)
scrot "$SS_DIR/desktop/%Y-%m-%d-%H:%M:%S_desktop.png"
notify-send "Screen captured"
;;
w)
scrot -u "$SS_DIR/window/%Y-%m-%d-%H:%M:%S-\$wx\$h.png"
notify-send "Window captured"
;;
\?)
echo "invalid option, read the code"
;;
esac
done

61
scripts/screenlock Executable file
View File

@ -0,0 +1,61 @@
#! /bin/bash
## lock the screen using i3lock (and maybe suspend)
## usage: screenlock [SUSPEND]
# WORKAROUND make the date show up in the right place on 2+ monitor setups
# I want it to only show up on the primary screen, so use xrandr to get the
# dimensions and position of the primary monitor and calculate the date position
# from that
geometry=$(xrandr | sed -n 's/^.*primary \([0-9]*\)x[0-9]*+\([0-9]\)*+[0-9]* .*/\1 \2/p')
width=$(echo "$geometry" | cut -f1 -d" ")
xpos=$(echo "$geometry" | cut -f2 -d" ")
xoffset=$(("$xpos" + "$width" / 2))
datepos="$xoffset:600"
# lock and fork so we can suspend with the screen locked
i3lock --color=000000 \
--pass-media-keys \
--nofork \
--ignore-empty-password \
--screen=0 \
--indicator \
--inside-color=00000055 \
--insidever-color=00000055 \
--insidewrong-color=00000055 \
--ring-color=555555ff \
--ringwrong-color=ff3333ff \
--ringver-color=99ceffff \
--keyhl-color=99ceffff \
--bshl-color=9523ffff \
--line-color=00000000 \
--separator-color=00000000 \
--clock \
--verif-color=99ceffff \
--wrong-color=ff8282ff \
--time-color=ffffffff \
--time-size=72 \
--time-str="%H:%M" \
--date-color=ffffffff \
--date-size=42 \
--date-str="%b %d, %Y" \
--date-align 0 \
--date-pos="$datepos" \
--wrong-size=72 \
--verif-size=72 \
--radius=300 \
--ring-width=25 &
# suspend if we want, and if this machine is currently using a battery
batpath=/sys/class/power_supply/BAT0/status
if [ -f "$batpath" ] && \
[ "$(cat $batpath)" == "Discharging" ] && \
[ "$1" == "true" ]; then
systemctl suspend
fi
# block until the screen is unlocked (since xss-lock expects the locker to exit
# only when unlocked)
wait

View File

@ -17,8 +17,8 @@
# #
# resolver: ./custom-snapshot.yaml # resolver: ./custom-snapshot.yaml
# resolver: https://example.com/snapshots/2018-01-01.yaml # resolver: https://example.com/snapshots/2018-01-01.yaml
#resolver: lts-17.4 resolver: lts-19.33
resolver: nightly-2022-03-03 #resolver: nightly-2022-03-03
# User packages to be built. # User packages to be built.
# Various formats can be used as shown in the example below. # Various formats can be used as shown in the example below.