Compare commits

..

1 Commits

Author SHA1 Message Date
Nathan Dwarshuis 73ed6b9734 ENH run xmonad and xmobar totally in rio 2022-12-31 21:03:58 -05:00
49 changed files with 1312 additions and 1909 deletions

View File

@ -1,3 +1,6 @@
{-# 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
@ -40,7 +43,7 @@ runAndWait [n] = do
p <- vmPID i
liftIO $ mapM_ waitUntilExit p
err = logError "Could not get machine ID"
runAndWait _ = logInfo "Usage: vbox-start VBOXNAME"
runAndWait _ = liftIO $ putStrLn "Usage: vbox-start VBOXNAME"
vmLaunch :: T.Text -> RIO SimpleApp ()
vmLaunch i = do

View File

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

View File

@ -1,16 +1,20 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
--------------------------------------------------------------------------------
-- XMonad binary
module Main (main) where
import Data.Internal.DBus
import Data.Internal.XIO
import Data.Internal.Dependency
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
@ -21,7 +25,8 @@ import System.Process
( getPid
, getProcessExitCode
)
import XMonad hiding (display)
import UnliftIO.Environment
import XMonad
import XMonad.Actions.CopyWindow
import XMonad.Actions.CycleWS
import XMonad.Actions.PhysicalScreens
@ -45,7 +50,6 @@ 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
@ -61,37 +65,15 @@ import XMonad.Util.NamedActions
import XMonad.Util.WorkspaceCompare
main :: IO ()
main = parse >>= xio
main = getArgs >>= parse
parse :: IO XOpts
parse = execParser opts
where
parseOpts = parseDeps <|> parseTest <|> pure XRun
opts =
info (parseOpts <**> helper) $
fullDesc <> header "xmonad: the best window manager ever"
parse :: [String] -> IO ()
parse [] = run
parse ["--deps"] = withCache printDeps
-- parse ["--test"] = void $ withCache . evalConf =<< connectDBusX
parse _ = usage
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 :: IO ()
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
@ -106,31 +88,31 @@ run = do
-- signal handlers to carry over to the top.
uninstallSignalHandlers
hSetBuffering stdout LineBuffering
withDBusX_ $ \db -> do
let fs = features $ dbSysClient db
withDBusInterfaces db (fsDBusExporters fs) $ \unexporters -> do
withCache $ do
withDBusX_ $ \db -> do
let sys = dbSysClient db
let fs = features sys
startDBusInterfaces db fs
withXmobar $ \xmobarP -> do
withChildDaemons fs $ \ds -> do
let toClean = Cleanup ds (Just xmobarP) unexporters
void $ executeSometimes $ fsRemovableMon fs $ dbSysClient db
void $ async $ void $ executeSometimes $ fsPowerMon fs
let ts = ThreadState ds (Just xmobarP)
startRemovableMon db fs
startPowerMon fs
dws <- startDynWorkspaces fs
runIO <- askRunInIO
let cleanup = runCleanup runIO toClean db
kbs <- filterExternal <$> evalExternal (fsKeys fs runIO cleanup db)
kbs <- filterExternal <$> evalExternal (fsKeys fs ts db)
sk <- evalAlways $ fsShowKeys fs
ha <- evalAlways $ fsACPIHandler fs
tt <- evalAlways $ fsTabbedTheme fs
let conf =
ewmh $
addKeymap dws (liftIO . runIO . sk) kbs $
addKeymap dws sk kbs $
docks $
def
{ terminal = myTerm
, modMask = myModMask
, layoutHook = myLayouts tt
, manageHook = myManageHook dws
, handleEventHook = myEventHook runIO ha
, handleEventHook = myEventHook ha
, startupHook = myStartupHook
, workspaces = myWorkspaces
, logHook = myLoghook xmobarP
@ -139,21 +121,32 @@ run = do
, normalBorderColor = T.unpack XT.bordersColor
, focusedBorderColor = T.unpack XT.selectedBordersColor
}
runXMonad conf
io $ 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 $ async $ runWorkspaceMon dws
void $ io $ async $ runWorkspaceMon dws
return dws
runXMonad :: (LayoutClass l Window, Read (l Window)) => XConfig l -> XIO ()
runXMonad :: (LayoutClass l Window, Read (l Window)) => XConfig l -> IO ()
runXMonad conf = do
dirs <- getCreateDirectories
liftIO $ launch conf dirs
launch conf dirs
getCreateDirectories :: XIO Directories
startDBusInterfaces :: DBusState -> FeatureSet -> FIO ()
startDBusInterfaces db fs =
mapM_ (\f -> executeSometimes $ f $ dbSesClient db) $
fsDBusExporters fs
getCreateDirectories :: IO Directories
getCreateDirectories = do
ds <- liftIO getDirectories
ds <- getDirectories
mapM_ (createIfMissing ds) [dataDir, cfgDir, cacheDir]
return ds
where
@ -161,19 +154,19 @@ getCreateDirectories = do
let d = f ds
r <- tryIO $ createDirectoryIfMissing True d
case r of
(Left e) -> logError $ display e
(Left e) -> print e
_ -> return ()
data FeatureSet = FeatureSet
{ fsKeys :: (XIO () -> IO ()) -> X () -> DBusState -> [KeyGroup FeatureX]
, fsDBusExporters :: [Maybe NamedSesConnection -> Sometimes (XIO (), XIO ())]
{ fsKeys :: ThreadState -> DBusState -> [KeyGroup FeatureX]
, fsDBusExporters :: [Maybe SesClient -> SometimesIO]
, fsPowerMon :: SometimesIO
, fsRemovableMon :: Maybe NamedSysConnection -> SometimesIO
, fsDaemons :: [Sometimes (XIO (Process () () ()))]
, fsRemovableMon :: Maybe SysClient -> SometimesIO
, fsDaemons :: [Sometimes (FIO (Process () () ()))]
, fsACPIHandler :: Always (String -> X ())
, fsTabbedTheme :: Always Theme
, fsDynWorkspaces :: [Sometimes DynWorkspace]
, fsShowKeys :: Always ([((KeyMask, KeySym), NamedAction)] -> XIO ())
, fsShowKeys :: Always ([((KeyMask, KeySym), NamedAction)] -> X ())
}
tabbedFeature :: Always Theme
@ -183,7 +176,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 NamedSysConnection -> FeatureSet
features :: Maybe SysClient -> FeatureSet
features cl =
FeatureSet
{ fsKeys = externalBindings
@ -197,12 +190,8 @@ features cl =
, fsDaemons = [runNetAppDaemon cl, runAutolock]
}
withXmobar :: (Process Handle () () -> XIO a) -> XIO a
withXmobar = bracket startXmobar stopXmobar
startXmobar :: XIO (Process Handle () ())
startXmobar :: FIO (Process Handle () ())
startXmobar = do
logInfo "starting xmobar child process"
p <- proc "xmobar" [] start
io $ hSetBuffering (getStdin p) LineBuffering
return p
@ -212,87 +201,66 @@ startXmobar = do
. setStdin createPipe
. setCreateGroup True
stopXmobar
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
=> Process Handle () ()
-> m ()
stopXmobar p = do
logInfo "stopping xmobar child process"
io $ killNoWait p
startChildDaemons :: FeatureSet -> FIO [Process () () ()]
startChildDaemons fs = catMaybes <$> mapM executeSometimes (fsDaemons fs)
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)
withChildDaemons :: FeatureSet -> ([Process () () ()] -> FIO a) -> FIO a
withChildDaemons fs = bracket (startChildDaemons fs) cleanup
where
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
cleanup ps = do
logInfo "stopping child processes"
mapM_ (io . killNoWait) ps
stopChildDaemons
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
=> [(Utf8Builder, Process () () ())]
-> m ()
stopChildDaemons = mapM_ stop
withXmobar :: (Process Handle () () -> FIO a) -> FIO a
withXmobar = bracket startXmobar cleanup
where
stop (n, p) = do
logInfo $ "stopping child process: " <> n
liftIO $ killNoWait p
cleanup p = do
logInfo "stopping xmobar child process"
io $ killNoWait p
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 $
printDeps :: FIO ()
printDeps = withDBus_ $ \db -> do
(i, f, d) <- allFeatures db
mapM_ (liftIO . putStrLn . T.unpack) $
fmap showFulfillment $
sort $
nub $
concat $
fmap dumpSometimes dbus
++ fmap dumpSometimes others
++ fmap dumpSometimes allDWs'
++ fmap dumpFeature bfs
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')
where
mockClean = Cleanup {clChildren = [], clXmobar = Nothing, clDBusUnexporters = []}
ts = ThreadState {tsChildPIDs = [], tsXmobar = Nothing}
usage :: IO ()
usage =
putStrLn $
intercalate
"\n"
[ "xmonad: run greatest window manager"
, "xmonad --deps: print dependencies"
]
--------------------------------------------------------------------------------
-- Concurrency configuration
data Cleanup = Cleanup
{ clChildren :: [(Utf8Builder, Process () () ())]
, clXmobar :: Maybe (Process Handle () ())
, clDBusUnexporters :: [XIO ()]
data ThreadState = ThreadState
{ tsChildPIDs :: [Process () () ()]
, tsXmobar :: Maybe (Process Handle () ())
}
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
runCleanup :: ThreadState -> DBusState -> X ()
runCleanup ts db = io $ do
mapM_ killNoWait $ tsXmobar ts
mapM_ killNoWait $ tsChildPIDs ts
disconnectDBusX db
-- | Kill a process (group) after xmonad has already started
-- This is necessary (as opposed to 'stopProcess' from rio) because a) xmonad
@ -345,6 +313,9 @@ vmTag = "VM"
xsaneTag :: String
xsaneTag = "XSANE"
f5Tag :: String
f5Tag = "F5VPN"
gimpDynamicWorkspace :: Sometimes DynWorkspace
gimpDynamicWorkspace = sometimesIO_ "gimp workspace" "gimp" tree dw
where
@ -417,11 +388,31 @@ 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
]
--------------------------------------------------------------------------------
@ -436,10 +427,6 @@ 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"] $
@ -622,30 +609,20 @@ manageApps dws =
--------------------------------------------------------------------------------
-- Eventhook configuration
myEventHook
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
=> (m () -> IO ())
-> (String -> X ())
-> Event
-> X All
myEventHook runIO handler = xMsgEventHook runIO handler <+> handleEventHook def
myEventHook :: (String -> X ()) -> Event -> X All
myEventHook handler = xMsgEventHook handler <+> handleEventHook def
-- | React to ClientMessage events from concurrent threads
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}
xMsgEventHook :: (String -> X ()) -> Event -> X All
xMsgEventHook 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 -> liftIO $ runIO $ logWarn "unknown concurrent message"
Unknown -> io $ putStrLn "WARNING: unknown concurrent message"
return (All True)
xMsgEventHook _ _ _ = return (All True)
xMsgEventHook _ _ = return (All True)
--------------------------------------------------------------------------------
-- Keymap configuration
@ -748,13 +725,13 @@ data KeyGroup a = KeyGroup
, kgBindings :: [KeyBinding a]
}
evalExternal :: [KeyGroup FeatureX] -> XIO [KeyGroup MaybeX]
evalExternal :: [KeyGroup FeatureX] -> FIO [KeyGroup MaybeX]
evalExternal = mapM go
where
go k@KeyGroup {kgBindings = bs} =
(\bs' -> k {kgBindings = bs'}) <$> mapM evalKeyBinding bs
evalKeyBinding :: KeyBinding FeatureX -> XIO (KeyBinding MaybeX)
evalKeyBinding :: KeyBinding FeatureX -> FIO (KeyBinding MaybeX)
evalKeyBinding k@KeyBinding {kbMaybeAction = a} =
(\f -> k {kbMaybeAction = f}) <$> evalFeature a
@ -769,52 +746,52 @@ filterExternal = fmap go
]
}
externalBindings :: (XIO () -> IO ()) -> X () -> DBusState -> [KeyGroup FeatureX]
externalBindings runIO cleanup db =
externalBindings :: ThreadState -> DBusState -> [KeyGroup FeatureX]
externalBindings ts db =
[ KeyGroup
"Launchers"
[ 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
[ 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
]
, KeyGroup
"Actions"
[ KeyBinding "M-q" "close window" $ ftrAlways "kill window function" kill1
, KeyBinding "M-r" "run program" $ Left $ toX runCmdMenu
, KeyBinding "M-r" "run program" $ Left runCmdMenu
, KeyBinding "M-<Space>" "warp pointer" $ ftrAlways "warp function" $ warpToWindow 0.5 0.5
, 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
, 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
-- , ("M-C-S-s", "capture focused window", spawn myWindowCap)
]
, KeyGroup
"Multimedia"
[ 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
[ 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
]
, KeyGroup
"Dunst"
[ 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
[ 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
]
, KeyGroup
"System"
@ -832,25 +809,22 @@ externalBindings runIO cleanup db =
, -- M-<F1> reserved for showing the keymap
KeyBinding "M-<F2>" "restart xmonad" restartf
, KeyBinding "M-<F3>" "recompile xmonad" recompilef
, 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-<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-<F12>" "switch gpu" $ Left runOptimusPrompt
]
]
where
ses = dbSesClient db
sys = dbSysClient db
brightessControls ctl getter = (toX . getter . ctl) ses
brightessControls ctl getter = (getter . ctl) ses
ib = Left . brightessControls intelBacklightControls
ck = Left . brightessControls clevoKeyboardControls
ftrAlways n = Right . Always n . Always_ . FallbackAlone
restartf = ftrAlways "restart function" (cleanup >> runRestart)
restartf = ftrAlways "restart function" (runCleanup ts db >> runRestart)
recompilef = ftrAlways "recompile function" runRecompile
toX_ = liftIO . runIO
toX = fmap toX_
type MaybeX = Maybe (X ())

View File

@ -5,17 +5,7 @@ module Data.Internal.DBus
( SafeClient (..)
, SysClient (..)
, SesClient (..)
, NamedConnection (..)
, NamedSesConnection
, NamedSysConnection
, DBusEnv (..)
, DIO
, HasClient (..)
, releaseBusName
, withDIO
, addMatchCallback
, addMatchCallbackSignal
, matchSignalFull
, matchProperty
, matchPropertyFull
, matchPropertyChanged
@ -35,218 +25,93 @@ 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
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
toClient :: c -> Client
getDBusClient
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
=> Maybe BusName
-> m (Maybe (NamedConnection c))
=> m (Maybe c)
disconnectDBusClient
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
=> NamedConnection c
-> m ()
disconnectDBusClient c = do
releaseBusName c
liftIO $ disconnect $ ncClient c
disconnectDBusClient :: MonadUnliftIO m => c -> m ()
disconnectDBusClient = liftIO . disconnect . toClient
withDBusClient
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
=> Maybe BusName
-> (NamedConnection c -> m a)
=> (c -> m a)
-> m (Maybe a)
withDBusClient n f =
bracket (getDBusClient n) (mapM (liftIO . disconnect . ncClient)) $ mapM f
withDBusClient f =
bracket getDBusClient (mapM (liftIO . disconnect . toClient)) $ mapM f
withDBusClient_
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
=> Maybe BusName
-> (NamedConnection c -> m ())
=> (c -> m ())
-> m ()
withDBusClient_ n = void . withDBusClient n
withDBusClient_ = void . withDBusClient
fromDBusClient
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
=> Maybe BusName
-> (NamedConnection c -> a)
=> (c -> a)
-> m (Maybe a)
fromDBusClient n f = withDBusClient n (return . f)
fromDBusClient f = withDBusClient (return . f)
data SysClient = SysClient
newtype SysClient = SysClient Client
instance SafeClient SysClient where
getDBusClient = connectToDBusWithName True SysClient
toClient (SysClient cl) = cl
data SesClient = SesClient
getDBusClient = fmap SysClient <$> getSomeDBusClient True
newtype SesClient = SesClient Client
instance SafeClient SesClient where
-- TODO wet
getDBusClient = connectToDBusWithName False SesClient
toClient (SesClient cl) = cl
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
}
getDBusClient = fmap SesClient <$> getSomeDBusClient False
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'
getSomeDBusClient
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
=> Bool
-> m (Maybe Client)
getDBusClient' sys = do
getSomeDBusClient sys = do
res <- try $ liftIO $ if sys then connectSystem else connectSession
case res of
Left e -> do
logInfo $ displayBytesUtf8 $ BC.pack $ clientErrorMessage e
logError $ Utf8Builder $ encodeUtf8Builder $ T.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'
:: (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 -> 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)
=> BusName
:: (MonadUnliftIO m, SafeClient c)
=> c
-> BusName
-> ObjectPath
-> InterfaceName
-> MemberName
-> m MethodBody
callMethod bus path iface = callMethod' . methodCallBus bus path iface
callMethod client bus path iface = callMethod' client . methodCallBus bus path iface
methodCallBus :: BusName -> ObjectPath -> InterfaceName -> MemberName -> MethodCall
methodCallBus b p i m =
@ -260,22 +125,8 @@ methodCallBus b p i m =
dbusInterface :: InterfaceName
dbusInterface = interfaceName_ "org.freedesktop.DBus"
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
callGetNameOwner :: (MonadUnliftIO m, SafeClient c) => c -> BusName -> m (Maybe BusName)
callGetNameOwner cl name = bodyToMaybe <$> callMethod' cl mc
where
mc =
(methodCallBus dbusName dbusPath dbusInterface mem)
@ -286,7 +137,6 @@ callGetNameOwner name = do
--------------------------------------------------------------------------------
-- Variant parsing
-- TODO log failures here?
fromSingletonVariant :: IsVariant a => [Variant] -> Maybe a
fromSingletonVariant = fromVariant <=< listToMaybe
@ -298,29 +148,14 @@ 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
:: ( MonadReader (env c) m
, MonadUnliftIO m
, SafeClient c
, HasClient env
)
:: (MonadUnliftIO m, SafeClient c)
=> MatchRule
-> SignalCallback m
-> c
-> m SignalHandler
addMatchCallback rule cb = addMatchCallbackSignal rule (cb . signalBody)
addMatchCallback rule cb cl = withRunInIO $ \run -> do
addMatch (toClient cl) rule $ run . cb . signalBody
matchSignal
:: Maybe BusName
@ -337,35 +172,15 @@ matchSignal b p i m =
}
matchSignalFull
:: ( MonadReader (env c) m
, HasLogFunc (env c)
, MonadUnliftIO m
, SafeClient c
, HasClient env
)
=> BusName
:: (MonadUnliftIO m, SafeClient c)
=> c
-> BusName
-> Maybe ObjectPath
-> Maybe InterfaceName
-> Maybe MemberName
-> m (Maybe MatchRule)
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
matchSignalFull client b p i m =
fmap (\o -> matchSignal (Just o) p i m) <$> callGetNameOwner client b
--------------------------------------------------------------------------------
-- Properties
@ -377,42 +192,31 @@ propertySignal :: MemberName
propertySignal = memberName_ "PropertiesChanged"
callPropertyGet
:: ( HasClient env
, MonadReader (env c) m
, HasLogFunc (env c)
, MonadUnliftIO m
, SafeClient c
)
:: (MonadUnliftIO m, SafeClient c)
=> BusName
-> ObjectPath
-> InterfaceName
-> MemberName
-> c
-> m [Variant]
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]
callPropertyGet bus path iface property cl =
liftIO $
fmap (either (const []) (: [])) $
getProperty (toClient cl) $
methodCallBus bus path iface property
matchProperty :: Maybe BusName -> Maybe ObjectPath -> MatchRule
matchProperty b p =
matchSignal b p (Just propertyInterface) (Just propertySignal)
matchPropertyFull
:: ( MonadReader (env c) m
, HasLogFunc (env c)
, MonadUnliftIO m
, SafeClient c
, HasClient env
)
=> BusName
:: (MonadUnliftIO m, SafeClient c)
=> c
-> BusName
-> Maybe ObjectPath
-> m (Maybe MatchRule)
matchPropertyFull b p =
matchSignalFull b p (Just propertyInterface) (Just propertySignal)
matchPropertyFull cl b p =
matchSignalFull cl b p (Just propertyInterface) (Just propertySignal)
data SignalMatch a = Match a | NoMatch | Failure deriving (Eq, Show)
@ -424,26 +228,26 @@ withSignalMatch _ NoMatch = return ()
matchPropertyChanged
:: IsVariant a
=> InterfaceName
-> MemberName
-> T.Text
-> [Variant]
-> SignalMatch a
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'
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'
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 InterfaceName (M.Map T.Text Variant))
type ObjectTree = M.Map ObjectPath (M.Map T.Text (M.Map T.Text Variant))
omInterface :: InterfaceName
omInterface = interfaceName_ "org.freedesktop.DBus.ObjectManager"
@ -458,132 +262,43 @@ omInterfacesRemoved :: MemberName
omInterfacesRemoved = memberName_ "InterfacesRemoved"
callGetManagedObjects
:: ( MonadReader (env c) m
, HasLogFunc (env c)
, MonadUnliftIO m
, SafeClient c
, HasClient env
)
=> BusName
:: (MonadUnliftIO m, SafeClient c)
=> c
-> BusName
-> ObjectPath
-> m ObjectTree
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
callGetManagedObjects cl bus path =
either (const M.empty) (fromMaybe M.empty . fromSingletonVariant)
<$> callMethod cl bus path omInterface getManagedObjects
addInterfaceChangedListener
:: ( MonadReader (env c) m
, HasLogFunc (env c)
, MonadUnliftIO m
, SafeClient c
, HasClient env
)
:: (MonadUnliftIO m, SafeClient c)
=> BusName
-> MemberName
-> ObjectPath
-> SignalCallback m
-> c
-> m (Maybe SignalHandler)
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 <> "'"
addInterfaceChangedListener bus prop path sc cl = do
rule <- matchSignalFull cl bus (Just path) (Just omInterface) (Just prop)
forM rule $ \r -> addMatchCallback r sc cl
addInterfaceAddedListener
:: ( MonadReader (env c) m
, HasLogFunc (env c)
, MonadUnliftIO m
, SafeClient c
, HasClient env
)
:: (MonadUnliftIO m, SafeClient c)
=> BusName
-> ObjectPath
-> SignalCallback m
-> c
-> m (Maybe SignalHandler)
addInterfaceAddedListener bus =
addInterfaceChangedListener bus omInterfacesAdded
addInterfaceRemovedListener
:: ( MonadReader (env c) m
, HasLogFunc (env c)
, MonadUnliftIO m
, SafeClient c
, HasClient env
)
:: (MonadUnliftIO m, SafeClient c)
=> 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,7 +1,14 @@
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
--------------------------------------------------------------------------------
-- Functions for handling dependencies
module Data.Internal.XIO
module Data.Internal.Dependency
-- feature types
( Feature
, Always (..)
@ -19,7 +26,6 @@ module Data.Internal.XIO
, SubfeatureRoot
, Msg (..)
-- configuration
, XEnv (..)
, XParams (..)
, XPFeatures (..)
, XPQuery
@ -47,9 +53,8 @@ module Data.Internal.XIO
, dumpSometimes
, showFulfillment
-- testing
, XIO
, runXIO
, hRunXIO
, FIO
, withCache
, evalFeature
, executeSometimes
, executeAlways
@ -91,7 +96,6 @@ module Data.Internal.XIO
, process
-- misc
, shellTest
, withLogFile
)
where
@ -100,7 +104,6 @@ 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)
@ -112,7 +115,7 @@ import qualified RIO.Text as T
import System.Posix.Files
import System.Process.Typed (nullStream)
import UnliftIO.Environment
import XMonad.Core (X, dataDir, getDirectories, io)
import XMonad.Core (X, io)
import XMonad.Internal.IO
import XMonad.Internal.Shell hiding (proc, runProcess)
import XMonad.Internal.Theme
@ -125,47 +128,30 @@ import XMonad.Internal.Theme
-- | Run feature evaluation(s) with the cache
-- Currently there is no easy way to not use this (oh well)
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
withCache :: FIO a -> IO a
withCache x = do
logOpts <- logOptionsHandle stderr False
pc <- mkDefaultProcessContext
withLogFunc logOpts $ \f -> do
p <- getParams
let s = XEnv f pc p
let s = DepStage 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) -> XIO a
executeAlways :: Always (IO a) -> FIO a
executeAlways = io <=< evalAlways
-- | Execute a Sometimes immediately (or do nothing if failure)
executeSometimes :: Sometimes (XIO a) -> XIO (Maybe a)
executeSometimes :: Sometimes (FIO a) -> FIO (Maybe a)
executeSometimes a = maybe (return Nothing) (fmap Just) =<< evalSometimes a
-- | Possibly return the action of an Always/Sometimes
evalFeature :: Feature a -> XIO (Maybe a)
evalFeature :: Feature a -> FIO (Maybe a)
evalFeature (Right a) = Just <$> evalAlways a
evalFeature (Left s) = evalSometimes s
-- | Possibly return the action of a Sometimes
evalSometimes :: Sometimes a -> XIO (Maybe a)
evalSometimes :: Sometimes a -> FIO (Maybe a)
evalSometimes x = either goFail goPass =<< evalSometimesMsg x
where
goPass (a, ws) = putErrors ws >> return (Just a)
@ -173,13 +159,13 @@ evalSometimes x = either goFail goPass =<< evalSometimesMsg x
putErrors = mapM_ logMsg
-- | Return the action of an Always
evalAlways :: Always a -> XIO a
evalAlways :: Always a -> FIO a
evalAlways a = do
(x, ws) <- evalAlwaysMsg a
mapM_ logMsg ws
return x
logMsg :: FMsg -> XIO ()
logMsg :: FMsg -> FIO ()
logMsg (FMsg fn n (Msg ll m)) = do
p <- io getProgName
f $ Utf8Builder $ encodeUtf8Builder $ T.unwords $ fmt s (T.pack p)
@ -200,9 +186,8 @@ logMsg (FMsg fn n (Msg ll m)) = do
--------------------------------------------------------------------------------
-- Package status
showFulfillment :: Fulfillment -> Utf8Builder
showFulfillment (Package t n) =
displayShow t <> "\t" <> Utf8Builder (encodeUtf8Builder n)
showFulfillment :: Fulfillment -> T.Text
showFulfillment (Package t n) = T.concat [T.pack $ show t, "\t", n]
dumpFeature :: Feature a -> [Fulfillment]
dumpFeature = either dumpSometimes dumpAlways
@ -224,7 +209,7 @@ type AlwaysIO = Always (IO ())
type SometimesX = Sometimes (X ())
type SometimesIO = Sometimes (XIO ())
type SometimesIO = Sometimes (FIO ())
type Feature a = Either (Sometimes a) (Always a)
@ -234,13 +219,12 @@ 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) deriving (Functor)
data Always a = Always T.Text (Always_ a)
-- | 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
@ -249,23 +233,15 @@ 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) deriving (Functor)
data Sometimes a = Sometimes T.Text XPQuery (Sometimes_ a)
-- | Feature that might not be present (inner data)
type Sometimes_ a = [SubfeatureRoot a]
@ -278,7 +254,6 @@ data Subfeature f = Subfeature
{ sfData :: f
, sfName :: T.Text
}
deriving (Functor)
type SubfeatureRoot a = Subfeature (Root a)
@ -288,24 +263,8 @@ 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 -> 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
| 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)
-- | The dependency tree with rule to merge results when needed
data Tree d d_ p
@ -330,7 +289,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] (XIO (Result p))
IORead T.Text [Fulfillment] (FIO (Result p))
| -- always yields a payload
IOConst p
| -- an always that yields a payload
@ -343,11 +302,12 @@ 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] (XIO (Maybe Msg))
| IOTest_ T.Text [Fulfillment] (FIO (Maybe Msg))
| forall a. IOSometimes_ (Sometimes a)
-- | A system component to an IODependency
@ -357,23 +317,23 @@ data SystemDependency
| AccessiblePath FilePath Bool Bool
| Systemd UnitType T.Text
| Process T.Text
deriving (Eq, Show)
deriving (Eq, Show, Generic)
-- | The type of a systemd service
data UnitType = SystemUnit | UserUnit deriving (Eq, Show)
data UnitType = SystemUnit | UserUnit deriving (Eq, Show, Generic)
-- | Wrapper type to describe and endpoint
data DBusMember
= Method_ MemberName
| Signal_ MemberName
| Property_ T.Text
deriving (Eq, Show)
deriving (Eq, Show, Generic)
-- | 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, Ord)
data ArchPkg = Official | AUR | Custom deriving (Eq, Show, Generic, Ord)
--------------------------------------------------------------------------------
-- Tested dependency tree
@ -416,25 +376,19 @@ data PostFail = PostFail [Msg] | PostMissing Msg
--------------------------------------------------------------------------------
-- Configuration
type XIO a = RIO XEnv a
type FIO a = RIO DepStage a
data XEnv = XEnv
{ xLogFun :: !LogFunc
, xProcCxt :: !ProcessContext
, xParams :: !XParams
data DepStage = DepStage
{ dsLogFun :: !LogFunc
, dsProcCxt :: !ProcessContext
, dsParams :: !XParams
}
instance HasLogFunc XEnv where
logFuncL = lens xLogFun (\x y -> x {xLogFun = y})
instance HasLogFunc DepStage where
logFuncL = lens dsLogFun (\x y -> x {dsLogFun = 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})
instance HasProcessContext DepStage where
processContextL = lens dsProcCxt (\x y -> x {dsProcCxt = y})
data XParams = XParams
{ xpLogLevel :: LogLevel
@ -468,8 +422,7 @@ data XPFeatures = XPFeatures
, xpfIntelBacklight :: Bool
, xpfClevoBacklight :: Bool
, xpfBattery :: Bool
, xpfEthPrefix :: Maybe Text
, xpfWifiPrefix :: Maybe Text
, xpfF5VPN :: Bool
}
instance FromJSON XPFeatures where
@ -496,9 +449,7 @@ instance FromJSON XPFeatures where
<*> o
.:+ "battery"
<*> o
.:? "ethPrefix"
<*> o
.:? "wifiPrefix"
.:+ "f5vpn"
defParams :: XParams
defParams =
@ -521,8 +472,7 @@ defXPFeatures =
, xpfIntelBacklight = False
, xpfClevoBacklight = False
, xpfBattery = False
, xpfEthPrefix = Nothing
, xpfWifiPrefix = Nothing
, xpfF5VPN = False
}
type XPQuery = XPFeatures -> Bool
@ -533,7 +483,7 @@ getParams = do
maybe (return defParams) (liftIO . decodeYaml) p
where
decodeYaml p =
either (\e -> TI.putStrLn (T.pack $ show e) >> return defParams) return
either (\e -> print e >> return defParams) return
=<< decodeFileEither p
getParamFile :: MonadIO m => m (Maybe FilePath)
@ -557,9 +507,9 @@ infix 9 .:+
--------------------------------------------------------------------------------
-- Testing pipeline
evalSometimesMsg :: Sometimes a -> XIO (Either [FMsg] (a, [FMsg]))
evalSometimesMsg :: Sometimes a -> FIO (Either [FMsg] (a, [FMsg]))
evalSometimesMsg (Sometimes n u xs) = do
r <- asks (u . xpFeatures . xParams)
r <- asks (u . xpFeatures . dsParams)
if not r
then return $ Left [dis n]
else do
@ -571,7 +521,7 @@ evalSometimesMsg (Sometimes n u xs) = do
where
dis name = FMsg name Nothing (Msg LevelDebug "feature disabled")
evalAlwaysMsg :: Always a -> XIO (a, [FMsg])
evalAlwaysMsg :: Always a -> FIO (a, [FMsg])
evalAlwaysMsg (Always n x) = do
r <- testAlways x
return $ case r of
@ -591,7 +541,7 @@ failedMsg fn Subfeature {sfData = d, sfName = n} = case d of
where
f = fmap (FMsg fn (Just n))
testAlways :: Always_ a -> XIO (PostAlways a)
testAlways :: Always_ a -> FIO (PostAlways a)
testAlways = go []
where
go failed (Option fd next) = do
@ -601,18 +551,18 @@ testAlways = go []
(Right pass) -> return $ Primary pass failed next
go failed (Always_ ar) = (`Fallback` failed) <$> evalFallbackRoot ar
evalFallbackRoot :: FallbackRoot a -> XIO a
evalFallbackRoot :: FallbackRoot a -> FIO a
evalFallbackRoot (FallbackAlone a) = return a
evalFallbackRoot (FallbackTree a s) = a <$> evalFallbackStack s
evalFallbackStack :: FallbackStack p -> XIO p
evalFallbackStack :: FallbackStack p -> FIO 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 -> XIO (PostSometimes a)
testSometimes :: Sometimes_ a -> FIO (PostSometimes a)
testSometimes = go (PostSometimes Nothing [])
where
go ts [] = return ts
@ -622,13 +572,13 @@ testSometimes = go (PostSometimes Nothing [])
(Left l) -> go (ts {psFailed = l : psFailed ts}) xs
(Right pass) -> return $ ts {psSuccess = Just pass}
testSubfeature :: SubfeatureRoot a -> XIO (Either SubfeatureFail (SubfeaturePass a))
testSubfeature :: SubfeatureRoot a -> FIO (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 -> XIO (Either PostFail (PostPass a))
testRoot :: Root a -> FIO (Either PostFail (PostPass a))
testRoot r = do
case r of
(IORoot a t) -> go a testIODep_ testIODep t
@ -642,7 +592,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 -> XIO (MResult q)) t =
go a f_ (f :: forall q. d q -> FIO (MResult q)) t =
bimap PostFail (fmap a) <$> testTree f_ f t
go_ a f_ t = bimap PostFail (PostPass a) <$> testTree_ f_ t
@ -655,13 +605,13 @@ type MResult p = Memoized (Result p)
testTree
:: forall d d_ p
. (d_ -> XIO MResult_)
-> (forall q. d q -> XIO (MResult q))
. (d_ -> FIO MResult_)
-> (forall q. d q -> FIO (MResult q))
-> Tree d d_ p
-> XIO (Either [Msg] (PostPass p))
-> FIO (Either [Msg] (PostPass p))
testTree test_ test = go
where
go :: forall q. Tree d d_ q -> XIO (Result q)
go :: forall q. Tree d d_ q -> FIO (Result q)
go (And12 f a b) = do
ra <- go a
liftRight (\pa -> (and2nd f pa =<<) <$> go b) ra
@ -678,7 +628,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 -> XIO (MResult p)
testIODep :: IODependency p -> FIO (MResult p)
testIODep d = memoizeMVar $ case d of
IORead _ _ t -> t
IOConst c -> return $ Right $ PostPass c []
@ -706,7 +656,7 @@ type Result_ = Either [Msg] [Msg]
type MResult_ = Memoized Result_
testTree_ :: (d -> XIO MResult_) -> Tree_ d -> XIO Result_
testTree_ :: (d -> FIO MResult_) -> Tree_ d -> FIO Result_
testTree_ test = go
where
go (And_ a b) = either (return . Left) (`test2nd` b) =<< go a
@ -714,10 +664,10 @@ testTree_ test = go
go (Only_ a) = runMemoized =<< test a
test2nd ws = fmap ((Right . (ws ++)) =<<) . go
testIODep_ :: IODependency_ -> XIO MResult_
testIODep_ :: IODependency_ -> FIO MResult_
testIODep_ d = memoizeMVar $ testIODepNoCache_ d
testIODepNoCache_ :: IODependency_ -> XIO Result_
testIODepNoCache_ :: IODependency_ -> FIO Result_
testIODepNoCache_ (IOSystem_ _ s) = readResult_ <$> testSysDependency s
testIODepNoCache_ (IOTest_ _ _ t) = readResult_ <$> t
testIODepNoCache_ (IOSometimes_ x) =
@ -812,7 +762,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 -> XIO (Result FontBuilder)
-- testFont :: T.Text -> FIO (Result FontBuilder)
-- testFont = liftIO . testFont'
testFont
@ -833,16 +783,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" (fromMaybe "en" . xpfEthPrefix)
readEthernet = readInterface "get ethernet interface" isEthernet
readWireless :: IODependency T.Text
readWireless = readInterface "get wireless interface" (fromMaybe "wl" . xpfWifiPrefix)
readWireless = readInterface "get wireless interface" isWireless
-- 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 =
@ -854,12 +804,11 @@ 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 -> (XPFeatures -> Text) -> IODependency T.Text
readInterface :: T.Text -> (T.Text -> Bool) -> IODependency T.Text
readInterface n f = IORead n [] go
where
go = do
p <- asks (f . xpFeatures . xParams)
ns <- filter (T.isPrefixOf p) <$> listInterfaces
go = io $ do
ns <- filter f <$> listInterfaces
case ns of
[] -> return $ Left [Msg LevelError "no interfaces found"]
(x : xs) -> do
@ -871,7 +820,7 @@ readInterface n f = IORead n [] go
--------------------------------------------------------------------------------
-- Misc testers
socketExists :: T.Text -> [Fulfillment] -> XIO FilePath -> IODependency_
socketExists :: T.Text -> [Fulfillment] -> FIO FilePath -> IODependency_
socketExists n ful =
IOTest_ (T.unwords ["test if", n, "socket exists"]) ful . socketExists'
@ -895,12 +844,12 @@ introspectInterface = interfaceName_ "org.freedesktop.DBus.Introspectable"
introspectMethod :: MemberName
introspectMethod = memberName_ "Introspect"
testDBusDep_ :: SafeClient c => NamedConnection c -> DBusDependency_ c -> XIO MResult_
testDBusDep_ :: SafeClient c => c -> DBusDependency_ c -> FIO MResult_
testDBusDep_ c d = memoizeMVar $ testDBusDepNoCache_ c d
testDBusDepNoCache_ :: SafeClient c => NamedConnection c -> DBusDependency_ c -> XIO Result_
testDBusDepNoCache_ cl (Bus _ bus) = do
ret <- withDIO cl $ callMethod queryBus queryPath queryIface queryMem
testDBusDepNoCache_ :: SafeClient c => c -> DBusDependency_ c -> FIO Result_
testDBusDepNoCache_ cl (Bus _ bus) = io $ do
ret <- callMethod cl queryBus queryPath queryIface queryMem
return $ case ret of
Left e -> Left [Msg LevelError e]
Right b ->
@ -919,10 +868,8 @@ testDBusDepNoCache_ cl (Bus _ bus) = do
queryMem = memberName_ "ListNames"
bodyGetNames [v] = fromMaybe [] $ fromVariant v :: [T.Text]
bodyGetNames _ = []
testDBusDepNoCache_ cl (Endpoint _ busname objpath iface mem) = do
ret <-
withDIO cl $
callMethod busname objpath introspectInterface introspectMethod
testDBusDepNoCache_ cl (Endpoint _ busname objpath iface mem) = io $ do
ret <- callMethod cl busname objpath introspectInterface introspectMethod
return $ case ret of
Left e -> Left [Msg LevelError e]
Right body -> procBody body
@ -978,6 +925,12 @@ 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
@ -1029,17 +982,16 @@ sometimesExeArgs fn n ful sys path args =
sometimesDBus
:: SafeClient c
=> Maybe (NamedConnection c)
=> Maybe c
-> T.Text
-> T.Text
-> Tree_ (DBusDependency_ c)
-> (NamedConnection c -> a)
-> (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
:: (HasClient (DBusEnv env), SafeClient c, MonadReader env m, MonadUnliftIO m)
:: (SafeClient c, MonadIO m)
=> T.Text
-> T.Text
-> [Fulfillment]
@ -1047,13 +999,13 @@ sometimesEndpoint
-> ObjectPath
-> InterfaceName
-> MemberName
-> Maybe (NamedConnection c)
-> Maybe 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 = void $ withDIO c $ callMethod busname path iface mem
cmd c = io $ void $ callMethod c busname path iface mem
--------------------------------------------------------------------------------
-- Dependency Tree Constructors

View File

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

View File

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

View File

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

View File

@ -1,3 +1,6 @@
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
--------------------------------------------------------------------------------
-- Concurrent module to handle events from acpid
@ -7,7 +10,7 @@ module XMonad.Internal.Concurrent.ACPIEvent
)
where
import Data.Internal.XIO
import Data.Internal.Dependency
import Network.Socket
import Network.Socket.ByteString
import RIO
@ -30,18 +33,15 @@ data ACPIEvent
| LidClose
deriving (Eq)
fromACPIEvent :: ACPIEvent -> Int
fromACPIEvent x = case x of
Power -> 0
Sleep -> 1
LidClose -> 2
instance Enum ACPIEvent where
toEnum 0 = Power
toEnum 1 = Sleep
toEnum 2 = LidClose
toEnum _ = errorWithoutStackTrace "ACPI.Enum.ACPIEvent.toEnum: bad argument"
toACPIEvent :: Int -> Maybe ACPIEvent
toACPIEvent x = case x of
0 -> Just Power
1 -> Just Sleep
2 -> Just LidClose
_ -> Nothing
fromEnum Power = 0
fromEnum Sleep = 1
fromEnum LidClose = 2
--------------------------------------------------------------------------------
-- 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 . fromACPIEvent
sendACPIEvent = sendXMsg ACPI . show . fromEnum
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 = toACPIEvent =<< readMaybe tag :: Maybe ACPIEvent
let acpiTag = toEnum <$> 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 $ liftIO runSuspend
forM_ status $ flip when runSuspend
lock
--------------------------------------------------------------------------------

