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.
--
-- The only reason why this is needed is because I want to manage virtualboxes
@ -43,7 +40,7 @@ runAndWait [n] = do
p <- vmPID i
liftIO $ mapM_ waitUntilExit p
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 i = do

View File

@ -1,5 +1,3 @@
{-# LANGUAGE OverloadedStrings #-}
-- | Xmobar binary
--
-- Features:
@ -12,16 +10,15 @@
module Main (main) where
import Data.Internal.DBus
import Data.Internal.Dependency
import Data.Internal.XIO
import GHC.Enum (enumFrom)
import Options.Applicative
import RIO hiding (hFlush)
import qualified RIO.ByteString.Lazy as BL
import RIO.FilePath
import RIO.List
import RIO.Process
import qualified RIO.NonEmpty as NE
import qualified RIO.Text as T
import System.IO
import UnliftIO.Environment
import XMonad.Core hiding (config)
import XMonad.Internal.Command.Desktop
import XMonad.Internal.Command.Power
import XMonad.Internal.DBus.Brightness.ClevoKeyboard
import XMonad.Internal.DBus.Brightness.IntelBacklight
@ -32,32 +29,58 @@ import Xmobar hiding
( iconOffset
, run
)
import Xmobar.Plugins.ActiveConnection
import Xmobar.Plugins.Bluetooth
import Xmobar.Plugins.ClevoKeyboard
import Xmobar.Plugins.Common
import Xmobar.Plugins.Device
import Xmobar.Plugins.IntelBacklight
import Xmobar.Plugins.Screensaver
import Xmobar.Plugins.VPN
main :: IO ()
main = getArgs >>= parse
main = parse >>= xio
parse :: [String] -> IO ()
parse [] = run
parse ["--deps"] = withCache printDeps
parse ["--test"] = withCache $ withDBus_ evalConfig
parse _ = usage
parse :: IO XOpts
parse = execParser opts
where
parseOpts = parseDeps <|> parseTest <|> pure XRun
opts =
info (parseOpts <**> helper) $
fullDesc <> header "xmobar: the best taskbar ever"
run :: IO ()
run = withCache $ withDBus_ $ \db -> do
c <- evalConfig db
-- this is needed to see any printed messages
liftIO $ do
hFlush stdout
xmobar c
data XOpts = XDeps | XTest | XRun
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
cs <- getAllCommands <$> rightPlugins db
bf <- getTextFont
@ -65,19 +88,14 @@ evalConfig db = do
d <- io $ cfgDir <$> getDirectories
return $ config bf ifs ios cs d
printDeps :: FIO ()
printDeps = withDBus_ $ \db -> do
let ps = sort $ nub $ fmap showFulfillment $ concatMap dumpFeature $ allFeatures db
io $ mapM_ (putStrLn . T.unpack) ps
usage :: IO ()
usage =
putStrLn $
intercalate
"\n"
[ "xmobar: run greatest taskbar"
, "xmobar --deps: print dependencies"
]
printDeps :: XIO ()
printDeps = withDBus_ Nothing Nothing $ \db ->
mapM_ logInfo $
fmap showFulfillment $
sort $
nub $
concatMap dumpFeature $
allFeatures db
--------------------------------------------------------------------------------
-- toplevel configuration
@ -100,7 +118,7 @@ iconFont =
fontSometimes
"XMobar Icon 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)
iconOffset :: BarFont -> Int
@ -146,7 +164,7 @@ config bf ifs ios br confDir =
, pickBroadest = False
, persistent = True
, -- store the icons with the xmonad/xmobar stack project
iconRoot = confDir ++ "/icons"
iconRoot = confDir </> "assets" </> "icons"
, commands = csRunnable <$> concatRegions br
}
@ -169,7 +187,7 @@ getAllCommands right =
, brRight = catMaybes right
}
rightPlugins :: DBusState -> FIO [Maybe CmdSpec]
rightPlugins :: DBusState -> XIO [Maybe CmdSpec]
rightPlugins db =
mapM evalFeature $
allFeatures db
@ -201,11 +219,11 @@ getWireless =
xpfWireless
[Subfeature (IORoot wirelessCmd $ Only readWireless) "sysfs path"]
getEthernet :: Maybe SysClient -> BarFeature
getEthernet cl = iconDBus "ethernet status indicator" xpfEthernet root tree
getEthernet :: Maybe NamedSysConnection -> BarFeature
getEthernet cl = iconDBus_ "ethernet status indicator" xpfEthernet root (Only_ devDep)
where
root useIcon tree' = DBusRoot (const . ethernetCmd useIcon) tree' cl
tree = And1 (Only readEthernet) (Only_ devDep)
root useIcon tree' =
DBusRoot_ (const $ ethernetCmd useIcon) tree' cl
getBattery :: BarFeature
getBattery = iconIO_ "battery level indicator" xpfBattery root tree
@ -217,18 +235,12 @@ getBattery = iconIO_ "battery level indicator" xpfBattery root tree
io $
fmap (Msg LevelError) <$> hasBattery
getVPN :: Maybe SysClient -> BarFeature
getVPN cl = iconDBus_ "VPN status indicator" xpfVPN root $ toAnd_ vpnDep test
getVPN :: Maybe NamedSysConnection -> BarFeature
getVPN cl = iconDBus_ "VPN status indicator" xpfVPN root (Only_ devDep)
where
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
getAlsa :: BarFeature
@ -239,7 +251,7 @@ getAlsa =
where
root useIcon = IORoot_ (alsaCmd useIcon)
getBl :: Maybe SesClient -> BarFeature
getBl :: Maybe NamedSesConnection -> BarFeature
getBl =
xmobarDBus
"Intel backlight indicator"
@ -247,7 +259,7 @@ getBl =
intelBacklightSignalDep
blCmd
getCk :: Maybe SesClient -> BarFeature
getCk :: Maybe NamedSesConnection -> BarFeature
getCk =
xmobarDBus
"Clevo keyboard indicator"
@ -255,7 +267,7 @@ getCk =
clevoKeyboardSignalDep
ckCmd
getSs :: Maybe SesClient -> BarFeature
getSs :: Maybe NamedSesConnection -> BarFeature
getSs = xmobarDBus "screensaver indicator" (const True) ssSignalDep ssCmd
getLock :: Always CmdSpec
@ -272,7 +284,7 @@ xmobarDBus
-> XPQuery
-> DBusDependency_ c
-> (Fontifier -> CmdSpec)
-> Maybe c
-> Maybe (NamedConnection c)
-> BarFeature
xmobarDBus n q dep cmd cl = iconDBus_ n q root (Only_ dep)
where
@ -286,18 +298,16 @@ iconIO_
-> BarFeature
iconIO_ = iconSometimes' And_ Only_
iconDBus
:: SafeClient c
=> T.Text
-> XPQuery
-> (Fontifier -> DBusTree c p -> Root CmdSpec)
-> DBusTree c p
-> BarFeature
iconDBus = iconSometimes' And1 $ Only_ . DBusIO
-- iconDBus
-- :: T.Text
-- -> XPQuery
-- -> (Fontifier -> DBusTree c p -> Root CmdSpec)
-- -> DBusTree c p
-- -> BarFeature
-- iconDBus = iconSometimes' And1 $ Only_ . DBusIO
iconDBus_
:: SafeClient c
=> T.Text
:: T.Text
-> XPQuery
-> (Fontifier -> DBusTree_ c -> Root CmdSpec)
-> DBusTree_ c
@ -359,13 +369,19 @@ wirelessCmd iface =
, "<icon=wifi_%%.xpm/>"
]
ethernetCmd :: Fontifier -> T.Text -> CmdSpec
ethernetCmd fontify iface =
ethernetCmd :: Fontifier -> CmdSpec
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
{ csAlias = iface
{ csAlias = connAlias contypes
, csRunnable =
Run $
Device (iface, fontify IconMedium "\xf0e8" "ETH", colors)
ActiveConnection (contypes, fontify IconMedium icon abbr, colors)
}
batteryCmd :: Fontifier -> CmdSpec
@ -401,20 +417,13 @@ batteryCmd fontify =
, fontify' "\xf1e6" "AC"
]
vpnCmd :: Fontifier -> CmdSpec
vpnCmd fontify =
CmdSpec
{ csAlias = vpnAlias
, csRunnable = Run $ VPN (fontify IconMedium "\xf023" "VPN", colors)
}
btCmd :: Fontifier -> CmdSpec
btCmd fontify =
CmdSpec
{ csAlias = btAlias
, csRunnable =
Run $
Bluetooth (fontify' "\xf5b0" "+", fontify' "\xf5ae" "-") colors
Bluetooth (fontify' "\x0f00b1" "+", fontify' "\x0f00af" "-") colors
}
where
fontify' i = fontify IconLarge i . T.append "BT"
@ -455,7 +464,7 @@ ckCmd :: Fontifier -> CmdSpec
ckCmd fontify =
CmdSpec
{ csAlias = ckAlias
, csRunnable = Run $ ClevoKeyboard $ fontify IconSmall "\xf40b" "KB: "
, csRunnable = Run $ ClevoKeyboard $ fontify IconSmall "\xf11c" "KB: "
}
ssCmd :: Fontifier -> CmdSpec
@ -491,8 +500,8 @@ lockCmd fontify =
]
}
where
numIcon = fontify' "\xf8a5" "N"
capIcon = fontify' "\xf657" "C"
numIcon = fontify' "\x0f03a6" "N"
capIcon = fontify' "\x0f0bf1" "C"
fontify' = fontify IconXLarge
disabledColor = xmobarFGColor XT.backdropFgColor
@ -503,36 +512,13 @@ dateCmd =
, 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
--
-- ASSUME there is only one text font for this entire configuration. This
-- will correspond to the first font/offset parameters in the config record.
getTextFont :: FIO T.Text
getTextFont :: XIO T.Text
getTextFont = do
fb <- evalAlways textFont
return $ fb textFontData
@ -540,7 +526,7 @@ getTextFont = do
--------------------------------------------------------------------------------
-- icon fonts
getIconFonts :: FIO ([T.Text], [Int])
getIconFonts :: XIO ([T.Text], [Int])
getIconFonts = do
fb <- evalSometimes iconFont
return $ maybe ([], []) apply fb

View File

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

View File