View File

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

View File

@ -34,8 +34,6 @@ 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
@ -90,49 +88,38 @@ data DynWorkspace = DynWorkspace
-- the same as that in XMonad itself (eg with Query types)
-- type MatchTags = M.Map String String
data WEnv = WEnv
{ wDisplay :: !Display
, wDynWorkspaces :: ![DynWorkspace]
, wCurPIDs :: !(MVar (S.Set Pid))
, wXEnv :: !XEnv
data WConf = WConf
{ display :: Display
, dynWorkspaces :: [DynWorkspace]
, curPIDs :: MVar (S.Set Pid)
}
instance HasLogFunc WEnv where
logFuncL = lens wXEnv (\x y -> x {wXEnv = y}) . logFuncL
type W a = RIO WConf ()
type WIO a = RIO WEnv a
runWorkspaceMon :: [DynWorkspace] -> XIO ()
runWorkspaceMon :: [DynWorkspace] -> IO ()
runWorkspaceMon dws = withOpenDisplay $ \dpy -> do
root <- liftIO $ rootWindow dpy $ defaultScreen dpy
root <- rootWindow dpy $ defaultScreen dpy
-- listen only for substructure change events (which includes MapNotify)
liftIO $ allocaSetWindowAttributes $ \a -> do
allocaSetWindowAttributes $ \a -> do
set_event_mask a substructureNotifyMask
changeWindowAttributes dpy root cWEventMask a
withRunInIO $ \runIO -> do
void $ allocaXEvent $ runIO . withEvents dpy
void $ allocaXEvent $ withEvents dpy
where
wrapEnv dpy ps x =
WEnv
{ wDisplay = dpy
, wDynWorkspaces = dws
, wCurPIDs = ps
, wXEnv = x
}
withEvents dpy e = do
ps <- newMVar S.empty
mapRIO (wrapEnv dpy ps) $ do
let c = WConf {display = dpy, dynWorkspaces = dws, curPIDs = ps}
runRIO c $
forever $
handleEvent =<< io (nextEvent dpy e >> getEvent e)
handleEvent :: Event -> WIO ()
handleEvent :: Event -> W ()
-- | 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 wDisplay
dpy <- asks display
hint <- io $ getClassHint dpy w
dws <- asks wDynWorkspaces
dws <- asks dynWorkspaces
let tag =
M.lookup (resClass hint) $
M.fromList $
@ -146,28 +133,21 @@ handleEvent MapNotifyEvent {ev_window = w} = do
_ -> return ()
handleEvent _ = return ()
withUniquePid :: Pid -> String -> WIO ()
withUniquePid :: Pid -> String -> W ()
withUniquePid pid tag = do
ps <- asks wCurPIDs
ps <- asks curPIDs
pids <- readMVar ps
unless (pid `elem` pids)
io
$ unless (pid `elem` pids)
$ bracket_
(modifyMVar_ ps (return . S.insert pid))
(modifyMVar_ ps (return . S.delete pid))
$ 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) <> "'"
$ waitUntilExit pid >> sendXMsg Workspace 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,3 +1,6 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
--------------------------------------------------------------------------------
-- VirtualBox-specific functions
@ -8,7 +11,7 @@ module XMonad.Internal.Concurrent.VirtualBox
)
where
import Data.Internal.XIO
import Data.Internal.Dependency
import RIO hiding (try)
import RIO.Directory
import RIO.FilePath
@ -33,7 +36,7 @@ vmInstanceConfig vmName = do
vmDirectory :: IO (Either String String)
vmDirectory = do
p <- vmConfig
s <- tryIO $ readFileUtf8 p
s <- tryIO $ readFile p
return $ case s of
(Left _) -> Left "could not read VirtualBox config file"
(Right x) ->