@ -5,7 +5,17 @@ module Data.Internal.DBus
( SafeClient (..)
, SysClient (..)
, SesClient (..)
, NamedConnection (..)
, NamedSesConnection
, NamedSysConnection
, DBusEnv (..)
, DIO
, HasClient (..)
, releaseBusName
, withDIO
, addMatchCallback
, addMatchCallbackSignal
, matchSignalFull
, matchProperty
, matchPropertyFull
, matchPropertyChanged
@ -25,93 +35,218 @@ module Data.Internal.DBus
, addInterfaceRemovedListener
, fromSingletonVariant
, bodyToMaybe
, exportPair
, displayBusName
, displayObjectPath
, displayMemberName
, displayInterfaceName
, displayWrapQuote
, busNameT
, interfaceNameT
, memberNameT
, objectPathT
)
where
import DBus
import DBus.Client
import qualified Data.ByteString.Char8 as BC
import RIO
import RIO.List
import qualified RIO.Map as M
import qualified RIO.Text as T
--------------------------------------------------------------------------------
-- Type-safe client
class SafeClient c where
toClient :: c -> Client
data NamedConnection c = NamedConnection
{ ncClient :: !Client
, ncHumanName :: !(Maybe BusName)
--, ncUniqueName :: !BusName
, ncType :: !c
}
type NamedSesConnection = NamedConnection SesClient
type NamedSysConnection = NamedConnection SysClient
class SafeClient c where
getDBusClient
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
=> m (Maybe c)
=> Maybe BusName
-> m (Maybe (NamedConnection c))
disconnectDBusClient :: MonadUnliftIO m => c -> m ()
disconnectDBusClient = liftIO . disconnect . toClient
disconnectDBusClient
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
=> NamedConnection c
-> m ()
disconnectDBusClient c = do
releaseBusName c
liftIO $ disconnect $ ncClient c
withDBusClient
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
=> (c -> m a)
=> Maybe BusName
-> (NamedConnection c -> m a)
-> m (Maybe a)
withDBusClient f =
bracket getDBusClient (mapM (liftIO . disconnect . toClient)) $ mapM f
withDBusClient n f =
bracket (getDBusClient n) (mapM (liftIO . disconnect . ncClient)) $ mapM f
withDBusClient_
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
=> (c -> m ())
=> Maybe BusName
-> (NamedConnection c -> m ())
-> m ()
withDBusClient_ = void . withDBusClient
withDBusClient_ n = void . withDBusClient n
fromDBusClient
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
=> (c -> a)
=> Maybe BusName
-> (NamedConnection c -> 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
toClient (SysClient cl) = cl
getDBusClient = connectToDBusWithName True SysClient
getDBusClient = fmap SysClient <$> getSomeDBusClient True
newtype SesClient = SesClient Client
data SesClient = SesClient
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)
=> Bool
-> m (Maybe Client)
getSomeDBusClient sys = do
getDBusClient' sys = do
res <- try $ liftIO $ if sys then connectSystem else connectSession
case res of
Left e -> do
logError $ Utf8Builder $ encodeUtf8Builder $ T.pack $ clientErrorMessage e
logInfo $ displayBytesUtf8 $ BC.pack $ clientErrorMessage e
return Nothing
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
type MethodBody = Either T.Text [Variant]
callMethod' :: (MonadUnliftIO m, SafeClient c) => c -> MethodCall -> m MethodBody
callMethod' cl =
liftIO
. fmap (bimap (T.pack . methodErrorMessage) methodReturnBody)
. call (toClient cl)
callMethod'
:: (SafeClient c, MonadUnliftIO m, MonadReader (env c) m, HasClient env)
=> MethodCall
-> m MethodBody
callMethod' mc = do
cl <- ncClient <$> view clientL
liftIO $ bimap (T.pack . methodErrorMessage) methodReturnBody <$> call cl mc
callMethod
:: (MonadUnliftIO m, SafeClient c)
=> c
-> BusName
:: (SafeClient c, MonadUnliftIO m, MonadReader (env c) m, HasClient env)
=> BusName
-> ObjectPath
-> InterfaceName
-> MemberName
-> 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 b p i m =
@ -125,8 +260,22 @@ methodCallBus b p i m =
dbusInterface :: InterfaceName
dbusInterface = interfaceName_ "org.freedesktop.DBus"
callGetNameOwner :: (MonadUnliftIO m, SafeClient c) => c -> BusName -> m (Maybe BusName)
callGetNameOwner cl name = bodyToMaybe <$> callMethod' cl mc
callGetNameOwner
:: ( 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
mc =
(methodCallBus dbusName dbusPath dbusInterface mem)
@ -137,6 +286,7 @@ callGetNameOwner cl name = bodyToMaybe <$> callMethod' cl mc
--------------------------------------------------------------------------------
-- Variant parsing
-- TODO log failures here?
fromSingletonVariant :: IsVariant a => [Variant] -> Maybe a
fromSingletonVariant = fromVariant <=< listToMaybe
@ -148,14 +298,29 @@ bodyToMaybe = either (const Nothing) fromSingletonVariant
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
:: (MonadUnliftIO m, SafeClient c)
:: ( MonadReader (env c) m
, MonadUnliftIO m
, SafeClient c
, HasClient env
)
=> MatchRule
-> SignalCallback m
-> c
-> m SignalHandler
addMatchCallback rule cb cl = withRunInIO $ \run -> do
addMatch (toClient cl) rule $ run . cb . signalBody
addMatchCallback rule cb = addMatchCallbackSignal rule (cb . signalBody)
matchSignal
:: Maybe BusName
@ -172,15 +337,35 @@ matchSignal b p i m =
}
matchSignalFull
:: (MonadUnliftIO m, SafeClient c)
=> c
-> BusName
:: ( MonadReader (env c) m
, HasLogFunc (env c)
, MonadUnliftIO m
, SafeClient c
, HasClient env
)
=> BusName
-> Maybe ObjectPath
-> Maybe InterfaceName
-> Maybe MemberName
-> m (Maybe MatchRule)
matchSignalFull client b p i m =
fmap (\o -> matchSignal (Just o) p i m) <$> callGetNameOwner client b
matchSignalFull b p i m = do
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
@ -192,31 +377,42 @@ propertySignal :: MemberName
propertySignal = memberName_ "PropertiesChanged"
callPropertyGet
:: (MonadUnliftIO m, SafeClient c)
:: ( HasClient env
, MonadReader (env c) m
, HasLogFunc (env c)
, MonadUnliftIO m
, SafeClient c
)
=> BusName
-> ObjectPath
-> InterfaceName
-> MemberName
-> c
-> m [Variant]
callPropertyGet bus path iface property cl =
liftIO $
fmap (either (const []) (: [])) $
getProperty (toClient cl) $
methodCallBus bus path iface property
callPropertyGet bus path iface property = do
cl <- ncClient <$> view clientL
res <- liftIO $ getProperty cl $ methodCallBus bus path iface property
case res of
Left err -> do
logError $ displayBytesUtf8 $ BC.pack $ methodErrorMessage err
return []
Right v -> return [v]
matchProperty :: Maybe BusName -> Maybe ObjectPath -> MatchRule
matchProperty b p =
matchSignal b p (Just propertyInterface) (Just propertySignal)
matchPropertyFull
:: (MonadUnliftIO m, SafeClient c)
=> c
-> BusName
:: ( MonadReader (env c) m
, HasLogFunc (env c)
, MonadUnliftIO m
, SafeClient c
, HasClient env
)
=> BusName
-> Maybe ObjectPath
-> m (Maybe MatchRule)
matchPropertyFull cl b p =
matchSignalFull cl b p (Just propertyInterface) (Just propertySignal)
matchPropertyFull b p =
matchSignalFull b p (Just propertyInterface) (Just propertySignal)
data SignalMatch a = Match a | NoMatch | Failure deriving (Eq, Show)
@ -228,26 +424,26 @@ withSignalMatch _ NoMatch = return ()
matchPropertyChanged
:: IsVariant a
=> InterfaceName
-> T.Text
-> MemberName
-> [Variant]
-> SignalMatch a
matchPropertyChanged iface property [i, body, _] =
let i' = (fromVariant i :: Maybe T.Text)
b = toMap body
in case (i', b) of
(Just i'', Just b') ->
if i'' == T.pack (formatInterfaceName iface)
then maybe NoMatch Match $ fromVariant =<< M.lookup property b'
matchPropertyChanged iface property [sigIface, sigValues, _] =
let i = fromVariant sigIface :: Maybe T.Text
v = fromVariant sigValues :: Maybe (M.Map T.Text Variant)
in case (i, v) of
(Just i', Just v') ->
if i' == interfaceNameT iface
then
maybe NoMatch Match $
fromVariant =<< M.lookup (memberNameT property) v'
else NoMatch
_ -> Failure
where
toMap v = fromVariant v :: Maybe (M.Map T.Text Variant)
matchPropertyChanged _ _ _ = Failure
--------------------------------------------------------------------------------
-- 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_ "org.freedesktop.DBus.ObjectManager"
@ -262,43 +458,132 @@ omInterfacesRemoved :: MemberName
omInterfacesRemoved = memberName_ "InterfacesRemoved"
callGetManagedObjects
:: (MonadUnliftIO m, SafeClient c)
=> c
-> BusName
:: ( MonadReader (env c) m
, HasLogFunc (env c)
, MonadUnliftIO m
, SafeClient c
, HasClient env
)
=> BusName
-> ObjectPath
-> m ObjectTree
callGetManagedObjects cl bus path =
either (const M.empty) (fromMaybe M.empty . fromSingletonVariant)
<$> callMethod cl bus path omInterface getManagedObjects
callGetManagedObjects bus path = do
res <- callMethod 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
:: (MonadUnliftIO m, SafeClient c)
:: ( MonadReader (env c) m
, HasLogFunc (env c)
, MonadUnliftIO m
, SafeClient c
, HasClient env
)
=> BusName
-> MemberName
-> ObjectPath
-> SignalCallback m
-> c
-> m (Maybe SignalHandler)
addInterfaceChangedListener bus prop path sc cl = do
rule <- matchSignalFull cl bus (Just path) (Just omInterface) (Just prop)
forM rule $ \r -> addMatchCallback r sc cl
addInterfaceChangedListener bus prop path sc = do
res <- matchSignalFull bus (Just path) (Just omInterface) (Just prop)
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
:: (MonadUnliftIO m, SafeClient c)
:: ( MonadReader (env c) m
, HasLogFunc (env c)
, MonadUnliftIO m
, SafeClient c
, HasClient env
)
=> BusName
-> ObjectPath
-> SignalCallback m
-> c
-> m (Maybe SignalHandler)
addInterfaceAddedListener bus =
addInterfaceChangedListener bus omInterfacesAdded
addInterfaceRemovedListener
:: (MonadUnliftIO m, SafeClient c)
:: ( MonadReader (env c) m
, HasLogFunc (env c)
, MonadUnliftIO m
, SafeClient c
, HasClient env
)
=> BusName
-> ObjectPath
-> SignalCallback m
-> c
-> m (Maybe SignalHandler)
addInterfaceRemovedListener bus =
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
module Data.Internal.Dependency
module Data.Internal.XIO
-- feature types
( Feature
, Always (..)
@ -26,6 +19,7 @@ module Data.Internal.Dependency
, SubfeatureRoot
, Msg (..)
-- configuration
, XEnv (..)
, XParams (..)
, XPFeatures (..)
, XPQuery
@ -53,8 +47,9 @@ module Data.Internal.Dependency
, dumpSometimes
, showFulfillment
-- testing
, FIO
, withCache
, XIO
, runXIO
, hRunXIO
, evalFeature
, executeSometimes
, executeAlways
@ -96,6 +91,7 @@ module Data.Internal.Dependency
, process
-- misc
, shellTest
, withLogFile
)
where
@ -104,6 +100,7 @@ import qualified DBus.Introspection as I
import Data.Aeson hiding (Error, Result)
import Data.Aeson.Key
import Data.Internal.DBus
import qualified Data.Text.IO as TI
import Data.Yaml
import GHC.IO.Exception (ioe_description)
import RIO hiding (bracket, fromString)
@ -115,7 +112,7 @@ import qualified RIO.Text as T
import System.Posix.Files
import System.Process.Typed (nullStream)
import UnliftIO.Environment
import XMonad.Core (X, io)
import XMonad.Core (X, dataDir, getDirectories, io)
import XMonad.Internal.IO
import XMonad.Internal.Shell hiding (proc, runProcess)
import XMonad.Internal.Theme
@ -128,30 +125,47 @@ import XMonad.Internal.Theme
-- | Run feature evaluation(s) with the cache
-- Currently there is no easy way to not use this (oh well)
withCache :: FIO a -> IO a
withCache x = do
logOpts <- logOptionsHandle stderr False
runXIO :: FilePath -> XIO a -> IO a
runXIO logfile x = withLogFile logfile $ \h -> hRunXIO True h x
-- 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
withLogFunc logOpts $ \f -> do
p <- getParams
let s = DepStage f pc p
let s = XEnv f pc p
runRIO s x
logOptionsHandle_ :: MonadUnliftIO m => Bool -> Handle -> m LogOptions
logOptionsHandle_ v h =
setLogVerboseFormat v . setLogUseTime v <$> logOptionsHandle h False
-- | Execute an Always immediately
executeAlways :: Always (IO a) -> FIO a
executeAlways :: Always (IO a) -> XIO a
executeAlways = io <=< evalAlways
-- | 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
-- | 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 (Left s) = evalSometimes s
-- | 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
where
goPass (a, ws) = putErrors ws >> return (Just a)
@ -159,13 +173,13 @@ evalSometimes x = either goFail goPass =<< evalSometimesMsg x
putErrors = mapM_ logMsg
-- | Return the action of an Always
evalAlways :: Always a -> FIO a
evalAlways :: Always a -> XIO a
evalAlways a = do
(x, ws) <- evalAlwaysMsg a
mapM_ logMsg ws
return x
logMsg :: FMsg -> FIO ()
logMsg :: FMsg -> XIO ()
logMsg (FMsg fn n (Msg ll m)) = do
p <- io getProgName
f $ Utf8Builder $ encodeUtf8Builder $ T.unwords $ fmt s (T.pack p)
@ -186,8 +200,9 @@ logMsg (FMsg fn n (Msg ll m)) = do
--------------------------------------------------------------------------------
-- Package status
showFulfillment :: Fulfillment -> T.Text
showFulfillment (Package t n) = T.concat [T.pack $ show t, "\t", n]
showFulfillment :: Fulfillment -> Utf8Builder
showFulfillment (Package t n) =
displayShow t <> "\t" <> Utf8Builder (encodeUtf8Builder n)
dumpFeature :: Feature a -> [Fulfillment]
dumpFeature = either dumpSometimes dumpAlways
@ -209,7 +224,7 @@ type AlwaysIO = Always (IO ())
type SometimesX = Sometimes (X ())
type SometimesIO = Sometimes (FIO ())
type SometimesIO = Sometimes (XIO ())
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
-- 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)
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)
data Always_ a
= Option (SubfeatureRoot a) (Always_ a)
| Always_ (FallbackRoot a)
deriving (Functor)
-- | Root of a fallback action for an always
-- This may either be a lone action or a function that depends on the results
@ -233,15 +249,23 @@ data FallbackRoot a
= FallbackAlone a
| 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
data FallbackStack p
= FallbackBottom (Always p)
| 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
-- This is like an Always except it doesn't fall back on a guaranteed monadic
-- 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)
type Sometimes_ a = [SubfeatureRoot a]
@ -254,6 +278,7 @@ data Subfeature f = Subfeature
{ sfData :: f
, sfName :: T.Text
}
deriving (Functor)
type SubfeatureRoot a = Subfeature (Root a)
@ -263,8 +288,24 @@ type SubfeatureRoot a = Subfeature (Root a)
data Root a
= forall p. IORoot (p -> a) (IOTree p)
| IORoot_ a IOTree_
| forall c p. SafeClient c => DBusRoot (p -> c -> a) (DBusTree c p) (Maybe c)
| forall c. SafeClient c => DBusRoot_ (c -> a) (DBusTree_ c) (Maybe c)
| forall c p.
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
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)
data IODependency p
= -- 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
IOConst p
| -- an always that yields a payload
@ -302,12 +343,11 @@ data DBusDependency_ c
= Bus [Fulfillment] BusName
| Endpoint [Fulfillment] BusName ObjectPath InterfaceName DBusMember
| DBusIO IODependency_
deriving (Generic)
-- | A dependency that only requires IO to evaluate (no payload)
data IODependency_
= IOSystem_ [Fulfillment] SystemDependency
| IOTest_ T.Text [Fulfillment] (FIO (Maybe Msg))
| IOTest_ T.Text [Fulfillment] (XIO (Maybe Msg))
| forall a. IOSometimes_ (Sometimes a)
-- | A system component to an IODependency
@ -317,23 +357,23 @@ data SystemDependency
| AccessiblePath FilePath Bool Bool
| Systemd UnitType T.Text
| Process T.Text
deriving (Eq, Show, Generic)
deriving (Eq, Show)
-- | 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
data DBusMember
= Method_ MemberName
| Signal_ MemberName
| Property_ T.Text
deriving (Eq, Show, Generic)
deriving (Eq, Show)
-- | A means to fulfill a dependency
-- 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 ArchPkg = Official | AUR | Custom deriving (Eq, Show, Generic, Ord)
data ArchPkg = Official | AUR | Custom deriving (Eq, Show, Ord)
--------------------------------------------------------------------------------
-- Tested dependency tree
@ -376,19 +416,25 @@ data PostFail = PostFail [Msg] | PostMissing Msg
--------------------------------------------------------------------------------
-- Configuration
type FIO a = RIO DepStage a
type XIO a = RIO XEnv a
data DepStage = DepStage
{ dsLogFun :: !LogFunc
, dsProcCxt :: !ProcessContext
, dsParams :: !XParams
data XEnv = XEnv
{ xLogFun :: !LogFunc
, xProcCxt :: !ProcessContext
, xParams :: !XParams
}
instance HasLogFunc DepStage where
logFuncL = lens dsLogFun (\x y -> x {dsLogFun = y})
instance HasLogFunc XEnv where
logFuncL = lens xLogFun (\x y -> x {xLogFun = y})
instance HasProcessContext DepStage where
processContextL = lens dsProcCxt (\x y -> x {dsProcCxt = y})
instance HasLogFunc (DBusEnv XEnv c) where
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
{ xpLogLevel :: LogLevel
@ -422,7 +468,8 @@ data XPFeatures = XPFeatures
, xpfIntelBacklight :: Bool
, xpfClevoBacklight :: Bool
, xpfBattery :: Bool
, xpfF5VPN :: Bool
, xpfEthPrefix :: Maybe Text
, xpfWifiPrefix :: Maybe Text
}
instance FromJSON XPFeatures where
@ -449,7 +496,9 @@ instance FromJSON XPFeatures where
<*> o
.:+ "battery"
<*> o
.:+ "f5vpn"
.:? "ethPrefix"
<*> o
.:? "wifiPrefix"
defParams :: XParams
defParams =
@ -472,7 +521,8 @@ defXPFeatures =
, xpfIntelBacklight = False
, xpfClevoBacklight = False
, xpfBattery = False
, xpfF5VPN = False
, xpfEthPrefix = Nothing
, xpfWifiPrefix = Nothing
}
type XPQuery = XPFeatures -> Bool
@ -483,7 +533,7 @@ getParams = do
maybe (return defParams) (liftIO . decodeYaml) p
where
decodeYaml p =
either (\e -> print e >> return defParams) return
either (\e -> TI.putStrLn (T.pack $ show e) >> return defParams) return
=<< decodeFileEither p
getParamFile :: MonadIO m => m (Maybe FilePath)
@ -507,9 +557,9 @@ infix 9 .:+
--------------------------------------------------------------------------------
-- Testing pipeline
evalSometimesMsg :: Sometimes a -> FIO (Either [FMsg] (a, [FMsg]))
evalSometimesMsg :: Sometimes a -> XIO (Either [FMsg] (a, [FMsg]))
evalSometimesMsg (Sometimes n u xs) = do
r <- asks (u . xpFeatures . dsParams)
r <- asks (u . xpFeatures . xParams)
if not r
then return $ Left [dis n]
else do
@ -521,7 +571,7 @@ evalSometimesMsg (Sometimes n u xs) = do
where
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
r <- testAlways x
return $ case r of
@ -541,7 +591,7 @@ failedMsg fn Subfeature {sfData = d, sfName = n} = case d of
where
f = fmap (FMsg fn (Just n))
testAlways :: Always_ a -> FIO (PostAlways a)
testAlways :: Always_ a -> XIO (PostAlways a)
testAlways = go []
where
go failed (Option fd next) = do
@ -551,18 +601,18 @@ testAlways = go []
(Right pass) -> return $ Primary pass failed next
go failed (Always_ ar) = (`Fallback` failed) <$> evalFallbackRoot ar
evalFallbackRoot :: FallbackRoot a -> FIO a
evalFallbackRoot :: FallbackRoot a -> XIO a
evalFallbackRoot (FallbackAlone a) = return a
evalFallbackRoot (FallbackTree a s) = a <$> evalFallbackStack s
evalFallbackStack :: FallbackStack p -> FIO p
evalFallbackStack :: FallbackStack p -> XIO p
evalFallbackStack (FallbackBottom a) = evalAlways a
evalFallbackStack (FallbackStack f a as) = do
ps <- evalFallbackStack as
p <- evalAlways a
return $ f p ps
testSometimes :: Sometimes_ a -> FIO (PostSometimes a)
testSometimes :: Sometimes_ a -> XIO (PostSometimes a)
testSometimes = go (PostSometimes Nothing [])
where
go ts [] = return ts
@ -572,13 +622,13 @@ testSometimes = go (PostSometimes Nothing [])
(Left l) -> go (ts {psFailed = l : psFailed ts}) xs
(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
t' <- testRoot t
-- monomorphism restriction :(
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
case r of
(IORoot a t) -> go a testIODep_ testIODep t
@ -592,7 +642,7 @@ testRoot r = do
Msg LevelError "client not available"
where
-- 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
go_ a f_ t = bimap PostFail (PostPass a) <$> testTree_ f_ t
@ -605,13 +655,13 @@ type MResult p = Memoized (Result p)
testTree
:: forall d d_ p
. (d_ -> FIO MResult_)
-> (forall q. d q -> FIO (MResult q))
. (d_ -> XIO MResult_)
-> (forall q. d q -> XIO (MResult q))
-> Tree d d_ p
-> FIO (Either [Msg] (PostPass p))
-> XIO (Either [Msg] (PostPass p))
testTree test_ test = go
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
ra <- go a
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
liftRight = either (return . Left)
testIODep :: IODependency p -> FIO (MResult p)
testIODep :: IODependency p -> XIO (MResult p)
testIODep d = memoizeMVar $ case d of
IORead _ _ t -> t
IOConst c -> return $ Right $ PostPass c []
@ -656,7 +706,7 @@ type Result_ = Either [Msg] [Msg]
type MResult_ = Memoized Result_
testTree_ :: (d -> FIO MResult_) -> Tree_ d -> FIO Result_
testTree_ :: (d -> XIO MResult_) -> Tree_ d -> XIO Result_
testTree_ test = go
where
go (And_ a b) = either (return . Left) (`test2nd` b) =<< go a
@ -664,10 +714,10 @@ testTree_ test = go
go (Only_ a) = runMemoized =<< test a
test2nd ws = fmap ((Right . (ws ++)) =<<) . go
testIODep_ :: IODependency_ -> FIO MResult_
testIODep_ :: IODependency_ -> XIO MResult_
testIODep_ d = memoizeMVar $ testIODepNoCache_ d
testIODepNoCache_ :: IODependency_ -> FIO Result_
testIODepNoCache_ :: IODependency_ -> XIO Result_
testIODepNoCache_ (IOSystem_ _ s) = readResult_ <$> testSysDependency s
testIODepNoCache_ (IOTest_ _ _ t) = readResult_ <$> t
testIODepNoCache_ (IOSometimes_ x) =
@ -762,7 +812,7 @@ fontDependency_ fam ful = IOTest_ (fontTestName fam) ful $ voidRead <$> testFont
fontTestName :: T.Text -> T.Text
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
@ -783,16 +833,16 @@ testFont fam = maybe pass (Left . (: [])) <$> shellTest "fc-list" args msg
-- start with "en" and wireless interfaces always start with "wl"
readEthernet :: IODependency T.Text
readEthernet = readInterface "get ethernet interface" isEthernet
readEthernet = readInterface "get ethernet interface" (fromMaybe "en" . xpfEthPrefix)
readWireless :: IODependency T.Text
readWireless = readInterface "get wireless interface" isWireless
readWireless = readInterface "get wireless interface" (fromMaybe "wl" . xpfWifiPrefix)
isWireless :: T.Text -> Bool
isWireless = T.isPrefixOf "wl"
-- isWireless :: T.Text -> Bool
-- isWireless = T.isPrefixOf "wl"
isEthernet :: T.Text -> Bool
isEthernet = T.isPrefixOf "en"
-- isEthernet :: T.Text -> Bool
-- isEthernet = T.isPrefixOf "en"
listInterfaces :: MonadUnliftIO m => m [T.Text]
listInterfaces =
@ -804,11 +854,12 @@ sysfsNet = "/sys/class/net"
-- ASSUME there are no (non-base) packages required to make these interfaces
-- 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
where
go = io $ do
ns <- filter f <$> listInterfaces
go = do
p <- asks (f . xpFeatures . xParams)
ns <- filter (T.isPrefixOf p) <$> listInterfaces
case ns of
[] -> return $ Left [Msg LevelError "no interfaces found"]
(x : xs) -> do
@ -820,7 +871,7 @@ readInterface n f = IORead n [] go
--------------------------------------------------------------------------------
-- Misc testers
socketExists :: T.Text -> [Fulfillment] -> FIO FilePath -> IODependency_
socketExists :: T.Text -> [Fulfillment] -> XIO FilePath -> IODependency_
socketExists n ful =
IOTest_ (T.unwords ["test if", n, "socket exists"]) ful . socketExists'
@ -844,12 +895,12 @@ introspectInterface = interfaceName_ "org.freedesktop.DBus.Introspectable"
introspectMethod :: MemberName
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
testDBusDepNoCache_ :: SafeClient c => c -> DBusDependency_ c -> FIO Result_
testDBusDepNoCache_ cl (Bus _ bus) = io $ do
ret <- callMethod cl queryBus queryPath queryIface queryMem
testDBusDepNoCache_ :: SafeClient c => NamedConnection c -> DBusDependency_ c -> XIO Result_
testDBusDepNoCache_ cl (Bus _ bus) = do
ret <- withDIO cl $ callMethod queryBus queryPath queryIface queryMem
return $ case ret of
Left e -> Left [Msg LevelError e]
Right b ->
@ -868,8 +919,10 @@ testDBusDepNoCache_ cl (Bus _ bus) = io $ do
queryMem = memberName_ "ListNames"
bodyGetNames [v] = fromMaybe [] $ fromVariant v :: [T.Text]
bodyGetNames _ = []
testDBusDepNoCache_ cl (Endpoint _ busname objpath iface mem) = io $ do
ret <- callMethod cl busname objpath introspectInterface introspectMethod
testDBusDepNoCache_ cl (Endpoint _ busname objpath iface mem) = do
ret <-
withDIO cl $
callMethod busname objpath introspectInterface introspectMethod
return $ case ret of
Left e -> Left [Msg LevelError e]
Right body -> procBody body
@ -925,12 +978,6 @@ testDBusDepNoCache_ _ (DBusIO i) = testIODepNoCache_ i
-- ioSubfeature :: MonadIO m => SubfeatureRoot (IO a) -> SubfeatureRoot (m a)
-- 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
@ -982,16 +1029,17 @@ sometimesExeArgs fn n ful sys path args =
sometimesDBus
:: SafeClient c
=> Maybe c
=> Maybe (NamedConnection c)
-> T.Text
-> T.Text
-> Tree_ (DBusDependency_ c)
-> (c -> a)
-> (NamedConnection c -> a)
-> Sometimes a
sometimesDBus c fn n t x = sometimes1 fn n $ DBusRoot_ x t c
-- TODO do I need to hardcode XEnv?
sometimesEndpoint
:: (SafeClient c, MonadIO m)
:: (HasClient (DBusEnv env), SafeClient c, MonadReader env m, MonadUnliftIO m)
=> T.Text
-> T.Text
-> [Fulfillment]
@ -999,13 +1047,13 @@ sometimesEndpoint
-> ObjectPath
-> InterfaceName
-> MemberName
-> Maybe c
-> Maybe (NamedConnection c)
-> Sometimes (m ())
sometimesEndpoint fn name ful busname path iface mem cl =
sometimesDBus cl fn name deps cmd
where
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

View File

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

View File

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

View File

@ -1,5 +1,3 @@
{-# LANGUAGE OverloadedStrings #-}
--------------------------------------------------------------------------------
-- Commands for controlling power
@ -26,7 +24,7 @@ module XMonad.Internal.Command.Power
)
where
import Data.Internal.Dependency
import Data.Internal.XIO
import Graphics.X11.Types
import RIO
import RIO.Directory
@ -69,29 +67,30 @@ runScreenLock =
False
myScreenlock
runPowerOff :: X ()
runPowerOff :: MonadUnliftIO m => m ()
runPowerOff = spawn "systemctl poweroff"
runSuspend :: X ()
runSuspend :: MonadUnliftIO m => m ()
runSuspend = spawn "systemctl suspend"
runHibernate :: X ()
runHibernate :: MonadUnliftIO m => m ()
runHibernate = spawn "systemctl hibernate"
runReboot :: X ()
runReboot :: MonadUnliftIO m => m ()
runReboot = spawn "systemctl reboot"
--------------------------------------------------------------------------------
-- Autolock
runAutolock :: Sometimes (FIO (P.Process () () ()))
runAutolock :: Sometimes (XIO (P.Process () () ()))
runAutolock = sometimesIO_ "automatic screen lock" "xss-lock" tree cmd
where
tree =
And_ (Only_ $ sysExe [Package Official "xss-lock"] "xss-lock") $
Only_ $
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
@ -106,7 +105,7 @@ confirmPrompt' :: T.Text -> X () -> XT.FontBuilder -> X ()
confirmPrompt' s x fb = confirmPrompt (XT.promptTheme fb) (T.unpack s) x
suspendPrompt :: XT.FontBuilder -> X ()
suspendPrompt = confirmPrompt' "suspend?" runSuspend
suspendPrompt = confirmPrompt' "suspend?" $ liftIO runSuspend
quitPrompt :: XT.FontBuilder -> X ()
quitPrompt = confirmPrompt' "quit?" $ io exitSuccess
@ -180,17 +179,20 @@ data PowerMaybeAction
| Reboot
deriving (Eq)
instance Enum PowerMaybeAction where
toEnum 0 = Poweroff
toEnum 1 = Shutdown
toEnum 2 = Hibernate
toEnum 3 = Reboot
toEnum _ = errorWithoutStackTrace "Main.Enum.PowerMaybeAction.toEnum: bad argument"
fromPMA :: PowerMaybeAction -> Int
fromPMA a = case a of
Poweroff -> 0
Shutdown -> 1
Hibernate -> 2
Reboot -> 3
fromEnum Poweroff = 0
fromEnum Shutdown = 1
fromEnum Hibernate = 2
fromEnum Reboot = 3
toPMA :: Int -> Maybe PowerMaybeAction
toPMA x = case x of
0 -> Just Poweroff
1 -> Just Shutdown
2 -> Just Hibernate
3 -> Just Reboot
_ -> Nothing
data PowerPrompt = PowerPrompt
@ -222,9 +224,11 @@ powerPrompt lock fb = mkXPrompt PowerPrompt theme comp executeMaybeAction
, (xK_Return, quit)
, (xK_Escape, quit)
]
sendMaybeAction a = setInput (show $ fromEnum a) >> setSuccess True >> setDone True
executeMaybeAction a = case toEnum $ read a of
Poweroff -> runPowerOff
Shutdown -> lock >> runSuspend
Hibernate -> lock >> runHibernate
Reboot -> runReboot
sendMaybeAction a = setInput (show $ fromPMA a) >> setSuccess True >> setDone True
executeMaybeAction a = case toPMA =<< readMaybe a of
Just Poweroff -> liftIO runPowerOff
Just Shutdown -> lock >> liftIO runSuspend
Just Hibernate -> lock >> liftIO runHibernate
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
@ -10,7 +7,7 @@ module XMonad.Internal.Concurrent.ACPIEvent
)
where
import Data.Internal.Dependency
import Data.Internal.XIO
import Network.Socket
import Network.Socket.ByteString
import RIO
@ -33,15 +30,18 @@ data ACPIEvent
| LidClose
deriving (Eq)
instance Enum ACPIEvent where
toEnum 0 = Power
toEnum 1 = Sleep
toEnum 2 = LidClose
toEnum _ = errorWithoutStackTrace "ACPI.Enum.ACPIEvent.toEnum: bad argument"
fromACPIEvent :: ACPIEvent -> Int
fromACPIEvent x = case x of
Power -> 0
Sleep -> 1
LidClose -> 2
fromEnum Power = 0
fromEnum Sleep = 1
fromEnum LidClose = 2
toACPIEvent :: Int -> Maybe ACPIEvent
toACPIEvent x = case x of
0 -> Just Power
1 -> Just Sleep
2 -> Just LidClose
_ -> Nothing
--------------------------------------------------------------------------------
-- Internal functions
@ -64,7 +64,7 @@ parseLine line =
-- | Send an ACPIEvent to the X server as a ClientMessage
sendACPIEvent :: ACPIEvent -> IO ()
sendACPIEvent = sendXMsg ACPI . show . fromEnum
sendACPIEvent = sendXMsg ACPI . show . fromACPIEvent
isDischarging :: IO (Maybe Bool)
isDischarging = do
@ -91,14 +91,14 @@ socketDep = Only_ $ pathR acpiPath [Package Official "acpid"]
-- Xmonad's event hook)
handleACPI :: FontBuilder -> X () -> String -> X ()
handleACPI fb lock tag = do
let acpiTag = toEnum <$> readMaybe tag :: Maybe ACPIEvent
let acpiTag = toACPIEvent =<< readMaybe tag :: Maybe ACPIEvent
forM_ acpiTag $ \case
Power -> powerPrompt lock fb
Sleep -> suspendPrompt fb
LidClose -> do
status <- io isDischarging
-- only run suspend if battery exists and is discharging
forM_ status $ flip when runSuspend
forM_ status $ flip when $ liftIO runSuspend
lock
--------------------------------------------------------------------------------

View File

@ -28,6 +28,7 @@ import Graphics.X11.Xlib.Atom
import Graphics.X11.Xlib.Display
import Graphics.X11.Xlib.Event
import Graphics.X11.Xlib.Extras
import RIO
import XMonad.Internal.IO
--------------------------------------------------------------------------------
@ -42,14 +43,18 @@ data XMsgType
| Unknown
deriving (Eq, Show)
instance Enum XMsgType where
toEnum 0 = ACPI
toEnum 1 = Workspace
toEnum _ = errorWithoutStackTrace "ACPI.Enum.ACPIEvent.toEnum: bad argument"
fromXMsgType :: XMsgType -> Int
fromXMsgType x = case x of
ACPI -> 0
Workspace -> 1
Unknown -> 2
fromEnum ACPI = 0
fromEnum Workspace = 1
fromEnum Unknown = 2
toXMsgType :: Int -> Maybe XMsgType
toXMsgType x = case x of
0 -> Just ACPI
1 -> Just Workspace
2 -> Just Unknown
_ -> Nothing
--------------------------------------------------------------------------------
-- Exported API
@ -58,9 +63,9 @@ instance Enum XMsgType where
-- type and payload
splitXMsg :: (Integral a) => [a] -> (XMsgType, String)
splitXMsg [] = (Unknown, "")
splitXMsg (x : xs) = (xtype, tag)
splitXMsg (x : xs) = (fromMaybe Unknown xtype, tag)
where
xtype = toEnum $ fromIntegral x
xtype = toXMsgType $ fromIntegral x
tag = chr . fromIntegral <$> takeWhile (/= 0) xs
-- | 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)
sendEvent dpy root False substructureNotifyMask e
where
x = fromIntegral $ fromEnum xtype
x = fromIntegral $ fromXMsgType xtype
t = fmap (fromIntegral . fromEnum) tag