View File

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

View File

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

View File

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

View File

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

View File

@ -1,17 +1,20 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
--------------------------------------------------------------------------------
-- High-level interface for managing XMonad's DBus
module XMonad.Internal.DBus.Control
( Client
, DBusState (..)
, withDBusInterfaces
, withDBusX
, withDBusX_
, withDBus
, withDBus_
, withDBusX
, withDBusX_
, connectDBus
, connectDBusX
, disconnectDBus
-- , disconnectDBusX
, disconnectDBusX
, getDBusClient
, withDBusClient
, withDBusClient_
@ -23,7 +26,7 @@ where
import DBus
import DBus.Client
import Data.Internal.DBus
import Data.Internal.XIO
import Data.Internal.Dependency
import RIO
import XMonad.Internal.DBus.Brightness.ClevoKeyboard
import XMonad.Internal.DBus.Brightness.IntelBacklight
@ -32,157 +35,90 @@ import XMonad.Internal.DBus.Screensaver
-- | Current connections to the DBus (session and system buses)
data DBusState = DBusState
{ dbSesClient :: Maybe NamedSesConnection
, dbSysClient :: Maybe NamedSysConnection
{ dbSesClient :: Maybe SesClient
, dbSysClient :: Maybe SysClient
}
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 a
withDBusX = withDBus (Just xmonadSesBusName) Nothing
-> m (Maybe a)
withDBusX f = withDBus $ \db ->
-- TODO log error if this fails
forM (dbSesClient db) $ \ses ->
bracket_ (requestXMonadName ses) (releaseXMonadName ses) (f db)
withDBus_
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
=> Maybe BusName
-> Maybe BusName
-> (DBusState -> m a)
=> (DBusState -> m a)
-> m ()
withDBus_ sesname sysname = void . withDBus sesname sysname
withDBus_ = void . withDBus
withDBus
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
=> Maybe BusName
-> Maybe BusName
-> (DBusState -> m a)
=> (DBusState -> m a)
-> m a
withDBus sesname sysname = bracket (connectDBus sesname sysname) disconnectDBus
withDBus = bracket connectDBus disconnectDBus
-- | Connect to the DBus
connectDBus
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
=> Maybe BusName
-> Maybe BusName
-> m DBusState
connectDBus sesname sysname = do
ses <- getDBusClient sesname
sys <- getDBusClient sysname
=> m DBusState
connectDBus = do
ses <- getDBusClient
sys <- getDBusClient
return DBusState {dbSesClient = ses, dbSysClient = sys}
-- | Disconnect from the DBus
disconnectDBus
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
=> DBusState
-> m ()
disconnectDBus :: MonadUnliftIO m => DBusState -> m ()
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
-- | 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
-- :: (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
-- | Disconnect from DBus and release the XMonad name
disconnectDBusX
:: MonadUnliftIO m
=> DBusState
-> m ()
disconnectDBusX db = do
forM_ (dbSesClient db) releaseXMonadName
disconnectDBus db
-- | All exporter features to be assigned to the DBus
dbusExporters
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
=> [Maybe NamedSesConnection -> Sometimes (m (), m ())]
dbusExporters :: [Maybe SesClient -> SometimesIO]
dbusExporters = [exportScreensaver, exportIntelBacklight, exportClevoKeyboard]
-- 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"
releaseXMonadName
:: MonadUnliftIO m
=> SesClient
-> m ()
releaseXMonadName ses = do
liftIO $ void $ releaseName (toClient ses) 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
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 ++ "'"

View File

@ -1,3 +1,5 @@
{-# LANGUAGE OverloadedStrings #-}
--------------------------------------------------------------------------------
-- Module for monitoring removable drive events
--
@ -9,7 +11,7 @@ module XMonad.Internal.DBus.Removable (runRemovableMon) where
import DBus
import DBus.Client
import Data.Internal.DBus
import Data.Internal.XIO
import Data.Internal.Dependency
import RIO
import qualified RIO.Map as M
import XMonad.Core (io)
@ -71,36 +73,25 @@ removedHasDrive [_, a] =
(fromVariant a :: Maybe [String])
removedHasDrive _ = False
playSoundMaybe :: MonadUnliftIO m => FilePath -> Bool -> m ()
playSoundMaybe :: FilePath -> Bool -> IO ()
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
:: ( HasClient (DBusEnv env)
, MonadReader env m
, MonadUnliftIO m
)
=> NamedSysConnection
-> m ()
listenDevices :: SysClient -> IO ()
listenDevices cl = do
addMatch' memAdded driveInsertedSound addedHasDrive
addMatch' memRemoved driveRemovedSound removedHasDrive
where
addMatch' m p f = do
let rule = ruleUdisks {matchMember = Just m}
void $ withDIO cl $ addMatchCallback rule (playSoundMaybe p . f)
addMatch' m p f =
void $
addMatch (toClient cl) ruleUdisks {matchMember = Just m} $
playSoundMaybe p . f . signalBody
runRemovableMon
:: ( HasClient (DBusEnv env)
, MonadReader env m
, MonadUnliftIO m
)
=> Maybe NamedSysConnection
-> Sometimes (m ())
runRemovableMon :: Maybe SysClient -> SometimesIO
runRemovableMon cl =
sometimesDBus cl "removeable device monitor" "dbus monitor" deps listenDevices
sometimesDBus cl "removeable device monitor" "dbus monitor" deps $ io . listenDevices
where
deps = toAnd_ addedDep removedDep

View File

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

View File

@ -1,3 +1,5 @@
{-# LANGUAGE ViewPatterns #-}
--------------------------------------------------------------------------------
-- Random IO-ish functions used throughtout xmonad
--
@ -39,7 +41,7 @@ import System.Process
-- read
readInt :: MonadIO m => (Read a, Integral a) => FilePath -> m a
readInt = fmap (fromMaybe 0 . readMaybe . takeWhile isDigit . T.unpack) . readFileUtf8
readInt = fmap (read . takeWhile isDigit . T.unpack) . readFileUtf8
readBool :: MonadIO m => FilePath -> m Bool
readBool = fmap (== (1 :: Int)) . readInt
@ -47,7 +49,7 @@ readBool = fmap (== (1 :: Int)) . readInt
--------------------------------------------------------------------------------
-- write
writeInt :: (MonadIO m, Show a) => FilePath -> a -> m ()
writeInt :: MonadIO m => (Show a, Integral a) => FilePath -> a -> m ()
writeInt f = writeFileUtf8 f . T.pack . show
writeBool :: MonadIO m => FilePath -> Bool -> m ()
@ -60,7 +62,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, RealFrac c) => (a, a) -> b -> c
rawToPercent :: (Integral a, Integral b, Read b, RealFrac c) => (a, a) -> b -> c
rawToPercent (lower, upper) raw =
100 * (fromIntegral raw - fromIntegral lower) / fromIntegral (upper - lower)
@ -164,7 +166,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 :: (MonadUnliftIO m) => Pid -> m ()
waitUntilExit :: (MonadIO m) => Pid -> m ()
waitUntilExit pid = do
res <- doesDirectoryExist $ "/proc" </> show pid
when res $ do

View File

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

View File

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

View File

@ -1,3 +1,5 @@
{-# LANGUAGE OverloadedStrings #-}
--------------------------------------------------------------------------------
-- Theme for XMonad and Xmobar
@ -31,7 +33,6 @@ 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

@ -1,155 +0,0 @@
--------------------------------------------------------------------------------
-- 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,10 +1,11 @@
{-# 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
@ -12,17 +13,15 @@ import Xmobar.Plugins.Common
startBacklight
:: (MonadUnliftIO m, RealFrac a)
=> Maybe BusName
-> Maybe FilePath
-> ((Maybe a -> DIO SimpleApp SesClient ()) -> DIO SimpleApp SesClient ())
-> DIO SimpleApp SesClient (Maybe a)
=> ((Maybe a -> RIO SimpleApp ()) -> SesClient -> RIO SimpleApp ())
-> (SesClient -> RIO SimpleApp (Maybe a))
-> T.Text
-> Callback
-> m ()
startBacklight n name matchSignal callGetBrightness icon cb = do
withDBusClientConnection cb n name $ \c -> withDIO c $ do
matchSignal dpy
dpy =<< callGetBrightness
startBacklight matchSignal callGetBrightness icon cb = do
withDBusClientConnection cb $ \c -> do
matchSignal dpy c
dpy =<< callGetBrightness c
where
formatBrightness b = return $ T.concat [icon, T.pack $ show (round b :: Integer), "%"]
dpy = displayMaybe cb formatBrightness

View File

@ -1,3 +1,5 @@
{-# LANGUAGE OverloadedStrings #-}
--------------------------------------------------------------------------------
-- Bluetooth plugin
--
@ -7,18 +9,28 @@
-- 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>".
--
-- 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.
-- 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)
--
-- TODO also not sure if I need to care about multiple adapters and/or the
-- adapter changing. For now it should just get the first adaptor and only pay
-- attention to devices associated with it.
-- adapter changing.
module Xmobar.Plugins.Bluetooth
( Bluetooth (..)
@ -30,12 +42,11 @@ where
import DBus
import DBus.Client
import Data.Internal.DBus
import Data.Internal.XIO
import Data.Internal.Dependency
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
@ -54,28 +65,31 @@ data Bluetooth = Bluetooth Icons Colors deriving (Read, Show)
instance Exec Bluetooth where
alias (Bluetooth _ _) = T.unpack btAlias
start (Bluetooth icons colors) cb =
withDBusClientConnection cb Nothing (Just "bluetooth.log") $
startAdapter icons colors cb
withDBusClientConnection cb $ startAdapter icons colors cb
startAdapter
:: Icons
:: MonadUnliftIO m
=> Icons
-> Colors
-> Callback
-> NamedSysConnection
-> RIO SimpleApp ()
-> SysClient
-> m ()
startAdapter is cs cb cl = do
ot <- getBtObjectTree cl
state <- newMVar emptyState
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
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
--------------------------------------------------------------------------------
-- Icon Display
@ -87,9 +101,9 @@ type IconFormatter = (Maybe Bool -> Bool -> T.Text)
type Icons = (T.Text, T.Text)
displayIcon :: Callback -> IconFormatter -> BTIO ()
displayIcon :: MonadUnliftIO m => Callback -> IconFormatter -> MutableBtState -> m ()
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
@ -100,52 +114,47 @@ 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.
type BTIO = PluginIO BtState SysClient
data BTDevice = BTDevice
{ btDevConnected :: Maybe Bool
, btDevSigHandler :: SignalHandler
}
type ConnectedDevices = M.Map ObjectPath BTDevice
data BtState = BtState
{ btDevices :: S.Set ObjectPath
{ btDevices :: ConnectedDevices
, btPowered :: Maybe Bool
}
type MutableBtState = MVar BtState
emptyState :: BtState
emptyState =
BtState
{ btDevices = S.empty
{ btDevices = M.empty
, btPowered = Nothing
}
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
readState :: MonadUnliftIO m => MutableBtState -> m (Maybe Bool, Bool)
readState state = do
p <- readPowered state
c <- readDevices state
return (p, anyDevicesConnected c)
--------------------------------------------------------------------------------
-- Object manager
findAdaptor :: ObjectTree -> Maybe ObjectPath
findAdaptor = find (("/org/bluez/hci" `isPrefixOf`) . formatObjectPath) . M.keys
findAdapter :: ObjectTree -> Maybe ObjectPath
findAdapter = find (("/org/bluez/hci" `isPrefixOf`) . formatObjectPath) . 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
findDevices :: ObjectPath -> ObjectTree -> [ObjectPath]
findDevices adapter = filter (adaptorHasDevice adapter) . M.keys
adaptorHasDevice :: ObjectPath -> ObjectPath -> Bool
adaptorHasDevice adaptor device = case splitPathNoRoot device of
@ -155,120 +164,190 @@ adaptorHasDevice adaptor device = case splitPathNoRoot device of
splitPathNoRoot :: ObjectPath -> [FilePath]
splitPathNoRoot = dropWhile (== "/") . splitDirectories . formatObjectPath
getBtObjectTree
:: ( HasClient env
, SafeClient c
, MonadReader (env c) m
, HasLogFunc (env c)
, MonadUnliftIO m
)
=> m ObjectTree
getBtObjectTree = callGetManagedObjects btBus btOMPath
getBtObjectTree :: MonadUnliftIO m => SysClient -> m ObjectTree
getBtObjectTree sys = callGetManagedObjects sys 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
-- | Get powered state of adaptor and log the result
initAdapterState :: ObjectPath -> BTIO ()
initAdapterState adapter = do
reply <- callGetPowered adapter
putPowered $ fromSingletonVariant reply
initAdapter
:: (MonadUnliftIO m)
=> MutableBtState
-> ObjectPath
-> SysClient
-> m ()
initAdapter state adapter client = do
reply <- callGetPowered adapter client
putPowered state $ fromSingletonVariant reply
matchBTProperty
:: ( SafeClient c
, HasClient env
, MonadReader (env c) m
, HasLogFunc (env c)
, MonadUnliftIO m
)
=> ObjectPath
:: (MonadUnliftIO m)
=> SysClient
-> ObjectPath
-> m (Maybe MatchRule)
matchBTProperty p = matchPropertyFull btBus (Just p)
matchBTProperty sys p = matchPropertyFull sys btBus (Just p)
-- | 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
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
where
callback sig =
withNestedDBusClientConnection Nothing Nothing $
withSignalMatch procMatch $
matchPropertyChanged adaptorInterface adaptorPowered sig
procMatch = beforeDisplay . putPowered
procMatch = withSignalMatch $ \b -> putPowered state b >> dpy
callGetPowered
:: ( HasClient env
, MonadReader (env c) m
, HasLogFunc (env c)
, SafeClient c
, MonadUnliftIO m
)
=> ObjectPath
-> m [Variant]
callGetPowered :: MonadUnliftIO m => ObjectPath -> SysClient -> m [Variant]
callGetPowered adapter =
callPropertyGet btBus adapter adaptorInterface adaptorPowered
callPropertyGet btBus adapter adapterInterface $
memberName_ $
T.unpack adaptorPowered
putPowered :: Maybe Bool -> BTIO ()
putPowered ds = modifyState $ \s -> return (s {btPowered = ds}, ())
matchPowered :: [Variant] -> SignalMatch Bool
matchPowered = matchPropertyChanged adapterInterface adaptorPowered
readPowered :: BTIO (Maybe Bool)
readPowered = fmap btPowered $ readMVar =<< asks plugState
putPowered :: MonadUnliftIO m => MutableBtState -> Maybe Bool -> m ()
putPowered m ds = modifyMVar_ m (\s -> return s {btPowered = ds})
adaptorInterface :: InterfaceName
adaptorInterface = interfaceName_ "org.bluez.Adapter1"
readPowered :: MonadUnliftIO m => MutableBtState -> m (Maybe Bool)
readPowered = fmap btPowered . readMVar
adaptorPowered :: MemberName
adapterInterface :: InterfaceName
adapterInterface = interfaceName_ "org.bluez.Adapter1"
adaptorPowered :: T.Text
adaptorPowered = "Powered"
--------------------------------------------------------------------------------
-- Devices
initDevicesState :: ObjectPath -> ObjectTree -> BTIO ()
initDevicesState adaptor ot = do
let devices = findConnectedDevices adaptor ot
modifyState $ \s -> return (s {btDevices = S.fromList 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
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"
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
where
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}, ())
procMatch = withSignalMatch $ \c -> updateDevice state device c >> dpy
readDevices :: BTIO (S.Set ObjectPath)
readDevices = fmap btDevices $ readMVar =<< asks plugState
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
devInterface :: InterfaceName
devInterface = interfaceName_ "org.bluez.Device1"
devConnected :: MemberName
devConnected :: T.Text
devConnected = "Connected"

View File

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

View File

@ -1,52 +1,27 @@
{-# 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 ()
@ -57,22 +32,18 @@ data Colors = Colors
deriving (Eq, Show, Read)
startListener
:: ( HasClient env
, MonadReader (env c) m
, MonadUnliftIO m
, SafeClient c
, IsVariant a
)
:: (MonadUnliftIO m, SafeClient c, IsVariant a)
=> MatchRule
-> m [Variant]
-> (c -> m [Variant])
-> ([Variant] -> SignalMatch a)
-> (a -> m T.Text)
-> Callback
-> c
-> m ()
startListener rule getProp fromSignal toColor cb = do
reply <- getProp
startListener rule getProp fromSignal toColor cb client = do
reply <- getProp client
displayMaybe cb toColor $ fromSingletonVariant reply
void $ addMatchCallback rule (procMatch . fromSignal)
void $ addMatchCallback rule (procMatch . fromSignal) client
where
procMatch = procSignalMatch cb toColor
@ -99,42 +70,6 @@ displayMaybe' cb = maybe (liftIO $ cb $ T.unpack na)
withDBusClientConnection
:: (MonadUnliftIO m, SafeClient c)
=> Callback
-> Maybe BusName
-> Maybe FilePath
-> (NamedConnection c -> RIO SimpleApp ())
-> (c -> RIO SimpleApp ())
-> m ()
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
withDBusClientConnection cb f = runSimpleApp $ displayMaybe' cb f =<< getDBusClient

View File

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

View File

@ -1,3 +1,5 @@
{-# LANGUAGE OverloadedStrings #-}
--------------------------------------------------------------------------------
-- Screensaver plugin
--
@ -10,8 +12,6 @@ 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,13 +24,9 @@ ssAlias = "screensaver"
instance Exec Screensaver where
alias (Screensaver _) = T.unpack ssAlias
start (Screensaver (text, colors)) cb =
withDBusClientConnection
cb
(Just "org.xmobar.screensaver")
(Just "screensaver.log")
$ \cl -> withDIO cl $ do
matchSignal dpy
dpy =<< callQuery
start (Screensaver (text, colors)) cb = do
withDBusClientConnection cb $ \sys -> do
matchSignal display sys
display =<< callQuery sys
where
dpy = displayMaybe cb $ return . (\s -> colorText colors s text)
display = displayMaybe cb $ return . (\s -> colorText colors s text)

133
lib/Xmobar/Plugins/VPN.hs Normal file
View File

@ -0,0 +1,133 @@
{-# 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,47 +9,9 @@ extra-source-files:
- README.md
- fourmolu.yaml
- make_pkgs
- runtime_pkgs
- assets/icons/*
- assets/sound/*
- icons/*
- scripts/*
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
- sound/*
dependencies:
- rio >= 0.1.21.0
@ -73,21 +35,14 @@ 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
@ -97,15 +52,21 @@ 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

View File

@ -1,22 +0,0 @@
#! /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

View File

@ -1,61 +0,0 @@
#! /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-19.33
#resolver: nightly-2022-03-03
#resolver: lts-17.4
resolver: nightly-2022-03-03
# User packages to be built.
# Various formats can be used as shown in the example below.