View File

@ -34,6 +34,8 @@ module XMonad.Internal.Concurrent.DynamicWorkspaces
)
where
import qualified Data.ByteString.Char8 as BC
import Data.Internal.XIO
import Graphics.X11.Types
import Graphics.X11.Xlib.Atom
import Graphics.X11.Xlib.Display
@ -88,38 +90,49 @@ data DynWorkspace = DynWorkspace
-- the same as that in XMonad itself (eg with Query types)
-- type MatchTags = M.Map String String
data WConf = WConf
{ display :: Display
, dynWorkspaces :: [DynWorkspace]
, curPIDs :: MVar (S.Set Pid)
data WEnv = WEnv
{ wDisplay :: !Display
, wDynWorkspaces :: ![DynWorkspace]
, 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
root <- rootWindow dpy $ defaultScreen dpy
root <- liftIO $ rootWindow dpy $ defaultScreen dpy
-- listen only for substructure change events (which includes MapNotify)
allocaSetWindowAttributes $ \a -> do
liftIO $ allocaSetWindowAttributes $ \a -> do
set_event_mask a substructureNotifyMask
changeWindowAttributes dpy root cWEventMask a
void $ allocaXEvent $ withEvents dpy
withRunInIO $ \runIO -> do
void $ allocaXEvent $ runIO . withEvents dpy
where
wrapEnv dpy ps x =
WEnv
{ wDisplay = dpy
, wDynWorkspaces = dws
, wCurPIDs = ps
, wXEnv = x
}
withEvents dpy e = do
ps <- newMVar S.empty
let c = WConf {display = dpy, dynWorkspaces = dws, curPIDs = ps}
runRIO c $
mapRIO (wrapEnv dpy ps) $ do
forever $
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
-- use CreateNotify but that is really noisy)
handleEvent MapNotifyEvent {ev_window = w} = do
dpy <- asks display
dpy <- asks wDisplay
hint <- io $ getClassHint dpy w
dws <- asks dynWorkspaces
dws <- asks wDynWorkspaces
let tag =
M.lookup (resClass hint) $
M.fromList $
@ -133,21 +146,28 @@ handleEvent MapNotifyEvent {ev_window = w} = do
_ -> return ()
handleEvent _ = return ()
withUniquePid :: Pid -> String -> W ()
withUniquePid :: Pid -> String -> WIO ()
withUniquePid pid tag = do
ps <- asks curPIDs
ps <- asks wCurPIDs
pids <- readMVar ps
io
$ unless (pid `elem` pids)
unless (pid `elem` pids)
$ bracket_
(modifyMVar_ ps (return . S.insert 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
-- When launching apps on dymamic workspaces, first check if they are running
-- and launch if not, then switch to their workspace
wsOccupied :: Eq a1 => a1 -> W.StackSet a1 l a2 sid sd -> Bool
wsOccupied tag ws =
elem tag $

View File

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

View File

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

View File

@ -1,5 +1,3 @@
{-# LANGUAGE OverloadedStrings #-}
--------------------------------------------------------------------------------
-- DBus module for DBus brightness controls
@ -18,10 +16,9 @@ import DBus
import DBus.Client
import qualified DBus.Introspection as I
import Data.Internal.DBus
import Data.Internal.Dependency
import Data.Internal.XIO
import RIO
import qualified RIO.Text as T
import XMonad.Core (io)
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
-- is one method to get the current brightness.
data BrightnessConfig a b = BrightnessConfig
{ bcMin :: (a, a) -> IO b
, bcMax :: (a, a) -> IO b
, bcDec :: (a, a) -> IO b
, bcInc :: (a, a) -> IO b
, bcGet :: (a, a) -> IO b
data BrightnessConfig m a b = BrightnessConfig
{ bcMin :: (a, a) -> m b
, bcMax :: (a, a) -> m b
, bcDec :: (a, a) -> m b
, bcInc :: (a, a) -> m b
, bcGet :: (a, a) -> m b
, bcMinRaw :: a
, bcGetMax :: IO a
, bcGetMax :: m a
, bcPath :: ObjectPath
, bcInterface :: InterfaceName
, bcName :: T.Text
}
data BrightnessControls = BrightnessControls
{ bctlMax :: SometimesX
, bctlMin :: SometimesX
, bctlInc :: SometimesX
, bctlDec :: SometimesX
data BrightnessControls m = BrightnessControls
{ bctlMax :: Sometimes (m ())
, bctlMin :: Sometimes (m ())
, bctlInc :: Sometimes (m ())
, bctlDec :: Sometimes (m ())
}
brightnessControls
:: XPQuery
-> BrightnessConfig a b
-> Maybe SesClient
-> BrightnessControls
:: (HasClient (DBusEnv env), MonadReader env m, MonadUnliftIO m)
=> XPQuery
-> BrightnessConfig m a b
-> Maybe NamedSesConnection
-> BrightnessControls m
brightnessControls q bc cl =
BrightnessControls
{ bctlMax = cb "max brightness" memMax
@ -68,26 +66,34 @@ brightnessControls q bc cl =
cb = callBacklight q cl bc
callGetBrightness
:: (MonadUnliftIO m, SafeClient c, Num n)
=> BrightnessConfig a b
-> c
:: ( HasClient env
, MonadReader (env c) m
, MonadUnliftIO m
, SafeClient c
, Num n
)
=> BrightnessConfig m a b
-> m (Maybe n)
callGetBrightness BrightnessConfig {bcPath = p, bcInterface = i} client =
callGetBrightness BrightnessConfig {bcPath = p, bcInterface = i} =
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} =
Endpoint [] xmonadBusName p i $ Signal_ memCur
Endpoint [] xmonadSesBusName p i $ Signal_ memCur
matchSignal
:: (MonadUnliftIO m, SafeClient c, Num n)
=> BrightnessConfig a b
:: ( HasClient env
, MonadReader (env c) m
, MonadUnliftIO m
, SafeClient c
, Num n
)
=> BrightnessConfig m a b
-> (Maybe n -> m ())
-> c
-> m ()
matchSignal BrightnessConfig {bcPath = p, bcInterface = i} cb =
void . addMatchCallback brMatcher (cb . bodyGetBrightness)
void $ addMatchCallback brMatcher (cb . bodyGetBrightness)
where
-- TODO add busname to this
brMatcher =
@ -101,45 +107,46 @@ matchSignal BrightnessConfig {bcPath = p, bcInterface = i} cb =
-- Internal DBus Crap
brightnessExporter
:: RealFrac b
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m, RealFrac b)
=> XPQuery
-> [Fulfillment]
-> [IODependency_]
-> BrightnessConfig a b
-> Maybe SesClient
-> SometimesIO
-> BrightnessConfig m a b
-> Maybe NamedSesConnection
-> Sometimes (m (), m ())
brightnessExporter q ful deps bc@BrightnessConfig {bcName = n} cl =
Sometimes (T.append n " DBus Interface") q [Subfeature root "exporter"]
where
root = DBusRoot_ (exportBrightnessControls' bc) tree cl
tree = listToAnds (Bus ful xmonadBusName) $ fmap DBusIO deps
root = DBusRoot_ (exportBrightnessControlsInner bc) tree cl
tree = listToAnds (Bus ful xmonadSesBusName) $ fmap DBusIO deps
exportBrightnessControls'
:: (MonadUnliftIO m, RealFrac b)
=> BrightnessConfig a b
-> SesClient
-> m ()
exportBrightnessControls' bc cl = io $ do
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]
}
exportBrightnessControlsInner
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m, RealFrac b)
=> BrightnessConfig m a b
-> NamedSesConnection
-> (m (), m ())
exportBrightnessControlsInner bc = cmd
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 =
I.Signal
{ I.signalName = memCur
@ -153,7 +160,7 @@ exportBrightnessControls' bc cl = io $ do
emitBrightness
:: (MonadUnliftIO m, RealFrac b)
=> BrightnessConfig a b
=> BrightnessConfig m a b
-> Client
-> b
-> m ()
@ -163,26 +170,18 @@ emitBrightness BrightnessConfig {bcPath = p, bcInterface = i} client cur =
sig = signal p i memCur
callBacklight
:: XPQuery
-> Maybe SesClient
-> BrightnessConfig a b
:: (MonadReader env m, HasClient (DBusEnv env), MonadUnliftIO m)
=> XPQuery
-> Maybe NamedSesConnection
-> BrightnessConfig m a b
-> T.Text
-> MemberName
-> SometimesX
callBacklight
q
cl
BrightnessConfig
{ bcPath = p
, 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
-> Sometimes (m ())
callBacklight q cl BrightnessConfig {bcPath = p, bcInterface = i, bcName = n} controlName m =
Sometimes (T.unwords [n, controlName]) q [Subfeature root "method call"]
where
root = DBusRoot_ cmd (Only_ $ Endpoint [] xmonadSesBusName p i $ Method_ m) cl
cmd c = void $ withDIO c $ callMethod xmonadSesBusName p i m
bodyGetBrightness :: Num a => [Variant] -> Maybe a
bodyGetBrightness [b] = fromIntegral <$> (fromVariant b :: Maybe Int32)

View File

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

View File

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

View File

@ -1,20 +1,17 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
--------------------------------------------------------------------------------
-- High-level interface for managing XMonad's DBus
module XMonad.Internal.DBus.Control
( Client
, DBusState (..)
, withDBus
, withDBus_
, withDBusInterfaces
, withDBusX
, withDBusX_
, withDBus
, withDBus_
, connectDBus
, connectDBusX
, disconnectDBus
, disconnectDBusX
-- , disconnectDBusX
, getDBusClient
, withDBusClient
, withDBusClient_
@ -26,7 +23,7 @@ where
import DBus
import DBus.Client
import Data.Internal.DBus
import Data.Internal.Dependency
import Data.Internal.XIO
import RIO
import XMonad.Internal.DBus.Brightness.ClevoKeyboard
import XMonad.Internal.DBus.Brightness.IntelBacklight
@ -35,90 +32,157 @@ import XMonad.Internal.DBus.Screensaver
-- | Current connections to the DBus (session and system buses)
data DBusState = DBusState
{ dbSesClient :: Maybe SesClient
, dbSysClient :: Maybe SysClient
{ dbSesClient :: Maybe NamedSesConnection
, dbSysClient :: Maybe NamedSysConnection
}
withDBusX_
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
=> (DBusState -> m a)
-> m ()
withDBusX_ = void . withDBusX_
withDBusX_ = void . withDBusX
withDBusX
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
=> (DBusState -> m a)
-> m (Maybe a)
withDBusX f = withDBus $ \db ->
-- TODO log error if this fails
forM (dbSesClient db) $ \ses ->
bracket_ (requestXMonadName ses) (releaseXMonadName ses) (f db)
-> m a
withDBusX = withDBus (Just xmonadSesBusName) Nothing
withDBus_
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
=> (DBusState -> m a)
=> Maybe BusName
-> Maybe BusName
-> (DBusState -> m a)
-> m ()
withDBus_ = void . withDBus
withDBus_ sesname sysname = void . withDBus sesname sysname
withDBus
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
=> (DBusState -> m a)
=> Maybe BusName
-> Maybe BusName
-> (DBusState -> m a)
-> m a
withDBus = bracket connectDBus disconnectDBus
withDBus sesname sysname = bracket (connectDBus sesname sysname) disconnectDBus
-- | Connect to the DBus
connectDBus
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
=> m DBusState
connectDBus = do
ses <- getDBusClient
sys <- getDBusClient
=> Maybe BusName
-> Maybe BusName
-> m DBusState
connectDBus sesname sysname = do
ses <- getDBusClient sesname
sys <- getDBusClient sysname
return DBusState {dbSesClient = ses, dbSysClient = sys}
-- | Disconnect from the DBus
disconnectDBus :: MonadUnliftIO m => DBusState -> m ()
disconnectDBus db = disc dbSesClient >> disc dbSysClient
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
disconnectDBus
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
=> DBusState
-> m ()
disconnectDBusX db = do
forM_ (dbSesClient db) releaseXMonadName
disconnectDBus db
disconnectDBus db = disc dbSesClient >> disc dbSysClient
where
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
dbusExporters :: [Maybe SesClient -> SometimesIO]
dbusExporters
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
=> [Maybe NamedSesConnection -> Sometimes (m (), m ())]
dbusExporters = [exportScreensaver, exportIntelBacklight, exportClevoKeyboard]
releaseXMonadName
:: MonadUnliftIO m
=> SesClient
-> m ()
releaseXMonadName ses = do
liftIO $ void $ releaseName (toClient ses) xmonadBusName
-- releaseXMonadName
-- :: (SafeClient c, MonadReader env m, HasLogFunc env, MonadUnliftIO m)
-- => c
-- -> m ()
-- releaseXMonadName cl = do
-- -- TODO this might error?
-- liftIO $ void $ releaseName (toClient cl) xmonadBusName
-- logInfo "released xmonad name"
requestXMonadName :: MonadUnliftIO m => SesClient -> m ()
requestXMonadName ses = do
res <- liftIO $ requestName (toClient ses) xmonadBusName []
-- TODO if the client is not released on shutdown the owner will be different
let msg
| res == NamePrimaryOwner = Nothing
| res == NameAlreadyOwner = Just $ "this process already owns " ++ xn
| res == NameInQueue
|| res == NameExists =
Just $ "another process owns " ++ xn
| otherwise = Just $ "unknown error when requesting " ++ xn
liftIO $ forM_ msg putStrLn
where
xn = "'" ++ formatBusName xmonadBusName ++ "'"
-- releaseBusName
-- :: (SafeClient c, MonadReader env m, HasLogFunc env, MonadUnliftIO m)
-- => BusName
-- -> c
-- -> m ()
-- releaseBusName n cl = do
-- -- TODO this might error?
-- liftIO $ void $ releaseName (toClient cl) n
-- logInfo $ "released bus name: " <> displayBusName n
-- requestBusName
-- :: (SafeClient c, MonadReader env m, HasLogFunc env, MonadUnliftIO m)
-- => BusName
-- -> 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
--
@ -11,7 +9,7 @@ module XMonad.Internal.DBus.Removable (runRemovableMon) where
import DBus
import DBus.Client
import Data.Internal.DBus
import Data.Internal.Dependency
import Data.Internal.XIO
import RIO
import qualified RIO.Map as M
import XMonad.Core (io)
@ -73,25 +71,36 @@ removedHasDrive [_, a] =
(fromVariant a :: Maybe [String])
removedHasDrive _ = False
playSoundMaybe :: FilePath -> Bool -> IO ()
playSoundMaybe :: MonadUnliftIO m => FilePath -> Bool -> m ()
playSoundMaybe p b = when b $ io $ playSound p
-- 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
-- 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.
listenDevices :: SysClient -> IO ()
listenDevices
:: ( HasClient (DBusEnv env)
, MonadReader env m
, MonadUnliftIO m
)
=> NamedSysConnection
-> m ()
listenDevices cl = do
addMatch' memAdded driveInsertedSound addedHasDrive
addMatch' memRemoved driveRemovedSound removedHasDrive
where
addMatch' m p f =
void $
addMatch (toClient cl) ruleUdisks {matchMember = Just m} $
playSoundMaybe p . f . signalBody
addMatch' m p f = do
let rule = ruleUdisks {matchMember = Just m}
void $ withDIO cl $ addMatchCallback rule (playSoundMaybe p . f)
runRemovableMon :: Maybe SysClient -> SometimesIO
runRemovableMon
:: ( HasClient (DBusEnv env)
, MonadReader env m
, MonadUnliftIO m
)
=> Maybe NamedSysConnection
-> Sometimes (m ())
runRemovableMon cl =
sometimesDBus cl "removeable device monitor" "dbus monitor" deps $ io . listenDevices
sometimesDBus cl "removeable device monitor" "dbus monitor" deps listenDevices
where
deps = toAnd_ addedDep removedDep

View File

@ -1,5 +1,3 @@
{-# LANGUAGE OverloadedStrings #-}
--------------------------------------------------------------------------------
-- DBus module for X11 screensave/DPMS control
@ -16,7 +14,7 @@ import DBus
import DBus.Client
import qualified DBus.Introspection as I
import Data.Internal.DBus
import Data.Internal.Dependency
import Data.Internal.XIO
import Graphics.X11.XScreenSaver
import RIO
import XMonad.Internal.DBus.Common
@ -93,24 +91,24 @@ bodyGetCurrentState _ = Nothing
--------------------------------------------------------------------------------
-- Exported haskell API
exportScreensaver :: Maybe SesClient -> SometimesIO
exportScreensaver
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
=> Maybe NamedSesConnection
-> Sometimes (m (), m ())
exportScreensaver ses =
sometimesDBus ses "screensaver toggle" "xset" (toAnd_ bus ssx) cmd
where
cmd cl =
let cl' = toClient cl
in withRunInIO $ \run ->
export
cl'
ssPath
defaultInterface
{ interfaceName = interface
, interfaceMethods =
[ autoMethod memToggle $ run $ emitState cl' =<< toggle
, autoMethod memQuery (run query)
]
, interfaceSignals = [sig]
}
cmd = exportPair ssPath $ \cl_ -> do
liftIO $ withRunInIO $ \run ->
return $
defaultInterface
{ interfaceName = interface
, interfaceMethods =
[ autoMethod memToggle $ run $ emitState cl_ =<< toggle
, autoMethod memQuery (run query)
]
, interfaceSignals = [sig]
}
sig =
I.Signal
{ I.signalName = memState
@ -121,32 +119,42 @@ exportScreensaver ses =
}
]
}
bus = Bus [] xmonadBusName
bus = Bus [] xmonadSesBusName
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 =
sometimesEndpoint
"screensaver toggle"
"dbus switch"
[]
xmonadBusName
xmonadSesBusName
ssPath
interface
memToggle
callQuery :: MonadUnliftIO m => SesClient -> m (Maybe SSState)
callQuery ses = do
reply <- callMethod ses xmonadBusName ssPath interface memQuery
callQuery
:: (HasClient env, MonadReader (env SesClient) m, MonadUnliftIO m)
=> m (Maybe SSState)
callQuery = do
reply <- callMethod xmonadSesBusName ssPath interface memQuery
return $ either (const Nothing) bodyGetCurrentState reply
matchSignal :: MonadUnliftIO m => (Maybe SSState -> m ()) -> SesClient -> m ()
matchSignal cb ses =
matchSignal
:: ( HasClient env
, MonadReader (env SesClient) m
, MonadUnliftIO m
)
=> (Maybe SSState -> m ())
-> m ()
matchSignal cb =
void $
addMatchCallback
ruleCurrentState
(cb . bodyGetCurrentState)
ses
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
--
@ -41,7 +39,7 @@ import System.Process
-- read
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 = fmap (== (1 :: Int)) . readInt
@ -49,7 +47,7 @@ readBool = fmap (== (1 :: Int)) . readInt
--------------------------------------------------------------------------------
-- 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
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
-- given by a runtime argument, which is scaled linearly to the range 0-100
-- (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 =
100 * (fromIntegral raw - fromIntegral lower) / fromIntegral (upper - lower)
@ -166,7 +164,7 @@ getPermissionsSafe f = do
-- | Block until a PID has exited.
-- 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.
waitUntilExit :: (MonadIO m) => Pid -> m ()
waitUntilExit :: (MonadUnliftIO m) => Pid -> m ()
waitUntilExit pid = do
res <- doesDirectoryExist $ "/proc" </> show pid
when res $ do

View File

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

View File

@ -1,5 +1,3 @@
{-# LANGUAGE OverloadedStrings #-}
-- Functions for formatting and spawning shell commands
module XMonad.Internal.Shell
@ -85,8 +83,31 @@ spawn :: MonadIO m => T.Text -> m ()
spawn = X.spawn . T.unpack
-- | Run 'XMonad.Run.Utils.spawnPipe' with 'Text' input.
spawnPipe :: MonadIO m => T.Text -> m Handle
spawnPipe = XR.spawnPipe . T.unpack
spawnPipe :: MonadUnliftIO m => T.Text -> m Handle
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
spawnCmd :: MonadIO m => FilePath -> [T.Text] -> m ()

View File

@ -1,5 +1,3 @@
{-# LANGUAGE OverloadedStrings #-}
--------------------------------------------------------------------------------
-- Theme for XMonad and Xmobar
@ -33,6 +31,7 @@ where
import Data.Colour
import Data.Colour.SRGB
import RIO
import qualified RIO.Text as T
import qualified XMonad.Layout.Decoration as D
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
--
-- Use the custom DBus interface exported by the XMonad process so I can react
-- to signals spawned by commands
module Xmobar.Plugins.BacklightCommon (startBacklight) where
import DBus
import Data.Internal.DBus
import RIO
import qualified RIO.Text as T
@ -13,15 +12,17 @@ import Xmobar.Plugins.Common
startBacklight
:: (MonadUnliftIO m, RealFrac a)
=> ((Maybe a -> RIO SimpleApp ()) -> SesClient -> RIO SimpleApp ())
-> (SesClient -> RIO SimpleApp (Maybe a))
=> Maybe BusName
-> Maybe FilePath
-> ((Maybe a -> DIO SimpleApp SesClient ()) -> DIO SimpleApp SesClient ())
-> DIO SimpleApp SesClient (Maybe a)
-> T.Text
-> Callback
-> m ()
startBacklight matchSignal callGetBrightness icon cb = do
withDBusClientConnection cb $ \c -> do
matchSignal dpy c
dpy =<< callGetBrightness c
startBacklight n name matchSignal callGetBrightness icon cb = do
withDBusClientConnection cb n name $ \c -> withDIO c $ do
matchSignal dpy
dpy =<< callGetBrightness
where
formatBrightness b = return $ T.concat [icon, T.pack $ show (round b :: Integer), "%"]
dpy = displayMaybe cb formatBrightness

View File

@ -1,5 +1,3 @@
{-# LANGUAGE OverloadedStrings #-}
--------------------------------------------------------------------------------
-- Bluetooth plugin
--
@ -9,28 +7,18 @@
-- 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>".
--
-- This plugin will reflect if the adapter is powered and if any device is
-- connected to it. The rough outline for this procedure:
-- 1) get the adapter from the object manager
-- 2) get all devices associated with the adapter using the object interface
-- 3) determine if the adapter is powered
-- 4) determine if any devices are connected
-- 5) format the icon; powered vs not powered controls the color and connected
-- vs not connected controls the icon (connected bluetooth symbol has two
-- 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)
-- Simple and somewhat crude way to do this is to have two monitors, one
-- watching the powered state of the adaptor and one listening for connection
-- changes. The former is easy since this is just one /org/bluez/hciX. For the
-- latter, each 'Connected' property is embedded in each individual device path
-- on `org.bluez.Device1', so just watch the entire bluez bus for property
-- changes and filter those that correspond to the aforementioned
-- interface/property. Track all this in a state which keeps the powered
-- property and a running list of connected devices.
--
-- 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
( Bluetooth (..)
@ -42,11 +30,12 @@ where
import DBus
import DBus.Client
import Data.Internal.DBus
import Data.Internal.Dependency
import Data.Internal.XIO
import RIO
import RIO.FilePath
import RIO.List
import qualified RIO.Map as M
import qualified RIO.Set as S
import qualified RIO.Text as T
import XMonad.Internal.DBus.Common
import Xmobar
@ -65,31 +54,28 @@ data Bluetooth = Bluetooth Icons Colors deriving (Read, Show)
instance Exec Bluetooth where
alias (Bluetooth _ _) = T.unpack btAlias
start (Bluetooth icons colors) cb =
withDBusClientConnection cb $ startAdapter icons colors cb
withDBusClientConnection cb Nothing (Just "bluetooth.log") $
startAdapter icons colors cb
startAdapter
:: MonadUnliftIO m
=> Icons
:: Icons
-> Colors
-> Callback
-> SysClient
-> m ()
-> NamedSysConnection
-> RIO SimpleApp ()
startAdapter is cs cb cl = do
ot <- getBtObjectTree cl
state <- newMVar emptyState
let dpy = displayIcon cb (iconFormatter is cs) state
forM_ (findAdapter ot) $ \adapter -> do
-- set up adapter
initAdapter state adapter cl
-- TODO this step could fail; at least warn the user...
void $ addAdaptorListener state dpy adapter cl
-- set up devices on the adapter (and listeners for adding/removing devices)
let devices = findDevices adapter ot
addDeviceAddedListener state dpy adapter cl
addDeviceRemovedListener state dpy adapter cl
forM_ devices $ \d -> addAndInitDevice state dpy d cl
-- after setting things up, show the icon based on the initialized state
dpy
let dpy cb' = displayIcon cb' (iconFormatter is cs)
mapRIO (PluginEnv cl state dpy cb) $ do
ot <- getBtObjectTree
case findAdaptor ot of
Nothing -> logError "could not find bluetooth adapter"
Just adaptor -> do
initAdapterState adaptor
initDevicesState adaptor ot
startAdaptorListener adaptor
startConnectedListener adaptor
pluginDisplay
--------------------------------------------------------------------------------
-- Icon Display
@ -101,9 +87,9 @@ type IconFormatter = (Maybe Bool -> Bool -> T.Text)
type Icons = (T.Text, T.Text)
displayIcon :: MonadUnliftIO m => Callback -> IconFormatter -> MutableBtState -> m ()
displayIcon :: Callback -> IconFormatter -> BTIO ()
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
iconFormatter :: Icons -> Colors -> IconFormatter
@ -114,47 +100,52 @@ iconFormatter (iconConn, iconDisc) cs powered connected =
--------------------------------------------------------------------------------
-- 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
{ btDevConnected :: Maybe Bool
, btDevSigHandler :: SignalHandler
}
type ConnectedDevices = M.Map ObjectPath BTDevice
type BTIO = PluginIO BtState SysClient
data BtState = BtState
{ btDevices :: ConnectedDevices
{ btDevices :: S.Set ObjectPath
, btPowered :: Maybe Bool
}
type MutableBtState = MVar BtState
emptyState :: BtState
emptyState =
BtState
{ btDevices = M.empty
{ btDevices = S.empty
, btPowered = Nothing
}
readState :: MonadUnliftIO m => MutableBtState -> m (Maybe Bool, Bool)
readState state = do
p <- readPowered state
c <- readDevices state
return (p, anyDevicesConnected c)
readState :: BTIO (Maybe Bool, Bool)
readState = do
p <- readPowered
c <- readDevices
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
findAdapter :: ObjectTree -> Maybe ObjectPath
findAdapter = find (("/org/bluez/hci" `isPrefixOf`) . formatObjectPath) . M.keys
findAdaptor :: ObjectTree -> Maybe ObjectPath
findAdaptor = find (("/org/bluez/hci" `isPrefixOf`) . formatObjectPath) . M.keys
findDevices :: ObjectPath -> ObjectTree -> [ObjectPath]
findDevices adapter = filter (adaptorHasDevice adapter) . M.keys
-- | Search the object tree for devices which are in a connected state.
-- 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 adaptor device = case splitPathNoRoot device of
@ -164,190 +155,120 @@ adaptorHasDevice adaptor device = case splitPathNoRoot device of
splitPathNoRoot :: ObjectPath -> [FilePath]
splitPathNoRoot = dropWhile (== "/") . splitDirectories . formatObjectPath
getBtObjectTree :: MonadUnliftIO m => SysClient -> m ObjectTree
getBtObjectTree sys = callGetManagedObjects sys btBus btOMPath
getBtObjectTree
:: ( HasClient env
, SafeClient c
, MonadReader (env c) m
, HasLogFunc (env c)
, MonadUnliftIO m
)
=> m ObjectTree
getBtObjectTree = callGetManagedObjects btBus btOMPath
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
initAdapter
:: (MonadUnliftIO m)
=> MutableBtState
-> ObjectPath
-> SysClient
-> m ()
initAdapter state adapter client = do
reply <- callGetPowered adapter client
putPowered state $ fromSingletonVariant reply
-- | Get powered state of adaptor and log the result
initAdapterState :: ObjectPath -> BTIO ()
initAdapterState adapter = do
reply <- callGetPowered adapter
putPowered $ fromSingletonVariant reply
matchBTProperty
:: (MonadUnliftIO m)
=> SysClient
-> ObjectPath
:: ( SafeClient c
, HasClient env
, MonadReader (env c) m
, HasLogFunc (env c)
, MonadUnliftIO m
)
=> ObjectPath
-> m (Maybe MatchRule)
matchBTProperty sys p = matchPropertyFull sys btBus (Just p)
matchBTProperty p = matchPropertyFull btBus (Just p)
addAdaptorListener
:: MonadUnliftIO m
=> MutableBtState
-> m ()
-> ObjectPath
-> SysClient
-> m (Maybe SignalHandler)
addAdaptorListener state dpy adaptor sys = do
rule <- matchBTProperty sys adaptor
forM rule $ \r -> addMatchCallback r (procMatch . matchPowered) sys
-- | Start a listener that monitors changes to the powered state of an adaptor
startAdaptorListener :: ObjectPath -> BTIO ()
startAdaptorListener adaptor = do
res <- matchBTProperty adaptor
case res of
Just rule -> void $ addMatchCallback rule callback
Nothing -> do
logError $
"could not add listener for prop "
<> displayMemberName adaptorPowered
<> " on path "
<> displayObjectPath adaptor
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 =
callPropertyGet btBus adapter adapterInterface $
memberName_ $
T.unpack adaptorPowered
callPropertyGet btBus adapter adaptorInterface adaptorPowered
matchPowered :: [Variant] -> SignalMatch Bool
matchPowered = matchPropertyChanged adapterInterface adaptorPowered
putPowered :: Maybe Bool -> BTIO ()
putPowered ds = modifyState $ \s -> return (s {btPowered = ds}, ())
putPowered :: MonadUnliftIO m => MutableBtState -> Maybe Bool -> m ()
putPowered m ds = modifyMVar_ m (\s -> return s {btPowered = ds})
readPowered :: BTIO (Maybe Bool)
readPowered = fmap btPowered $ readMVar =<< asks plugState
readPowered :: MonadUnliftIO m => MutableBtState -> m (Maybe Bool)
readPowered = fmap btPowered . readMVar
adaptorInterface :: InterfaceName
adaptorInterface = interfaceName_ "org.bluez.Adapter1"
adapterInterface :: InterfaceName
adapterInterface = interfaceName_ "org.bluez.Adapter1"
adaptorPowered :: T.Text
adaptorPowered :: MemberName
adaptorPowered = "Powered"
--------------------------------------------------------------------------------
-- Devices
addAndInitDevice
:: MonadUnliftIO m
=> MutableBtState
-> m ()
-> 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
initDevicesState :: ObjectPath -> ObjectTree -> BTIO ()
initDevicesState adaptor ot = do
let devices = findConnectedDevices adaptor ot
modifyState $ \s -> return (s {btDevices = S.fromList devices}, ())
initDevice
:: MonadUnliftIO m
=> MutableBtState
-> SignalHandler
-> ObjectPath
-> SysClient
-> m ()
initDevice state sh device sys = do
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
startConnectedListener :: ObjectPath -> BTIO ()
startConnectedListener adaptor = do
reply <- matchPropertyFull btBus Nothing
case reply of
Just rule -> do
void $ addMatchCallbackSignal rule callback
logInfo $ "Started listening for device connections on " <> adaptor_
Nothing -> logError "Could not listen for connection changes"
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
matchConnected = matchPropertyChanged devInterface devConnected
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
readDevices :: BTIO (S.Set ObjectPath)
readDevices = fmap btDevices $ readMVar =<< asks plugState
devInterface :: InterfaceName
devInterface = interfaceName_ "org.bluez.Device1"
devConnected :: T.Text
devConnected :: MemberName
devConnected = "Connected"

View File

@ -1,5 +1,3 @@
{-# LANGUAGE OverloadedStrings #-}
--------------------------------------------------------------------------------
-- Clevo Keyboard plugin
--
@ -12,6 +10,7 @@ module Xmobar.Plugins.ClevoKeyboard
)
where
import RIO
import qualified RIO.Text as T
import XMonad.Internal.DBus.Brightness.ClevoKeyboard
import Xmobar
@ -25,4 +24,9 @@ ckAlias = "clevokeyboard"
instance Exec ClevoKeyboard where
alias (ClevoKeyboard _) = T.unpack ckAlias
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
( colorText
, startListener
, procSignalMatch
, na
, fromSingletonVariant
, withNestedDBusClientConnection
, withDBusClientConnection
, Callback
, Colors (..)
, displayMaybe
, displayMaybe'
, xmobarFGColor
, PluginEnv (..)
, PluginIO
, pluginDisplay
)
where
import DBus
import DBus.Client
import Data.Internal.DBus
import Data.Internal.XIO
import RIO
import qualified RIO.Text as T
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 :(
type Callback = String -> IO ()
@ -32,18 +57,22 @@ data Colors = Colors
deriving (Eq, Show, Read)
startListener
:: (MonadUnliftIO m, SafeClient c, IsVariant a)
:: ( HasClient env
, MonadReader (env c) m
, MonadUnliftIO m
, SafeClient c
, IsVariant a
)
=> MatchRule
-> (c -> m [Variant])
-> m [Variant]
-> ([Variant] -> SignalMatch a)
-> (a -> m T.Text)
-> Callback
-> c
-> m ()
startListener rule getProp fromSignal toColor cb client = do
reply <- getProp client
startListener rule getProp fromSignal toColor cb = do
reply <- getProp
displayMaybe cb toColor $ fromSingletonVariant reply
void $ addMatchCallback rule (procMatch . fromSignal) client
void $ addMatchCallback rule (procMatch . fromSignal)
where
procMatch = procSignalMatch cb toColor
@ -70,6 +99,42 @@ displayMaybe' cb = maybe (liftIO $ cb $ T.unpack na)
withDBusClientConnection
:: (MonadUnliftIO m, SafeClient c)
=> Callback
-> (c -> RIO SimpleApp ())
-> Maybe BusName
-> Maybe FilePath
-> (NamedConnection c -> RIO SimpleApp ())
-> 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
--
@ -12,6 +10,7 @@ module Xmobar.Plugins.IntelBacklight
)
where
import RIO
import qualified RIO.Text as T
import XMonad.Internal.DBus.Brightness.IntelBacklight
import Xmobar
@ -25,4 +24,9 @@ blAlias = "intelbacklight"
instance Exec IntelBacklight where
alias (IntelBacklight _) = T.unpack blAlias
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
--
@ -12,6 +10,8 @@ module Xmobar.Plugins.Screensaver
)
where
import Data.Internal.DBus
import RIO
import qualified RIO.Text as T
import XMonad.Internal.DBus.Screensaver
import Xmobar
@ -24,9 +24,13 @@ ssAlias = "screensaver"
instance Exec Screensaver where
alias (Screensaver _) = T.unpack ssAlias
start (Screensaver (text, colors)) cb = do
withDBusClientConnection cb $ \sys -> do
matchSignal display sys
display =<< callQuery sys
start (Screensaver (text, colors)) cb =
withDBusClientConnection
cb
(Just "org.xmobar.screensaver")
(Just "screensaver.log")
$ \cl -> withDIO cl $ do
matchSignal dpy
dpy =<< callQuery
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
- fourmolu.yaml
- make_pkgs
- icons/*
- runtime_pkgs
- assets/icons/*
- assets/sound/*
- 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:
- rio >= 0.1.21.0
@ -35,14 +73,21 @@ dependencies:
- typed-process >= 0.2.8.0
- network >= 3.1.2.7
- 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:
source-dirs: lib/
ghc-options:
- -Wall
- -Werror
- -Wpartial-fields
- -O2
executables:
xmobar: &bin
@ -52,21 +97,15 @@ executables:
- xmonad-config
ghc-options:
- -threaded
- -Wall
- -Werror
- -Wpartial-fields
- -O2
xmonad:
<<: *bin
main: xmonad.hs
ghc-options:
- -threaded
- -Wall
- -Werror
- -Wpartial-fields
- -O2
# this is needed to avoid writing super complex layout types
- -fno-warn-missing-signatures
vbox-start:
<<: *bin
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: https://example.com/snapshots/2018-01-01.yaml
#resolver: lts-17.4
resolver: nightly-2022-03-03
resolver: lts-19.33
#resolver: nightly-2022-03-03
# User packages to be built.
# Various formats can be used as shown in the example below.