Compare commits
1 Commits
master
...
fix_proces
Author | SHA1 | Date |
---|---|---|
Nathan Dwarshuis | 73ed6b9734 |
|
@ -1,3 +1,6 @@
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
{-# LANGUAGE ScopedTypeVariables #-}
|
||||||
|
|
||||||
-- | Start a VirtualBox instance with a sentinel wrapper process.
|
-- | Start a VirtualBox instance with a sentinel wrapper process.
|
||||||
--
|
--
|
||||||
-- The only reason why this is needed is because I want to manage virtualboxes
|
-- The only reason why this is needed is because I want to manage virtualboxes
|
||||||
|
@ -40,7 +43,7 @@ runAndWait [n] = do
|
||||||
p <- vmPID i
|
p <- vmPID i
|
||||||
liftIO $ mapM_ waitUntilExit p
|
liftIO $ mapM_ waitUntilExit p
|
||||||
err = logError "Could not get machine ID"
|
err = logError "Could not get machine ID"
|
||||||
runAndWait _ = logInfo "Usage: vbox-start VBOXNAME"
|
runAndWait _ = liftIO $ putStrLn "Usage: vbox-start VBOXNAME"
|
||||||
|
|
||||||
vmLaunch :: T.Text -> RIO SimpleApp ()
|
vmLaunch :: T.Text -> RIO SimpleApp ()
|
||||||
vmLaunch i = do
|
vmLaunch i = do
|
||||||
|
|
200
bin/xmobar.hs
200
bin/xmobar.hs
|
@ -1,3 +1,5 @@
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
-- | Xmobar binary
|
-- | Xmobar binary
|
||||||
--
|
--
|
||||||
-- Features:
|
-- Features:
|
||||||
|
@ -10,15 +12,16 @@
|
||||||
module Main (main) where
|
module Main (main) where
|
||||||
|
|
||||||
import Data.Internal.DBus
|
import Data.Internal.DBus
|
||||||
import Data.Internal.XIO
|
import Data.Internal.Dependency
|
||||||
import GHC.Enum (enumFrom)
|
|
||||||
import Options.Applicative
|
|
||||||
import RIO hiding (hFlush)
|
import RIO hiding (hFlush)
|
||||||
import RIO.FilePath
|
import qualified RIO.ByteString.Lazy as BL
|
||||||
import RIO.List
|
import RIO.List
|
||||||
import qualified RIO.NonEmpty as NE
|
import RIO.Process
|
||||||
import qualified RIO.Text as T
|
import qualified RIO.Text as T
|
||||||
|
import System.IO
|
||||||
|
import UnliftIO.Environment
|
||||||
import XMonad.Core hiding (config)
|
import XMonad.Core hiding (config)
|
||||||
|
import XMonad.Internal.Command.Desktop
|
||||||
import XMonad.Internal.Command.Power
|
import XMonad.Internal.Command.Power
|
||||||
import XMonad.Internal.DBus.Brightness.ClevoKeyboard
|
import XMonad.Internal.DBus.Brightness.ClevoKeyboard
|
||||||
import XMonad.Internal.DBus.Brightness.IntelBacklight
|
import XMonad.Internal.DBus.Brightness.IntelBacklight
|
||||||
|
@ -29,58 +32,32 @@ import Xmobar hiding
|
||||||
( iconOffset
|
( iconOffset
|
||||||
, run
|
, run
|
||||||
)
|
)
|
||||||
import Xmobar.Plugins.ActiveConnection
|
|
||||||
import Xmobar.Plugins.Bluetooth
|
import Xmobar.Plugins.Bluetooth
|
||||||
import Xmobar.Plugins.ClevoKeyboard
|
import Xmobar.Plugins.ClevoKeyboard
|
||||||
import Xmobar.Plugins.Common
|
import Xmobar.Plugins.Common
|
||||||
|
import Xmobar.Plugins.Device
|
||||||
import Xmobar.Plugins.IntelBacklight
|
import Xmobar.Plugins.IntelBacklight
|
||||||
import Xmobar.Plugins.Screensaver
|
import Xmobar.Plugins.Screensaver
|
||||||
|
import Xmobar.Plugins.VPN
|
||||||
|
|
||||||
main :: IO ()
|
main :: IO ()
|
||||||
main = parse >>= xio
|
main = getArgs >>= parse
|
||||||
|
|
||||||
parse :: IO XOpts
|
parse :: [String] -> IO ()
|
||||||
parse = execParser opts
|
parse [] = run
|
||||||
where
|
parse ["--deps"] = withCache printDeps
|
||||||
parseOpts = parseDeps <|> parseTest <|> pure XRun
|
parse ["--test"] = withCache $ withDBus_ evalConfig
|
||||||
opts =
|
parse _ = usage
|
||||||
info (parseOpts <**> helper) $
|
|
||||||
fullDesc <> header "xmobar: the best taskbar ever"
|
|
||||||
|
|
||||||
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
|
evalConfig :: DBusState -> FIO Config
|
||||||
parseDeps =
|
|
||||||
flag'
|
|
||||||
XDeps
|
|
||||||
(long "deps" <> short 'd' <> help "print dependencies")
|
|
||||||
|
|
||||||
parseTest :: Parser XOpts
|
|
||||||
parseTest =
|
|
||||||
flag'
|
|
||||||
XTest
|
|
||||||
(long "test" <> short 't' <> help "test dependencies without running")
|
|
||||||
|
|
||||||
xio :: XOpts -> IO ()
|
|
||||||
xio o = case o of
|
|
||||||
XDeps -> hRunXIO False stderr printDeps
|
|
||||||
XTest -> hRunXIO False stderr $ withDBus_ Nothing Nothing evalConfig
|
|
||||||
XRun -> runXIO "xmobar.log" run
|
|
||||||
|
|
||||||
run :: XIO ()
|
|
||||||
run = do
|
|
||||||
-- IDK why this is needed, I thought this was default
|
|
||||||
liftIO $ hSetBuffering stdout LineBuffering
|
|
||||||
-- this isn't totally necessary except for the fact that killing xmobar
|
|
||||||
-- will make it print something about catching SIGTERM, and without
|
|
||||||
-- linebuffering it usually only prints the first few characters (even then
|
|
||||||
-- it only prints 10-20% of the time)
|
|
||||||
liftIO $ hSetBuffering stderr LineBuffering
|
|
||||||
-- TODO do these dbus things really need to remain connected?
|
|
||||||
c <- withDBus Nothing Nothing evalConfig
|
|
||||||
liftIO $ xmobar c
|
|
||||||
|
|
||||||
evalConfig :: DBusState -> XIO Config
|
|
||||||
evalConfig db = do
|
evalConfig db = do
|
||||||
cs <- getAllCommands <$> rightPlugins db
|
cs <- getAllCommands <$> rightPlugins db
|
||||||
bf <- getTextFont
|
bf <- getTextFont
|
||||||
|
@ -88,14 +65,19 @@ evalConfig db = do
|
||||||
d <- io $ cfgDir <$> getDirectories
|
d <- io $ cfgDir <$> getDirectories
|
||||||
return $ config bf ifs ios cs d
|
return $ config bf ifs ios cs d
|
||||||
|
|
||||||
printDeps :: XIO ()
|
printDeps :: FIO ()
|
||||||
printDeps = withDBus_ Nothing Nothing $ \db ->
|
printDeps = withDBus_ $ \db -> do
|
||||||
mapM_ logInfo $
|
let ps = sort $ nub $ fmap showFulfillment $ concatMap dumpFeature $ allFeatures db
|
||||||
fmap showFulfillment $
|
io $ mapM_ (putStrLn . T.unpack) ps
|
||||||
sort $
|
|
||||||
nub $
|
usage :: IO ()
|
||||||
concatMap dumpFeature $
|
usage =
|
||||||
allFeatures db
|
putStrLn $
|
||||||
|
intercalate
|
||||||
|
"\n"
|
||||||
|
[ "xmobar: run greatest taskbar"
|
||||||
|
, "xmobar --deps: print dependencies"
|
||||||
|
]
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- toplevel configuration
|
-- toplevel configuration
|
||||||
|
@ -118,7 +100,7 @@ iconFont =
|
||||||
fontSometimes
|
fontSometimes
|
||||||
"XMobar Icon Font"
|
"XMobar Icon Font"
|
||||||
"Symbols Nerd 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)
|
-- | Offsets for the icons in the bar (relative to the text offset)
|
||||||
iconOffset :: BarFont -> Int
|
iconOffset :: BarFont -> Int
|
||||||
|
@ -164,7 +146,7 @@ config bf ifs ios br confDir =
|
||||||
, pickBroadest = False
|
, pickBroadest = False
|
||||||
, persistent = True
|
, persistent = True
|
||||||
, -- store the icons with the xmonad/xmobar stack project
|
, -- store the icons with the xmonad/xmobar stack project
|
||||||
iconRoot = confDir </> "assets" </> "icons"
|
iconRoot = confDir ++ "/icons"
|
||||||
, commands = csRunnable <$> concatRegions br
|
, commands = csRunnable <$> concatRegions br
|
||||||
}
|
}
|
||||||
|
|
||||||
|
@ -187,7 +169,7 @@ getAllCommands right =
|
||||||
, brRight = catMaybes right
|
, brRight = catMaybes right
|
||||||
}
|
}
|
||||||
|
|
||||||
rightPlugins :: DBusState -> XIO [Maybe CmdSpec]
|
rightPlugins :: DBusState -> FIO [Maybe CmdSpec]
|
||||||
rightPlugins db =
|
rightPlugins db =
|
||||||
mapM evalFeature $
|
mapM evalFeature $
|
||||||
allFeatures db
|
allFeatures db
|
||||||
|
@ -219,11 +201,11 @@ getWireless =
|
||||||
xpfWireless
|
xpfWireless
|
||||||
[Subfeature (IORoot wirelessCmd $ Only readWireless) "sysfs path"]
|
[Subfeature (IORoot wirelessCmd $ Only readWireless) "sysfs path"]
|
||||||
|
|
||||||
getEthernet :: Maybe NamedSysConnection -> BarFeature
|
getEthernet :: Maybe SysClient -> BarFeature
|
||||||
getEthernet cl = iconDBus_ "ethernet status indicator" xpfEthernet root (Only_ devDep)
|
getEthernet cl = iconDBus "ethernet status indicator" xpfEthernet root tree
|
||||||
where
|
where
|
||||||
root useIcon tree' =
|
root useIcon tree' = DBusRoot (const . ethernetCmd useIcon) tree' cl
|
||||||
DBusRoot_ (const $ ethernetCmd useIcon) tree' cl
|
tree = And1 (Only readEthernet) (Only_ devDep)
|
||||||
|
|
||||||
getBattery :: BarFeature
|
getBattery :: BarFeature
|
||||||
getBattery = iconIO_ "battery level indicator" xpfBattery root tree
|
getBattery = iconIO_ "battery level indicator" xpfBattery root tree
|
||||||
|
@ -235,12 +217,18 @@ getBattery = iconIO_ "battery level indicator" xpfBattery root tree
|
||||||
io $
|
io $
|
||||||
fmap (Msg LevelError) <$> hasBattery
|
fmap (Msg LevelError) <$> hasBattery
|
||||||
|
|
||||||
getVPN :: Maybe NamedSysConnection -> BarFeature
|
getVPN :: Maybe SysClient -> BarFeature
|
||||||
getVPN cl = iconDBus_ "VPN status indicator" xpfVPN root (Only_ devDep)
|
getVPN cl = iconDBus_ "VPN status indicator" xpfVPN root $ toAnd_ vpnDep test
|
||||||
where
|
where
|
||||||
root useIcon tree = DBusRoot_ (const $ vpnCmd useIcon) tree cl
|
root useIcon tree = DBusRoot_ (const $ vpnCmd useIcon) tree cl
|
||||||
|
test =
|
||||||
|
DBusIO $
|
||||||
|
IOTest_
|
||||||
|
"Use nmcli to test if VPN is present"
|
||||||
|
networkManagerPkgs
|
||||||
|
vpnPresent
|
||||||
|
|
||||||
getBt :: Maybe NamedSysConnection -> BarFeature
|
getBt :: Maybe SysClient -> BarFeature
|
||||||
getBt = xmobarDBus "bluetooth status indicator" xpfBluetooth btDep btCmd
|
getBt = xmobarDBus "bluetooth status indicator" xpfBluetooth btDep btCmd
|
||||||
|
|
||||||
getAlsa :: BarFeature
|
getAlsa :: BarFeature
|
||||||
|
@ -251,7 +239,7 @@ getAlsa =
|
||||||
where
|
where
|
||||||
root useIcon = IORoot_ (alsaCmd useIcon)
|
root useIcon = IORoot_ (alsaCmd useIcon)
|
||||||
|
|
||||||
getBl :: Maybe NamedSesConnection -> BarFeature
|
getBl :: Maybe SesClient -> BarFeature
|
||||||
getBl =
|
getBl =
|
||||||
xmobarDBus
|
xmobarDBus
|
||||||
"Intel backlight indicator"
|
"Intel backlight indicator"
|
||||||
|
@ -259,7 +247,7 @@ getBl =
|
||||||
intelBacklightSignalDep
|
intelBacklightSignalDep
|
||||||
blCmd
|
blCmd
|
||||||
|
|
||||||
getCk :: Maybe NamedSesConnection -> BarFeature
|
getCk :: Maybe SesClient -> BarFeature
|
||||||
getCk =
|
getCk =
|
||||||
xmobarDBus
|
xmobarDBus
|
||||||
"Clevo keyboard indicator"
|
"Clevo keyboard indicator"
|
||||||
|
@ -267,7 +255,7 @@ getCk =
|
||||||
clevoKeyboardSignalDep
|
clevoKeyboardSignalDep
|
||||||
ckCmd
|
ckCmd
|
||||||
|
|
||||||
getSs :: Maybe NamedSesConnection -> BarFeature
|
getSs :: Maybe SesClient -> BarFeature
|
||||||
getSs = xmobarDBus "screensaver indicator" (const True) ssSignalDep ssCmd
|
getSs = xmobarDBus "screensaver indicator" (const True) ssSignalDep ssCmd
|
||||||
|
|
||||||
getLock :: Always CmdSpec
|
getLock :: Always CmdSpec
|
||||||
|
@ -284,7 +272,7 @@ xmobarDBus
|
||||||
-> XPQuery
|
-> XPQuery
|
||||||
-> DBusDependency_ c
|
-> DBusDependency_ c
|
||||||
-> (Fontifier -> CmdSpec)
|
-> (Fontifier -> CmdSpec)
|
||||||
-> Maybe (NamedConnection c)
|
-> Maybe c
|
||||||
-> BarFeature
|
-> BarFeature
|
||||||
xmobarDBus n q dep cmd cl = iconDBus_ n q root (Only_ dep)
|
xmobarDBus n q dep cmd cl = iconDBus_ n q root (Only_ dep)
|
||||||
where
|
where
|
||||||
|
@ -298,16 +286,18 @@ iconIO_
|
||||||
-> BarFeature
|
-> BarFeature
|
||||||
iconIO_ = iconSometimes' And_ Only_
|
iconIO_ = iconSometimes' And_ Only_
|
||||||
|
|
||||||
-- iconDBus
|
iconDBus
|
||||||
-- :: T.Text
|
:: SafeClient c
|
||||||
-- -> XPQuery
|
=> T.Text
|
||||||
-- -> (Fontifier -> DBusTree c p -> Root CmdSpec)
|
-> XPQuery
|
||||||
-- -> DBusTree c p
|
-> (Fontifier -> DBusTree c p -> Root CmdSpec)
|
||||||
-- -> BarFeature
|
-> DBusTree c p
|
||||||
-- iconDBus = iconSometimes' And1 $ Only_ . DBusIO
|
-> BarFeature
|
||||||
|
iconDBus = iconSometimes' And1 $ Only_ . DBusIO
|
||||||
|
|
||||||
iconDBus_
|
iconDBus_
|
||||||
:: T.Text
|
:: SafeClient c
|
||||||
|
=> T.Text
|
||||||
-> XPQuery
|
-> XPQuery
|
||||||
-> (Fontifier -> DBusTree_ c -> Root CmdSpec)
|
-> (Fontifier -> DBusTree_ c -> Root CmdSpec)
|
||||||
-> DBusTree_ c
|
-> DBusTree_ c
|
||||||
|
@ -369,19 +359,13 @@ wirelessCmd iface =
|
||||||
, "<icon=wifi_%%.xpm/>"
|
, "<icon=wifi_%%.xpm/>"
|
||||||
]
|
]
|
||||||
|
|
||||||
ethernetCmd :: Fontifier -> CmdSpec
|
ethernetCmd :: Fontifier -> T.Text -> CmdSpec
|
||||||
ethernetCmd = connCmd "\xf0e8" "ETH" ("vlan" :| ["802-3-ethernet"])
|
ethernetCmd fontify iface =
|
||||||
|
|
||||||
vpnCmd :: Fontifier -> CmdSpec
|
|
||||||
vpnCmd = connCmd "\xf023" "VPN" ("tun" :| [])
|
|
||||||
|
|
||||||
connCmd :: T.Text -> T.Text -> NE.NonEmpty T.Text -> Fontifier -> CmdSpec
|
|
||||||
connCmd icon abbr contypes fontify =
|
|
||||||
CmdSpec
|
CmdSpec
|
||||||
{ csAlias = connAlias contypes
|
{ csAlias = iface
|
||||||
, csRunnable =
|
, csRunnable =
|
||||||
Run $
|
Run $
|
||||||
ActiveConnection (contypes, fontify IconMedium icon abbr, colors)
|
Device (iface, fontify IconMedium "\xf0e8" "ETH", colors)
|
||||||
}
|
}
|
||||||
|
|
||||||
batteryCmd :: Fontifier -> CmdSpec
|
batteryCmd :: Fontifier -> CmdSpec
|
||||||
|
@ -417,13 +401,20 @@ batteryCmd fontify =
|
||||||
, fontify' "\xf1e6" "AC"
|
, fontify' "\xf1e6" "AC"
|
||||||
]
|
]
|
||||||
|
|
||||||
|
vpnCmd :: Fontifier -> CmdSpec
|
||||||
|
vpnCmd fontify =
|
||||||
|
CmdSpec
|
||||||
|
{ csAlias = vpnAlias
|
||||||
|
, csRunnable = Run $ VPN (fontify IconMedium "\xf023" "VPN", colors)
|
||||||
|
}
|
||||||
|
|
||||||
btCmd :: Fontifier -> CmdSpec
|
btCmd :: Fontifier -> CmdSpec
|
||||||
btCmd fontify =
|
btCmd fontify =
|
||||||
CmdSpec
|
CmdSpec
|
||||||
{ csAlias = btAlias
|
{ csAlias = btAlias
|
||||||
, csRunnable =
|
, csRunnable =
|
||||||
Run $
|
Run $
|
||||||
Bluetooth (fontify' "\x0f00b1" "+", fontify' "\x0f00af" "-") colors
|
Bluetooth (fontify' "\xf5b0" "+", fontify' "\xf5ae" "-") colors
|
||||||
}
|
}
|
||||||
where
|
where
|
||||||
fontify' i = fontify IconLarge i . T.append "BT"
|
fontify' i = fontify IconLarge i . T.append "BT"
|
||||||
|
@ -464,7 +455,7 @@ ckCmd :: Fontifier -> CmdSpec
|
||||||
ckCmd fontify =
|
ckCmd fontify =
|
||||||
CmdSpec
|
CmdSpec
|
||||||
{ csAlias = ckAlias
|
{ csAlias = ckAlias
|
||||||
, csRunnable = Run $ ClevoKeyboard $ fontify IconSmall "\xf11c" "KB: "
|
, csRunnable = Run $ ClevoKeyboard $ fontify IconSmall "\xf40b" "KB: "
|
||||||
}
|
}
|
||||||
|
|
||||||
ssCmd :: Fontifier -> CmdSpec
|
ssCmd :: Fontifier -> CmdSpec
|
||||||
|
@ -500,8 +491,8 @@ lockCmd fontify =
|
||||||
]
|
]
|
||||||
}
|
}
|
||||||
where
|
where
|
||||||
numIcon = fontify' "\x0f03a6" "N"
|
numIcon = fontify' "\xf8a5" "N"
|
||||||
capIcon = fontify' "\x0f0bf1" "C"
|
capIcon = fontify' "\xf657" "C"
|
||||||
fontify' = fontify IconXLarge
|
fontify' = fontify IconXLarge
|
||||||
disabledColor = xmobarFGColor XT.backdropFgColor
|
disabledColor = xmobarFGColor XT.backdropFgColor
|
||||||
|
|
||||||
|
@ -512,13 +503,36 @@ dateCmd =
|
||||||
, csRunnable = Run $ Date "%Y-%m-%d %H:%M:%S " "date" 10
|
, csRunnable = Run $ Date "%Y-%m-%d %H:%M:%S " "date" 10
|
||||||
}
|
}
|
||||||
|
|
||||||
|
--------------------------------------------------------------------------------
|
||||||
|
-- low-level testing functions
|
||||||
|
|
||||||
|
vpnPresent :: FIO (Maybe Msg)
|
||||||
|
vpnPresent = do
|
||||||
|
res <- proc "nmcli" args readProcess
|
||||||
|
return $ case res of
|
||||||
|
(ExitSuccess, out, _)
|
||||||
|
| "vpn" `elem` BL.split 10 out -> Nothing
|
||||||
|
| otherwise -> Just $ Msg LevelError "vpn not found"
|
||||||
|
(ExitFailure c, _, err) ->
|
||||||
|
Just $
|
||||||
|
Msg LevelError $
|
||||||
|
T.concat
|
||||||
|
[ "vpn search exited with code "
|
||||||
|
, T.pack $ show c
|
||||||
|
, ": "
|
||||||
|
, T.decodeUtf8With T.lenientDecode $
|
||||||
|
BL.toStrict err
|
||||||
|
]
|
||||||
|
where
|
||||||
|
args = ["-c", "no", "-t", "-f", "TYPE", "c", "show"]
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- text font
|
-- text font
|
||||||
--
|
--
|
||||||
-- ASSUME there is only one text font for this entire configuration. This
|
-- ASSUME there is only one text font for this entire configuration. This
|
||||||
-- will correspond to the first font/offset parameters in the config record.
|
-- will correspond to the first font/offset parameters in the config record.
|
||||||
|
|
||||||
getTextFont :: XIO T.Text
|
getTextFont :: FIO T.Text
|
||||||
getTextFont = do
|
getTextFont = do
|
||||||
fb <- evalAlways textFont
|
fb <- evalAlways textFont
|
||||||
return $ fb textFontData
|
return $ fb textFontData
|
||||||
|
@ -526,7 +540,7 @@ getTextFont = do
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- icon fonts
|
-- icon fonts
|
||||||
|
|
||||||
getIconFonts :: XIO ([T.Text], [Int])
|
getIconFonts :: FIO ([T.Text], [Int])
|
||||||
getIconFonts = do
|
getIconFonts = do
|
||||||
fb <- evalSometimes iconFont
|
fb <- evalSometimes iconFont
|
||||||
return $ maybe ([], []) apply fb
|
return $ maybe ([], []) apply fb
|
||||||
|
|
356
bin/xmonad.hs
356
bin/xmonad.hs
|
@ -1,16 +1,20 @@
|
||||||
|
{-# LANGUAGE FlexibleContexts #-}
|
||||||
|
{-# LANGUAGE FlexibleInstances #-}
|
||||||
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- XMonad binary
|
-- XMonad binary
|
||||||
|
|
||||||
module Main (main) where
|
module Main (main) where
|
||||||
|
|
||||||
import Data.Internal.DBus
|
import Data.Internal.DBus
|
||||||
import Data.Internal.XIO
|
import Data.Internal.Dependency
|
||||||
import Data.Monoid
|
import Data.Monoid
|
||||||
import Data.Text.IO (hPutStrLn)
|
import Data.Text.IO (hPutStrLn)
|
||||||
import Graphics.X11.Types
|
import Graphics.X11.Types
|
||||||
import Graphics.X11.Xlib.Atom
|
import Graphics.X11.Xlib.Atom
|
||||||
import Graphics.X11.Xlib.Extras
|
import Graphics.X11.Xlib.Extras
|
||||||
import Options.Applicative hiding (action)
|
|
||||||
import RIO
|
import RIO
|
||||||
import RIO.Directory
|
import RIO.Directory
|
||||||
import RIO.List
|
import RIO.List
|
||||||
|
@ -21,7 +25,8 @@ import System.Process
|
||||||
( getPid
|
( getPid
|
||||||
, getProcessExitCode
|
, getProcessExitCode
|
||||||
)
|
)
|
||||||
import XMonad hiding (display)
|
import UnliftIO.Environment
|
||||||
|
import XMonad
|
||||||
import XMonad.Actions.CopyWindow
|
import XMonad.Actions.CopyWindow
|
||||||
import XMonad.Actions.CycleWS
|
import XMonad.Actions.CycleWS
|
||||||
import XMonad.Actions.PhysicalScreens
|
import XMonad.Actions.PhysicalScreens
|
||||||
|
@ -45,7 +50,6 @@ import XMonad.Internal.DBus.Removable
|
||||||
import XMonad.Internal.DBus.Screensaver
|
import XMonad.Internal.DBus.Screensaver
|
||||||
import XMonad.Internal.Shell hiding (proc)
|
import XMonad.Internal.Shell hiding (proc)
|
||||||
import qualified XMonad.Internal.Theme as XT
|
import qualified XMonad.Internal.Theme as XT
|
||||||
import XMonad.Layout.Decoration
|
|
||||||
import XMonad.Layout.MultiToggle
|
import XMonad.Layout.MultiToggle
|
||||||
import XMonad.Layout.NoBorders
|
import XMonad.Layout.NoBorders
|
||||||
import XMonad.Layout.NoFrillsDecoration
|
import XMonad.Layout.NoFrillsDecoration
|
||||||
|
@ -61,37 +65,15 @@ import XMonad.Util.NamedActions
|
||||||
import XMonad.Util.WorkspaceCompare
|
import XMonad.Util.WorkspaceCompare
|
||||||
|
|
||||||
main :: IO ()
|
main :: IO ()
|
||||||
main = parse >>= xio
|
main = getArgs >>= parse
|
||||||
|
|
||||||
parse :: IO XOpts
|
parse :: [String] -> IO ()
|
||||||
parse = execParser opts
|
parse [] = run
|
||||||
where
|
parse ["--deps"] = withCache printDeps
|
||||||
parseOpts = parseDeps <|> parseTest <|> pure XRun
|
-- parse ["--test"] = void $ withCache . evalConf =<< connectDBusX
|
||||||
opts =
|
parse _ = usage
|
||||||
info (parseOpts <**> helper) $
|
|
||||||
fullDesc <> header "xmonad: the best window manager ever"
|
|
||||||
|
|
||||||
data XOpts = XDeps | XTest | XRun
|
run :: IO ()
|
||||||
|
|
||||||
parseDeps :: Parser XOpts
|
|
||||||
parseDeps =
|
|
||||||
flag'
|
|
||||||
XDeps
|
|
||||||
(long "deps" <> short 'd' <> help "print dependencies")
|
|
||||||
|
|
||||||
parseTest :: Parser XOpts
|
|
||||||
parseTest =
|
|
||||||
flag'
|
|
||||||
XTest
|
|
||||||
(long "test" <> short 't' <> help "test dependencies without running")
|
|
||||||
|
|
||||||
xio :: XOpts -> IO ()
|
|
||||||
xio o = case o of
|
|
||||||
XDeps -> hRunXIO False stderr printDeps
|
|
||||||
XTest -> undefined
|
|
||||||
XRun -> runXIO "xmonad.log" run
|
|
||||||
|
|
||||||
run :: XIO ()
|
|
||||||
run = do
|
run = do
|
||||||
-- These first two commands are only significant when xmonad is restarted.
|
-- These first two commands are only significant when xmonad is restarted.
|
||||||
-- The 'launch' function below this will turn off buffering (so flushes are
|
-- The 'launch' function below this will turn off buffering (so flushes are
|
||||||
|
@ -106,31 +88,31 @@ run = do
|
||||||
-- signal handlers to carry over to the top.
|
-- signal handlers to carry over to the top.
|
||||||
uninstallSignalHandlers
|
uninstallSignalHandlers
|
||||||
hSetBuffering stdout LineBuffering
|
hSetBuffering stdout LineBuffering
|
||||||
|
withCache $ do
|
||||||
withDBusX_ $ \db -> do
|
withDBusX_ $ \db -> do
|
||||||
let fs = features $ dbSysClient db
|
let sys = dbSysClient db
|
||||||
withDBusInterfaces db (fsDBusExporters fs) $ \unexporters -> do
|
let fs = features sys
|
||||||
|
startDBusInterfaces db fs
|
||||||
withXmobar $ \xmobarP -> do
|
withXmobar $ \xmobarP -> do
|
||||||
withChildDaemons fs $ \ds -> do
|
withChildDaemons fs $ \ds -> do
|
||||||
let toClean = Cleanup ds (Just xmobarP) unexporters
|
let ts = ThreadState ds (Just xmobarP)
|
||||||
void $ executeSometimes $ fsRemovableMon fs $ dbSysClient db
|
startRemovableMon db fs
|
||||||
void $ async $ void $ executeSometimes $ fsPowerMon fs
|
startPowerMon fs
|
||||||
dws <- startDynWorkspaces fs
|
dws <- startDynWorkspaces fs
|
||||||
runIO <- askRunInIO
|
kbs <- filterExternal <$> evalExternal (fsKeys fs ts db)
|
||||||
let cleanup = runCleanup runIO toClean db
|
|
||||||
kbs <- filterExternal <$> evalExternal (fsKeys fs runIO cleanup db)
|
|
||||||
sk <- evalAlways $ fsShowKeys fs
|
sk <- evalAlways $ fsShowKeys fs
|
||||||
ha <- evalAlways $ fsACPIHandler fs
|
ha <- evalAlways $ fsACPIHandler fs
|
||||||
tt <- evalAlways $ fsTabbedTheme fs
|
tt <- evalAlways $ fsTabbedTheme fs
|
||||||
let conf =
|
let conf =
|
||||||
ewmh $
|
ewmh $
|
||||||
addKeymap dws (liftIO . runIO . sk) kbs $
|
addKeymap dws sk kbs $
|
||||||
docks $
|
docks $
|
||||||
def
|
def
|
||||||
{ terminal = myTerm
|
{ terminal = myTerm
|
||||||
, modMask = myModMask
|
, modMask = myModMask
|
||||||
, layoutHook = myLayouts tt
|
, layoutHook = myLayouts tt
|
||||||
, manageHook = myManageHook dws
|
, manageHook = myManageHook dws
|
||||||
, handleEventHook = myEventHook runIO ha
|
, handleEventHook = myEventHook ha
|
||||||
, startupHook = myStartupHook
|
, startupHook = myStartupHook
|
||||||
, workspaces = myWorkspaces
|
, workspaces = myWorkspaces
|
||||||
, logHook = myLoghook xmobarP
|
, logHook = myLoghook xmobarP
|
||||||
|
@ -139,21 +121,32 @@ run = do
|
||||||
, normalBorderColor = T.unpack XT.bordersColor
|
, normalBorderColor = T.unpack XT.bordersColor
|
||||||
, focusedBorderColor = T.unpack XT.selectedBordersColor
|
, focusedBorderColor = T.unpack XT.selectedBordersColor
|
||||||
}
|
}
|
||||||
runXMonad conf
|
io $ runXMonad conf
|
||||||
where
|
where
|
||||||
|
startRemovableMon db fs =
|
||||||
|
void $
|
||||||
|
executeSometimes $
|
||||||
|
fsRemovableMon fs $
|
||||||
|
dbSysClient db
|
||||||
|
startPowerMon fs = void $ async $ void $ executeSometimes $ fsPowerMon fs
|
||||||
startDynWorkspaces fs = do
|
startDynWorkspaces fs = do
|
||||||
dws <- catMaybes <$> mapM evalSometimes (fsDynWorkspaces fs)
|
dws <- catMaybes <$> mapM evalSometimes (fsDynWorkspaces fs)
|
||||||
void $ async $ runWorkspaceMon dws
|
void $ io $ async $ runWorkspaceMon dws
|
||||||
return 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
|
runXMonad conf = do
|
||||||
dirs <- getCreateDirectories
|
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
|
getCreateDirectories = do
|
||||||
ds <- liftIO getDirectories
|
ds <- getDirectories
|
||||||
mapM_ (createIfMissing ds) [dataDir, cfgDir, cacheDir]
|
mapM_ (createIfMissing ds) [dataDir, cfgDir, cacheDir]
|
||||||
return ds
|
return ds
|
||||||
where
|
where
|
||||||
|
@ -161,19 +154,19 @@ getCreateDirectories = do
|
||||||
let d = f ds
|
let d = f ds
|
||||||
r <- tryIO $ createDirectoryIfMissing True d
|
r <- tryIO $ createDirectoryIfMissing True d
|
||||||
case r of
|
case r of
|
||||||
(Left e) -> logError $ display e
|
(Left e) -> print e
|
||||||
_ -> return ()
|
_ -> return ()
|
||||||
|
|
||||||
data FeatureSet = FeatureSet
|
data FeatureSet = FeatureSet
|
||||||
{ fsKeys :: (XIO () -> IO ()) -> X () -> DBusState -> [KeyGroup FeatureX]
|
{ fsKeys :: ThreadState -> DBusState -> [KeyGroup FeatureX]
|
||||||
, fsDBusExporters :: [Maybe NamedSesConnection -> Sometimes (XIO (), XIO ())]
|
, fsDBusExporters :: [Maybe SesClient -> SometimesIO]
|
||||||
, fsPowerMon :: SometimesIO
|
, fsPowerMon :: SometimesIO
|
||||||
, fsRemovableMon :: Maybe NamedSysConnection -> SometimesIO
|
, fsRemovableMon :: Maybe SysClient -> SometimesIO
|
||||||
, fsDaemons :: [Sometimes (XIO (Process () () ()))]
|
, fsDaemons :: [Sometimes (FIO (Process () () ()))]
|
||||||
, fsACPIHandler :: Always (String -> X ())
|
, fsACPIHandler :: Always (String -> X ())
|
||||||
, fsTabbedTheme :: Always Theme
|
, fsTabbedTheme :: Always Theme
|
||||||
, fsDynWorkspaces :: [Sometimes DynWorkspace]
|
, fsDynWorkspaces :: [Sometimes DynWorkspace]
|
||||||
, fsShowKeys :: Always ([((KeyMask, KeySym), NamedAction)] -> XIO ())
|
, fsShowKeys :: Always ([((KeyMask, KeySym), NamedAction)] -> X ())
|
||||||
}
|
}
|
||||||
|
|
||||||
tabbedFeature :: Always Theme
|
tabbedFeature :: Always Theme
|
||||||
|
@ -183,7 +176,7 @@ tabbedFeature = Always "theme for tabbed windows" $ Option sf fallback
|
||||||
niceTheme = IORoot XT.tabbedTheme $ fontTree XT.defFontFamily defFontPkgs
|
niceTheme = IORoot XT.tabbedTheme $ fontTree XT.defFontFamily defFontPkgs
|
||||||
fallback = Always_ $ FallbackAlone $ XT.tabbedTheme XT.fallbackFont
|
fallback = Always_ $ FallbackAlone $ XT.tabbedTheme XT.fallbackFont
|
||||||
|
|
||||||
features :: Maybe NamedSysConnection -> FeatureSet
|
features :: Maybe SysClient -> FeatureSet
|
||||||
features cl =
|
features cl =
|
||||||
FeatureSet
|
FeatureSet
|
||||||
{ fsKeys = externalBindings
|
{ fsKeys = externalBindings
|
||||||
|
@ -197,12 +190,8 @@ features cl =
|
||||||
, fsDaemons = [runNetAppDaemon cl, runAutolock]
|
, fsDaemons = [runNetAppDaemon cl, runAutolock]
|
||||||
}
|
}
|
||||||
|
|
||||||
withXmobar :: (Process Handle () () -> XIO a) -> XIO a
|
startXmobar :: FIO (Process Handle () ())
|
||||||
withXmobar = bracket startXmobar stopXmobar
|
|
||||||
|
|
||||||
startXmobar :: XIO (Process Handle () ())
|
|
||||||
startXmobar = do
|
startXmobar = do
|
||||||
logInfo "starting xmobar child process"
|
|
||||||
p <- proc "xmobar" [] start
|
p <- proc "xmobar" [] start
|
||||||
io $ hSetBuffering (getStdin p) LineBuffering
|
io $ hSetBuffering (getStdin p) LineBuffering
|
||||||
return p
|
return p
|
||||||
|
@ -212,87 +201,66 @@ startXmobar = do
|
||||||
. setStdin createPipe
|
. setStdin createPipe
|
||||||
. setCreateGroup True
|
. setCreateGroup True
|
||||||
|
|
||||||
stopXmobar
|
startChildDaemons :: FeatureSet -> FIO [Process () () ()]
|
||||||
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
|
startChildDaemons fs = catMaybes <$> mapM executeSometimes (fsDaemons fs)
|
||||||
=> Process Handle () ()
|
|
||||||
-> m ()
|
withChildDaemons :: FeatureSet -> ([Process () () ()] -> FIO a) -> FIO a
|
||||||
stopXmobar p = do
|
withChildDaemons fs = bracket (startChildDaemons fs) cleanup
|
||||||
|
where
|
||||||
|
cleanup ps = do
|
||||||
|
logInfo "stopping child processes"
|
||||||
|
mapM_ (io . killNoWait) ps
|
||||||
|
|
||||||
|
withXmobar :: (Process Handle () () -> FIO a) -> FIO a
|
||||||
|
withXmobar = bracket startXmobar cleanup
|
||||||
|
where
|
||||||
|
cleanup p = do
|
||||||
logInfo "stopping xmobar child process"
|
logInfo "stopping xmobar child process"
|
||||||
io $ killNoWait p
|
io $ killNoWait p
|
||||||
|
|
||||||
withChildDaemons
|
printDeps :: FIO ()
|
||||||
:: FeatureSet
|
printDeps = withDBus_ $ \db -> do
|
||||||
-> ([(Utf8Builder, Process () () ())] -> XIO a)
|
(i, f, d) <- allFeatures db
|
||||||
-> XIO a
|
mapM_ (liftIO . putStrLn . T.unpack) $
|
||||||
withChildDaemons fs = bracket (startChildDaemons fs) stopChildDaemons
|
|
||||||
|
|
||||||
startChildDaemons :: FeatureSet -> XIO [(Utf8Builder, Process () () ())]
|
|
||||||
startChildDaemons fs = catMaybes <$> mapM start (fsDaemons fs)
|
|
||||||
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
|
|
||||||
|
|
||||||
stopChildDaemons
|
|
||||||
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
|
|
||||||
=> [(Utf8Builder, Process () () ())]
|
|
||||||
-> m ()
|
|
||||||
stopChildDaemons = mapM_ stop
|
|
||||||
where
|
|
||||||
stop (n, p) = do
|
|
||||||
logInfo $ "stopping child process: " <> n
|
|
||||||
liftIO $ 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 $
|
|
||||||
fmap showFulfillment $
|
fmap showFulfillment $
|
||||||
sort $
|
sort $
|
||||||
nub $
|
nub $
|
||||||
concat $
|
concat $
|
||||||
fmap dumpSometimes dbus
|
fmap dumpFeature f ++ fmap dumpSometimes i ++ fmap dumpSometimes d
|
||||||
++ fmap dumpSometimes others
|
|
||||||
++ fmap dumpSometimes allDWs'
|
allFeatures :: DBusState -> FIO ([SometimesIO], [FeatureX], [Sometimes DynWorkspace])
|
||||||
++ fmap dumpFeature bfs
|
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
|
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
|
-- Concurrency configuration
|
||||||
|
|
||||||
data Cleanup = Cleanup
|
data ThreadState = ThreadState
|
||||||
{ clChildren :: [(Utf8Builder, Process () () ())]
|
{ tsChildPIDs :: [Process () () ()]
|
||||||
, clXmobar :: Maybe (Process Handle () ())
|
, tsXmobar :: Maybe (Process Handle () ())
|
||||||
, clDBusUnexporters :: [XIO ()]
|
|
||||||
}
|
}
|
||||||
|
|
||||||
runCleanup
|
runCleanup :: ThreadState -> DBusState -> X ()
|
||||||
:: (XIO () -> IO ())
|
runCleanup ts db = io $ do
|
||||||
-> Cleanup
|
mapM_ killNoWait $ tsXmobar ts
|
||||||
-> DBusState
|
mapM_ killNoWait $ tsChildPIDs ts
|
||||||
-> X ()
|
disconnectDBusX db
|
||||||
runCleanup runIO ts db = liftIO $ runIO $ do
|
|
||||||
mapM_ stopXmobar $ clXmobar ts
|
|
||||||
stopChildDaemons $ clChildren ts
|
|
||||||
sequence_ $ clDBusUnexporters ts
|
|
||||||
disconnectDBus db
|
|
||||||
|
|
||||||
-- | Kill a process (group) after xmonad has already started
|
-- | Kill a process (group) after xmonad has already started
|
||||||
-- This is necessary (as opposed to 'stopProcess' from rio) because a) xmonad
|
-- This is necessary (as opposed to 'stopProcess' from rio) because a) xmonad
|
||||||
|
@ -345,6 +313,9 @@ vmTag = "VM"
|
||||||
xsaneTag :: String
|
xsaneTag :: String
|
||||||
xsaneTag = "XSANE"
|
xsaneTag = "XSANE"
|
||||||
|
|
||||||
|
f5Tag :: String
|
||||||
|
f5Tag = "F5VPN"
|
||||||
|
|
||||||
gimpDynamicWorkspace :: Sometimes DynWorkspace
|
gimpDynamicWorkspace :: Sometimes DynWorkspace
|
||||||
gimpDynamicWorkspace = sometimesIO_ "gimp workspace" "gimp" tree dw
|
gimpDynamicWorkspace = sometimesIO_ "gimp workspace" "gimp" tree dw
|
||||||
where
|
where
|
||||||
|
@ -417,11 +388,31 @@ xsaneDynamicWorkspace =
|
||||||
}
|
}
|
||||||
c = "Xsane"
|
c = "Xsane"
|
||||||
|
|
||||||
|
f5vpnDynamicWorkspace :: Sometimes DynWorkspace
|
||||||
|
f5vpnDynamicWorkspace =
|
||||||
|
Sometimes
|
||||||
|
"F5 VPN workspace"
|
||||||
|
xpfF5VPN
|
||||||
|
[Subfeature (IORoot_ dw tree) "f5vpn"]
|
||||||
|
where
|
||||||
|
tree = Only_ $ sysExe [Package AUR "f5vpn"] "f5vpn"
|
||||||
|
dw =
|
||||||
|
DynWorkspace
|
||||||
|
{ dwName = "F5Vpn"
|
||||||
|
, dwTag = f5Tag
|
||||||
|
, dwClass = c
|
||||||
|
, dwHook = [className =? c -?> appendShift f5Tag]
|
||||||
|
, dwKey = 'i'
|
||||||
|
, dwCmd = Just skip
|
||||||
|
}
|
||||||
|
c = "F5 VPN"
|
||||||
|
|
||||||
allDWs' :: [Sometimes DynWorkspace]
|
allDWs' :: [Sometimes DynWorkspace]
|
||||||
allDWs' =
|
allDWs' =
|
||||||
[ xsaneDynamicWorkspace
|
[ xsaneDynamicWorkspace
|
||||||
, vmDynamicWorkspace
|
, vmDynamicWorkspace
|
||||||
, gimpDynamicWorkspace
|
, gimpDynamicWorkspace
|
||||||
|
, f5vpnDynamicWorkspace
|
||||||
]
|
]
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
|
@ -436,10 +427,6 @@ myLayouts tt =
|
||||||
mkToggle (single HIDE) $
|
mkToggle (single HIDE) $
|
||||||
tall ||| fulltab ||| full
|
tall ||| fulltab ||| full
|
||||||
where
|
where
|
||||||
addTopBar
|
|
||||||
:: (Eq a)
|
|
||||||
=> l a
|
|
||||||
-> ModifiedLayout (Decoration NoFrillsDecoration DefaultShrinker) l a
|
|
||||||
addTopBar = noFrillsDeco shrinkText tt
|
addTopBar = noFrillsDeco shrinkText tt
|
||||||
tall =
|
tall =
|
||||||
renamed [Replace "Tall"] $
|
renamed [Replace "Tall"] $
|
||||||
|
@ -622,30 +609,20 @@ manageApps dws =
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- Eventhook configuration
|
-- Eventhook configuration
|
||||||
|
|
||||||
myEventHook
|
myEventHook :: (String -> X ()) -> Event -> X All
|
||||||
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
|
myEventHook handler = xMsgEventHook handler <+> handleEventHook def
|
||||||
=> (m () -> IO ())
|
|
||||||
-> (String -> X ())
|
|
||||||
-> Event
|
|
||||||
-> X All
|
|
||||||
myEventHook runIO handler = xMsgEventHook runIO handler <+> handleEventHook def
|
|
||||||
|
|
||||||
-- | React to ClientMessage events from concurrent threads
|
-- | React to ClientMessage events from concurrent threads
|
||||||
xMsgEventHook
|
xMsgEventHook :: (String -> X ()) -> Event -> X All
|
||||||
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
|
xMsgEventHook handler ClientMessageEvent {ev_message_type = t, ev_data = d}
|
||||||
=> (m () -> IO ())
|
|
||||||
-> (String -> X ())
|
|
||||||
-> Event
|
|
||||||
-> X All
|
|
||||||
xMsgEventHook runIO handler ClientMessageEvent {ev_message_type = t, ev_data = d}
|
|
||||||
| t == bITMAP = do
|
| t == bITMAP = do
|
||||||
let (xtype, tag) = splitXMsg d
|
let (xtype, tag) = splitXMsg d
|
||||||
case xtype of
|
case xtype of
|
||||||
Workspace -> removeDynamicWorkspace tag
|
Workspace -> removeDynamicWorkspace tag
|
||||||
ACPI -> handler tag
|
ACPI -> handler tag
|
||||||
Unknown -> liftIO $ runIO $ logWarn "unknown concurrent message"
|
Unknown -> io $ putStrLn "WARNING: unknown concurrent message"
|
||||||
return (All True)
|
return (All True)
|
||||||
xMsgEventHook _ _ _ = return (All True)
|
xMsgEventHook _ _ = return (All True)
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- Keymap configuration
|
-- Keymap configuration
|
||||||
|
@ -748,13 +725,13 @@ data KeyGroup a = KeyGroup
|
||||||
, kgBindings :: [KeyBinding a]
|
, kgBindings :: [KeyBinding a]
|
||||||
}
|
}
|
||||||
|
|
||||||
evalExternal :: [KeyGroup FeatureX] -> XIO [KeyGroup MaybeX]
|
evalExternal :: [KeyGroup FeatureX] -> FIO [KeyGroup MaybeX]
|
||||||
evalExternal = mapM go
|
evalExternal = mapM go
|
||||||
where
|
where
|
||||||
go k@KeyGroup {kgBindings = bs} =
|
go k@KeyGroup {kgBindings = bs} =
|
||||||
(\bs' -> k {kgBindings = bs'}) <$> mapM evalKeyBinding bs
|
(\bs' -> k {kgBindings = bs'}) <$> mapM evalKeyBinding bs
|
||||||
|
|
||||||
evalKeyBinding :: KeyBinding FeatureX -> XIO (KeyBinding MaybeX)
|
evalKeyBinding :: KeyBinding FeatureX -> FIO (KeyBinding MaybeX)
|
||||||
evalKeyBinding k@KeyBinding {kbMaybeAction = a} =
|
evalKeyBinding k@KeyBinding {kbMaybeAction = a} =
|
||||||
(\f -> k {kbMaybeAction = f}) <$> evalFeature a
|
(\f -> k {kbMaybeAction = f}) <$> evalFeature a
|
||||||
|
|
||||||
|
@ -769,52 +746,52 @@ filterExternal = fmap go
|
||||||
]
|
]
|
||||||
}
|
}
|
||||||
|
|
||||||
externalBindings :: (XIO () -> IO ()) -> X () -> DBusState -> [KeyGroup FeatureX]
|
externalBindings :: ThreadState -> DBusState -> [KeyGroup FeatureX]
|
||||||
externalBindings runIO cleanup db =
|
externalBindings ts db =
|
||||||
[ KeyGroup
|
[ KeyGroup
|
||||||
"Launchers"
|
"Launchers"
|
||||||
[ KeyBinding "<XF86Search>" "select/launch app" $ Left $ toX runAppMenu
|
[ KeyBinding "<XF86Search>" "select/launch app" $ Left runAppMenu
|
||||||
, KeyBinding "M-g" "launch clipboard manager" $ Left $ toX runClipMenu
|
, KeyBinding "M-g" "launch clipboard manager" $ Left runClipMenu
|
||||||
, KeyBinding "M-a" "launch network selector" $ Left $ toX $ runNetMenu sys
|
, KeyBinding "M-a" "launch network selector" $ Left $ runNetMenu sys
|
||||||
, KeyBinding "M-w" "launch window selector" $ Left $ toX runWinMenu
|
, KeyBinding "M-w" "launch window selector" $ Left runWinMenu
|
||||||
, KeyBinding "M-u" "launch device selector" $ Left $ toX runDevMenu
|
, KeyBinding "M-u" "launch device selector" $ Left runDevMenu
|
||||||
, KeyBinding "M-b" "launch bitwarden selector" $ Left $ toX $ runBwMenu ses
|
, KeyBinding "M-b" "launch bitwarden selector" $ Left $ runBwMenu ses
|
||||||
, KeyBinding "M-v" "launch ExpressVPN selector" $ Left $ toX runVPNMenu
|
, KeyBinding "M-v" "launch ExpressVPN selector" $ Left runVPNMenu
|
||||||
, KeyBinding "M-e" "launch bluetooth selector" $ Left $ toX runBTMenu
|
, KeyBinding "M-e" "launch bluetooth selector" $ Left runBTMenu
|
||||||
, KeyBinding "M-C-e" "launch editor" $ Left $ toX runEditor
|
, KeyBinding "M-C-e" "launch editor" $ Left runEditor
|
||||||
, KeyBinding "M-C-w" "launch browser" $ Left $ toX runBrowser
|
, KeyBinding "M-C-w" "launch browser" $ Left runBrowser
|
||||||
, KeyBinding "M-C-t" "launch terminal with tmux" $ Left $ toX runTMux
|
, KeyBinding "M-C-t" "launch terminal with tmux" $ Left runTMux
|
||||||
, KeyBinding "M-C-S-t" "launch terminal" $ Left $ toX runTerm
|
, KeyBinding "M-C-S-t" "launch terminal" $ Left runTerm
|
||||||
, KeyBinding "M-C-q" "launch calc" $ Left $ toX runCalc
|
, KeyBinding "M-C-q" "launch calc" $ Left runCalc
|
||||||
, KeyBinding "M-C-f" "launch file manager" $ Left $ toX runFileManager
|
, KeyBinding "M-C-f" "launch file manager" $ Left runFileManager
|
||||||
]
|
]
|
||||||
, KeyGroup
|
, KeyGroup
|
||||||
"Actions"
|
"Actions"
|
||||||
[ KeyBinding "M-q" "close window" $ ftrAlways "kill window function" kill1
|
[ KeyBinding "M-q" "close window" $ ftrAlways "kill window function" kill1
|
||||||
, KeyBinding "M-r" "run program" $ Left $ toX runCmdMenu
|
, KeyBinding "M-r" "run program" $ Left runCmdMenu
|
||||||
, KeyBinding "M-<Space>" "warp pointer" $ ftrAlways "warp function" $ warpToWindow 0.5 0.5
|
, KeyBinding "M-<Space>" "warp pointer" $ ftrAlways "warp function" $ warpToWindow 0.5 0.5
|
||||||
, KeyBinding "M-C-s" "capture area" $ Left $ toX $ runAreaCapture ses
|
, KeyBinding "M-C-s" "capture area" $ Left $ runAreaCapture ses
|
||||||
, KeyBinding "M-C-S-s" "capture screen" $ Left $ toX $ runScreenCapture ses
|
, KeyBinding "M-C-S-s" "capture screen" $ Left $ runScreenCapture ses
|
||||||
, KeyBinding "M-C-d" "capture desktop" $ Left $ toX $ runDesktopCapture ses
|
, KeyBinding "M-C-d" "capture desktop" $ Left $ runDesktopCapture ses
|
||||||
, KeyBinding "M-C-b" "browse captures" $ Left $ toX runCaptureBrowser
|
, KeyBinding "M-C-b" "browse captures" $ Left runCaptureBrowser
|
||||||
-- , ("M-C-S-s", "capture focused window", spawn myWindowCap)
|
-- , ("M-C-S-s", "capture focused window", spawn myWindowCap)
|
||||||
]
|
]
|
||||||
, KeyGroup
|
, KeyGroup
|
||||||
"Multimedia"
|
"Multimedia"
|
||||||
[ KeyBinding "<XF86AudioPlay>" "toggle play/pause" $ Left $ toX runTogglePlay
|
[ KeyBinding "<XF86AudioPlay>" "toggle play/pause" $ Left runTogglePlay
|
||||||
, KeyBinding "<XF86AudioPrev>" "previous track" $ Left $ toX runPrevTrack
|
, KeyBinding "<XF86AudioPrev>" "previous track" $ Left runPrevTrack
|
||||||
, KeyBinding "<XF86AudioNext>" "next track" $ Left $ toX runNextTrack
|
, KeyBinding "<XF86AudioNext>" "next track" $ Left runNextTrack
|
||||||
, KeyBinding "<XF86AudioStop>" "stop" $ Left $ toX runStopPlay
|
, KeyBinding "<XF86AudioStop>" "stop" $ Left runStopPlay
|
||||||
, KeyBinding "<XF86AudioLowerVolume>" "volume down" $ Left $ toX runVolumeDown
|
, KeyBinding "<XF86AudioLowerVolume>" "volume down" $ Left runVolumeDown
|
||||||
, KeyBinding "<XF86AudioRaiseVolume>" "volume up" $ Left $ toX runVolumeUp
|
, KeyBinding "<XF86AudioRaiseVolume>" "volume up" $ Left runVolumeUp
|
||||||
, KeyBinding "<XF86AudioMute>" "volume mute" $ Left $ toX runVolumeMute
|
, KeyBinding "<XF86AudioMute>" "volume mute" $ Left runVolumeMute
|
||||||
]
|
]
|
||||||
, KeyGroup
|
, KeyGroup
|
||||||
"Dunst"
|
"Dunst"
|
||||||
[ KeyBinding "M-`" "dunst history" $ Left $ toX $ runNotificationHistory ses
|
[ KeyBinding "M-`" "dunst history" $ Left $ runNotificationHistory ses
|
||||||
, KeyBinding "M-S-`" "dunst close" $ Left $ toX $ runNotificationClose ses
|
, KeyBinding "M-S-`" "dunst close" $ Left $ runNotificationClose ses
|
||||||
, KeyBinding "M-M1-`" "dunst context menu" $ Left $ toX $ runNotificationContext ses
|
, KeyBinding "M-M1-`" "dunst context menu" $ Left $ runNotificationContext ses
|
||||||
, KeyBinding "M-C-`" "dunst close all" $ Left $ toX $ runNotificationCloseAll ses
|
, KeyBinding "M-C-`" "dunst close all" $ Left $ runNotificationCloseAll ses
|
||||||
]
|
]
|
||||||
, KeyGroup
|
, KeyGroup
|
||||||
"System"
|
"System"
|
||||||
|
@ -832,25 +809,22 @@ externalBindings runIO cleanup db =
|
||||||
, -- M-<F1> reserved for showing the keymap
|
, -- M-<F1> reserved for showing the keymap
|
||||||
KeyBinding "M-<F2>" "restart xmonad" restartf
|
KeyBinding "M-<F2>" "restart xmonad" restartf
|
||||||
, KeyBinding "M-<F3>" "recompile xmonad" recompilef
|
, KeyBinding "M-<F3>" "recompile xmonad" recompilef
|
||||||
, KeyBinding "M-<F7>" "select autorandr profile" $ Left $ toX runAutorandrMenu
|
, KeyBinding "M-<F8>" "select autorandr profile" $ Left runAutorandrMenu
|
||||||
, KeyBinding "M-<F8>" "toggle wifi" $ Left $ toX runToggleWifi
|
, KeyBinding "M-<F9>" "toggle ethernet" $ Left runToggleEthernet
|
||||||
, KeyBinding "M-<F9>" "toggle network" $ Left $ toX runToggleNetworking
|
, KeyBinding "M-<F10>" "toggle bluetooth" $ Left $ runToggleBluetooth sys
|
||||||
, KeyBinding "M-<F10>" "toggle bluetooth" $ Left $ toX $ runToggleBluetooth sys
|
, KeyBinding "M-<F11>" "toggle screensaver" $ Left $ callToggle ses
|
||||||
, KeyBinding "M-<F11>" "toggle screensaver" $ Left $ toX $ callToggle ses
|
|
||||||
, KeyBinding "M-<F12>" "switch gpu" $ Left runOptimusPrompt
|
, KeyBinding "M-<F12>" "switch gpu" $ Left runOptimusPrompt
|
||||||
]
|
]
|
||||||
]
|
]
|
||||||
where
|
where
|
||||||
ses = dbSesClient db
|
ses = dbSesClient db
|
||||||
sys = dbSysClient db
|
sys = dbSysClient db
|
||||||
brightessControls ctl getter = (toX . getter . ctl) ses
|
brightessControls ctl getter = (getter . ctl) ses
|
||||||
ib = Left . brightessControls intelBacklightControls
|
ib = Left . brightessControls intelBacklightControls
|
||||||
ck = Left . brightessControls clevoKeyboardControls
|
ck = Left . brightessControls clevoKeyboardControls
|
||||||
ftrAlways n = Right . Always n . Always_ . FallbackAlone
|
ftrAlways n = Right . Always n . Always_ . FallbackAlone
|
||||||
restartf = ftrAlways "restart function" (cleanup >> runRestart)
|
restartf = ftrAlways "restart function" (runCleanup ts db >> runRestart)
|
||||||
recompilef = ftrAlways "recompile function" runRecompile
|
recompilef = ftrAlways "recompile function" runRecompile
|
||||||
toX_ = liftIO . runIO
|
|
||||||
toX = fmap toX_
|
|
||||||
|
|
||||||
type MaybeX = Maybe (X ())
|
type MaybeX = Maybe (X ())
|
||||||
|
|
||||||
|
|
|
@ -5,17 +5,7 @@ module Data.Internal.DBus
|
||||||
( SafeClient (..)
|
( SafeClient (..)
|
||||||
, SysClient (..)
|
, SysClient (..)
|
||||||
, SesClient (..)
|
, SesClient (..)
|
||||||
, NamedConnection (..)
|
|
||||||
, NamedSesConnection
|
|
||||||
, NamedSysConnection
|
|
||||||
, DBusEnv (..)
|
|
||||||
, DIO
|
|
||||||
, HasClient (..)
|
|
||||||
, releaseBusName
|
|
||||||
, withDIO
|
|
||||||
, addMatchCallback
|
, addMatchCallback
|
||||||
, addMatchCallbackSignal
|
|
||||||
, matchSignalFull
|
|
||||||
, matchProperty
|
, matchProperty
|
||||||
, matchPropertyFull
|
, matchPropertyFull
|
||||||
, matchPropertyChanged
|
, matchPropertyChanged
|
||||||
|
@ -35,218 +25,93 @@ module Data.Internal.DBus
|
||||||
, addInterfaceRemovedListener
|
, addInterfaceRemovedListener
|
||||||
, fromSingletonVariant
|
, fromSingletonVariant
|
||||||
, bodyToMaybe
|
, bodyToMaybe
|
||||||
, exportPair
|
|
||||||
, displayBusName
|
|
||||||
, displayObjectPath
|
|
||||||
, displayMemberName
|
|
||||||
, displayInterfaceName
|
|
||||||
, displayWrapQuote
|
|
||||||
, busNameT
|
|
||||||
, interfaceNameT
|
|
||||||
, memberNameT
|
|
||||||
, objectPathT
|
|
||||||
)
|
)
|
||||||
where
|
where
|
||||||
|
|
||||||
import DBus
|
import DBus
|
||||||
import DBus.Client
|
import DBus.Client
|
||||||
import qualified Data.ByteString.Char8 as BC
|
|
||||||
import RIO
|
import RIO
|
||||||
import RIO.List
|
|
||||||
import qualified RIO.Map as M
|
import qualified RIO.Map as M
|
||||||
import qualified RIO.Text as T
|
import qualified RIO.Text as T
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- Type-safe client
|
-- Type-safe client
|
||||||
|
|
||||||
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
|
class SafeClient c where
|
||||||
|
toClient :: c -> Client
|
||||||
|
|
||||||
getDBusClient
|
getDBusClient
|
||||||
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
|
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
|
||||||
=> Maybe BusName
|
=> m (Maybe c)
|
||||||
-> m (Maybe (NamedConnection c))
|
|
||||||
|
|
||||||
disconnectDBusClient
|
disconnectDBusClient :: MonadUnliftIO m => c -> m ()
|
||||||
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
|
disconnectDBusClient = liftIO . disconnect . toClient
|
||||||
=> NamedConnection c
|
|
||||||
-> m ()
|
|
||||||
disconnectDBusClient c = do
|
|
||||||
releaseBusName c
|
|
||||||
liftIO $ disconnect $ ncClient c
|
|
||||||
|
|
||||||
withDBusClient
|
withDBusClient
|
||||||
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
|
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
|
||||||
=> Maybe BusName
|
=> (c -> m a)
|
||||||
-> (NamedConnection c -> m a)
|
|
||||||
-> m (Maybe a)
|
-> m (Maybe a)
|
||||||
withDBusClient n f =
|
withDBusClient f =
|
||||||
bracket (getDBusClient n) (mapM (liftIO . disconnect . ncClient)) $ mapM f
|
bracket getDBusClient (mapM (liftIO . disconnect . toClient)) $ mapM f
|
||||||
|
|
||||||
withDBusClient_
|
withDBusClient_
|
||||||
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
|
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
|
||||||
=> Maybe BusName
|
=> (c -> m ())
|
||||||
-> (NamedConnection c -> m ())
|
|
||||||
-> m ()
|
-> m ()
|
||||||
withDBusClient_ n = void . withDBusClient n
|
withDBusClient_ = void . withDBusClient
|
||||||
|
|
||||||
fromDBusClient
|
fromDBusClient
|
||||||
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
|
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
|
||||||
=> Maybe BusName
|
=> (c -> a)
|
||||||
-> (NamedConnection c -> a)
|
|
||||||
-> m (Maybe 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
|
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
|
instance SafeClient SesClient where
|
||||||
-- TODO wet
|
toClient (SesClient cl) = cl
|
||||||
getDBusClient = connectToDBusWithName False SesClient
|
|
||||||
|
|
||||||
connectToDBusWithName
|
getDBusClient = fmap SesClient <$> getSomeDBusClient False
|
||||||
:: (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
|
|
||||||
}
|
|
||||||
|
|
||||||
releaseBusName
|
getSomeDBusClient
|
||||||
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
|
|
||||||
=> NamedConnection c
|
|
||||||
-> m ()
|
|
||||||
releaseBusName NamedConnection {ncClient, ncHumanName} = do
|
|
||||||
-- TODO this might error?
|
|
||||||
case ncHumanName of
|
|
||||||
Just n -> do
|
|
||||||
liftIO $ void $ releaseName ncClient n
|
|
||||||
logInfo $ "released bus name: " <> displayBusName n
|
|
||||||
Nothing -> return ()
|
|
||||||
|
|
||||||
requestBusName
|
|
||||||
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
|
|
||||||
=> BusName
|
|
||||||
-> Client
|
|
||||||
-> m (Maybe BusName)
|
|
||||||
requestBusName n cl = do
|
|
||||||
res <- try $ liftIO $ requestName cl n []
|
|
||||||
case res of
|
|
||||||
Left e -> do
|
|
||||||
logError $ displayBytesUtf8 $ BC.pack $ clientErrorMessage e
|
|
||||||
return Nothing
|
|
||||||
Right r -> do
|
|
||||||
let msg
|
|
||||||
| r == NamePrimaryOwner = "registering name"
|
|
||||||
| r == NameAlreadyOwner = "this process already owns name"
|
|
||||||
| r == NameInQueue
|
|
||||||
|| r == NameExists =
|
|
||||||
"another process owns name"
|
|
||||||
-- this should never happen
|
|
||||||
| otherwise = "unknown error when requesting name"
|
|
||||||
logInfo $ msg <> ": " <> displayBusName n
|
|
||||||
case r of
|
|
||||||
NamePrimaryOwner -> return $ Just n
|
|
||||||
_ -> return Nothing
|
|
||||||
|
|
||||||
getDBusClient'
|
|
||||||
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
|
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
|
||||||
=> Bool
|
=> Bool
|
||||||
-> m (Maybe Client)
|
-> m (Maybe Client)
|
||||||
getDBusClient' sys = do
|
getSomeDBusClient sys = do
|
||||||
res <- try $ liftIO $ if sys then connectSystem else connectSession
|
res <- try $ liftIO $ if sys then connectSystem else connectSession
|
||||||
case res of
|
case res of
|
||||||
Left e -> do
|
Left e -> do
|
||||||
logInfo $ displayBytesUtf8 $ BC.pack $ clientErrorMessage e
|
logError $ Utf8Builder $ encodeUtf8Builder $ T.pack $ clientErrorMessage e
|
||||||
return Nothing
|
return Nothing
|
||||||
Right c -> return $ Just c
|
Right c -> return $ Just c
|
||||||
|
|
||||||
--callHello :: Client -> IO (Maybe BusName)
|
|
||||||
--callHello cl = do
|
|
||||||
-- reply <- call_ cl $ methodCallBus dbusName dbusPath dbusInterface "Hello"
|
|
||||||
-- case methodReturnBody reply of
|
|
||||||
-- [name] | Just nameStr <- fromVariant name -> do
|
|
||||||
-- busName <- parseBusName nameStr
|
|
||||||
-- return $ Just busName
|
|
||||||
-- _ -> return Nothing
|
|
||||||
--
|
|
||||||
data DBusEnv env c = DBusEnv {dClient :: !(NamedConnection c), dEnv :: !env}
|
|
||||||
|
|
||||||
type DIO env c = RIO (DBusEnv env c)
|
|
||||||
|
|
||||||
instance HasClient (DBusEnv SimpleApp) where
|
|
||||||
clientL = lens dClient (\x y -> x {dClient = y})
|
|
||||||
|
|
||||||
instance HasLogFunc (DBusEnv SimpleApp c) where
|
|
||||||
logFuncL = lens dEnv (\x y -> x {dEnv = y}) . logFuncL
|
|
||||||
|
|
||||||
withDIO
|
|
||||||
:: (MonadUnliftIO m, MonadReader env m)
|
|
||||||
=> NamedConnection c
|
|
||||||
-> DIO env c a
|
|
||||||
-> m a
|
|
||||||
withDIO cl x = do
|
|
||||||
env <- ask
|
|
||||||
runRIO (DBusEnv cl env) x
|
|
||||||
|
|
||||||
class HasClient env where
|
|
||||||
clientL :: SafeClient c => Lens' (env c) (NamedConnection c)
|
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- Methods
|
-- Methods
|
||||||
|
|
||||||
type MethodBody = Either T.Text [Variant]
|
type MethodBody = Either T.Text [Variant]
|
||||||
|
|
||||||
callMethod'
|
callMethod' :: (MonadUnliftIO m, SafeClient c) => c -> MethodCall -> m MethodBody
|
||||||
:: (SafeClient c, MonadUnliftIO m, MonadReader (env c) m, HasClient env)
|
callMethod' cl =
|
||||||
=> MethodCall
|
liftIO
|
||||||
-> m MethodBody
|
. fmap (bimap (T.pack . methodErrorMessage) methodReturnBody)
|
||||||
callMethod' mc = do
|
. call (toClient cl)
|
||||||
cl <- ncClient <$> view clientL
|
|
||||||
liftIO $ bimap (T.pack . methodErrorMessage) methodReturnBody <$> call cl mc
|
|
||||||
|
|
||||||
callMethod
|
callMethod
|
||||||
:: (SafeClient c, MonadUnliftIO m, MonadReader (env c) m, HasClient env)
|
:: (MonadUnliftIO m, SafeClient c)
|
||||||
=> BusName
|
=> c
|
||||||
|
-> BusName
|
||||||
-> ObjectPath
|
-> ObjectPath
|
||||||
-> InterfaceName
|
-> InterfaceName
|
||||||
-> MemberName
|
-> MemberName
|
||||||
-> m MethodBody
|
-> 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 :: BusName -> ObjectPath -> InterfaceName -> MemberName -> MethodCall
|
||||||
methodCallBus b p i m =
|
methodCallBus b p i m =
|
||||||
|
@ -260,22 +125,8 @@ methodCallBus b p i m =
|
||||||
dbusInterface :: InterfaceName
|
dbusInterface :: InterfaceName
|
||||||
dbusInterface = interfaceName_ "org.freedesktop.DBus"
|
dbusInterface = interfaceName_ "org.freedesktop.DBus"
|
||||||
|
|
||||||
callGetNameOwner
|
callGetNameOwner :: (MonadUnliftIO m, SafeClient c) => c -> BusName -> m (Maybe BusName)
|
||||||
:: ( SafeClient c
|
callGetNameOwner cl name = bodyToMaybe <$> callMethod' cl mc
|
||||||
, MonadUnliftIO m
|
|
||||||
, MonadReader (env c) m
|
|
||||||
, HasClient env
|
|
||||||
, HasLogFunc (env c)
|
|
||||||
)
|
|
||||||
=> BusName
|
|
||||||
-> m (Maybe BusName)
|
|
||||||
callGetNameOwner name = do
|
|
||||||
res <- callMethod' mc
|
|
||||||
case res of
|
|
||||||
Left err -> do
|
|
||||||
logError $ Utf8Builder $ encodeUtf8Builder err
|
|
||||||
return Nothing
|
|
||||||
Right body -> return $ fromSingletonVariant body
|
|
||||||
where
|
where
|
||||||
mc =
|
mc =
|
||||||
(methodCallBus dbusName dbusPath dbusInterface mem)
|
(methodCallBus dbusName dbusPath dbusInterface mem)
|
||||||
|
@ -286,7 +137,6 @@ callGetNameOwner name = do
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- Variant parsing
|
-- Variant parsing
|
||||||
|
|
||||||
-- TODO log failures here?
|
|
||||||
fromSingletonVariant :: IsVariant a => [Variant] -> Maybe a
|
fromSingletonVariant :: IsVariant a => [Variant] -> Maybe a
|
||||||
fromSingletonVariant = fromVariant <=< listToMaybe
|
fromSingletonVariant = fromVariant <=< listToMaybe
|
||||||
|
|
||||||
|
@ -298,29 +148,14 @@ bodyToMaybe = either (const Nothing) fromSingletonVariant
|
||||||
|
|
||||||
type SignalCallback m = [Variant] -> m ()
|
type SignalCallback m = [Variant] -> m ()
|
||||||
|
|
||||||
addMatchCallbackSignal
|
|
||||||
:: ( MonadReader (env c) m
|
|
||||||
, MonadUnliftIO m
|
|
||||||
, SafeClient c
|
|
||||||
, HasClient env
|
|
||||||
)
|
|
||||||
=> MatchRule
|
|
||||||
-> (Signal -> m ())
|
|
||||||
-> m SignalHandler
|
|
||||||
addMatchCallbackSignal rule cb = do
|
|
||||||
cl <- ncClient <$> view clientL
|
|
||||||
withRunInIO $ \run -> addMatch cl rule $ run . cb
|
|
||||||
|
|
||||||
addMatchCallback
|
addMatchCallback
|
||||||
:: ( MonadReader (env c) m
|
:: (MonadUnliftIO m, SafeClient c)
|
||||||
, MonadUnliftIO m
|
|
||||||
, SafeClient c
|
|
||||||
, HasClient env
|
|
||||||
)
|
|
||||||
=> MatchRule
|
=> MatchRule
|
||||||
-> SignalCallback m
|
-> SignalCallback m
|
||||||
|
-> c
|
||||||
-> m SignalHandler
|
-> m SignalHandler
|
||||||
addMatchCallback rule cb = addMatchCallbackSignal rule (cb . signalBody)
|
addMatchCallback rule cb cl = withRunInIO $ \run -> do
|
||||||
|
addMatch (toClient cl) rule $ run . cb . signalBody
|
||||||
|
|
||||||
matchSignal
|
matchSignal
|
||||||
:: Maybe BusName
|
:: Maybe BusName
|
||||||
|
@ -337,35 +172,15 @@ matchSignal b p i m =
|
||||||
}
|
}
|
||||||
|
|
||||||
matchSignalFull
|
matchSignalFull
|
||||||
:: ( MonadReader (env c) m
|
:: (MonadUnliftIO m, SafeClient c)
|
||||||
, HasLogFunc (env c)
|
=> c
|
||||||
, MonadUnliftIO m
|
-> BusName
|
||||||
, SafeClient c
|
|
||||||
, HasClient env
|
|
||||||
)
|
|
||||||
=> BusName
|
|
||||||
-> Maybe ObjectPath
|
-> Maybe ObjectPath
|
||||||
-> Maybe InterfaceName
|
-> Maybe InterfaceName
|
||||||
-> Maybe MemberName
|
-> Maybe MemberName
|
||||||
-> m (Maybe MatchRule)
|
-> m (Maybe MatchRule)
|
||||||
matchSignalFull b p i m = do
|
matchSignalFull client b p i m =
|
||||||
res <- callGetNameOwner b
|
fmap (\o -> matchSignal (Just o) p i m) <$> callGetNameOwner client b
|
||||||
case res of
|
|
||||||
Just o -> return $ Just $ matchSignal (Just o) p i m
|
|
||||||
Nothing -> do
|
|
||||||
logError msg
|
|
||||||
return Nothing
|
|
||||||
where
|
|
||||||
bus_ = displayWrapQuote $ displayBusName b
|
|
||||||
iface_ = displayWrapQuote . displayInterfaceName <$> i
|
|
||||||
path_ = displayWrapQuote . displayObjectPath <$> p
|
|
||||||
mem_ = displayWrapQuote . displayMemberName <$> m
|
|
||||||
match =
|
|
||||||
intersperse ", " $
|
|
||||||
mapMaybe (\(k, v) -> fmap ((k <> "=") <>) v) $
|
|
||||||
zip ["interface", "path", "member"] [iface_, path_, mem_]
|
|
||||||
stem = "could not get match rule for bus " <> bus_
|
|
||||||
msg = if null match then stem else stem <> " where " <> mconcat match
|
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- Properties
|
-- Properties
|
||||||
|
@ -377,42 +192,31 @@ propertySignal :: MemberName
|
||||||
propertySignal = memberName_ "PropertiesChanged"
|
propertySignal = memberName_ "PropertiesChanged"
|
||||||
|
|
||||||
callPropertyGet
|
callPropertyGet
|
||||||
:: ( HasClient env
|
:: (MonadUnliftIO m, SafeClient c)
|
||||||
, MonadReader (env c) m
|
|
||||||
, HasLogFunc (env c)
|
|
||||||
, MonadUnliftIO m
|
|
||||||
, SafeClient c
|
|
||||||
)
|
|
||||||
=> BusName
|
=> BusName
|
||||||
-> ObjectPath
|
-> ObjectPath
|
||||||
-> InterfaceName
|
-> InterfaceName
|
||||||
-> MemberName
|
-> MemberName
|
||||||
|
-> c
|
||||||
-> m [Variant]
|
-> m [Variant]
|
||||||
callPropertyGet bus path iface property = do
|
callPropertyGet bus path iface property cl =
|
||||||
cl <- ncClient <$> view clientL
|
liftIO $
|
||||||
res <- liftIO $ getProperty cl $ methodCallBus bus path iface property
|
fmap (either (const []) (: [])) $
|
||||||
case res of
|
getProperty (toClient cl) $
|
||||||
Left err -> do
|
methodCallBus bus path iface property
|
||||||
logError $ displayBytesUtf8 $ BC.pack $ methodErrorMessage err
|
|
||||||
return []
|
|
||||||
Right v -> return [v]
|
|
||||||
|
|
||||||
matchProperty :: Maybe BusName -> Maybe ObjectPath -> MatchRule
|
matchProperty :: Maybe BusName -> Maybe ObjectPath -> MatchRule
|
||||||
matchProperty b p =
|
matchProperty b p =
|
||||||
matchSignal b p (Just propertyInterface) (Just propertySignal)
|
matchSignal b p (Just propertyInterface) (Just propertySignal)
|
||||||
|
|
||||||
matchPropertyFull
|
matchPropertyFull
|
||||||
:: ( MonadReader (env c) m
|
:: (MonadUnliftIO m, SafeClient c)
|
||||||
, HasLogFunc (env c)
|
=> c
|
||||||
, MonadUnliftIO m
|
-> BusName
|
||||||
, SafeClient c
|
|
||||||
, HasClient env
|
|
||||||
)
|
|
||||||
=> BusName
|
|
||||||
-> Maybe ObjectPath
|
-> Maybe ObjectPath
|
||||||
-> m (Maybe MatchRule)
|
-> m (Maybe MatchRule)
|
||||||
matchPropertyFull b p =
|
matchPropertyFull cl b p =
|
||||||
matchSignalFull b p (Just propertyInterface) (Just propertySignal)
|
matchSignalFull cl b p (Just propertyInterface) (Just propertySignal)
|
||||||
|
|
||||||
data SignalMatch a = Match a | NoMatch | Failure deriving (Eq, Show)
|
data SignalMatch a = Match a | NoMatch | Failure deriving (Eq, Show)
|
||||||
|
|
||||||
|
@ -424,26 +228,26 @@ withSignalMatch _ NoMatch = return ()
|
||||||
matchPropertyChanged
|
matchPropertyChanged
|
||||||
:: IsVariant a
|
:: IsVariant a
|
||||||
=> InterfaceName
|
=> InterfaceName
|
||||||
-> MemberName
|
-> T.Text
|
||||||
-> [Variant]
|
-> [Variant]
|
||||||
-> SignalMatch a
|
-> SignalMatch a
|
||||||
matchPropertyChanged iface property [sigIface, sigValues, _] =
|
matchPropertyChanged iface property [i, body, _] =
|
||||||
let i = fromVariant sigIface :: Maybe T.Text
|
let i' = (fromVariant i :: Maybe T.Text)
|
||||||
v = fromVariant sigValues :: Maybe (M.Map T.Text Variant)
|
b = toMap body
|
||||||
in case (i, v) of
|
in case (i', b) of
|
||||||
(Just i', Just v') ->
|
(Just i'', Just b') ->
|
||||||
if i' == interfaceNameT iface
|
if i'' == T.pack (formatInterfaceName iface)
|
||||||
then
|
then maybe NoMatch Match $ fromVariant =<< M.lookup property b'
|
||||||
maybe NoMatch Match $
|
|
||||||
fromVariant =<< M.lookup (memberNameT property) v'
|
|
||||||
else NoMatch
|
else NoMatch
|
||||||
_ -> Failure
|
_ -> Failure
|
||||||
|
where
|
||||||
|
toMap v = fromVariant v :: Maybe (M.Map T.Text Variant)
|
||||||
matchPropertyChanged _ _ _ = Failure
|
matchPropertyChanged _ _ _ = Failure
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- Object Manager
|
-- Object Manager
|
||||||
|
|
||||||
type ObjectTree = M.Map ObjectPath (M.Map InterfaceName (M.Map T.Text Variant))
|
type ObjectTree = M.Map ObjectPath (M.Map T.Text (M.Map T.Text Variant))
|
||||||
|
|
||||||
omInterface :: InterfaceName
|
omInterface :: InterfaceName
|
||||||
omInterface = interfaceName_ "org.freedesktop.DBus.ObjectManager"
|
omInterface = interfaceName_ "org.freedesktop.DBus.ObjectManager"
|
||||||
|
@ -458,132 +262,43 @@ omInterfacesRemoved :: MemberName
|
||||||
omInterfacesRemoved = memberName_ "InterfacesRemoved"
|
omInterfacesRemoved = memberName_ "InterfacesRemoved"
|
||||||
|
|
||||||
callGetManagedObjects
|
callGetManagedObjects
|
||||||
:: ( MonadReader (env c) m
|
:: (MonadUnliftIO m, SafeClient c)
|
||||||
, HasLogFunc (env c)
|
=> c
|
||||||
, MonadUnliftIO m
|
-> BusName
|
||||||
, SafeClient c
|
|
||||||
, HasClient env
|
|
||||||
)
|
|
||||||
=> BusName
|
|
||||||
-> ObjectPath
|
-> ObjectPath
|
||||||
-> m ObjectTree
|
-> m ObjectTree
|
||||||
callGetManagedObjects bus path = do
|
callGetManagedObjects cl bus path =
|
||||||
res <- callMethod bus path omInterface getManagedObjects
|
either (const M.empty) (fromMaybe M.empty . fromSingletonVariant)
|
||||||
case res of
|
<$> callMethod cl bus path omInterface getManagedObjects
|
||||||
Left err -> do
|
|
||||||
logError $ Utf8Builder $ encodeUtf8Builder err
|
|
||||||
return M.empty
|
|
||||||
Right v ->
|
|
||||||
return $
|
|
||||||
fmap (M.mapKeys interfaceName_) $
|
|
||||||
fromMaybe M.empty $
|
|
||||||
fromSingletonVariant v
|
|
||||||
|
|
||||||
addInterfaceChangedListener
|
addInterfaceChangedListener
|
||||||
:: ( MonadReader (env c) m
|
:: (MonadUnliftIO m, SafeClient c)
|
||||||
, HasLogFunc (env c)
|
|
||||||
, MonadUnliftIO m
|
|
||||||
, SafeClient c
|
|
||||||
, HasClient env
|
|
||||||
)
|
|
||||||
=> BusName
|
=> BusName
|
||||||
-> MemberName
|
-> MemberName
|
||||||
-> ObjectPath
|
-> ObjectPath
|
||||||
-> SignalCallback m
|
-> SignalCallback m
|
||||||
|
-> c
|
||||||
-> m (Maybe SignalHandler)
|
-> m (Maybe SignalHandler)
|
||||||
addInterfaceChangedListener bus prop path sc = do
|
addInterfaceChangedListener bus prop path sc cl = do
|
||||||
res <- matchSignalFull bus (Just path) (Just omInterface) (Just prop)
|
rule <- matchSignalFull cl bus (Just path) (Just omInterface) (Just prop)
|
||||||
case res of
|
forM rule $ \r -> addMatchCallback r sc cl
|
||||||
Nothing -> do
|
|
||||||
logError $
|
|
||||||
"could not add listener for property"
|
|
||||||
<> prop_
|
|
||||||
<> " at path "
|
|
||||||
<> path_
|
|
||||||
<> " on bus "
|
|
||||||
<> bus_
|
|
||||||
return Nothing
|
|
||||||
Just rule -> Just <$> addMatchCallback rule sc
|
|
||||||
where
|
|
||||||
bus_ = "'" <> displayBusName bus <> "'"
|
|
||||||
path_ = "'" <> displayObjectPath path <> "'"
|
|
||||||
prop_ = "'" <> displayMemberName prop <> "'"
|
|
||||||
|
|
||||||
addInterfaceAddedListener
|
addInterfaceAddedListener
|
||||||
:: ( MonadReader (env c) m
|
:: (MonadUnliftIO m, SafeClient c)
|
||||||
, HasLogFunc (env c)
|
|
||||||
, MonadUnliftIO m
|
|
||||||
, SafeClient c
|
|
||||||
, HasClient env
|
|
||||||
)
|
|
||||||
=> BusName
|
=> BusName
|
||||||
-> ObjectPath
|
-> ObjectPath
|
||||||
-> SignalCallback m
|
-> SignalCallback m
|
||||||
|
-> c
|
||||||
-> m (Maybe SignalHandler)
|
-> m (Maybe SignalHandler)
|
||||||
addInterfaceAddedListener bus =
|
addInterfaceAddedListener bus =
|
||||||
addInterfaceChangedListener bus omInterfacesAdded
|
addInterfaceChangedListener bus omInterfacesAdded
|
||||||
|
|
||||||
addInterfaceRemovedListener
|
addInterfaceRemovedListener
|
||||||
:: ( MonadReader (env c) m
|
:: (MonadUnliftIO m, SafeClient c)
|
||||||
, HasLogFunc (env c)
|
|
||||||
, MonadUnliftIO m
|
|
||||||
, SafeClient c
|
|
||||||
, HasClient env
|
|
||||||
)
|
|
||||||
=> BusName
|
=> BusName
|
||||||
-> ObjectPath
|
-> ObjectPath
|
||||||
-> SignalCallback m
|
-> SignalCallback m
|
||||||
|
-> c
|
||||||
-> m (Maybe SignalHandler)
|
-> m (Maybe SignalHandler)
|
||||||
addInterfaceRemovedListener bus =
|
addInterfaceRemovedListener bus =
|
||||||
addInterfaceChangedListener bus omInterfacesRemoved
|
addInterfaceChangedListener bus omInterfacesRemoved
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
|
||||||
-- Interface export/unexport
|
|
||||||
|
|
||||||
exportPair
|
|
||||||
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
|
|
||||||
=> ObjectPath
|
|
||||||
-> (Client -> m Interface)
|
|
||||||
-> NamedConnection c
|
|
||||||
-> (m (), m ())
|
|
||||||
exportPair path toIface cl = (up, down)
|
|
||||||
where
|
|
||||||
cl_ = ncClient cl
|
|
||||||
up = do
|
|
||||||
logInfo $ "adding interface: " <> path_
|
|
||||||
i <- toIface cl_
|
|
||||||
liftIO $ export cl_ path i
|
|
||||||
down = do
|
|
||||||
logInfo $ "removing interface: " <> path_
|
|
||||||
liftIO $ unexport cl_ path
|
|
||||||
path_ = displayObjectPath path
|
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
|
||||||
-- logging helpers
|
|
||||||
|
|
||||||
busNameT :: BusName -> T.Text
|
|
||||||
busNameT = T.pack . formatBusName
|
|
||||||
|
|
||||||
objectPathT :: ObjectPath -> T.Text
|
|
||||||
objectPathT = T.pack . formatObjectPath
|
|
||||||
|
|
||||||
interfaceNameT :: InterfaceName -> T.Text
|
|
||||||
interfaceNameT = T.pack . formatInterfaceName
|
|
||||||
|
|
||||||
memberNameT :: MemberName -> T.Text
|
|
||||||
memberNameT = T.pack . formatMemberName
|
|
||||||
|
|
||||||
displayBusName :: BusName -> Utf8Builder
|
|
||||||
displayBusName = displayBytesUtf8 . BC.pack . formatBusName
|
|
||||||
|
|
||||||
displayObjectPath :: ObjectPath -> Utf8Builder
|
|
||||||
displayObjectPath = displayBytesUtf8 . BC.pack . formatObjectPath
|
|
||||||
|
|
||||||
displayMemberName :: MemberName -> Utf8Builder
|
|
||||||
displayMemberName = displayBytesUtf8 . BC.pack . formatMemberName
|
|
||||||
|
|
||||||
displayInterfaceName :: InterfaceName -> Utf8Builder
|
|
||||||
displayInterfaceName = displayBytesUtf8 . BC.pack . formatInterfaceName
|
|
||||||
|
|
||||||
displayWrapQuote :: Utf8Builder -> Utf8Builder
|
|
||||||
displayWrapQuote x = "'" <> x <> "'"
|
|
||||||
|
|
|
@ -1,7 +1,14 @@
|
||||||
|
{-# LANGUAGE DeriveFunctor #-}
|
||||||
|
{-# LANGUAGE DeriveGeneric #-}
|
||||||
|
{-# LANGUAGE GADTs #-}
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
{-# LANGUAGE RankNTypes #-}
|
||||||
|
{-# LANGUAGE ScopedTypeVariables #-}
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- Functions for handling dependencies
|
-- Functions for handling dependencies
|
||||||
|
|
||||||
module Data.Internal.XIO
|
module Data.Internal.Dependency
|
||||||
-- feature types
|
-- feature types
|
||||||
( Feature
|
( Feature
|
||||||
, Always (..)
|
, Always (..)
|
||||||
|
@ -19,7 +26,6 @@ module Data.Internal.XIO
|
||||||
, SubfeatureRoot
|
, SubfeatureRoot
|
||||||
, Msg (..)
|
, Msg (..)
|
||||||
-- configuration
|
-- configuration
|
||||||
, XEnv (..)
|
|
||||||
, XParams (..)
|
, XParams (..)
|
||||||
, XPFeatures (..)
|
, XPFeatures (..)
|
||||||
, XPQuery
|
, XPQuery
|
||||||
|
@ -47,9 +53,8 @@ module Data.Internal.XIO
|
||||||
, dumpSometimes
|
, dumpSometimes
|
||||||
, showFulfillment
|
, showFulfillment
|
||||||
-- testing
|
-- testing
|
||||||
, XIO
|
, FIO
|
||||||
, runXIO
|
, withCache
|
||||||
, hRunXIO
|
|
||||||
, evalFeature
|
, evalFeature
|
||||||
, executeSometimes
|
, executeSometimes
|
||||||
, executeAlways
|
, executeAlways
|
||||||
|
@ -91,7 +96,6 @@ module Data.Internal.XIO
|
||||||
, process
|
, process
|
||||||
-- misc
|
-- misc
|
||||||
, shellTest
|
, shellTest
|
||||||
, withLogFile
|
|
||||||
)
|
)
|
||||||
where
|
where
|
||||||
|
|
||||||
|
@ -100,7 +104,6 @@ import qualified DBus.Introspection as I
|
||||||
import Data.Aeson hiding (Error, Result)
|
import Data.Aeson hiding (Error, Result)
|
||||||
import Data.Aeson.Key
|
import Data.Aeson.Key
|
||||||
import Data.Internal.DBus
|
import Data.Internal.DBus
|
||||||
import qualified Data.Text.IO as TI
|
|
||||||
import Data.Yaml
|
import Data.Yaml
|
||||||
import GHC.IO.Exception (ioe_description)
|
import GHC.IO.Exception (ioe_description)
|
||||||
import RIO hiding (bracket, fromString)
|
import RIO hiding (bracket, fromString)
|
||||||
|
@ -112,7 +115,7 @@ import qualified RIO.Text as T
|
||||||
import System.Posix.Files
|
import System.Posix.Files
|
||||||
import System.Process.Typed (nullStream)
|
import System.Process.Typed (nullStream)
|
||||||
import UnliftIO.Environment
|
import UnliftIO.Environment
|
||||||
import XMonad.Core (X, dataDir, getDirectories, io)
|
import XMonad.Core (X, io)
|
||||||
import XMonad.Internal.IO
|
import XMonad.Internal.IO
|
||||||
import XMonad.Internal.Shell hiding (proc, runProcess)
|
import XMonad.Internal.Shell hiding (proc, runProcess)
|
||||||
import XMonad.Internal.Theme
|
import XMonad.Internal.Theme
|
||||||
|
@ -125,47 +128,30 @@ import XMonad.Internal.Theme
|
||||||
|
|
||||||
-- | Run feature evaluation(s) with the cache
|
-- | Run feature evaluation(s) with the cache
|
||||||
-- Currently there is no easy way to not use this (oh well)
|
-- Currently there is no easy way to not use this (oh well)
|
||||||
runXIO :: FilePath -> XIO a -> IO a
|
withCache :: FIO a -> IO a
|
||||||
runXIO logfile x = withLogFile logfile $ \h -> hRunXIO True h x
|
withCache x = do
|
||||||
|
logOpts <- logOptionsHandle stderr False
|
||||||
-- TODO use dhall to encode config file and log here to control the loglevel
|
|
||||||
withLogFile :: MonadUnliftIO m => FilePath -> (Handle -> m a) -> m a
|
|
||||||
withLogFile logfile f = do
|
|
||||||
p <- (</> logfile) . dataDir <$> liftIO getDirectories
|
|
||||||
catchIO (withBinaryFile p AppendMode f) $ \e -> do
|
|
||||||
liftIO $ TI.putStrLn $ T.pack $ show e
|
|
||||||
liftIO $ TI.putStrLn "could not open log file, falling back to stderr"
|
|
||||||
f stderr
|
|
||||||
|
|
||||||
hRunXIO :: Bool -> Handle -> XIO a -> IO a
|
|
||||||
hRunXIO verbose h x = do
|
|
||||||
hSetBuffering h LineBuffering
|
|
||||||
logOpts <- logOptionsHandle_ verbose h
|
|
||||||
pc <- mkDefaultProcessContext
|
pc <- mkDefaultProcessContext
|
||||||
withLogFunc logOpts $ \f -> do
|
withLogFunc logOpts $ \f -> do
|
||||||
p <- getParams
|
p <- getParams
|
||||||
let s = XEnv f pc p
|
let s = DepStage f pc p
|
||||||
runRIO s x
|
runRIO s x
|
||||||
|
|
||||||
logOptionsHandle_ :: MonadUnliftIO m => Bool -> Handle -> m LogOptions
|
|
||||||
logOptionsHandle_ v h =
|
|
||||||
setLogVerboseFormat v . setLogUseTime v <$> logOptionsHandle h False
|
|
||||||
|
|
||||||
-- | Execute an Always immediately
|
-- | Execute an Always immediately
|
||||||
executeAlways :: Always (IO a) -> XIO a
|
executeAlways :: Always (IO a) -> FIO a
|
||||||
executeAlways = io <=< evalAlways
|
executeAlways = io <=< evalAlways
|
||||||
|
|
||||||
-- | Execute a Sometimes immediately (or do nothing if failure)
|
-- | Execute a Sometimes immediately (or do nothing if failure)
|
||||||
executeSometimes :: Sometimes (XIO a) -> XIO (Maybe a)
|
executeSometimes :: Sometimes (FIO a) -> FIO (Maybe a)
|
||||||
executeSometimes a = maybe (return Nothing) (fmap Just) =<< evalSometimes a
|
executeSometimes a = maybe (return Nothing) (fmap Just) =<< evalSometimes a
|
||||||
|
|
||||||
-- | Possibly return the action of an Always/Sometimes
|
-- | Possibly return the action of an Always/Sometimes
|
||||||
evalFeature :: Feature a -> XIO (Maybe a)
|
evalFeature :: Feature a -> FIO (Maybe a)
|
||||||
evalFeature (Right a) = Just <$> evalAlways a
|
evalFeature (Right a) = Just <$> evalAlways a
|
||||||
evalFeature (Left s) = evalSometimes s
|
evalFeature (Left s) = evalSometimes s
|
||||||
|
|
||||||
-- | Possibly return the action of a Sometimes
|
-- | Possibly return the action of a Sometimes
|
||||||
evalSometimes :: Sometimes a -> XIO (Maybe a)
|
evalSometimes :: Sometimes a -> FIO (Maybe a)
|
||||||
evalSometimes x = either goFail goPass =<< evalSometimesMsg x
|
evalSometimes x = either goFail goPass =<< evalSometimesMsg x
|
||||||
where
|
where
|
||||||
goPass (a, ws) = putErrors ws >> return (Just a)
|
goPass (a, ws) = putErrors ws >> return (Just a)
|
||||||
|
@ -173,13 +159,13 @@ evalSometimes x = either goFail goPass =<< evalSometimesMsg x
|
||||||
putErrors = mapM_ logMsg
|
putErrors = mapM_ logMsg
|
||||||
|
|
||||||
-- | Return the action of an Always
|
-- | Return the action of an Always
|
||||||
evalAlways :: Always a -> XIO a
|
evalAlways :: Always a -> FIO a
|
||||||
evalAlways a = do
|
evalAlways a = do
|
||||||
(x, ws) <- evalAlwaysMsg a
|
(x, ws) <- evalAlwaysMsg a
|
||||||
mapM_ logMsg ws
|
mapM_ logMsg ws
|
||||||
return x
|
return x
|
||||||
|
|
||||||
logMsg :: FMsg -> XIO ()
|
logMsg :: FMsg -> FIO ()
|
||||||
logMsg (FMsg fn n (Msg ll m)) = do
|
logMsg (FMsg fn n (Msg ll m)) = do
|
||||||
p <- io getProgName
|
p <- io getProgName
|
||||||
f $ Utf8Builder $ encodeUtf8Builder $ T.unwords $ fmt s (T.pack p)
|
f $ Utf8Builder $ encodeUtf8Builder $ T.unwords $ fmt s (T.pack p)
|
||||||
|
@ -200,9 +186,8 @@ logMsg (FMsg fn n (Msg ll m)) = do
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- Package status
|
-- Package status
|
||||||
|
|
||||||
showFulfillment :: Fulfillment -> Utf8Builder
|
showFulfillment :: Fulfillment -> T.Text
|
||||||
showFulfillment (Package t n) =
|
showFulfillment (Package t n) = T.concat [T.pack $ show t, "\t", n]
|
||||||
displayShow t <> "\t" <> Utf8Builder (encodeUtf8Builder n)
|
|
||||||
|
|
||||||
dumpFeature :: Feature a -> [Fulfillment]
|
dumpFeature :: Feature a -> [Fulfillment]
|
||||||
dumpFeature = either dumpSometimes dumpAlways
|
dumpFeature = either dumpSometimes dumpAlways
|
||||||
|
@ -224,7 +209,7 @@ type AlwaysIO = Always (IO ())
|
||||||
|
|
||||||
type SometimesX = Sometimes (X ())
|
type SometimesX = Sometimes (X ())
|
||||||
|
|
||||||
type SometimesIO = Sometimes (XIO ())
|
type SometimesIO = Sometimes (FIO ())
|
||||||
|
|
||||||
type Feature a = Either (Sometimes a) (Always a)
|
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
|
-- | Feature that is guaranteed to work
|
||||||
-- This is composed of sub-features that are tested in order, and if all fail
|
-- This is composed of sub-features that are tested in order, and if all fail
|
||||||
-- the fallback is a monadic action (eg a plain haskell function)
|
-- the fallback is a monadic action (eg a plain haskell function)
|
||||||
data Always a = Always T.Text (Always_ a) deriving (Functor)
|
data Always a = Always T.Text (Always_ a)
|
||||||
|
|
||||||
-- | Feature that is guaranteed to work (inner data)
|
-- | Feature that is guaranteed to work (inner data)
|
||||||
data Always_ a
|
data Always_ a
|
||||||
= Option (SubfeatureRoot a) (Always_ a)
|
= Option (SubfeatureRoot a) (Always_ a)
|
||||||
| Always_ (FallbackRoot a)
|
| Always_ (FallbackRoot a)
|
||||||
deriving (Functor)
|
|
||||||
|
|
||||||
-- | Root of a fallback action for an always
|
-- | Root of a fallback action for an always
|
||||||
-- This may either be a lone action or a function that depends on the results
|
-- This may either be a lone action or a function that depends on the results
|
||||||
|
@ -249,23 +233,15 @@ data FallbackRoot a
|
||||||
= FallbackAlone a
|
= FallbackAlone a
|
||||||
| forall p. FallbackTree (p -> a) (FallbackStack p)
|
| forall p. FallbackTree (p -> a) (FallbackStack p)
|
||||||
|
|
||||||
instance Functor FallbackRoot where
|
|
||||||
fmap f (FallbackAlone a) = FallbackAlone (f a)
|
|
||||||
fmap f (FallbackTree g s) = FallbackTree (f . g) s
|
|
||||||
|
|
||||||
-- | Always features that are used as a payload for a fallback action
|
-- | Always features that are used as a payload for a fallback action
|
||||||
data FallbackStack p
|
data FallbackStack p
|
||||||
= FallbackBottom (Always p)
|
= FallbackBottom (Always p)
|
||||||
| forall x y. FallbackStack (x -> y -> p) (Always x) (FallbackStack y)
|
| forall x y. FallbackStack (x -> y -> p) (Always x) (FallbackStack y)
|
||||||
|
|
||||||
instance Functor FallbackStack where
|
|
||||||
fmap f (FallbackBottom a) = FallbackBottom $ fmap f a
|
|
||||||
fmap f (FallbackStack g a s) = FallbackStack (\x -> f . g x) a s
|
|
||||||
|
|
||||||
-- | Feature that might not be present
|
-- | Feature that might not be present
|
||||||
-- This is like an Always except it doesn't fall back on a guaranteed monadic
|
-- This is like an Always except it doesn't fall back on a guaranteed monadic
|
||||||
-- action
|
-- action
|
||||||
data Sometimes a = Sometimes T.Text XPQuery (Sometimes_ a) deriving (Functor)
|
data Sometimes a = Sometimes T.Text XPQuery (Sometimes_ a)
|
||||||
|
|
||||||
-- | Feature that might not be present (inner data)
|
-- | Feature that might not be present (inner data)
|
||||||
type Sometimes_ a = [SubfeatureRoot a]
|
type Sometimes_ a = [SubfeatureRoot a]
|
||||||
|
@ -278,7 +254,6 @@ data Subfeature f = Subfeature
|
||||||
{ sfData :: f
|
{ sfData :: f
|
||||||
, sfName :: T.Text
|
, sfName :: T.Text
|
||||||
}
|
}
|
||||||
deriving (Functor)
|
|
||||||
|
|
||||||
type SubfeatureRoot a = Subfeature (Root a)
|
type SubfeatureRoot a = Subfeature (Root a)
|
||||||
|
|
||||||
|
@ -288,24 +263,8 @@ type SubfeatureRoot a = Subfeature (Root a)
|
||||||
data Root a
|
data Root a
|
||||||
= forall p. IORoot (p -> a) (IOTree p)
|
= forall p. IORoot (p -> a) (IOTree p)
|
||||||
| IORoot_ a IOTree_
|
| IORoot_ a IOTree_
|
||||||
| forall c p.
|
| forall c p. SafeClient c => DBusRoot (p -> c -> a) (DBusTree c p) (Maybe c)
|
||||||
SafeClient c =>
|
| forall c. SafeClient c => DBusRoot_ (c -> a) (DBusTree_ c) (Maybe c)
|
||||||
DBusRoot
|
|
||||||
(p -> NamedConnection c -> a)
|
|
||||||
(DBusTree c p)
|
|
||||||
(Maybe (NamedConnection c))
|
|
||||||
| forall c.
|
|
||||||
SafeClient c =>
|
|
||||||
DBusRoot_
|
|
||||||
(NamedConnection c -> a)
|
|
||||||
(DBusTree_ c)
|
|
||||||
(Maybe (NamedConnection c))
|
|
||||||
|
|
||||||
instance Functor Root where
|
|
||||||
fmap f (IORoot a t) = IORoot (f . a) t
|
|
||||||
fmap f (IORoot_ a t) = IORoot_ (f a) t
|
|
||||||
fmap f (DBusRoot a t cl) = DBusRoot (\p c -> f $ a p c) t cl
|
|
||||||
fmap f (DBusRoot_ a t cl) = DBusRoot_ (f . a) t cl
|
|
||||||
|
|
||||||
-- | The dependency tree with rule to merge results when needed
|
-- | The dependency tree with rule to merge results when needed
|
||||||
data Tree d d_ p
|
data Tree d d_ p
|
||||||
|
@ -330,7 +289,7 @@ type DBusTree_ c = Tree_ (DBusDependency_ c)
|
||||||
-- | A dependency that only requires IO to evaluate (with payload)
|
-- | A dependency that only requires IO to evaluate (with payload)
|
||||||
data IODependency p
|
data IODependency p
|
||||||
= -- an IO action that yields a payload
|
= -- an IO action that yields a payload
|
||||||
IORead T.Text [Fulfillment] (XIO (Result p))
|
IORead T.Text [Fulfillment] (FIO (Result p))
|
||||||
| -- always yields a payload
|
| -- always yields a payload
|
||||||
IOConst p
|
IOConst p
|
||||||
| -- an always that yields a payload
|
| -- an always that yields a payload
|
||||||
|
@ -343,11 +302,12 @@ data DBusDependency_ c
|
||||||
= Bus [Fulfillment] BusName
|
= Bus [Fulfillment] BusName
|
||||||
| Endpoint [Fulfillment] BusName ObjectPath InterfaceName DBusMember
|
| Endpoint [Fulfillment] BusName ObjectPath InterfaceName DBusMember
|
||||||
| DBusIO IODependency_
|
| DBusIO IODependency_
|
||||||
|
deriving (Generic)
|
||||||
|
|
||||||
-- | A dependency that only requires IO to evaluate (no payload)
|
-- | A dependency that only requires IO to evaluate (no payload)
|
||||||
data IODependency_
|
data IODependency_
|
||||||
= IOSystem_ [Fulfillment] SystemDependency
|
= IOSystem_ [Fulfillment] SystemDependency
|
||||||
| IOTest_ T.Text [Fulfillment] (XIO (Maybe Msg))
|
| IOTest_ T.Text [Fulfillment] (FIO (Maybe Msg))
|
||||||
| forall a. IOSometimes_ (Sometimes a)
|
| forall a. IOSometimes_ (Sometimes a)
|
||||||
|
|
||||||
-- | A system component to an IODependency
|
-- | A system component to an IODependency
|
||||||
|
@ -357,23 +317,23 @@ data SystemDependency
|
||||||
| AccessiblePath FilePath Bool Bool
|
| AccessiblePath FilePath Bool Bool
|
||||||
| Systemd UnitType T.Text
|
| Systemd UnitType T.Text
|
||||||
| Process T.Text
|
| Process T.Text
|
||||||
deriving (Eq, Show)
|
deriving (Eq, Show, Generic)
|
||||||
|
|
||||||
-- | The type of a systemd service
|
-- | 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
|
-- | Wrapper type to describe and endpoint
|
||||||
data DBusMember
|
data DBusMember
|
||||||
= Method_ MemberName
|
= Method_ MemberName
|
||||||
| Signal_ MemberName
|
| Signal_ MemberName
|
||||||
| Property_ T.Text
|
| Property_ T.Text
|
||||||
deriving (Eq, Show)
|
deriving (Eq, Show, Generic)
|
||||||
|
|
||||||
-- | A means to fulfill a dependency
|
-- | A means to fulfill a dependency
|
||||||
-- For now this is just the name of an Arch Linux package (AUR or official)
|
-- For now this is just the name of an Arch Linux package (AUR or official)
|
||||||
data Fulfillment = Package ArchPkg T.Text deriving (Eq, Show, Ord)
|
data Fulfillment = Package ArchPkg T.Text deriving (Eq, Show, Ord)
|
||||||
|
|
||||||
data ArchPkg = Official | AUR | Custom deriving (Eq, Show, Ord)
|
data ArchPkg = Official | AUR | Custom deriving (Eq, Show, Generic, Ord)
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- Tested dependency tree
|
-- Tested dependency tree
|
||||||
|
@ -416,25 +376,19 @@ data PostFail = PostFail [Msg] | PostMissing Msg
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- Configuration
|
-- Configuration
|
||||||
|
|
||||||
type XIO a = RIO XEnv a
|
type FIO a = RIO DepStage a
|
||||||
|
|
||||||
data XEnv = XEnv
|
data DepStage = DepStage
|
||||||
{ xLogFun :: !LogFunc
|
{ dsLogFun :: !LogFunc
|
||||||
, xProcCxt :: !ProcessContext
|
, dsProcCxt :: !ProcessContext
|
||||||
, xParams :: !XParams
|
, dsParams :: !XParams
|
||||||
}
|
}
|
||||||
|
|
||||||
instance HasLogFunc XEnv where
|
instance HasLogFunc DepStage where
|
||||||
logFuncL = lens xLogFun (\x y -> x {xLogFun = y})
|
logFuncL = lens dsLogFun (\x y -> x {dsLogFun = y})
|
||||||
|
|
||||||
instance HasLogFunc (DBusEnv XEnv c) where
|
instance HasProcessContext DepStage where
|
||||||
logFuncL = lens dEnv (\x y -> x {dEnv = y}) . logFuncL
|
processContextL = lens dsProcCxt (\x y -> x {dsProcCxt = y})
|
||||||
|
|
||||||
instance HasProcessContext XEnv where
|
|
||||||
processContextL = lens xProcCxt (\x y -> x {xProcCxt = y})
|
|
||||||
|
|
||||||
instance HasClient (DBusEnv XEnv) where
|
|
||||||
clientL = lens dClient (\x y -> x {dClient = y})
|
|
||||||
|
|
||||||
data XParams = XParams
|
data XParams = XParams
|
||||||
{ xpLogLevel :: LogLevel
|
{ xpLogLevel :: LogLevel
|
||||||
|
@ -468,8 +422,7 @@ data XPFeatures = XPFeatures
|
||||||
, xpfIntelBacklight :: Bool
|
, xpfIntelBacklight :: Bool
|
||||||
, xpfClevoBacklight :: Bool
|
, xpfClevoBacklight :: Bool
|
||||||
, xpfBattery :: Bool
|
, xpfBattery :: Bool
|
||||||
, xpfEthPrefix :: Maybe Text
|
, xpfF5VPN :: Bool
|
||||||
, xpfWifiPrefix :: Maybe Text
|
|
||||||
}
|
}
|
||||||
|
|
||||||
instance FromJSON XPFeatures where
|
instance FromJSON XPFeatures where
|
||||||
|
@ -496,9 +449,7 @@ instance FromJSON XPFeatures where
|
||||||
<*> o
|
<*> o
|
||||||
.:+ "battery"
|
.:+ "battery"
|
||||||
<*> o
|
<*> o
|
||||||
.:? "ethPrefix"
|
.:+ "f5vpn"
|
||||||
<*> o
|
|
||||||
.:? "wifiPrefix"
|
|
||||||
|
|
||||||
defParams :: XParams
|
defParams :: XParams
|
||||||
defParams =
|
defParams =
|
||||||
|
@ -521,8 +472,7 @@ defXPFeatures =
|
||||||
, xpfIntelBacklight = False
|
, xpfIntelBacklight = False
|
||||||
, xpfClevoBacklight = False
|
, xpfClevoBacklight = False
|
||||||
, xpfBattery = False
|
, xpfBattery = False
|
||||||
, xpfEthPrefix = Nothing
|
, xpfF5VPN = False
|
||||||
, xpfWifiPrefix = Nothing
|
|
||||||
}
|
}
|
||||||
|
|
||||||
type XPQuery = XPFeatures -> Bool
|
type XPQuery = XPFeatures -> Bool
|
||||||
|
@ -533,7 +483,7 @@ getParams = do
|
||||||
maybe (return defParams) (liftIO . decodeYaml) p
|
maybe (return defParams) (liftIO . decodeYaml) p
|
||||||
where
|
where
|
||||||
decodeYaml p =
|
decodeYaml p =
|
||||||
either (\e -> TI.putStrLn (T.pack $ show e) >> return defParams) return
|
either (\e -> print e >> return defParams) return
|
||||||
=<< decodeFileEither p
|
=<< decodeFileEither p
|
||||||
|
|
||||||
getParamFile :: MonadIO m => m (Maybe FilePath)
|
getParamFile :: MonadIO m => m (Maybe FilePath)
|
||||||
|
@ -557,9 +507,9 @@ infix 9 .:+
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- Testing pipeline
|
-- Testing pipeline
|
||||||
|
|
||||||
evalSometimesMsg :: Sometimes a -> XIO (Either [FMsg] (a, [FMsg]))
|
evalSometimesMsg :: Sometimes a -> FIO (Either [FMsg] (a, [FMsg]))
|
||||||
evalSometimesMsg (Sometimes n u xs) = do
|
evalSometimesMsg (Sometimes n u xs) = do
|
||||||
r <- asks (u . xpFeatures . xParams)
|
r <- asks (u . xpFeatures . dsParams)
|
||||||
if not r
|
if not r
|
||||||
then return $ Left [dis n]
|
then return $ Left [dis n]
|
||||||
else do
|
else do
|
||||||
|
@ -571,7 +521,7 @@ evalSometimesMsg (Sometimes n u xs) = do
|
||||||
where
|
where
|
||||||
dis name = FMsg name Nothing (Msg LevelDebug "feature disabled")
|
dis name = FMsg name Nothing (Msg LevelDebug "feature disabled")
|
||||||
|
|
||||||
evalAlwaysMsg :: Always a -> XIO (a, [FMsg])
|
evalAlwaysMsg :: Always a -> FIO (a, [FMsg])
|
||||||
evalAlwaysMsg (Always n x) = do
|
evalAlwaysMsg (Always n x) = do
|
||||||
r <- testAlways x
|
r <- testAlways x
|
||||||
return $ case r of
|
return $ case r of
|
||||||
|
@ -591,7 +541,7 @@ failedMsg fn Subfeature {sfData = d, sfName = n} = case d of
|
||||||
where
|
where
|
||||||
f = fmap (FMsg fn (Just n))
|
f = fmap (FMsg fn (Just n))
|
||||||
|
|
||||||
testAlways :: Always_ a -> XIO (PostAlways a)
|
testAlways :: Always_ a -> FIO (PostAlways a)
|
||||||
testAlways = go []
|
testAlways = go []
|
||||||
where
|
where
|
||||||
go failed (Option fd next) = do
|
go failed (Option fd next) = do
|
||||||
|
@ -601,18 +551,18 @@ testAlways = go []
|
||||||
(Right pass) -> return $ Primary pass failed next
|
(Right pass) -> return $ Primary pass failed next
|
||||||
go failed (Always_ ar) = (`Fallback` failed) <$> evalFallbackRoot ar
|
go failed (Always_ ar) = (`Fallback` failed) <$> evalFallbackRoot ar
|
||||||
|
|
||||||
evalFallbackRoot :: FallbackRoot a -> XIO a
|
evalFallbackRoot :: FallbackRoot a -> FIO a
|
||||||
evalFallbackRoot (FallbackAlone a) = return a
|
evalFallbackRoot (FallbackAlone a) = return a
|
||||||
evalFallbackRoot (FallbackTree a s) = a <$> evalFallbackStack s
|
evalFallbackRoot (FallbackTree a s) = a <$> evalFallbackStack s
|
||||||
|
|
||||||
evalFallbackStack :: FallbackStack p -> XIO p
|
evalFallbackStack :: FallbackStack p -> FIO p
|
||||||
evalFallbackStack (FallbackBottom a) = evalAlways a
|
evalFallbackStack (FallbackBottom a) = evalAlways a
|
||||||
evalFallbackStack (FallbackStack f a as) = do
|
evalFallbackStack (FallbackStack f a as) = do
|
||||||
ps <- evalFallbackStack as
|
ps <- evalFallbackStack as
|
||||||
p <- evalAlways a
|
p <- evalAlways a
|
||||||
return $ f p ps
|
return $ f p ps
|
||||||
|
|
||||||
testSometimes :: Sometimes_ a -> XIO (PostSometimes a)
|
testSometimes :: Sometimes_ a -> FIO (PostSometimes a)
|
||||||
testSometimes = go (PostSometimes Nothing [])
|
testSometimes = go (PostSometimes Nothing [])
|
||||||
where
|
where
|
||||||
go ts [] = return ts
|
go ts [] = return ts
|
||||||
|
@ -622,13 +572,13 @@ testSometimes = go (PostSometimes Nothing [])
|
||||||
(Left l) -> go (ts {psFailed = l : psFailed ts}) xs
|
(Left l) -> go (ts {psFailed = l : psFailed ts}) xs
|
||||||
(Right pass) -> return $ ts {psSuccess = Just pass}
|
(Right pass) -> return $ ts {psSuccess = Just pass}
|
||||||
|
|
||||||
testSubfeature :: SubfeatureRoot a -> XIO (Either SubfeatureFail (SubfeaturePass a))
|
testSubfeature :: SubfeatureRoot a -> FIO (Either SubfeatureFail (SubfeaturePass a))
|
||||||
testSubfeature sf@Subfeature {sfData = t} = do
|
testSubfeature sf@Subfeature {sfData = t} = do
|
||||||
t' <- testRoot t
|
t' <- testRoot t
|
||||||
-- monomorphism restriction :(
|
-- monomorphism restriction :(
|
||||||
return $ bimap (\n -> sf {sfData = n}) (\n -> sf {sfData = n}) t'
|
return $ bimap (\n -> sf {sfData = n}) (\n -> sf {sfData = n}) t'
|
||||||
|
|
||||||
testRoot :: Root a -> XIO (Either PostFail (PostPass a))
|
testRoot :: Root a -> FIO (Either PostFail (PostPass a))
|
||||||
testRoot r = do
|
testRoot r = do
|
||||||
case r of
|
case r of
|
||||||
(IORoot a t) -> go a testIODep_ testIODep t
|
(IORoot a t) -> go a testIODep_ testIODep t
|
||||||
|
@ -642,7 +592,7 @@ testRoot r = do
|
||||||
Msg LevelError "client not available"
|
Msg LevelError "client not available"
|
||||||
where
|
where
|
||||||
-- rank N polymorphism is apparently undecidable...gross
|
-- rank N polymorphism is apparently undecidable...gross
|
||||||
go a f_ (f :: forall q. d q -> XIO (MResult q)) t =
|
go a f_ (f :: forall q. d q -> FIO (MResult q)) t =
|
||||||
bimap PostFail (fmap a) <$> testTree f_ f t
|
bimap PostFail (fmap a) <$> testTree f_ f t
|
||||||
go_ a f_ t = bimap PostFail (PostPass a) <$> testTree_ f_ t
|
go_ a f_ t = bimap PostFail (PostPass a) <$> testTree_ f_ t
|
||||||
|
|
||||||
|
@ -655,13 +605,13 @@ type MResult p = Memoized (Result p)
|
||||||
|
|
||||||
testTree
|
testTree
|
||||||
:: forall d d_ p
|
:: forall d d_ p
|
||||||
. (d_ -> XIO MResult_)
|
. (d_ -> FIO MResult_)
|
||||||
-> (forall q. d q -> XIO (MResult q))
|
-> (forall q. d q -> FIO (MResult q))
|
||||||
-> Tree d d_ p
|
-> Tree d d_ p
|
||||||
-> XIO (Either [Msg] (PostPass p))
|
-> FIO (Either [Msg] (PostPass p))
|
||||||
testTree test_ test = go
|
testTree test_ test = go
|
||||||
where
|
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
|
go (And12 f a b) = do
|
||||||
ra <- go a
|
ra <- go a
|
||||||
liftRight (\pa -> (and2nd f pa =<<) <$> go b) ra
|
liftRight (\pa -> (and2nd f pa =<<) <$> go b) ra
|
||||||
|
@ -678,7 +628,7 @@ testTree test_ test = go
|
||||||
and2nd f (PostPass pa wa) (PostPass pb wb) = Right $ PostPass (f pa pb) $ wa ++ wb
|
and2nd f (PostPass pa wa) (PostPass pb wb) = Right $ PostPass (f pa pb) $ wa ++ wb
|
||||||
liftRight = either (return . Left)
|
liftRight = either (return . Left)
|
||||||
|
|
||||||
testIODep :: IODependency p -> XIO (MResult p)
|
testIODep :: IODependency p -> FIO (MResult p)
|
||||||
testIODep d = memoizeMVar $ case d of
|
testIODep d = memoizeMVar $ case d of
|
||||||
IORead _ _ t -> t
|
IORead _ _ t -> t
|
||||||
IOConst c -> return $ Right $ PostPass c []
|
IOConst c -> return $ Right $ PostPass c []
|
||||||
|
@ -706,7 +656,7 @@ type Result_ = Either [Msg] [Msg]
|
||||||
|
|
||||||
type MResult_ = Memoized Result_
|
type MResult_ = Memoized Result_
|
||||||
|
|
||||||
testTree_ :: (d -> XIO MResult_) -> Tree_ d -> XIO Result_
|
testTree_ :: (d -> FIO MResult_) -> Tree_ d -> FIO Result_
|
||||||
testTree_ test = go
|
testTree_ test = go
|
||||||
where
|
where
|
||||||
go (And_ a b) = either (return . Left) (`test2nd` b) =<< go a
|
go (And_ a b) = either (return . Left) (`test2nd` b) =<< go a
|
||||||
|
@ -714,10 +664,10 @@ testTree_ test = go
|
||||||
go (Only_ a) = runMemoized =<< test a
|
go (Only_ a) = runMemoized =<< test a
|
||||||
test2nd ws = fmap ((Right . (ws ++)) =<<) . go
|
test2nd ws = fmap ((Right . (ws ++)) =<<) . go
|
||||||
|
|
||||||
testIODep_ :: IODependency_ -> XIO MResult_
|
testIODep_ :: IODependency_ -> FIO MResult_
|
||||||
testIODep_ d = memoizeMVar $ testIODepNoCache_ d
|
testIODep_ d = memoizeMVar $ testIODepNoCache_ d
|
||||||
|
|
||||||
testIODepNoCache_ :: IODependency_ -> XIO Result_
|
testIODepNoCache_ :: IODependency_ -> FIO Result_
|
||||||
testIODepNoCache_ (IOSystem_ _ s) = readResult_ <$> testSysDependency s
|
testIODepNoCache_ (IOSystem_ _ s) = readResult_ <$> testSysDependency s
|
||||||
testIODepNoCache_ (IOTest_ _ _ t) = readResult_ <$> t
|
testIODepNoCache_ (IOTest_ _ _ t) = readResult_ <$> t
|
||||||
testIODepNoCache_ (IOSometimes_ x) =
|
testIODepNoCache_ (IOSometimes_ x) =
|
||||||
|
@ -812,7 +762,7 @@ fontDependency_ fam ful = IOTest_ (fontTestName fam) ful $ voidRead <$> testFont
|
||||||
fontTestName :: T.Text -> T.Text
|
fontTestName :: T.Text -> T.Text
|
||||||
fontTestName fam = T.unwords ["test if font", singleQuote fam, "exists"]
|
fontTestName fam = T.unwords ["test if font", singleQuote fam, "exists"]
|
||||||
|
|
||||||
-- testFont :: T.Text -> XIO (Result FontBuilder)
|
-- testFont :: T.Text -> FIO (Result FontBuilder)
|
||||||
-- testFont = liftIO . testFont'
|
-- testFont = liftIO . testFont'
|
||||||
|
|
||||||
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"
|
-- start with "en" and wireless interfaces always start with "wl"
|
||||||
|
|
||||||
readEthernet :: IODependency T.Text
|
readEthernet :: IODependency T.Text
|
||||||
readEthernet = readInterface "get ethernet interface" (fromMaybe "en" . xpfEthPrefix)
|
readEthernet = readInterface "get ethernet interface" isEthernet
|
||||||
|
|
||||||
readWireless :: IODependency T.Text
|
readWireless :: IODependency T.Text
|
||||||
readWireless = readInterface "get wireless interface" (fromMaybe "wl" . xpfWifiPrefix)
|
readWireless = readInterface "get wireless interface" isWireless
|
||||||
|
|
||||||
-- isWireless :: T.Text -> Bool
|
isWireless :: T.Text -> Bool
|
||||||
-- isWireless = T.isPrefixOf "wl"
|
isWireless = T.isPrefixOf "wl"
|
||||||
|
|
||||||
-- isEthernet :: T.Text -> Bool
|
isEthernet :: T.Text -> Bool
|
||||||
-- isEthernet = T.isPrefixOf "en"
|
isEthernet = T.isPrefixOf "en"
|
||||||
|
|
||||||
listInterfaces :: MonadUnliftIO m => m [T.Text]
|
listInterfaces :: MonadUnliftIO m => m [T.Text]
|
||||||
listInterfaces =
|
listInterfaces =
|
||||||
|
@ -854,12 +804,11 @@ sysfsNet = "/sys/class/net"
|
||||||
|
|
||||||
-- ASSUME there are no (non-base) packages required to make these interfaces
|
-- ASSUME there are no (non-base) packages required to make these interfaces
|
||||||
-- work (all at the kernel level)
|
-- work (all at the kernel level)
|
||||||
readInterface :: T.Text -> (XPFeatures -> Text) -> IODependency T.Text
|
readInterface :: T.Text -> (T.Text -> Bool) -> IODependency T.Text
|
||||||
readInterface n f = IORead n [] go
|
readInterface n f = IORead n [] go
|
||||||
where
|
where
|
||||||
go = do
|
go = io $ do
|
||||||
p <- asks (f . xpFeatures . xParams)
|
ns <- filter f <$> listInterfaces
|
||||||
ns <- filter (T.isPrefixOf p) <$> listInterfaces
|
|
||||||
case ns of
|
case ns of
|
||||||
[] -> return $ Left [Msg LevelError "no interfaces found"]
|
[] -> return $ Left [Msg LevelError "no interfaces found"]
|
||||||
(x : xs) -> do
|
(x : xs) -> do
|
||||||
|
@ -871,7 +820,7 @@ readInterface n f = IORead n [] go
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- Misc testers
|
-- Misc testers
|
||||||
|
|
||||||
socketExists :: T.Text -> [Fulfillment] -> XIO FilePath -> IODependency_
|
socketExists :: T.Text -> [Fulfillment] -> FIO FilePath -> IODependency_
|
||||||
socketExists n ful =
|
socketExists n ful =
|
||||||
IOTest_ (T.unwords ["test if", n, "socket exists"]) ful . socketExists'
|
IOTest_ (T.unwords ["test if", n, "socket exists"]) ful . socketExists'
|
||||||
|
|
||||||
|
@ -895,12 +844,12 @@ introspectInterface = interfaceName_ "org.freedesktop.DBus.Introspectable"
|
||||||
introspectMethod :: MemberName
|
introspectMethod :: MemberName
|
||||||
introspectMethod = memberName_ "Introspect"
|
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
|
testDBusDep_ c d = memoizeMVar $ testDBusDepNoCache_ c d
|
||||||
|
|
||||||
testDBusDepNoCache_ :: SafeClient c => NamedConnection c -> DBusDependency_ c -> XIO Result_
|
testDBusDepNoCache_ :: SafeClient c => c -> DBusDependency_ c -> FIO Result_
|
||||||
testDBusDepNoCache_ cl (Bus _ bus) = do
|
testDBusDepNoCache_ cl (Bus _ bus) = io $ do
|
||||||
ret <- withDIO cl $ callMethod queryBus queryPath queryIface queryMem
|
ret <- callMethod cl queryBus queryPath queryIface queryMem
|
||||||
return $ case ret of
|
return $ case ret of
|
||||||
Left e -> Left [Msg LevelError e]
|
Left e -> Left [Msg LevelError e]
|
||||||
Right b ->
|
Right b ->
|
||||||
|
@ -919,10 +868,8 @@ testDBusDepNoCache_ cl (Bus _ bus) = do
|
||||||
queryMem = memberName_ "ListNames"
|
queryMem = memberName_ "ListNames"
|
||||||
bodyGetNames [v] = fromMaybe [] $ fromVariant v :: [T.Text]
|
bodyGetNames [v] = fromMaybe [] $ fromVariant v :: [T.Text]
|
||||||
bodyGetNames _ = []
|
bodyGetNames _ = []
|
||||||
testDBusDepNoCache_ cl (Endpoint _ busname objpath iface mem) = do
|
testDBusDepNoCache_ cl (Endpoint _ busname objpath iface mem) = io $ do
|
||||||
ret <-
|
ret <- callMethod cl busname objpath introspectInterface introspectMethod
|
||||||
withDIO cl $
|
|
||||||
callMethod busname objpath introspectInterface introspectMethod
|
|
||||||
return $ case ret of
|
return $ case ret of
|
||||||
Left e -> Left [Msg LevelError e]
|
Left e -> Left [Msg LevelError e]
|
||||||
Right body -> procBody body
|
Right body -> procBody body
|
||||||
|
@ -978,6 +925,12 @@ testDBusDepNoCache_ _ (DBusIO i) = testIODepNoCache_ i
|
||||||
-- ioSubfeature :: MonadIO m => SubfeatureRoot (IO a) -> SubfeatureRoot (m a)
|
-- ioSubfeature :: MonadIO m => SubfeatureRoot (IO a) -> SubfeatureRoot (m a)
|
||||||
-- ioSubfeature sf = sf {sfData = ioRoot $ sfData sf}
|
-- ioSubfeature sf = sf {sfData = ioRoot $ sfData sf}
|
||||||
|
|
||||||
|
-- ioRoot :: MonadIO m => Root (IO a) -> Root (m a)
|
||||||
|
-- ioRoot (IORoot a t) = IORoot (io . a) t
|
||||||
|
-- ioRoot (IORoot_ a t) = IORoot_ (io a) t
|
||||||
|
-- ioRoot (DBusRoot a t cl) = DBusRoot (\p c -> io $ a p c) t cl
|
||||||
|
-- ioRoot (DBusRoot_ a t cl) = DBusRoot_ (io . a) t cl
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- Feature constructors
|
-- Feature constructors
|
||||||
|
|
||||||
|
@ -1029,17 +982,16 @@ sometimesExeArgs fn n ful sys path args =
|
||||||
|
|
||||||
sometimesDBus
|
sometimesDBus
|
||||||
:: SafeClient c
|
:: SafeClient c
|
||||||
=> Maybe (NamedConnection c)
|
=> Maybe c
|
||||||
-> T.Text
|
-> T.Text
|
||||||
-> T.Text
|
-> T.Text
|
||||||
-> Tree_ (DBusDependency_ c)
|
-> Tree_ (DBusDependency_ c)
|
||||||
-> (NamedConnection c -> a)
|
-> (c -> a)
|
||||||
-> Sometimes a
|
-> Sometimes a
|
||||||
sometimesDBus c fn n t x = sometimes1 fn n $ DBusRoot_ x t c
|
sometimesDBus c fn n t x = sometimes1 fn n $ DBusRoot_ x t c
|
||||||
|
|
||||||
-- TODO do I need to hardcode XEnv?
|
|
||||||
sometimesEndpoint
|
sometimesEndpoint
|
||||||
:: (HasClient (DBusEnv env), SafeClient c, MonadReader env m, MonadUnliftIO m)
|
:: (SafeClient c, MonadIO m)
|
||||||
=> T.Text
|
=> T.Text
|
||||||
-> T.Text
|
-> T.Text
|
||||||
-> [Fulfillment]
|
-> [Fulfillment]
|
||||||
|
@ -1047,13 +999,13 @@ sometimesEndpoint
|
||||||
-> ObjectPath
|
-> ObjectPath
|
||||||
-> InterfaceName
|
-> InterfaceName
|
||||||
-> MemberName
|
-> MemberName
|
||||||
-> Maybe (NamedConnection c)
|
-> Maybe c
|
||||||
-> Sometimes (m ())
|
-> Sometimes (m ())
|
||||||
sometimesEndpoint fn name ful busname path iface mem cl =
|
sometimesEndpoint fn name ful busname path iface mem cl =
|
||||||
sometimesDBus cl fn name deps cmd
|
sometimesDBus cl fn name deps cmd
|
||||||
where
|
where
|
||||||
deps = Only_ $ Endpoint ful busname path iface $ Method_ mem
|
deps = Only_ $ Endpoint ful busname path iface $ Method_ mem
|
||||||
cmd c = void $ withDIO c $ callMethod busname path iface mem
|
cmd c = io $ void $ callMethod c busname path iface mem
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- Dependency Tree Constructors
|
-- Dependency Tree Constructors
|
|
@ -1,3 +1,5 @@
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- Dmenu (Rofi) Commands
|
-- Dmenu (Rofi) Commands
|
||||||
|
|
||||||
|
@ -17,18 +19,15 @@ module XMonad.Internal.Command.DMenu
|
||||||
where
|
where
|
||||||
|
|
||||||
import DBus
|
import DBus
|
||||||
import qualified Data.ByteString.Char8 as BC
|
|
||||||
import Data.Internal.DBus
|
import Data.Internal.DBus
|
||||||
import Data.Internal.XIO
|
import Data.Internal.Dependency
|
||||||
import Graphics.X11.Types
|
import Graphics.X11.Types
|
||||||
import RIO
|
|
||||||
import qualified RIO.ByteString as B
|
|
||||||
import RIO.Directory
|
import RIO.Directory
|
||||||
( XdgDirectory (..)
|
( XdgDirectory (..)
|
||||||
, getXdgDirectory
|
, getXdgDirectory
|
||||||
)
|
)
|
||||||
import qualified RIO.Text as T
|
import qualified RIO.Text as T
|
||||||
-- import System.IO
|
import System.IO
|
||||||
import XMonad.Core hiding (spawn)
|
import XMonad.Core hiding (spawn)
|
||||||
import XMonad.Internal.Command.Desktop
|
import XMonad.Internal.Command.Desktop
|
||||||
import XMonad.Internal.DBus.Common
|
import XMonad.Internal.DBus.Common
|
||||||
|
@ -75,7 +74,7 @@ clipboardPkgs = [Package AUR "rofi-greenclip"]
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- Other internal functions
|
-- Other internal functions
|
||||||
|
|
||||||
spawnDmenuCmd :: MonadUnliftIO m => T.Text -> [T.Text] -> Sometimes (m ())
|
spawnDmenuCmd :: T.Text -> [T.Text] -> SometimesX
|
||||||
spawnDmenuCmd n =
|
spawnDmenuCmd n =
|
||||||
sometimesExeArgs n "rofi preset" dmenuPkgs True myDmenuCmd
|
sometimesExeArgs n "rofi preset" dmenuPkgs True myDmenuCmd
|
||||||
|
|
||||||
|
@ -98,7 +97,7 @@ dmenuDep = sysExe dmenuPkgs myDmenuCmd
|
||||||
-- Exported Commands
|
-- Exported Commands
|
||||||
|
|
||||||
-- TODO test that veracrypt and friends are installed
|
-- TODO test that veracrypt and friends are installed
|
||||||
runDevMenu :: MonadUnliftIO m => Sometimes (m ())
|
runDevMenu :: SometimesX
|
||||||
runDevMenu = sometimesIO_ "device manager" "rofi devices" t x
|
runDevMenu = sometimesIO_ "device manager" "rofi devices" t x
|
||||||
where
|
where
|
||||||
t = dmenuTree $ Only_ (localExe [] myDmenuDevices)
|
t = dmenuTree $ Only_ (localExe [] myDmenuDevices)
|
||||||
|
@ -111,7 +110,7 @@ runDevMenu = sometimesIO_ "device manager" "rofi devices" t x
|
||||||
++ myDmenuMatchingArgs
|
++ myDmenuMatchingArgs
|
||||||
|
|
||||||
-- TODO test that bluetooth interface exists
|
-- TODO test that bluetooth interface exists
|
||||||
runBTMenu :: MonadUnliftIO m => Sometimes (m ())
|
runBTMenu :: SometimesX
|
||||||
runBTMenu =
|
runBTMenu =
|
||||||
Sometimes
|
Sometimes
|
||||||
"bluetooth selector"
|
"bluetooth selector"
|
||||||
|
@ -121,7 +120,7 @@ runBTMenu =
|
||||||
cmd = spawnCmd myDmenuBluetooth $ "-c" : themeArgs "#0044bb"
|
cmd = spawnCmd myDmenuBluetooth $ "-c" : themeArgs "#0044bb"
|
||||||
tree = dmenuTree $ Only_ $ sysExe [] myDmenuBluetooth
|
tree = dmenuTree $ Only_ $ sysExe [] myDmenuBluetooth
|
||||||
|
|
||||||
runVPNMenu :: MonadUnliftIO m => Sometimes (m ())
|
runVPNMenu :: SometimesX
|
||||||
runVPNMenu =
|
runVPNMenu =
|
||||||
Sometimes
|
Sometimes
|
||||||
"VPN selector"
|
"VPN selector"
|
||||||
|
@ -137,16 +136,16 @@ runVPNMenu =
|
||||||
socketExists "expressVPN" [] $
|
socketExists "expressVPN" [] $
|
||||||
return "/var/lib/expressvpn/expressvpnd.socket"
|
return "/var/lib/expressvpn/expressvpnd.socket"
|
||||||
|
|
||||||
runCmdMenu :: MonadUnliftIO m => Sometimes (m ())
|
runCmdMenu :: SometimesX
|
||||||
runCmdMenu = spawnDmenuCmd "command menu" ["-show", "run"]
|
runCmdMenu = spawnDmenuCmd "command menu" ["-show", "run"]
|
||||||
|
|
||||||
runAppMenu :: MonadUnliftIO m => Sometimes (m ())
|
runAppMenu :: SometimesX
|
||||||
runAppMenu = spawnDmenuCmd "app launcher" ["-show", "drun"]
|
runAppMenu = spawnDmenuCmd "app launcher" ["-show", "drun"]
|
||||||
|
|
||||||
runWinMenu :: MonadUnliftIO m => Sometimes (m ())
|
runWinMenu :: SometimesX
|
||||||
runWinMenu = spawnDmenuCmd "window switcher" ["-show", "window"]
|
runWinMenu = spawnDmenuCmd "window switcher" ["-show", "window"]
|
||||||
|
|
||||||
runNetMenu :: MonadUnliftIO m => Maybe NamedSysConnection -> Sometimes (m ())
|
runNetMenu :: Maybe SysClient -> SometimesX
|
||||||
runNetMenu cl =
|
runNetMenu cl =
|
||||||
Sometimes
|
Sometimes
|
||||||
"network control menu"
|
"network control menu"
|
||||||
|
@ -162,7 +161,7 @@ runNetMenu cl =
|
||||||
DBusIO $
|
DBusIO $
|
||||||
sysExe [Package AUR "networkmanager-dmenu-git"] myDmenuNetworks
|
sysExe [Package AUR "networkmanager-dmenu-git"] myDmenuNetworks
|
||||||
|
|
||||||
runAutorandrMenu :: MonadUnliftIO m => Sometimes (m ())
|
runAutorandrMenu :: SometimesX
|
||||||
runAutorandrMenu = sometimesIO_ "autorandr menu" "rofi autorandr" tree cmd
|
runAutorandrMenu = sometimesIO_ "autorandr menu" "rofi autorandr" tree cmd
|
||||||
where
|
where
|
||||||
cmd = spawnCmd myDmenuMonitors $ themeArgs "#ff0066"
|
cmd = spawnCmd myDmenuMonitors $ themeArgs "#ff0066"
|
||||||
|
@ -171,7 +170,7 @@ runAutorandrMenu = sometimesIO_ "autorandr menu" "rofi autorandr" tree cmd
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- Password manager
|
-- Password manager
|
||||||
|
|
||||||
runBwMenu :: MonadUnliftIO m => Maybe NamedSesConnection -> Sometimes (m ())
|
runBwMenu :: Maybe SesClient -> SometimesX
|
||||||
runBwMenu cl = sometimesDBus cl "password manager" "rofi bitwarden" tree cmd
|
runBwMenu cl = sometimesDBus cl "password manager" "rofi bitwarden" tree cmd
|
||||||
where
|
where
|
||||||
cmd _ =
|
cmd _ =
|
||||||
|
@ -184,7 +183,7 @@ runBwMenu cl = sometimesDBus cl "password manager" "rofi bitwarden" tree cmd
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- Clipboard
|
-- Clipboard
|
||||||
|
|
||||||
runClipMenu :: MonadUnliftIO m => Sometimes (m ())
|
runClipMenu :: SometimesX
|
||||||
runClipMenu = sometimesIO_ "clipboard manager" "rofi greenclip" tree act
|
runClipMenu = sometimesIO_ "clipboard manager" "rofi greenclip" tree act
|
||||||
where
|
where
|
||||||
act = spawnCmd myDmenuCmd args
|
act = spawnCmd myDmenuCmd args
|
||||||
|
@ -207,9 +206,7 @@ runClipMenu = sometimesIO_ "clipboard manager" "rofi greenclip" tree act
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- Shortcut menu
|
-- Shortcut menu
|
||||||
|
|
||||||
runShowKeys
|
runShowKeys :: Always ([((KeyMask, KeySym), NamedAction)] -> X ())
|
||||||
:: (MonadReader env m, MonadUnliftIO m)
|
|
||||||
=> Always ([((KeyMask, KeySym), NamedAction)] -> m ())
|
|
||||||
runShowKeys =
|
runShowKeys =
|
||||||
Always "keyboard menu" $
|
Always "keyboard menu" $
|
||||||
Option showKeysDMenu $
|
Option showKeysDMenu $
|
||||||
|
@ -222,23 +219,18 @@ runShowKeys =
|
||||||
spawnNotify $
|
spawnNotify $
|
||||||
defNoteError {body = Just $ Text "could not display keymap"}
|
defNoteError {body = Just $ Text "could not display keymap"}
|
||||||
|
|
||||||
showKeysDMenu
|
showKeysDMenu :: SubfeatureRoot ([((KeyMask, KeySym), NamedAction)] -> X ())
|
||||||
:: (MonadReader env m, MonadUnliftIO m)
|
|
||||||
=> SubfeatureRoot ([((KeyMask, KeySym), NamedAction)] -> m ())
|
|
||||||
showKeysDMenu =
|
showKeysDMenu =
|
||||||
Subfeature
|
Subfeature
|
||||||
{ sfName = "keyboard shortcut menu"
|
{ sfName = "keyboard shortcut menu"
|
||||||
, sfData = IORoot_ showKeys $ Only_ dmenuDep
|
, sfData = IORoot_ showKeys $ Only_ dmenuDep
|
||||||
}
|
}
|
||||||
|
|
||||||
showKeys
|
showKeys :: [((KeyMask, KeySym), NamedAction)] -> X ()
|
||||||
:: (MonadReader env m, MonadUnliftIO m)
|
|
||||||
=> [((KeyMask, KeySym), NamedAction)]
|
|
||||||
-> m ()
|
|
||||||
showKeys kbs = do
|
showKeys kbs = do
|
||||||
h <- spawnPipe cmd
|
h <- spawnPipe cmd
|
||||||
B.hPut h $ BC.unlines $ BC.pack <$> showKm kbs
|
io $ hPutStr h $ unlines $ showKm kbs
|
||||||
hClose h
|
io $ hClose h
|
||||||
where
|
where
|
||||||
cmd =
|
cmd =
|
||||||
fmtCmd myDmenuCmd $
|
fmtCmd myDmenuCmd $
|
||||||
|
|
|
@ -1,3 +1,5 @@
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- General commands
|
-- General commands
|
||||||
|
|
||||||
|
@ -19,8 +21,7 @@ module XMonad.Internal.Command.Desktop
|
||||||
, runVolumeUp
|
, runVolumeUp
|
||||||
, runVolumeMute
|
, runVolumeMute
|
||||||
, runToggleBluetooth
|
, runToggleBluetooth
|
||||||
, runToggleNetworking
|
, runToggleEthernet
|
||||||
, runToggleWifi
|
|
||||||
, runRestart
|
, runRestart
|
||||||
, runRecompile
|
, runRecompile
|
||||||
, runAreaCapture
|
, runAreaCapture
|
||||||
|
@ -40,7 +41,7 @@ where
|
||||||
|
|
||||||
import DBus
|
import DBus
|
||||||
import Data.Internal.DBus
|
import Data.Internal.DBus
|
||||||
import Data.Internal.XIO
|
import Data.Internal.Dependency
|
||||||
import RIO
|
import RIO
|
||||||
import RIO.Directory
|
import RIO.Directory
|
||||||
import RIO.FilePath
|
import RIO.FilePath
|
||||||
|
@ -59,13 +60,13 @@ import XMonad.Operations
|
||||||
-- My Executables
|
-- My Executables
|
||||||
|
|
||||||
myTerm :: FilePath
|
myTerm :: FilePath
|
||||||
myTerm = "alacritty"
|
myTerm = "urxvt"
|
||||||
|
|
||||||
myCalc :: FilePath
|
myCalc :: FilePath
|
||||||
myCalc = "bc"
|
myCalc = "bc"
|
||||||
|
|
||||||
myBrowser :: FilePath
|
myBrowser :: FilePath
|
||||||
myBrowser = "firefox"
|
myBrowser = "brave"
|
||||||
|
|
||||||
myEditor :: FilePath
|
myEditor :: FilePath
|
||||||
myEditor = "emacsclient"
|
myEditor = "emacsclient"
|
||||||
|
@ -93,7 +94,8 @@ myNotificationCtrl = "dunstctl"
|
||||||
|
|
||||||
myTermPkgs :: [Fulfillment]
|
myTermPkgs :: [Fulfillment]
|
||||||
myTermPkgs =
|
myTermPkgs =
|
||||||
[ Package Official "alacritty"
|
[ Package Official "rxvt-unicode"
|
||||||
|
, Package Official "urxvt-perls"
|
||||||
]
|
]
|
||||||
|
|
||||||
myEditorPkgs :: [Fulfillment]
|
myEditorPkgs :: [Fulfillment]
|
||||||
|
@ -108,9 +110,6 @@ bluetoothPkgs = [Package Official "bluez-utils"]
|
||||||
networkManagerPkgs :: [Fulfillment]
|
networkManagerPkgs :: [Fulfillment]
|
||||||
networkManagerPkgs = [Package Official "networkmanager"]
|
networkManagerPkgs = [Package Official "networkmanager"]
|
||||||
|
|
||||||
nmcli :: IODependency_
|
|
||||||
nmcli = sysExe networkManagerPkgs "nmcli"
|
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- Misc constants
|
-- Misc constants
|
||||||
|
|
||||||
|
@ -120,10 +119,10 @@ volumeChangeSound = "smb_fireball.wav"
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- Some nice apps
|
-- Some nice apps
|
||||||
|
|
||||||
runTerm :: MonadUnliftIO m => Sometimes (m ())
|
runTerm :: SometimesX
|
||||||
runTerm = sometimesExe "terminal" "alacritty" myTermPkgs True myTerm
|
runTerm = sometimesExe "terminal" "urxvt" myTermPkgs True myTerm
|
||||||
|
|
||||||
runTMux :: MonadUnliftIO m => Sometimes (m ())
|
runTMux :: SometimesX
|
||||||
runTMux = sometimesIO_ "terminal multiplexer" "tmux" deps act
|
runTMux = sometimesIO_ "terminal multiplexer" "tmux" deps act
|
||||||
where
|
where
|
||||||
deps =
|
deps =
|
||||||
|
@ -141,13 +140,13 @@ runTMux = sometimesIO_ "terminal multiplexer" "tmux" deps act
|
||||||
t <- getTemporaryDirectory
|
t <- getTemporaryDirectory
|
||||||
return $ t </> "tmux-" ++ show u </> "default"
|
return $ t </> "tmux-" ++ show u </> "default"
|
||||||
|
|
||||||
runCalc :: MonadUnliftIO m => Sometimes (m ())
|
runCalc :: SometimesX
|
||||||
runCalc = sometimesIO_ "calculator" "bc" deps act
|
runCalc = sometimesIO_ "calculator" "bc" deps act
|
||||||
where
|
where
|
||||||
deps = toAnd_ (sysExe myTermPkgs myTerm) (sysExe [Package Official "bc"] myCalc)
|
deps = toAnd_ (sysExe myTermPkgs myTerm) (sysExe [Package Official "bc"] myCalc)
|
||||||
act = spawnCmd myTerm ["-e", T.pack myCalc, "-l"]
|
act = spawnCmd myTerm ["-e", T.pack myCalc, "-l"]
|
||||||
|
|
||||||
runBrowser :: MonadUnliftIO m => Sometimes (m ())
|
runBrowser :: SometimesX
|
||||||
runBrowser =
|
runBrowser =
|
||||||
sometimesExe
|
sometimesExe
|
||||||
"web browser"
|
"web browser"
|
||||||
|
@ -156,7 +155,7 @@ runBrowser =
|
||||||
False
|
False
|
||||||
myBrowser
|
myBrowser
|
||||||
|
|
||||||
runEditor :: MonadUnliftIO m => Sometimes (m ())
|
runEditor :: SometimesX
|
||||||
runEditor = sometimesIO_ "text editor" "emacs" tree cmd
|
runEditor = sometimesIO_ "text editor" "emacs" tree cmd
|
||||||
where
|
where
|
||||||
cmd =
|
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
|
-- before xmonad starts, so just check to see if the process has started
|
||||||
tree = toAnd_ (sysExe myEditorPkgs myEditor) $ process [] $ T.pack myEditorServer
|
tree = toAnd_ (sysExe myEditorPkgs myEditor) $ process [] $ T.pack myEditorServer
|
||||||
|
|
||||||
runFileManager :: MonadUnliftIO m => Sometimes (m ())
|
runFileManager :: SometimesX
|
||||||
runFileManager =
|
runFileManager =
|
||||||
sometimesExe
|
sometimesExe
|
||||||
"file browser"
|
"file browser"
|
||||||
|
@ -179,11 +178,7 @@ runFileManager =
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- Multimedia Commands
|
-- Multimedia Commands
|
||||||
|
|
||||||
runMultimediaIfInstalled
|
runMultimediaIfInstalled :: T.Text -> T.Text -> SometimesX
|
||||||
:: MonadUnliftIO m
|
|
||||||
=> T.Text
|
|
||||||
-> T.Text
|
|
||||||
-> Sometimes (m ())
|
|
||||||
runMultimediaIfInstalled n cmd =
|
runMultimediaIfInstalled n cmd =
|
||||||
sometimesExeArgs
|
sometimesExeArgs
|
||||||
(T.append n " multimedia control")
|
(T.append n " multimedia control")
|
||||||
|
@ -193,23 +188,23 @@ runMultimediaIfInstalled n cmd =
|
||||||
myMultimediaCtl
|
myMultimediaCtl
|
||||||
[cmd]
|
[cmd]
|
||||||
|
|
||||||
runTogglePlay :: MonadUnliftIO m => Sometimes (m ())
|
runTogglePlay :: SometimesX
|
||||||
runTogglePlay = runMultimediaIfInstalled "play/pause" "play-pause"
|
runTogglePlay = runMultimediaIfInstalled "play/pause" "play-pause"
|
||||||
|
|
||||||
runPrevTrack :: MonadUnliftIO m => Sometimes (m ())
|
runPrevTrack :: SometimesX
|
||||||
runPrevTrack = runMultimediaIfInstalled "previous track" "previous"
|
runPrevTrack = runMultimediaIfInstalled "previous track" "previous"
|
||||||
|
|
||||||
runNextTrack :: MonadUnliftIO m => Sometimes (m ())
|
runNextTrack :: SometimesX
|
||||||
runNextTrack = runMultimediaIfInstalled "next track" "next"
|
runNextTrack = runMultimediaIfInstalled "next track" "next"
|
||||||
|
|
||||||
runStopPlay :: MonadUnliftIO m => Sometimes (m ())
|
runStopPlay :: SometimesX
|
||||||
runStopPlay = runMultimediaIfInstalled "stop playback" "stop"
|
runStopPlay = runMultimediaIfInstalled "stop playback" "stop"
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- Volume Commands
|
-- Volume Commands
|
||||||
|
|
||||||
soundDir :: FilePath
|
soundDir :: FilePath
|
||||||
soundDir = "assets" </> "sound"
|
soundDir = "sound"
|
||||||
|
|
||||||
playSound :: MonadIO m => FilePath -> m ()
|
playSound :: MonadIO m => FilePath -> m ()
|
||||||
playSound file = do
|
playSound file = do
|
||||||
|
@ -218,13 +213,7 @@ playSound file = do
|
||||||
-- paplay seems to have less latency than aplay
|
-- paplay seems to have less latency than aplay
|
||||||
spawnCmd "paplay" [T.pack p]
|
spawnCmd "paplay" [T.pack p]
|
||||||
|
|
||||||
featureSound
|
featureSound :: T.Text -> FilePath -> X () -> X () -> SometimesX
|
||||||
:: MonadUnliftIO m
|
|
||||||
=> T.Text
|
|
||||||
-> FilePath
|
|
||||||
-> m ()
|
|
||||||
-> m ()
|
|
||||||
-> Sometimes (m ())
|
|
||||||
featureSound n file pre post =
|
featureSound n file pre post =
|
||||||
sometimesIO_ (T.unwords ["volume", n, " control"]) "paplay" tree $
|
sometimesIO_ (T.unwords ["volume", n, " control"]) "paplay" tree $
|
||||||
pre >> playSound file >> post
|
pre >> playSound file >> post
|
||||||
|
@ -233,24 +222,19 @@ featureSound n file pre post =
|
||||||
-- to play sound (duh) but libpulse is the package with the paplay binary
|
-- to play sound (duh) but libpulse is the package with the paplay binary
|
||||||
tree = Only_ $ sysExe [Package Official "pulseaudio"] "paplay"
|
tree = Only_ $ sysExe [Package Official "pulseaudio"] "paplay"
|
||||||
|
|
||||||
runVolumeDown :: MonadUnliftIO m => Sometimes (m ())
|
runVolumeDown :: SometimesX
|
||||||
runVolumeDown = featureSound "up" volumeChangeSound (return ()) $ void (lowerVolume 2)
|
runVolumeDown = featureSound "up" volumeChangeSound (return ()) $ void (lowerVolume 2)
|
||||||
|
|
||||||
runVolumeUp :: MonadUnliftIO m => Sometimes (m ())
|
runVolumeUp :: SometimesX
|
||||||
runVolumeUp = featureSound "down" volumeChangeSound (return ()) $ void (raiseVolume 2)
|
runVolumeUp = featureSound "down" volumeChangeSound (return ()) $ void (raiseVolume 2)
|
||||||
|
|
||||||
runVolumeMute :: MonadUnliftIO m => Sometimes (m ())
|
runVolumeMute :: SometimesX
|
||||||
runVolumeMute = featureSound "mute" volumeChangeSound (void toggleMute) $ return ()
|
runVolumeMute = featureSound "mute" volumeChangeSound (void toggleMute) $ return ()
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- Notification control
|
-- Notification control
|
||||||
|
|
||||||
runNotificationCmd
|
runNotificationCmd :: T.Text -> T.Text -> Maybe SesClient -> SometimesX
|
||||||
:: MonadUnliftIO m
|
|
||||||
=> T.Text
|
|
||||||
-> T.Text
|
|
||||||
-> Maybe NamedSesConnection
|
|
||||||
-> Sometimes (m ())
|
|
||||||
runNotificationCmd n arg cl =
|
runNotificationCmd n arg cl =
|
||||||
sometimesDBus cl (T.unwords [n, "control"]) "dunstctl" tree cmd
|
sometimesDBus cl (T.unwords [n, "control"]) "dunstctl" tree cmd
|
||||||
where
|
where
|
||||||
|
@ -261,37 +245,37 @@ runNotificationCmd n arg cl =
|
||||||
Method_ $
|
Method_ $
|
||||||
memberName_ "NotificationAction"
|
memberName_ "NotificationAction"
|
||||||
|
|
||||||
runNotificationClose :: MonadUnliftIO m => Maybe NamedSesConnection -> Sometimes (m ())
|
runNotificationClose :: Maybe SesClient -> SometimesX
|
||||||
runNotificationClose = runNotificationCmd "close notification" "close"
|
runNotificationClose = runNotificationCmd "close notification" "close"
|
||||||
|
|
||||||
runNotificationCloseAll :: MonadUnliftIO m => Maybe NamedSesConnection -> Sometimes (m ())
|
runNotificationCloseAll :: Maybe SesClient -> SometimesX
|
||||||
runNotificationCloseAll =
|
runNotificationCloseAll =
|
||||||
runNotificationCmd "close all notifications" "close-all"
|
runNotificationCmd "close all notifications" "close-all"
|
||||||
|
|
||||||
runNotificationHistory :: MonadUnliftIO m => Maybe NamedSesConnection -> Sometimes (m ())
|
runNotificationHistory :: Maybe SesClient -> SometimesX
|
||||||
runNotificationHistory =
|
runNotificationHistory =
|
||||||
runNotificationCmd "see notification history" "history-pop"
|
runNotificationCmd "see notification history" "history-pop"
|
||||||
|
|
||||||
runNotificationContext :: MonadUnliftIO m => Maybe NamedSesConnection -> Sometimes (m ())
|
runNotificationContext :: Maybe SesClient -> SometimesX
|
||||||
runNotificationContext =
|
runNotificationContext =
|
||||||
runNotificationCmd "open notification context" "context"
|
runNotificationCmd "open notification context" "context"
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- System commands
|
-- System commands
|
||||||
|
|
||||||
-- needed to lookup/prompt for passwords/keys for wifi connections and some VPNs
|
-- this is required for some vpn's to work properly with network-manager
|
||||||
runNetAppDaemon :: Maybe NamedSysConnection -> Sometimes (XIO (P.Process () () ()))
|
runNetAppDaemon :: Maybe SysClient -> Sometimes (FIO (P.Process () () ()))
|
||||||
runNetAppDaemon cl =
|
runNetAppDaemon cl =
|
||||||
Sometimes
|
Sometimes
|
||||||
"network applet"
|
"network applet"
|
||||||
(\x -> xpfVPN x || xpfWireless x)
|
xpfVPN
|
||||||
[Subfeature (DBusRoot_ cmd tree cl) "NM-applet"]
|
[Subfeature (DBusRoot_ cmd tree cl) "NM-applet"]
|
||||||
where
|
where
|
||||||
tree = toAnd_ app $ Bus networkManagerPkgs networkManagerBus
|
tree = toAnd_ app $ Bus networkManagerPkgs networkManagerBus
|
||||||
app = DBusIO $ sysExe [Package Official "network-manager-applet"] "nm-applet"
|
app = DBusIO $ sysExe [Package Official "network-manager-applet"] "nm-applet"
|
||||||
cmd _ = P.proc "nm-applet" [] (P.startProcess . P.setCreateGroup True)
|
cmd _ = P.proc "nm-applet" [] (P.startProcess . P.setCreateGroup True)
|
||||||
|
|
||||||
runToggleBluetooth :: MonadUnliftIO m => Maybe NamedSysConnection -> Sometimes (m ())
|
runToggleBluetooth :: Maybe SysClient -> SometimesX
|
||||||
runToggleBluetooth cl =
|
runToggleBluetooth cl =
|
||||||
Sometimes
|
Sometimes
|
||||||
"bluetooth toggle"
|
"bluetooth toggle"
|
||||||
|
@ -308,35 +292,27 @@ runToggleBluetooth cl =
|
||||||
#!>> fmtCmd myBluetooth ["power", "$a", ">", "/dev/null"]
|
#!>> fmtCmd myBluetooth ["power", "$a", ">", "/dev/null"]
|
||||||
#!&& fmtNotifyCmd defNoteInfo {body = Just $ Text "bluetooth powered $a"}
|
#!&& fmtNotifyCmd defNoteInfo {body = Just $ Text "bluetooth powered $a"}
|
||||||
|
|
||||||
runToggleNetworking :: MonadUnliftIO m => Sometimes (m ())
|
runToggleEthernet :: SometimesX
|
||||||
runToggleNetworking =
|
runToggleEthernet =
|
||||||
Sometimes
|
Sometimes
|
||||||
"network toggle"
|
"ethernet toggle"
|
||||||
(\x -> xpfEthernet x || xpfWireless x)
|
xpfEthernet
|
||||||
[Subfeature root "nmcli"]
|
[Subfeature root "nmcli"]
|
||||||
where
|
where
|
||||||
root = IORoot_ cmd $ Only_ nmcli
|
root =
|
||||||
cmd =
|
IORoot cmd $
|
||||||
|
And1 (Only readEthernet) $
|
||||||
|
Only_ $
|
||||||
|
sysExe networkManagerPkgs "nmcli"
|
||||||
|
-- TODO make this less noisy
|
||||||
|
cmd iface =
|
||||||
S.spawn $
|
S.spawn $
|
||||||
fmtCmd "nmcli" ["networking"]
|
fmtCmd "nmcli" ["-g", "GENERAL.STATE", "device", "show", iface]
|
||||||
#!| "grep -q enabled"
|
#!| "grep -q disconnected"
|
||||||
#!&& "a=off"
|
#!&& "a=connect"
|
||||||
#!|| "a=on"
|
#!|| "a=disconnect"
|
||||||
#!>> fmtCmd "nmcli" ["networking", "$a"]
|
#!>> fmtCmd "nmcli" ["device", "$a", iface]
|
||||||
#!&& fmtNotifyCmd defNoteInfo {body = Just $ Text "networking switched $a"}
|
#!&& fmtNotifyCmd defNoteInfo {body = Just $ Text "ethernet \"$a\"ed"}
|
||||||
|
|
||||||
runToggleWifi :: MonadUnliftIO m => Sometimes (m ())
|
|
||||||
runToggleWifi = Sometimes "wifi toggle" xpfWireless [Subfeature root "nmcli"]
|
|
||||||
where
|
|
||||||
root = IORoot_ cmd $ Only_ nmcli
|
|
||||||
cmd =
|
|
||||||
S.spawn $
|
|
||||||
fmtCmd "nmcli" ["radio", "wifi"]
|
|
||||||
#!| "grep -q enabled"
|
|
||||||
#!&& "a=off"
|
|
||||||
#!|| "a=on"
|
|
||||||
#!>> fmtCmd "nmcli" ["radio", "wifi", "$a"]
|
|
||||||
#!&& fmtNotifyCmd defNoteInfo {body = Just $ Text "wifi switched $a"}
|
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- Configuration commands
|
-- Configuration commands
|
||||||
|
@ -344,7 +320,6 @@ runToggleWifi = Sometimes "wifi toggle" xpfWireless [Subfeature root "nmcli"]
|
||||||
runRestart :: X ()
|
runRestart :: X ()
|
||||||
runRestart = restart "xmonad" True
|
runRestart = restart "xmonad" True
|
||||||
|
|
||||||
-- TODO use rio in here so I don't have to fill my xinit log with stack poop
|
|
||||||
-- TODO only recompile the VM binary if we have virtualbox enabled
|
-- TODO only recompile the VM binary if we have virtualbox enabled
|
||||||
runRecompile :: X ()
|
runRecompile :: X ()
|
||||||
runRecompile = do
|
runRecompile = do
|
||||||
|
@ -373,12 +348,7 @@ getCaptureDir = do
|
||||||
where
|
where
|
||||||
fallback = (</> ".local/share") <$> getHomeDirectory
|
fallback = (</> ".local/share") <$> getHomeDirectory
|
||||||
|
|
||||||
runFlameshot
|
runFlameshot :: T.Text -> T.Text -> Maybe SesClient -> SometimesX
|
||||||
:: MonadUnliftIO m
|
|
||||||
=> T.Text
|
|
||||||
-> T.Text
|
|
||||||
-> Maybe NamedSesConnection
|
|
||||||
-> Sometimes (m ())
|
|
||||||
runFlameshot n mode cl = sometimesDBus cl n (T.pack myCapture) tree cmd
|
runFlameshot n mode cl = sometimesDBus cl n (T.pack myCapture) tree cmd
|
||||||
where
|
where
|
||||||
cmd _ = spawnCmd myCapture [mode]
|
cmd _ = spawnCmd myCapture [mode]
|
||||||
|
@ -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
|
-- TODO this will steal focus from the current window (and puts it
|
||||||
-- in the root window?) ...need to fix
|
-- in the root window?) ...need to fix
|
||||||
runAreaCapture :: MonadUnliftIO m => Maybe NamedSesConnection -> Sometimes (m ())
|
runAreaCapture :: Maybe SesClient -> SometimesX
|
||||||
runAreaCapture = runFlameshot "screen area capture" "gui"
|
runAreaCapture = runFlameshot "screen area capture" "gui"
|
||||||
|
|
||||||
-- myWindowCap = "screencap -w" --external script
|
-- myWindowCap = "screencap -w" --external script
|
||||||
|
|
||||||
runDesktopCapture :: MonadUnliftIO m => Maybe NamedSesConnection -> Sometimes (m ())
|
runDesktopCapture :: Maybe SesClient -> SometimesX
|
||||||
runDesktopCapture = runFlameshot "fullscreen capture" "full"
|
runDesktopCapture = runFlameshot "fullscreen capture" "full"
|
||||||
|
|
||||||
runScreenCapture :: MonadUnliftIO m => Maybe NamedSesConnection -> Sometimes (m ())
|
runScreenCapture :: Maybe SesClient -> SometimesX
|
||||||
runScreenCapture = runFlameshot "screen capture" "screen"
|
runScreenCapture = runFlameshot "screen capture" "screen"
|
||||||
|
|
||||||
runCaptureBrowser :: MonadUnliftIO m => Sometimes (m ())
|
runCaptureBrowser :: SometimesX
|
||||||
runCaptureBrowser = sometimesIO_
|
runCaptureBrowser = sometimesIO_
|
||||||
"screen capture browser"
|
"screen capture browser"
|
||||||
"feh"
|
"feh"
|
||||||
|
|
|
@ -1,3 +1,5 @@
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- Commands for controlling power
|
-- Commands for controlling power
|
||||||
|
|
||||||
|
@ -24,7 +26,7 @@ module XMonad.Internal.Command.Power
|
||||||
)
|
)
|
||||||
where
|
where
|
||||||
|
|
||||||
import Data.Internal.XIO
|
import Data.Internal.Dependency
|
||||||
import Graphics.X11.Types
|
import Graphics.X11.Types
|
||||||
import RIO
|
import RIO
|
||||||
import RIO.Directory
|
import RIO.Directory
|
||||||
|
@ -67,30 +69,29 @@ runScreenLock =
|
||||||
False
|
False
|
||||||
myScreenlock
|
myScreenlock
|
||||||
|
|
||||||
runPowerOff :: MonadUnliftIO m => m ()
|
runPowerOff :: X ()
|
||||||
runPowerOff = spawn "systemctl poweroff"
|
runPowerOff = spawn "systemctl poweroff"
|
||||||
|
|
||||||
runSuspend :: MonadUnliftIO m => m ()
|
runSuspend :: X ()
|
||||||
runSuspend = spawn "systemctl suspend"
|
runSuspend = spawn "systemctl suspend"
|
||||||
|
|
||||||
runHibernate :: MonadUnliftIO m => m ()
|
runHibernate :: X ()
|
||||||
runHibernate = spawn "systemctl hibernate"
|
runHibernate = spawn "systemctl hibernate"
|
||||||
|
|
||||||
runReboot :: MonadUnliftIO m => m ()
|
runReboot :: X ()
|
||||||
runReboot = spawn "systemctl reboot"
|
runReboot = spawn "systemctl reboot"
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- Autolock
|
-- Autolock
|
||||||
|
|
||||||
runAutolock :: Sometimes (XIO (P.Process () () ()))
|
runAutolock :: Sometimes (FIO (P.Process () () ()))
|
||||||
runAutolock = sometimesIO_ "automatic screen lock" "xss-lock" tree cmd
|
runAutolock = sometimesIO_ "automatic screen lock" "xss-lock" tree cmd
|
||||||
where
|
where
|
||||||
tree =
|
tree =
|
||||||
And_ (Only_ $ sysExe [Package Official "xss-lock"] "xss-lock") $
|
And_ (Only_ $ sysExe [Package Official "xss-lock"] "xss-lock") $
|
||||||
Only_ $
|
Only_ $
|
||||||
IOSometimes_ runScreenLock
|
IOSometimes_ runScreenLock
|
||||||
cmd = P.proc "xss-lock" args (P.startProcess . P.setCreateGroup True)
|
cmd = P.proc "xss-lock" ["--ignore-sleep", "screenlock"] (P.startProcess . P.setCreateGroup True)
|
||||||
args = ["--ignore-sleep", "--", "screenlock", "true"]
|
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- Confirmation prompts
|
-- 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
|
confirmPrompt' s x fb = confirmPrompt (XT.promptTheme fb) (T.unpack s) x
|
||||||
|
|
||||||
suspendPrompt :: XT.FontBuilder -> X ()
|
suspendPrompt :: XT.FontBuilder -> X ()
|
||||||
suspendPrompt = confirmPrompt' "suspend?" $ liftIO runSuspend
|
suspendPrompt = confirmPrompt' "suspend?" runSuspend
|
||||||
|
|
||||||
quitPrompt :: XT.FontBuilder -> X ()
|
quitPrompt :: XT.FontBuilder -> X ()
|
||||||
quitPrompt = confirmPrompt' "quit?" $ io exitSuccess
|
quitPrompt = confirmPrompt' "quit?" $ io exitSuccess
|
||||||
|
@ -179,20 +180,17 @@ data PowerMaybeAction
|
||||||
| Reboot
|
| Reboot
|
||||||
deriving (Eq)
|
deriving (Eq)
|
||||||
|
|
||||||
fromPMA :: PowerMaybeAction -> Int
|
instance Enum PowerMaybeAction where
|
||||||
fromPMA a = case a of
|
toEnum 0 = Poweroff
|
||||||
Poweroff -> 0
|
toEnum 1 = Shutdown
|
||||||
Shutdown -> 1
|
toEnum 2 = Hibernate
|
||||||
Hibernate -> 2
|
toEnum 3 = Reboot
|
||||||
Reboot -> 3
|
toEnum _ = errorWithoutStackTrace "Main.Enum.PowerMaybeAction.toEnum: bad argument"
|
||||||
|
|
||||||
toPMA :: Int -> Maybe PowerMaybeAction
|
fromEnum Poweroff = 0
|
||||||
toPMA x = case x of
|
fromEnum Shutdown = 1
|
||||||
0 -> Just Poweroff
|
fromEnum Hibernate = 2
|
||||||
1 -> Just Shutdown
|
fromEnum Reboot = 3
|
||||||
2 -> Just Hibernate
|
|
||||||
3 -> Just Reboot
|
|
||||||
_ -> Nothing
|
|
||||||
|
|
||||||
data PowerPrompt = PowerPrompt
|
data PowerPrompt = PowerPrompt
|
||||||
|
|
||||||
|
@ -224,11 +222,9 @@ powerPrompt lock fb = mkXPrompt PowerPrompt theme comp executeMaybeAction
|
||||||
, (xK_Return, quit)
|
, (xK_Return, quit)
|
||||||
, (xK_Escape, quit)
|
, (xK_Escape, quit)
|
||||||
]
|
]
|
||||||
sendMaybeAction a = setInput (show $ fromPMA a) >> setSuccess True >> setDone True
|
sendMaybeAction a = setInput (show $ fromEnum a) >> setSuccess True >> setDone True
|
||||||
executeMaybeAction a = case toPMA =<< readMaybe a of
|
executeMaybeAction a = case toEnum $ read a of
|
||||||
Just Poweroff -> liftIO runPowerOff
|
Poweroff -> runPowerOff
|
||||||
Just Shutdown -> lock >> liftIO runSuspend
|
Shutdown -> lock >> runSuspend
|
||||||
Just Hibernate -> lock >> liftIO runHibernate
|
Hibernate -> lock >> runHibernate
|
||||||
Just Reboot -> liftIO runReboot
|
Reboot -> runReboot
|
||||||
-- TODO log an error here since this should never happen
|
|
||||||
Nothing -> skip
|
|
||||||
|
|
|
@ -1,3 +1,6 @@
|
||||||
|
{-# LANGUAGE LambdaCase #-}
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- Concurrent module to handle events from acpid
|
-- Concurrent module to handle events from acpid
|
||||||
|
|
||||||
|
@ -7,7 +10,7 @@ module XMonad.Internal.Concurrent.ACPIEvent
|
||||||
)
|
)
|
||||||
where
|
where
|
||||||
|
|
||||||
import Data.Internal.XIO
|
import Data.Internal.Dependency
|
||||||
import Network.Socket
|
import Network.Socket
|
||||||
import Network.Socket.ByteString
|
import Network.Socket.ByteString
|
||||||
import RIO
|
import RIO
|
||||||
|
@ -30,18 +33,15 @@ data ACPIEvent
|
||||||
| LidClose
|
| LidClose
|
||||||
deriving (Eq)
|
deriving (Eq)
|
||||||
|
|
||||||
fromACPIEvent :: ACPIEvent -> Int
|
instance Enum ACPIEvent where
|
||||||
fromACPIEvent x = case x of
|
toEnum 0 = Power
|
||||||
Power -> 0
|
toEnum 1 = Sleep
|
||||||
Sleep -> 1
|
toEnum 2 = LidClose
|
||||||
LidClose -> 2
|
toEnum _ = errorWithoutStackTrace "ACPI.Enum.ACPIEvent.toEnum: bad argument"
|
||||||
|
|
||||||
toACPIEvent :: Int -> Maybe ACPIEvent
|
fromEnum Power = 0
|
||||||
toACPIEvent x = case x of
|
fromEnum Sleep = 1
|
||||||
0 -> Just Power
|
fromEnum LidClose = 2
|
||||||
1 -> Just Sleep
|
|
||||||
2 -> Just LidClose
|
|
||||||
_ -> Nothing
|
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- Internal functions
|
-- Internal functions
|
||||||
|
@ -64,7 +64,7 @@ parseLine line =
|
||||||
|
|
||||||
-- | Send an ACPIEvent to the X server as a ClientMessage
|
-- | Send an ACPIEvent to the X server as a ClientMessage
|
||||||
sendACPIEvent :: ACPIEvent -> IO ()
|
sendACPIEvent :: ACPIEvent -> IO ()
|
||||||
sendACPIEvent = sendXMsg ACPI . show . fromACPIEvent
|
sendACPIEvent = sendXMsg ACPI . show . fromEnum
|
||||||
|
|
||||||
isDischarging :: IO (Maybe Bool)
|
isDischarging :: IO (Maybe Bool)
|
||||||
isDischarging = do
|
isDischarging = do
|
||||||
|
@ -91,14 +91,14 @@ socketDep = Only_ $ pathR acpiPath [Package Official "acpid"]
|
||||||
-- Xmonad's event hook)
|
-- Xmonad's event hook)
|
||||||
handleACPI :: FontBuilder -> X () -> String -> X ()
|
handleACPI :: FontBuilder -> X () -> String -> X ()
|
||||||
handleACPI fb lock tag = do
|
handleACPI fb lock tag = do
|
||||||
let acpiTag = toACPIEvent =<< readMaybe tag :: Maybe ACPIEvent
|
let acpiTag = toEnum <$> readMaybe tag :: Maybe ACPIEvent
|
||||||
forM_ acpiTag $ \case
|
forM_ acpiTag $ \case
|
||||||
Power -> powerPrompt lock fb
|
Power -> powerPrompt lock fb
|
||||||
Sleep -> suspendPrompt fb
|
Sleep -> suspendPrompt fb
|
||||||
LidClose -> do
|
LidClose -> do
|
||||||
status <- io isDischarging
|
status <- io isDischarging
|
||||||
-- only run suspend if battery exists and is discharging
|
-- only run suspend if battery exists and is discharging
|
||||||
forM_ status $ flip when $ liftIO runSuspend
|
forM_ status $ flip when runSuspend
|
||||||
lock
|
lock
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
|
|
|
@ -28,7 +28,6 @@ import Graphics.X11.Xlib.Atom
|
||||||
import Graphics.X11.Xlib.Display
|
import Graphics.X11.Xlib.Display
|
||||||
import Graphics.X11.Xlib.Event
|
import Graphics.X11.Xlib.Event
|
||||||
import Graphics.X11.Xlib.Extras
|
import Graphics.X11.Xlib.Extras
|
||||||
import RIO
|
|
||||||
import XMonad.Internal.IO
|
import XMonad.Internal.IO
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
|
@ -43,18 +42,14 @@ data XMsgType
|
||||||
| Unknown
|
| Unknown
|
||||||
deriving (Eq, Show)
|
deriving (Eq, Show)
|
||||||
|
|
||||||
fromXMsgType :: XMsgType -> Int
|
instance Enum XMsgType where
|
||||||
fromXMsgType x = case x of
|
toEnum 0 = ACPI
|
||||||
ACPI -> 0
|
toEnum 1 = Workspace
|
||||||
Workspace -> 1
|
toEnum _ = errorWithoutStackTrace "ACPI.Enum.ACPIEvent.toEnum: bad argument"
|
||||||
Unknown -> 2
|
|
||||||
|
|
||||||
toXMsgType :: Int -> Maybe XMsgType
|
fromEnum ACPI = 0
|
||||||
toXMsgType x = case x of
|
fromEnum Workspace = 1
|
||||||
0 -> Just ACPI
|
fromEnum Unknown = 2
|
||||||
1 -> Just Workspace
|
|
||||||
2 -> Just Unknown
|
|
||||||
_ -> Nothing
|
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- Exported API
|
-- Exported API
|
||||||
|
@ -63,9 +58,9 @@ toXMsgType x = case x of
|
||||||
-- type and payload
|
-- type and payload
|
||||||
splitXMsg :: (Integral a) => [a] -> (XMsgType, String)
|
splitXMsg :: (Integral a) => [a] -> (XMsgType, String)
|
||||||
splitXMsg [] = (Unknown, "")
|
splitXMsg [] = (Unknown, "")
|
||||||
splitXMsg (x : xs) = (fromMaybe Unknown xtype, tag)
|
splitXMsg (x : xs) = (xtype, tag)
|
||||||
where
|
where
|
||||||
xtype = toXMsgType $ fromIntegral x
|
xtype = toEnum $ fromIntegral x
|
||||||
tag = chr . fromIntegral <$> takeWhile (/= 0) xs
|
tag = chr . fromIntegral <$> takeWhile (/= 0) xs
|
||||||
|
|
||||||
-- | Emit a ClientMessage event to the X server with the given type and payloud
|
-- | Emit a ClientMessage event to the X server with the given type and payloud
|
||||||
|
@ -91,5 +86,5 @@ sendXMsg xtype tag = withOpenDisplay $ \dpy -> do
|
||||||
setClientMessageEvent' e root bITMAP 8 (x : t)
|
setClientMessageEvent' e root bITMAP 8 (x : t)
|
||||||
sendEvent dpy root False substructureNotifyMask e
|
sendEvent dpy root False substructureNotifyMask e
|
||||||
where
|
where
|
||||||
x = fromIntegral $ fromXMsgType xtype
|
x = fromIntegral $ fromEnum xtype
|
||||||
t = fmap (fromIntegral . fromEnum) tag
|
t = fmap (fromIntegral . fromEnum) tag
|
||||||
|
|
|
@ -34,8 +34,6 @@ module XMonad.Internal.Concurrent.DynamicWorkspaces
|
||||||
)
|
)
|
||||||
where
|
where
|
||||||
|
|
||||||
import qualified Data.ByteString.Char8 as BC
|
|
||||||
import Data.Internal.XIO
|
|
||||||
import Graphics.X11.Types
|
import Graphics.X11.Types
|
||||||
import Graphics.X11.Xlib.Atom
|
import Graphics.X11.Xlib.Atom
|
||||||
import Graphics.X11.Xlib.Display
|
import Graphics.X11.Xlib.Display
|
||||||
|
@ -90,49 +88,38 @@ data DynWorkspace = DynWorkspace
|
||||||
-- the same as that in XMonad itself (eg with Query types)
|
-- the same as that in XMonad itself (eg with Query types)
|
||||||
-- type MatchTags = M.Map String String
|
-- type MatchTags = M.Map String String
|
||||||
|
|
||||||
data WEnv = WEnv
|
data WConf = WConf
|
||||||
{ wDisplay :: !Display
|
{ display :: Display
|
||||||
, wDynWorkspaces :: ![DynWorkspace]
|
, dynWorkspaces :: [DynWorkspace]
|
||||||
, wCurPIDs :: !(MVar (S.Set Pid))
|
, curPIDs :: MVar (S.Set Pid)
|
||||||
, wXEnv :: !XEnv
|
|
||||||
}
|
}
|
||||||
|
|
||||||
instance HasLogFunc WEnv where
|
type W a = RIO WConf ()
|
||||||
logFuncL = lens wXEnv (\x y -> x {wXEnv = y}) . logFuncL
|
|
||||||
|
|
||||||
type WIO a = RIO WEnv a
|
runWorkspaceMon :: [DynWorkspace] -> IO ()
|
||||||
|
|
||||||
runWorkspaceMon :: [DynWorkspace] -> XIO ()
|
|
||||||
runWorkspaceMon dws = withOpenDisplay $ \dpy -> do
|
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)
|
-- listen only for substructure change events (which includes MapNotify)
|
||||||
liftIO $ allocaSetWindowAttributes $ \a -> do
|
allocaSetWindowAttributes $ \a -> do
|
||||||
set_event_mask a substructureNotifyMask
|
set_event_mask a substructureNotifyMask
|
||||||
changeWindowAttributes dpy root cWEventMask a
|
changeWindowAttributes dpy root cWEventMask a
|
||||||
withRunInIO $ \runIO -> do
|
void $ allocaXEvent $ withEvents dpy
|
||||||
void $ allocaXEvent $ runIO . withEvents dpy
|
|
||||||
where
|
where
|
||||||
wrapEnv dpy ps x =
|
|
||||||
WEnv
|
|
||||||
{ wDisplay = dpy
|
|
||||||
, wDynWorkspaces = dws
|
|
||||||
, wCurPIDs = ps
|
|
||||||
, wXEnv = x
|
|
||||||
}
|
|
||||||
withEvents dpy e = do
|
withEvents dpy e = do
|
||||||
ps <- newMVar S.empty
|
ps <- newMVar S.empty
|
||||||
mapRIO (wrapEnv dpy ps) $ do
|
let c = WConf {display = dpy, dynWorkspaces = dws, curPIDs = ps}
|
||||||
|
runRIO c $
|
||||||
forever $
|
forever $
|
||||||
handleEvent =<< io (nextEvent dpy e >> getEvent e)
|
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
|
-- | assume this fires at least once when a new window is created (also could
|
||||||
-- use CreateNotify but that is really noisy)
|
-- use CreateNotify but that is really noisy)
|
||||||
handleEvent MapNotifyEvent {ev_window = w} = do
|
handleEvent MapNotifyEvent {ev_window = w} = do
|
||||||
dpy <- asks wDisplay
|
dpy <- asks display
|
||||||
hint <- io $ getClassHint dpy w
|
hint <- io $ getClassHint dpy w
|
||||||
dws <- asks wDynWorkspaces
|
dws <- asks dynWorkspaces
|
||||||
let tag =
|
let tag =
|
||||||
M.lookup (resClass hint) $
|
M.lookup (resClass hint) $
|
||||||
M.fromList $
|
M.fromList $
|
||||||
|
@ -146,28 +133,21 @@ handleEvent MapNotifyEvent {ev_window = w} = do
|
||||||
_ -> return ()
|
_ -> return ()
|
||||||
handleEvent _ = return ()
|
handleEvent _ = return ()
|
||||||
|
|
||||||
withUniquePid :: Pid -> String -> WIO ()
|
withUniquePid :: Pid -> String -> W ()
|
||||||
withUniquePid pid tag = do
|
withUniquePid pid tag = do
|
||||||
ps <- asks wCurPIDs
|
ps <- asks curPIDs
|
||||||
pids <- readMVar ps
|
pids <- readMVar ps
|
||||||
unless (pid `elem` pids)
|
io
|
||||||
|
$ unless (pid `elem` pids)
|
||||||
$ bracket_
|
$ bracket_
|
||||||
(modifyMVar_ ps (return . S.insert pid))
|
(modifyMVar_ ps (return . S.insert pid))
|
||||||
(modifyMVar_ ps (return . S.delete pid))
|
(modifyMVar_ ps (return . S.delete pid))
|
||||||
$ do
|
$ waitUntilExit pid >> sendXMsg Workspace tag
|
||||||
logInfo $ "waiting for pid " <> pid_ <> " to exit on workspace " <> tag_
|
|
||||||
waitUntilExit pid
|
|
||||||
logInfo $ "pid " <> pid_ <> " exited on workspace " <> tag_
|
|
||||||
liftIO $ sendXMsg Workspace tag
|
|
||||||
where
|
|
||||||
pid_ = "'" <> displayShow pid <> "'"
|
|
||||||
tag_ = "'" <> displayBytesUtf8 (BC.pack tag) <> "'"
|
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- Launching apps
|
-- Launching apps
|
||||||
-- When launching apps on dymamic workspaces, first check if they are running
|
-- When launching apps on dymamic workspaces, first check if they are running
|
||||||
-- and launch if not, then switch to their workspace
|
-- and launch if not, then switch to their workspace
|
||||||
|
|
||||||
wsOccupied :: Eq a1 => a1 -> W.StackSet a1 l a2 sid sd -> Bool
|
wsOccupied :: Eq a1 => a1 -> W.StackSet a1 l a2 sid sd -> Bool
|
||||||
wsOccupied tag ws =
|
wsOccupied tag ws =
|
||||||
elem tag $
|
elem tag $
|
||||||
|
|
|
@ -1,3 +1,6 @@
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
{-# LANGUAGE ScopedTypeVariables #-}
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- VirtualBox-specific functions
|
-- VirtualBox-specific functions
|
||||||
|
|
||||||
|
@ -8,7 +11,7 @@ module XMonad.Internal.Concurrent.VirtualBox
|
||||||
)
|
)
|
||||||
where
|
where
|
||||||
|
|
||||||
import Data.Internal.XIO
|
import Data.Internal.Dependency
|
||||||
import RIO hiding (try)
|
import RIO hiding (try)
|
||||||
import RIO.Directory
|
import RIO.Directory
|
||||||
import RIO.FilePath
|
import RIO.FilePath
|
||||||
|
@ -33,7 +36,7 @@ vmInstanceConfig vmName = do
|
||||||
vmDirectory :: IO (Either String String)
|
vmDirectory :: IO (Either String String)
|
||||||
vmDirectory = do
|
vmDirectory = do
|
||||||
p <- vmConfig
|
p <- vmConfig
|
||||||
s <- tryIO $ readFileUtf8 p
|
s <- tryIO $ readFile p
|
||||||
return $ case s of
|
return $ case s of
|
||||||
(Left _) -> Left "could not read VirtualBox config file"
|
(Left _) -> Left "could not read VirtualBox config file"
|
||||||
(Right x) ->
|
(Right x) ->
|
||||||
|
|
|
@ -1,3 +1,5 @@
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- DBus module for Clevo Keyboard control
|
-- DBus module for Clevo Keyboard control
|
||||||
|
|
||||||
|
@ -13,7 +15,7 @@ where
|
||||||
|
|
||||||
import DBus
|
import DBus
|
||||||
import Data.Internal.DBus
|
import Data.Internal.DBus
|
||||||
import Data.Internal.XIO
|
import Data.Internal.Dependency
|
||||||
import RIO
|
import RIO
|
||||||
import RIO.FilePath
|
import RIO.FilePath
|
||||||
import XMonad.Internal.DBus.Brightness.Common
|
import XMonad.Internal.DBus.Brightness.Common
|
||||||
|
@ -44,34 +46,34 @@ backlightDir = "/sys/devices/platform/tuxedo_keyboard"
|
||||||
stateFile :: FilePath
|
stateFile :: FilePath
|
||||||
stateFile = backlightDir </> "state"
|
stateFile = backlightDir </> "state"
|
||||||
|
|
||||||
stateChange :: MonadUnliftIO m => Bool -> m ()
|
stateChange :: Bool -> IO ()
|
||||||
stateChange = writeBool stateFile
|
stateChange = writeBool stateFile
|
||||||
|
|
||||||
stateOn :: MonadUnliftIO m => m ()
|
stateOn :: IO ()
|
||||||
stateOn = stateChange True
|
stateOn = stateChange True
|
||||||
|
|
||||||
stateOff :: MonadUnliftIO m => m ()
|
stateOff :: IO ()
|
||||||
stateOff = stateChange False
|
stateOff = stateChange False
|
||||||
|
|
||||||
brightnessFile :: FilePath
|
brightnessFile :: FilePath
|
||||||
brightnessFile = backlightDir </> "brightness"
|
brightnessFile = backlightDir </> "brightness"
|
||||||
|
|
||||||
getBrightness :: MonadUnliftIO m => RawBounds -> m Brightness
|
getBrightness :: RawBounds -> IO Brightness
|
||||||
getBrightness bounds = readPercent bounds brightnessFile
|
getBrightness bounds = readPercent bounds brightnessFile
|
||||||
|
|
||||||
minBrightness :: MonadUnliftIO m => RawBounds -> m Brightness
|
minBrightness :: RawBounds -> IO Brightness
|
||||||
minBrightness bounds = do
|
minBrightness bounds = do
|
||||||
b <- writePercentMin bounds brightnessFile
|
b <- writePercentMin bounds brightnessFile
|
||||||
stateOff
|
stateOff
|
||||||
return b
|
return b
|
||||||
|
|
||||||
maxBrightness :: MonadUnliftIO m => RawBounds -> m Brightness
|
maxBrightness :: RawBounds -> IO Brightness
|
||||||
maxBrightness bounds = stateOn >> writePercentMax bounds brightnessFile
|
maxBrightness bounds = stateOn >> writePercentMax bounds brightnessFile
|
||||||
|
|
||||||
incBrightness :: MonadUnliftIO m => RawBounds -> m Brightness
|
incBrightness :: RawBounds -> IO Brightness
|
||||||
incBrightness bounds = stateOn >> incPercent steps brightnessFile bounds
|
incBrightness bounds = stateOn >> incPercent steps brightnessFile bounds
|
||||||
|
|
||||||
decBrightness :: MonadUnliftIO m => RawBounds -> m Brightness
|
decBrightness :: RawBounds -> IO Brightness
|
||||||
decBrightness bounds = do
|
decBrightness bounds = do
|
||||||
b <- decPercent steps brightnessFile bounds
|
b <- decPercent steps brightnessFile bounds
|
||||||
when (b == 0) stateOff
|
when (b == 0) stateOff
|
||||||
|
@ -86,7 +88,7 @@ blPath = objectPath_ "/clevo_keyboard"
|
||||||
interface :: InterfaceName
|
interface :: InterfaceName
|
||||||
interface = interfaceName_ "org.xmonad.Brightness"
|
interface = interfaceName_ "org.xmonad.Brightness"
|
||||||
|
|
||||||
clevoKeyboardConfig :: MonadUnliftIO m => BrightnessConfig m RawBrightness Brightness
|
clevoKeyboardConfig :: BrightnessConfig RawBrightness Brightness
|
||||||
clevoKeyboardConfig =
|
clevoKeyboardConfig =
|
||||||
BrightnessConfig
|
BrightnessConfig
|
||||||
{ bcMin = minBrightness
|
{ bcMin = minBrightness
|
||||||
|
@ -111,14 +113,9 @@ brightnessFileDep :: IODependency_
|
||||||
brightnessFileDep = pathR brightnessFile [Package AUR "tuxedo-keyboard"]
|
brightnessFileDep = pathR brightnessFile [Package AUR "tuxedo-keyboard"]
|
||||||
|
|
||||||
clevoKeyboardSignalDep :: DBusDependency_ SesClient
|
clevoKeyboardSignalDep :: DBusDependency_ SesClient
|
||||||
clevoKeyboardSignalDep =
|
clevoKeyboardSignalDep = signalDep clevoKeyboardConfig
|
||||||
-- TODO do I need to get rid of the IO here?
|
|
||||||
signalDep (clevoKeyboardConfig :: BrightnessConfig IO RawBrightness Brightness)
|
|
||||||
|
|
||||||
exportClevoKeyboard
|
exportClevoKeyboard :: Maybe SesClient -> SometimesIO
|
||||||
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
|
|
||||||
=> Maybe NamedSesConnection
|
|
||||||
-> Sometimes (m (), m ())
|
|
||||||
exportClevoKeyboard =
|
exportClevoKeyboard =
|
||||||
brightnessExporter
|
brightnessExporter
|
||||||
xpfClevoBacklight
|
xpfClevoBacklight
|
||||||
|
@ -126,23 +123,15 @@ exportClevoKeyboard =
|
||||||
[stateFileDep, brightnessFileDep]
|
[stateFileDep, brightnessFileDep]
|
||||||
clevoKeyboardConfig
|
clevoKeyboardConfig
|
||||||
|
|
||||||
clevoKeyboardControls
|
clevoKeyboardControls :: Maybe SesClient -> BrightnessControls
|
||||||
:: (HasClient (DBusEnv env), MonadReader env m, MonadUnliftIO m)
|
|
||||||
=> Maybe NamedSesConnection
|
|
||||||
-> BrightnessControls m
|
|
||||||
clevoKeyboardControls = brightnessControls xpfClevoBacklight clevoKeyboardConfig
|
clevoKeyboardControls = brightnessControls xpfClevoBacklight clevoKeyboardConfig
|
||||||
|
|
||||||
callGetBrightnessCK
|
callGetBrightnessCK :: MonadUnliftIO m => SesClient -> m (Maybe Brightness)
|
||||||
:: (SafeClient c, HasClient env, MonadReader (env c) m, MonadUnliftIO m)
|
|
||||||
=> m (Maybe Brightness)
|
|
||||||
callGetBrightnessCK = callGetBrightness clevoKeyboardConfig
|
callGetBrightnessCK = callGetBrightness clevoKeyboardConfig
|
||||||
|
|
||||||
matchSignalCK
|
matchSignalCK
|
||||||
:: ( SafeClient c
|
:: MonadUnliftIO m
|
||||||
, HasClient env
|
|
||||||
, MonadReader (env c) m
|
|
||||||
, MonadUnliftIO m
|
|
||||||
)
|
|
||||||
=> (Maybe Brightness -> m ())
|
=> (Maybe Brightness -> m ())
|
||||||
|
-> SesClient
|
||||||
-> m ()
|
-> m ()
|
||||||
matchSignalCK = matchSignal clevoKeyboardConfig
|
matchSignalCK = matchSignal clevoKeyboardConfig
|
||||||
|
|
|
@ -1,3 +1,5 @@
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- DBus module for DBus brightness controls
|
-- DBus module for DBus brightness controls
|
||||||
|
|
||||||
|
@ -16,9 +18,10 @@ import DBus
|
||||||
import DBus.Client
|
import DBus.Client
|
||||||
import qualified DBus.Introspection as I
|
import qualified DBus.Introspection as I
|
||||||
import Data.Internal.DBus
|
import Data.Internal.DBus
|
||||||
import Data.Internal.XIO
|
import Data.Internal.Dependency
|
||||||
import RIO
|
import RIO
|
||||||
import qualified RIO.Text as T
|
import qualified RIO.Text as T
|
||||||
|
import XMonad.Core (io)
|
||||||
import XMonad.Internal.DBus.Common
|
import XMonad.Internal.DBus.Common
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
|
@ -29,32 +32,31 @@ import XMonad.Internal.DBus.Common
|
||||||
-- integer and emit a signal with the same brightness value. Additionally, there
|
-- integer and emit a signal with the same brightness value. Additionally, there
|
||||||
-- is one method to get the current brightness.
|
-- is one method to get the current brightness.
|
||||||
|
|
||||||
data BrightnessConfig m a b = BrightnessConfig
|
data BrightnessConfig a b = BrightnessConfig
|
||||||
{ bcMin :: (a, a) -> m b
|
{ bcMin :: (a, a) -> IO b
|
||||||
, bcMax :: (a, a) -> m b
|
, bcMax :: (a, a) -> IO b
|
||||||
, bcDec :: (a, a) -> m b
|
, bcDec :: (a, a) -> IO b
|
||||||
, bcInc :: (a, a) -> m b
|
, bcInc :: (a, a) -> IO b
|
||||||
, bcGet :: (a, a) -> m b
|
, bcGet :: (a, a) -> IO b
|
||||||
, bcMinRaw :: a
|
, bcMinRaw :: a
|
||||||
, bcGetMax :: m a
|
, bcGetMax :: IO a
|
||||||
, bcPath :: ObjectPath
|
, bcPath :: ObjectPath
|
||||||
, bcInterface :: InterfaceName
|
, bcInterface :: InterfaceName
|
||||||
, bcName :: T.Text
|
, bcName :: T.Text
|
||||||
}
|
}
|
||||||
|
|
||||||
data BrightnessControls m = BrightnessControls
|
data BrightnessControls = BrightnessControls
|
||||||
{ bctlMax :: Sometimes (m ())
|
{ bctlMax :: SometimesX
|
||||||
, bctlMin :: Sometimes (m ())
|
, bctlMin :: SometimesX
|
||||||
, bctlInc :: Sometimes (m ())
|
, bctlInc :: SometimesX
|
||||||
, bctlDec :: Sometimes (m ())
|
, bctlDec :: SometimesX
|
||||||
}
|
}
|
||||||
|
|
||||||
brightnessControls
|
brightnessControls
|
||||||
:: (HasClient (DBusEnv env), MonadReader env m, MonadUnliftIO m)
|
:: XPQuery
|
||||||
=> XPQuery
|
-> BrightnessConfig a b
|
||||||
-> BrightnessConfig m a b
|
-> Maybe SesClient
|
||||||
-> Maybe NamedSesConnection
|
-> BrightnessControls
|
||||||
-> BrightnessControls m
|
|
||||||
brightnessControls q bc cl =
|
brightnessControls q bc cl =
|
||||||
BrightnessControls
|
BrightnessControls
|
||||||
{ bctlMax = cb "max brightness" memMax
|
{ bctlMax = cb "max brightness" memMax
|
||||||
|
@ -66,34 +68,26 @@ brightnessControls q bc cl =
|
||||||
cb = callBacklight q cl bc
|
cb = callBacklight q cl bc
|
||||||
|
|
||||||
callGetBrightness
|
callGetBrightness
|
||||||
:: ( HasClient env
|
:: (MonadUnliftIO m, SafeClient c, Num n)
|
||||||
, MonadReader (env c) m
|
=> BrightnessConfig a b
|
||||||
, MonadUnliftIO m
|
-> c
|
||||||
, SafeClient c
|
|
||||||
, Num n
|
|
||||||
)
|
|
||||||
=> BrightnessConfig m a b
|
|
||||||
-> m (Maybe n)
|
-> m (Maybe n)
|
||||||
callGetBrightness BrightnessConfig {bcPath = p, bcInterface = i} =
|
callGetBrightness BrightnessConfig {bcPath = p, bcInterface = i} client =
|
||||||
either (const Nothing) bodyGetBrightness
|
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} =
|
signalDep BrightnessConfig {bcPath = p, bcInterface = i} =
|
||||||
Endpoint [] xmonadSesBusName p i $ Signal_ memCur
|
Endpoint [] xmonadBusName p i $ Signal_ memCur
|
||||||
|
|
||||||
matchSignal
|
matchSignal
|
||||||
:: ( HasClient env
|
:: (MonadUnliftIO m, SafeClient c, Num n)
|
||||||
, MonadReader (env c) m
|
=> BrightnessConfig a b
|
||||||
, MonadUnliftIO m
|
|
||||||
, SafeClient c
|
|
||||||
, Num n
|
|
||||||
)
|
|
||||||
=> BrightnessConfig m a b
|
|
||||||
-> (Maybe n -> m ())
|
-> (Maybe n -> m ())
|
||||||
|
-> c
|
||||||
-> m ()
|
-> m ()
|
||||||
matchSignal BrightnessConfig {bcPath = p, bcInterface = i} cb =
|
matchSignal BrightnessConfig {bcPath = p, bcInterface = i} cb =
|
||||||
void $ addMatchCallback brMatcher (cb . bodyGetBrightness)
|
void . addMatchCallback brMatcher (cb . bodyGetBrightness)
|
||||||
where
|
where
|
||||||
-- TODO add busname to this
|
-- TODO add busname to this
|
||||||
brMatcher =
|
brMatcher =
|
||||||
|
@ -107,35 +101,33 @@ matchSignal BrightnessConfig {bcPath = p, bcInterface = i} cb =
|
||||||
-- Internal DBus Crap
|
-- Internal DBus Crap
|
||||||
|
|
||||||
brightnessExporter
|
brightnessExporter
|
||||||
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m, RealFrac b)
|
:: RealFrac b
|
||||||
=> XPQuery
|
=> XPQuery
|
||||||
-> [Fulfillment]
|
-> [Fulfillment]
|
||||||
-> [IODependency_]
|
-> [IODependency_]
|
||||||
-> BrightnessConfig m a b
|
-> BrightnessConfig a b
|
||||||
-> Maybe NamedSesConnection
|
-> Maybe SesClient
|
||||||
-> Sometimes (m (), m ())
|
-> SometimesIO
|
||||||
brightnessExporter q ful deps bc@BrightnessConfig {bcName = n} cl =
|
brightnessExporter q ful deps bc@BrightnessConfig {bcName = n} cl =
|
||||||
Sometimes (T.append n " DBus Interface") q [Subfeature root "exporter"]
|
Sometimes (T.append n " DBus Interface") q [Subfeature root "exporter"]
|
||||||
where
|
where
|
||||||
root = DBusRoot_ (exportBrightnessControlsInner bc) tree cl
|
root = DBusRoot_ (exportBrightnessControls' bc) tree cl
|
||||||
tree = listToAnds (Bus ful xmonadSesBusName) $ fmap DBusIO deps
|
tree = listToAnds (Bus ful xmonadBusName) $ fmap DBusIO deps
|
||||||
|
|
||||||
exportBrightnessControlsInner
|
exportBrightnessControls'
|
||||||
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m, RealFrac b)
|
:: (MonadUnliftIO m, RealFrac b)
|
||||||
=> BrightnessConfig m a b
|
=> BrightnessConfig a b
|
||||||
-> NamedSesConnection
|
-> SesClient
|
||||||
-> (m (), m ())
|
-> m ()
|
||||||
exportBrightnessControlsInner bc = cmd
|
exportBrightnessControls' bc cl = io $ do
|
||||||
where
|
let ses = toClient cl
|
||||||
cmd = exportPair (bcPath bc) $ \cl_ -> do
|
maxval <- bcGetMax bc -- assume the max value will never change
|
||||||
-- assume the max value will never change
|
let bounds = (bcMinRaw bc, maxval)
|
||||||
bounds <- (bcMinRaw bc,) <$> bcGetMax bc
|
let autoMethod' m f = autoMethod m $ emitBrightness bc ses =<< f bc bounds
|
||||||
runIO <- askRunInIO
|
let funget = bcGet bc
|
||||||
let autoMethod' m f = autoMethod m $ runIO $ do
|
export
|
||||||
val <- f bc bounds
|
ses
|
||||||
emitBrightness bc cl_ val
|
(bcPath bc)
|
||||||
funget <- toIO $ bcGet bc bounds
|
|
||||||
return $
|
|
||||||
defaultInterface
|
defaultInterface
|
||||||
{ interfaceName = bcInterface bc
|
{ interfaceName = bcInterface bc
|
||||||
, interfaceMethods =
|
, interfaceMethods =
|
||||||
|
@ -143,10 +135,11 @@ exportBrightnessControlsInner bc = cmd
|
||||||
, autoMethod' memMin bcMin
|
, autoMethod' memMin bcMin
|
||||||
, autoMethod' memInc bcInc
|
, autoMethod' memInc bcInc
|
||||||
, autoMethod' memDec bcDec
|
, autoMethod' memDec bcDec
|
||||||
, autoMethod memGet (round <$> funget :: IO Int32)
|
, autoMethod memGet (round <$> funget bounds :: IO Int32)
|
||||||
]
|
]
|
||||||
, interfaceSignals = [sig]
|
, interfaceSignals = [sig]
|
||||||
}
|
}
|
||||||
|
where
|
||||||
sig =
|
sig =
|
||||||
I.Signal
|
I.Signal
|
||||||
{ I.signalName = memCur
|
{ I.signalName = memCur
|
||||||
|
@ -160,7 +153,7 @@ exportBrightnessControlsInner bc = cmd
|
||||||
|
|
||||||
emitBrightness
|
emitBrightness
|
||||||
:: (MonadUnliftIO m, RealFrac b)
|
:: (MonadUnliftIO m, RealFrac b)
|
||||||
=> BrightnessConfig m a b
|
=> BrightnessConfig a b
|
||||||
-> Client
|
-> Client
|
||||||
-> b
|
-> b
|
||||||
-> m ()
|
-> m ()
|
||||||
|
@ -170,18 +163,26 @@ emitBrightness BrightnessConfig {bcPath = p, bcInterface = i} client cur =
|
||||||
sig = signal p i memCur
|
sig = signal p i memCur
|
||||||
|
|
||||||
callBacklight
|
callBacklight
|
||||||
:: (MonadReader env m, HasClient (DBusEnv env), MonadUnliftIO m)
|
:: XPQuery
|
||||||
=> XPQuery
|
-> Maybe SesClient
|
||||||
-> Maybe NamedSesConnection
|
-> BrightnessConfig a b
|
||||||
-> BrightnessConfig m a b
|
|
||||||
-> T.Text
|
-> T.Text
|
||||||
-> MemberName
|
-> MemberName
|
||||||
-> Sometimes (m ())
|
-> SometimesX
|
||||||
callBacklight q cl BrightnessConfig {bcPath = p, bcInterface = i, bcName = n} controlName m =
|
callBacklight
|
||||||
|
q
|
||||||
|
cl
|
||||||
|
BrightnessConfig
|
||||||
|
{ bcPath = p
|
||||||
|
, bcInterface = i
|
||||||
|
, bcName = n
|
||||||
|
}
|
||||||
|
controlName
|
||||||
|
m =
|
||||||
Sometimes (T.unwords [n, controlName]) q [Subfeature root "method call"]
|
Sometimes (T.unwords [n, controlName]) q [Subfeature root "method call"]
|
||||||
where
|
where
|
||||||
root = DBusRoot_ cmd (Only_ $ Endpoint [] xmonadSesBusName p i $ Method_ m) cl
|
root = DBusRoot_ cmd (Only_ $ Endpoint [] xmonadBusName p i $ Method_ m) cl
|
||||||
cmd c = void $ withDIO c $ callMethod xmonadSesBusName p i m
|
cmd c = io $ void $ callMethod c xmonadBusName p i m
|
||||||
|
|
||||||
bodyGetBrightness :: Num a => [Variant] -> Maybe a
|
bodyGetBrightness :: Num a => [Variant] -> Maybe a
|
||||||
bodyGetBrightness [b] = fromIntegral <$> (fromVariant b :: Maybe Int32)
|
bodyGetBrightness [b] = fromIntegral <$> (fromVariant b :: Maybe Int32)
|
||||||
|
|
|
@ -1,3 +1,5 @@
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- DBus module for Intel Backlight control
|
-- DBus module for Intel Backlight control
|
||||||
|
|
||||||
|
@ -13,7 +15,7 @@ where
|
||||||
|
|
||||||
import DBus
|
import DBus
|
||||||
import Data.Internal.DBus
|
import Data.Internal.DBus
|
||||||
import Data.Internal.XIO
|
import Data.Internal.Dependency
|
||||||
import RIO
|
import RIO
|
||||||
import RIO.FilePath
|
import RIO.FilePath
|
||||||
import XMonad.Internal.DBus.Brightness.Common
|
import XMonad.Internal.DBus.Brightness.Common
|
||||||
|
@ -43,22 +45,22 @@ maxFile = backlightDir </> "max_brightness"
|
||||||
curFile :: FilePath
|
curFile :: FilePath
|
||||||
curFile = backlightDir </> "brightness"
|
curFile = backlightDir </> "brightness"
|
||||||
|
|
||||||
getMaxRawBrightness :: MonadUnliftIO m => m RawBrightness
|
getMaxRawBrightness :: IO RawBrightness
|
||||||
getMaxRawBrightness = readInt maxFile
|
getMaxRawBrightness = readInt maxFile
|
||||||
|
|
||||||
getBrightness :: MonadUnliftIO m => RawBounds -> m Brightness
|
getBrightness :: RawBounds -> IO Brightness
|
||||||
getBrightness bounds = readPercent bounds curFile
|
getBrightness bounds = readPercent bounds curFile
|
||||||
|
|
||||||
minBrightness :: MonadUnliftIO m => RawBounds -> m Brightness
|
minBrightness :: RawBounds -> IO Brightness
|
||||||
minBrightness bounds = writePercentMin bounds curFile
|
minBrightness bounds = writePercentMin bounds curFile
|
||||||
|
|
||||||
maxBrightness :: MonadUnliftIO m => RawBounds -> m Brightness
|
maxBrightness :: RawBounds -> IO Brightness
|
||||||
maxBrightness bounds = writePercentMax bounds curFile
|
maxBrightness bounds = writePercentMax bounds curFile
|
||||||
|
|
||||||
incBrightness :: MonadUnliftIO m => RawBounds -> m Brightness
|
incBrightness :: RawBounds -> IO Brightness
|
||||||
incBrightness = incPercent steps curFile
|
incBrightness = incPercent steps curFile
|
||||||
|
|
||||||
decBrightness :: MonadUnliftIO m => RawBounds -> m Brightness
|
decBrightness :: RawBounds -> IO Brightness
|
||||||
decBrightness = decPercent steps curFile
|
decBrightness = decPercent steps curFile
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
|
@ -70,9 +72,7 @@ blPath = objectPath_ "/intelbacklight"
|
||||||
interface :: InterfaceName
|
interface :: InterfaceName
|
||||||
interface = interfaceName_ "org.xmonad.Brightness"
|
interface = interfaceName_ "org.xmonad.Brightness"
|
||||||
|
|
||||||
intelBacklightConfig
|
intelBacklightConfig :: BrightnessConfig RawBrightness Brightness
|
||||||
:: MonadUnliftIO m
|
|
||||||
=> BrightnessConfig m RawBrightness Brightness
|
|
||||||
intelBacklightConfig =
|
intelBacklightConfig =
|
||||||
BrightnessConfig
|
BrightnessConfig
|
||||||
{ bcMin = minBrightness
|
{ bcMin = minBrightness
|
||||||
|
@ -97,14 +97,9 @@ maxFileDep :: IODependency_
|
||||||
maxFileDep = pathR maxFile []
|
maxFileDep = pathR maxFile []
|
||||||
|
|
||||||
intelBacklightSignalDep :: DBusDependency_ SesClient
|
intelBacklightSignalDep :: DBusDependency_ SesClient
|
||||||
intelBacklightSignalDep =
|
intelBacklightSignalDep = signalDep intelBacklightConfig
|
||||||
-- TODO do I need to get rid of the IO here?
|
|
||||||
signalDep (intelBacklightConfig :: BrightnessConfig IO RawBrightness Brightness)
|
|
||||||
|
|
||||||
exportIntelBacklight
|
exportIntelBacklight :: Maybe SesClient -> SometimesIO
|
||||||
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
|
|
||||||
=> Maybe NamedSesConnection
|
|
||||||
-> Sometimes (m (), m ())
|
|
||||||
exportIntelBacklight =
|
exportIntelBacklight =
|
||||||
brightnessExporter
|
brightnessExporter
|
||||||
xpfIntelBacklight
|
xpfIntelBacklight
|
||||||
|
@ -112,23 +107,15 @@ exportIntelBacklight =
|
||||||
[curFileDep, maxFileDep]
|
[curFileDep, maxFileDep]
|
||||||
intelBacklightConfig
|
intelBacklightConfig
|
||||||
|
|
||||||
intelBacklightControls
|
intelBacklightControls :: Maybe SesClient -> BrightnessControls
|
||||||
:: (HasClient (DBusEnv env), MonadReader env m, MonadUnliftIO m)
|
|
||||||
=> Maybe NamedSesConnection
|
|
||||||
-> BrightnessControls m
|
|
||||||
intelBacklightControls = brightnessControls xpfIntelBacklight intelBacklightConfig
|
intelBacklightControls = brightnessControls xpfIntelBacklight intelBacklightConfig
|
||||||
|
|
||||||
callGetBrightnessIB
|
callGetBrightnessIB :: MonadUnliftIO m => SesClient -> m (Maybe Brightness)
|
||||||
:: (SafeClient c, HasClient env, MonadReader (env c) m, MonadUnliftIO m)
|
|
||||||
=> m (Maybe Brightness)
|
|
||||||
callGetBrightnessIB = callGetBrightness intelBacklightConfig
|
callGetBrightnessIB = callGetBrightness intelBacklightConfig
|
||||||
|
|
||||||
matchSignalIB
|
matchSignalIB
|
||||||
:: ( SafeClient c
|
:: MonadUnliftIO m
|
||||||
, HasClient env
|
|
||||||
, MonadReader (env c) m
|
|
||||||
, MonadUnliftIO m
|
|
||||||
)
|
|
||||||
=> (Maybe Brightness -> m ())
|
=> (Maybe Brightness -> m ())
|
||||||
|
-> SesClient
|
||||||
-> m ()
|
-> m ()
|
||||||
matchSignalIB = matchSignal intelBacklightConfig
|
matchSignalIB = matchSignal intelBacklightConfig
|
||||||
|
|
|
@ -2,8 +2,7 @@
|
||||||
-- High-level interface for managing XMonad's DBus
|
-- High-level interface for managing XMonad's DBus
|
||||||
|
|
||||||
module XMonad.Internal.DBus.Common
|
module XMonad.Internal.DBus.Common
|
||||||
( xmonadSesBusName
|
( xmonadBusName
|
||||||
, xmonadSysBusName
|
|
||||||
, btBus
|
, btBus
|
||||||
, notifyBus
|
, notifyBus
|
||||||
, notifyPath
|
, notifyPath
|
||||||
|
@ -13,11 +12,8 @@ where
|
||||||
|
|
||||||
import DBus
|
import DBus
|
||||||
|
|
||||||
xmonadSesBusName :: BusName
|
xmonadBusName :: BusName
|
||||||
xmonadSesBusName = busName_ "org.xmonad.session"
|
xmonadBusName = busName_ "org.xmonad"
|
||||||
|
|
||||||
xmonadSysBusName :: BusName
|
|
||||||
xmonadSysBusName = busName_ "org.xmonad.system"
|
|
||||||
|
|
||||||
btBus :: BusName
|
btBus :: BusName
|
||||||
btBus = busName_ "org.bluez"
|
btBus = busName_ "org.bluez"
|
||||||
|
|
|
@ -1,17 +1,20 @@
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
{-# LANGUAGE ScopedTypeVariables #-}
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- High-level interface for managing XMonad's DBus
|
-- High-level interface for managing XMonad's DBus
|
||||||
|
|
||||||
module XMonad.Internal.DBus.Control
|
module XMonad.Internal.DBus.Control
|
||||||
( Client
|
( Client
|
||||||
, DBusState (..)
|
, DBusState (..)
|
||||||
, withDBusInterfaces
|
|
||||||
, withDBusX
|
|
||||||
, withDBusX_
|
|
||||||
, withDBus
|
, withDBus
|
||||||
, withDBus_
|
, withDBus_
|
||||||
|
, withDBusX
|
||||||
|
, withDBusX_
|
||||||
, connectDBus
|
, connectDBus
|
||||||
|
, connectDBusX
|
||||||
, disconnectDBus
|
, disconnectDBus
|
||||||
-- , disconnectDBusX
|
, disconnectDBusX
|
||||||
, getDBusClient
|
, getDBusClient
|
||||||
, withDBusClient
|
, withDBusClient
|
||||||
, withDBusClient_
|
, withDBusClient_
|
||||||
|
@ -23,7 +26,7 @@ where
|
||||||
import DBus
|
import DBus
|
||||||
import DBus.Client
|
import DBus.Client
|
||||||
import Data.Internal.DBus
|
import Data.Internal.DBus
|
||||||
import Data.Internal.XIO
|
import Data.Internal.Dependency
|
||||||
import RIO
|
import RIO
|
||||||
import XMonad.Internal.DBus.Brightness.ClevoKeyboard
|
import XMonad.Internal.DBus.Brightness.ClevoKeyboard
|
||||||
import XMonad.Internal.DBus.Brightness.IntelBacklight
|
import XMonad.Internal.DBus.Brightness.IntelBacklight
|
||||||
|
@ -32,157 +35,90 @@ import XMonad.Internal.DBus.Screensaver
|
||||||
|
|
||||||
-- | Current connections to the DBus (session and system buses)
|
-- | Current connections to the DBus (session and system buses)
|
||||||
data DBusState = DBusState
|
data DBusState = DBusState
|
||||||
{ dbSesClient :: Maybe NamedSesConnection
|
{ dbSesClient :: Maybe SesClient
|
||||||
, dbSysClient :: Maybe NamedSysConnection
|
, dbSysClient :: Maybe SysClient
|
||||||
}
|
}
|
||||||
|
|
||||||
withDBusX_
|
withDBusX_
|
||||||
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
|
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
|
||||||
=> (DBusState -> m a)
|
=> (DBusState -> m a)
|
||||||
-> m ()
|
-> m ()
|
||||||
withDBusX_ = void . withDBusX
|
withDBusX_ = void . withDBusX_
|
||||||
|
|
||||||
withDBusX
|
withDBusX
|
||||||
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
|
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
|
||||||
=> (DBusState -> m a)
|
=> (DBusState -> m a)
|
||||||
-> m a
|
-> m (Maybe a)
|
||||||
withDBusX = withDBus (Just xmonadSesBusName) Nothing
|
withDBusX f = withDBus $ \db ->
|
||||||
|
-- TODO log error if this fails
|
||||||
|
forM (dbSesClient db) $ \ses ->
|
||||||
|
bracket_ (requestXMonadName ses) (releaseXMonadName ses) (f db)
|
||||||
|
|
||||||
withDBus_
|
withDBus_
|
||||||
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
|
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
|
||||||
=> Maybe BusName
|
=> (DBusState -> m a)
|
||||||
-> Maybe BusName
|
|
||||||
-> (DBusState -> m a)
|
|
||||||
-> m ()
|
-> m ()
|
||||||
withDBus_ sesname sysname = void . withDBus sesname sysname
|
withDBus_ = void . withDBus
|
||||||
|
|
||||||
withDBus
|
withDBus
|
||||||
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
|
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
|
||||||
=> Maybe BusName
|
=> (DBusState -> m a)
|
||||||
-> Maybe BusName
|
|
||||||
-> (DBusState -> m a)
|
|
||||||
-> m a
|
-> m a
|
||||||
withDBus sesname sysname = bracket (connectDBus sesname sysname) disconnectDBus
|
withDBus = bracket connectDBus disconnectDBus
|
||||||
|
|
||||||
-- | Connect to the DBus
|
-- | Connect to the DBus
|
||||||
connectDBus
|
connectDBus
|
||||||
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
|
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
|
||||||
=> Maybe BusName
|
=> m DBusState
|
||||||
-> Maybe BusName
|
connectDBus = do
|
||||||
-> m DBusState
|
ses <- getDBusClient
|
||||||
connectDBus sesname sysname = do
|
sys <- getDBusClient
|
||||||
ses <- getDBusClient sesname
|
|
||||||
sys <- getDBusClient sysname
|
|
||||||
return DBusState {dbSesClient = ses, dbSysClient = sys}
|
return DBusState {dbSesClient = ses, dbSysClient = sys}
|
||||||
|
|
||||||
-- | Disconnect from the DBus
|
-- | Disconnect from the DBus
|
||||||
disconnectDBus
|
disconnectDBus :: MonadUnliftIO m => DBusState -> m ()
|
||||||
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
|
|
||||||
=> DBusState
|
|
||||||
-> m ()
|
|
||||||
disconnectDBus db = disc dbSesClient >> disc dbSysClient
|
disconnectDBus db = disc dbSesClient >> disc dbSysClient
|
||||||
where
|
where
|
||||||
disc
|
|
||||||
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m, SafeClient c)
|
|
||||||
=> (DBusState -> Maybe (NamedConnection c))
|
|
||||||
-> m ()
|
|
||||||
disc f = maybe (return ()) disconnectDBusClient $ f db
|
disc f = maybe (return ()) disconnectDBusClient $ f db
|
||||||
|
|
||||||
-- -- | Connect to the DBus and request the XMonad name
|
-- | Connect to the DBus and request the XMonad name
|
||||||
-- connectDBusX
|
connectDBusX :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m) => m DBusState
|
||||||
-- :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
|
connectDBusX = do
|
||||||
-- => m DBusState
|
db <- connectDBus
|
||||||
-- connectDBusX = do
|
forM_ (dbSesClient db) requestXMonadName
|
||||||
-- db <- connectDBus
|
return db
|
||||||
-- requestXMonadName2 db
|
|
||||||
-- return db
|
|
||||||
|
|
||||||
-- -- | Disconnect from DBus and release the XMonad name
|
-- | Disconnect from DBus and release the XMonad name
|
||||||
-- disconnectDBusX
|
disconnectDBusX
|
||||||
-- :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
|
:: MonadUnliftIO m
|
||||||
-- => DBusState
|
=> DBusState
|
||||||
-- -> m ()
|
-> m ()
|
||||||
-- disconnectDBusX db = do
|
disconnectDBusX db = do
|
||||||
-- forM_ (dbSesClient db) releaseBusName
|
forM_ (dbSesClient db) releaseXMonadName
|
||||||
-- forM_ (dbSysClient db) releaseBusName
|
disconnectDBus db
|
||||||
-- disconnectDBus db
|
|
||||||
|
|
||||||
-- requestXMonadName2
|
|
||||||
-- :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
|
|
||||||
-- => DBusState
|
|
||||||
-- -> m ()
|
|
||||||
-- requestXMonadName2 db = do
|
|
||||||
-- forM_ (dbSesClient db) requestXMonadName
|
|
||||||
-- forM_ (dbSysClient db) requestXMonadName
|
|
||||||
|
|
||||||
withDBusInterfaces
|
|
||||||
:: DBusState
|
|
||||||
-> [Maybe NamedSesConnection -> Sometimes (XIO (), XIO ())]
|
|
||||||
-> ([XIO ()] -> XIO a)
|
|
||||||
-> XIO a
|
|
||||||
withDBusInterfaces db interfaces = bracket up sequence
|
|
||||||
where
|
|
||||||
up = do
|
|
||||||
pairs <- catMaybes <$> mapM (\f -> evalSometimes $ f $ dbSesClient db) interfaces
|
|
||||||
mapM_ fst pairs
|
|
||||||
return $ snd <$> pairs
|
|
||||||
|
|
||||||
-- | All exporter features to be assigned to the DBus
|
-- | All exporter features to be assigned to the DBus
|
||||||
dbusExporters
|
dbusExporters :: [Maybe SesClient -> SometimesIO]
|
||||||
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
|
|
||||||
=> [Maybe NamedSesConnection -> Sometimes (m (), m ())]
|
|
||||||
dbusExporters = [exportScreensaver, exportIntelBacklight, exportClevoKeyboard]
|
dbusExporters = [exportScreensaver, exportIntelBacklight, exportClevoKeyboard]
|
||||||
|
|
||||||
-- releaseXMonadName
|
releaseXMonadName
|
||||||
-- :: (SafeClient c, MonadReader env m, HasLogFunc env, MonadUnliftIO m)
|
:: MonadUnliftIO m
|
||||||
-- => c
|
=> SesClient
|
||||||
-- -> m ()
|
-> m ()
|
||||||
-- releaseXMonadName cl = do
|
releaseXMonadName ses = do
|
||||||
-- -- TODO this might error?
|
liftIO $ void $ releaseName (toClient ses) xmonadBusName
|
||||||
-- liftIO $ void $ releaseName (toClient cl) xmonadBusName
|
|
||||||
-- logInfo "released xmonad name"
|
|
||||||
|
|
||||||
-- releaseBusName
|
requestXMonadName :: MonadUnliftIO m => SesClient -> m ()
|
||||||
-- :: (SafeClient c, MonadReader env m, HasLogFunc env, MonadUnliftIO m)
|
requestXMonadName ses = do
|
||||||
-- => BusName
|
res <- liftIO $ requestName (toClient ses) xmonadBusName []
|
||||||
-- -> c
|
-- TODO if the client is not released on shutdown the owner will be different
|
||||||
-- -> m ()
|
let msg
|
||||||
-- releaseBusName n cl = do
|
| res == NamePrimaryOwner = Nothing
|
||||||
-- -- TODO this might error?
|
| res == NameAlreadyOwner = Just $ "this process already owns " ++ xn
|
||||||
-- liftIO $ void $ releaseName (toClient cl) n
|
| res == NameInQueue
|
||||||
-- logInfo $ "released bus name: " <> displayBusName n
|
|| res == NameExists =
|
||||||
|
Just $ "another process owns " ++ xn
|
||||||
-- requestBusName
|
| otherwise = Just $ "unknown error when requesting " ++ xn
|
||||||
-- :: (SafeClient c, MonadReader env m, HasLogFunc env, MonadUnliftIO m)
|
liftIO $ forM_ msg putStrLn
|
||||||
-- => BusName
|
where
|
||||||
-- -> c
|
xn = "'" ++ formatBusName xmonadBusName ++ "'"
|
||||||
-- -> 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
|
|
||||||
|
|
|
@ -1,3 +1,5 @@
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- Module for monitoring removable drive events
|
-- Module for monitoring removable drive events
|
||||||
--
|
--
|
||||||
|
@ -9,7 +11,7 @@ module XMonad.Internal.DBus.Removable (runRemovableMon) where
|
||||||
import DBus
|
import DBus
|
||||||
import DBus.Client
|
import DBus.Client
|
||||||
import Data.Internal.DBus
|
import Data.Internal.DBus
|
||||||
import Data.Internal.XIO
|
import Data.Internal.Dependency
|
||||||
import RIO
|
import RIO
|
||||||
import qualified RIO.Map as M
|
import qualified RIO.Map as M
|
||||||
import XMonad.Core (io)
|
import XMonad.Core (io)
|
||||||
|
@ -71,36 +73,25 @@ removedHasDrive [_, a] =
|
||||||
(fromVariant a :: Maybe [String])
|
(fromVariant a :: Maybe [String])
|
||||||
removedHasDrive _ = False
|
removedHasDrive _ = False
|
||||||
|
|
||||||
playSoundMaybe :: MonadUnliftIO m => FilePath -> Bool -> m ()
|
playSoundMaybe :: FilePath -> Bool -> IO ()
|
||||||
playSoundMaybe p b = when b $ io $ playSound p
|
playSoundMaybe p b = when b $ io $ playSound p
|
||||||
|
|
||||||
-- NOTE: the udisks2 service should be already running for this module to work.
|
-- NOTE: the udisks2 service should be already running for this module to work.
|
||||||
-- If it not already, we won't see any signals from the dbus until it is
|
-- If it not already, we won't see any signals from the dbus until it is
|
||||||
-- started (it will work after it is started however). It seems safe to simply
|
-- started (it will work after it is started however). It seems safe to simply
|
||||||
-- enable the udisks2 service at boot; however this is not default behavior.
|
-- enable the udisks2 service at boot; however this is not default behavior.
|
||||||
listenDevices
|
listenDevices :: SysClient -> IO ()
|
||||||
:: ( HasClient (DBusEnv env)
|
|
||||||
, MonadReader env m
|
|
||||||
, MonadUnliftIO m
|
|
||||||
)
|
|
||||||
=> NamedSysConnection
|
|
||||||
-> m ()
|
|
||||||
listenDevices cl = do
|
listenDevices cl = do
|
||||||
addMatch' memAdded driveInsertedSound addedHasDrive
|
addMatch' memAdded driveInsertedSound addedHasDrive
|
||||||
addMatch' memRemoved driveRemovedSound removedHasDrive
|
addMatch' memRemoved driveRemovedSound removedHasDrive
|
||||||
where
|
where
|
||||||
addMatch' m p f = do
|
addMatch' m p f =
|
||||||
let rule = ruleUdisks {matchMember = Just m}
|
void $
|
||||||
void $ withDIO cl $ addMatchCallback rule (playSoundMaybe p . f)
|
addMatch (toClient cl) ruleUdisks {matchMember = Just m} $
|
||||||
|
playSoundMaybe p . f . signalBody
|
||||||
|
|
||||||
runRemovableMon
|
runRemovableMon :: Maybe SysClient -> SometimesIO
|
||||||
:: ( HasClient (DBusEnv env)
|
|
||||||
, MonadReader env m
|
|
||||||
, MonadUnliftIO m
|
|
||||||
)
|
|
||||||
=> Maybe NamedSysConnection
|
|
||||||
-> Sometimes (m ())
|
|
||||||
runRemovableMon cl =
|
runRemovableMon cl =
|
||||||
sometimesDBus cl "removeable device monitor" "dbus monitor" deps listenDevices
|
sometimesDBus cl "removeable device monitor" "dbus monitor" deps $ io . listenDevices
|
||||||
where
|
where
|
||||||
deps = toAnd_ addedDep removedDep
|
deps = toAnd_ addedDep removedDep
|
||||||
|
|
|
@ -1,3 +1,5 @@
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- DBus module for X11 screensave/DPMS control
|
-- DBus module for X11 screensave/DPMS control
|
||||||
|
|
||||||
|
@ -14,7 +16,7 @@ import DBus
|
||||||
import DBus.Client
|
import DBus.Client
|
||||||
import qualified DBus.Introspection as I
|
import qualified DBus.Introspection as I
|
||||||
import Data.Internal.DBus
|
import Data.Internal.DBus
|
||||||
import Data.Internal.XIO
|
import Data.Internal.Dependency
|
||||||
import Graphics.X11.XScreenSaver
|
import Graphics.X11.XScreenSaver
|
||||||
import RIO
|
import RIO
|
||||||
import XMonad.Internal.DBus.Common
|
import XMonad.Internal.DBus.Common
|
||||||
|
@ -91,20 +93,20 @@ bodyGetCurrentState _ = Nothing
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- Exported haskell API
|
-- Exported haskell API
|
||||||
|
|
||||||
exportScreensaver
|
exportScreensaver :: Maybe SesClient -> SometimesIO
|
||||||
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
|
|
||||||
=> Maybe NamedSesConnection
|
|
||||||
-> Sometimes (m (), m ())
|
|
||||||
exportScreensaver ses =
|
exportScreensaver ses =
|
||||||
sometimesDBus ses "screensaver toggle" "xset" (toAnd_ bus ssx) cmd
|
sometimesDBus ses "screensaver toggle" "xset" (toAnd_ bus ssx) cmd
|
||||||
where
|
where
|
||||||
cmd = exportPair ssPath $ \cl_ -> do
|
cmd cl =
|
||||||
liftIO $ withRunInIO $ \run ->
|
let cl' = toClient cl
|
||||||
return $
|
in withRunInIO $ \run ->
|
||||||
|
export
|
||||||
|
cl'
|
||||||
|
ssPath
|
||||||
defaultInterface
|
defaultInterface
|
||||||
{ interfaceName = interface
|
{ interfaceName = interface
|
||||||
, interfaceMethods =
|
, interfaceMethods =
|
||||||
[ autoMethod memToggle $ run $ emitState cl_ =<< toggle
|
[ autoMethod memToggle $ run $ emitState cl' =<< toggle
|
||||||
, autoMethod memQuery (run query)
|
, autoMethod memQuery (run query)
|
||||||
]
|
]
|
||||||
, interfaceSignals = [sig]
|
, interfaceSignals = [sig]
|
||||||
|
@ -119,42 +121,32 @@ exportScreensaver ses =
|
||||||
}
|
}
|
||||||
]
|
]
|
||||||
}
|
}
|
||||||
bus = Bus [] xmonadSesBusName
|
bus = Bus [] xmonadBusName
|
||||||
ssx = DBusIO $ sysExe [Package Official "xorg-xset"] ssExecutable
|
ssx = DBusIO $ sysExe [Package Official "xorg-xset"] ssExecutable
|
||||||
|
|
||||||
callToggle
|
callToggle :: Maybe SesClient -> SometimesX
|
||||||
:: (HasClient (DBusEnv env), MonadReader env m, MonadUnliftIO m)
|
|
||||||
=> Maybe NamedSesConnection
|
|
||||||
-> Sometimes (m ())
|
|
||||||
callToggle =
|
callToggle =
|
||||||
sometimesEndpoint
|
sometimesEndpoint
|
||||||
"screensaver toggle"
|
"screensaver toggle"
|
||||||
"dbus switch"
|
"dbus switch"
|
||||||
[]
|
[]
|
||||||
xmonadSesBusName
|
xmonadBusName
|
||||||
ssPath
|
ssPath
|
||||||
interface
|
interface
|
||||||
memToggle
|
memToggle
|
||||||
|
|
||||||
callQuery
|
callQuery :: MonadUnliftIO m => SesClient -> m (Maybe SSState)
|
||||||
:: (HasClient env, MonadReader (env SesClient) m, MonadUnliftIO m)
|
callQuery ses = do
|
||||||
=> m (Maybe SSState)
|
reply <- callMethod ses xmonadBusName ssPath interface memQuery
|
||||||
callQuery = do
|
|
||||||
reply <- callMethod xmonadSesBusName ssPath interface memQuery
|
|
||||||
return $ either (const Nothing) bodyGetCurrentState reply
|
return $ either (const Nothing) bodyGetCurrentState reply
|
||||||
|
|
||||||
matchSignal
|
matchSignal :: MonadUnliftIO m => (Maybe SSState -> m ()) -> SesClient -> m ()
|
||||||
:: ( HasClient env
|
matchSignal cb ses =
|
||||||
, MonadReader (env SesClient) m
|
|
||||||
, MonadUnliftIO m
|
|
||||||
)
|
|
||||||
=> (Maybe SSState -> m ())
|
|
||||||
-> m ()
|
|
||||||
matchSignal cb =
|
|
||||||
void $
|
void $
|
||||||
addMatchCallback
|
addMatchCallback
|
||||||
ruleCurrentState
|
ruleCurrentState
|
||||||
(cb . bodyGetCurrentState)
|
(cb . bodyGetCurrentState)
|
||||||
|
ses
|
||||||
|
|
||||||
ssSignalDep :: DBusDependency_ SesClient
|
ssSignalDep :: DBusDependency_ SesClient
|
||||||
ssSignalDep = Endpoint [] xmonadSesBusName ssPath interface $ Signal_ memState
|
ssSignalDep = Endpoint [] xmonadBusName ssPath interface $ Signal_ memState
|
||||||
|
|
|
@ -1,3 +1,5 @@
|
||||||
|
{-# LANGUAGE ViewPatterns #-}
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- Random IO-ish functions used throughtout xmonad
|
-- Random IO-ish functions used throughtout xmonad
|
||||||
--
|
--
|
||||||
|
@ -39,7 +41,7 @@ import System.Process
|
||||||
-- read
|
-- read
|
||||||
|
|
||||||
readInt :: MonadIO m => (Read a, Integral a) => FilePath -> m a
|
readInt :: MonadIO m => (Read a, Integral a) => FilePath -> m a
|
||||||
readInt = fmap (fromMaybe 0 . readMaybe . takeWhile isDigit . T.unpack) . readFileUtf8
|
readInt = fmap (read . takeWhile isDigit . T.unpack) . readFileUtf8
|
||||||
|
|
||||||
readBool :: MonadIO m => FilePath -> m Bool
|
readBool :: MonadIO m => FilePath -> m Bool
|
||||||
readBool = fmap (== (1 :: Int)) . readInt
|
readBool = fmap (== (1 :: Int)) . readInt
|
||||||
|
@ -47,7 +49,7 @@ readBool = fmap (== (1 :: Int)) . readInt
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- write
|
-- 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
|
writeInt f = writeFileUtf8 f . T.pack . show
|
||||||
|
|
||||||
writeBool :: MonadIO m => FilePath -> Bool -> m ()
|
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
|
-- value. Assume that the file being read has a min of 0 and an unchanging max
|
||||||
-- given by a runtime argument, which is scaled linearly to the range 0-100
|
-- given by a runtime argument, which is scaled linearly to the range 0-100
|
||||||
-- (percent).
|
-- (percent).
|
||||||
rawToPercent :: (Integral a, Integral b, RealFrac c) => (a, a) -> b -> c
|
rawToPercent :: (Integral a, Integral b, Read b, RealFrac c) => (a, a) -> b -> c
|
||||||
rawToPercent (lower, upper) raw =
|
rawToPercent (lower, upper) raw =
|
||||||
100 * (fromIntegral raw - fromIntegral lower) / fromIntegral (upper - lower)
|
100 * (fromIntegral raw - fromIntegral lower) / fromIntegral (upper - lower)
|
||||||
|
|
||||||
|
@ -164,7 +166,7 @@ getPermissionsSafe f = do
|
||||||
-- | Block until a PID has exited.
|
-- | Block until a PID has exited.
|
||||||
-- Use this to control flow based on a process that was not explicitly started
|
-- Use this to control flow based on a process that was not explicitly started
|
||||||
-- by the Haskell runtime itself, and thus has no data structures to query.
|
-- by the Haskell runtime itself, and thus has no data structures to query.
|
||||||
waitUntilExit :: (MonadUnliftIO m) => Pid -> m ()
|
waitUntilExit :: (MonadIO m) => Pid -> m ()
|
||||||
waitUntilExit pid = do
|
waitUntilExit pid = do
|
||||||
res <- doesDirectoryExist $ "/proc" </> show pid
|
res <- doesDirectoryExist $ "/proc" </> show pid
|
||||||
when res $ do
|
when res $ do
|
||||||
|
|
|
@ -1,3 +1,5 @@
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- Functions for formatting and sending notifications
|
-- Functions for formatting and sending notifications
|
||||||
--
|
--
|
||||||
|
|
|
@ -1,3 +1,5 @@
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
-- Functions for formatting and spawning shell commands
|
-- Functions for formatting and spawning shell commands
|
||||||
|
|
||||||
module XMonad.Internal.Shell
|
module XMonad.Internal.Shell
|
||||||
|
@ -83,31 +85,8 @@ spawn :: MonadIO m => T.Text -> m ()
|
||||||
spawn = X.spawn . T.unpack
|
spawn = X.spawn . T.unpack
|
||||||
|
|
||||||
-- | Run 'XMonad.Run.Utils.spawnPipe' with 'Text' input.
|
-- | Run 'XMonad.Run.Utils.spawnPipe' with 'Text' input.
|
||||||
spawnPipe :: MonadUnliftIO m => T.Text -> m Handle
|
spawnPipe :: MonadIO m => T.Text -> m Handle
|
||||||
spawnPipe = liftIO . XR.spawnPipe . T.unpack
|
spawnPipe = XR.spawnPipe . T.unpack
|
||||||
|
|
||||||
-- spawnPipeRW
|
|
||||||
-- :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
|
|
||||||
-- => T.Text
|
|
||||||
-- -> m Handle
|
|
||||||
-- spawnPipeRW x = do
|
|
||||||
-- (r, h) <- liftIO mkPipe
|
|
||||||
-- child r
|
|
||||||
-- liftIO $ closeFd r
|
|
||||||
-- return h
|
|
||||||
-- where
|
|
||||||
-- mkPipe = do
|
|
||||||
-- (r, w) <- createPipe
|
|
||||||
-- setFdOption w CloseOnExec True
|
|
||||||
-- h <- fdToHandle w
|
|
||||||
-- -- ASSUME we are using utf8 everywhere
|
|
||||||
-- hSetEncoding h utf8
|
|
||||||
-- hSetBuffering h LineBuffering
|
|
||||||
-- return (r, h)
|
|
||||||
-- child r = void $ withRunInIO $ \runIO -> do
|
|
||||||
-- X.xfork $ runIO $ do
|
|
||||||
-- void $ liftIO $ dupTo r stdInput
|
|
||||||
-- liftIO $ executeFile "/bin/sh" False ["-c", T.unpack x] Nothing
|
|
||||||
|
|
||||||
-- | Run 'XMonad.Core.spawn' with a command and arguments
|
-- | Run 'XMonad.Core.spawn' with a command and arguments
|
||||||
spawnCmd :: MonadIO m => FilePath -> [T.Text] -> m ()
|
spawnCmd :: MonadIO m => FilePath -> [T.Text] -> m ()
|
||||||
|
|
|
@ -1,3 +1,5 @@
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- Theme for XMonad and Xmobar
|
-- Theme for XMonad and Xmobar
|
||||||
|
|
||||||
|
@ -31,7 +33,6 @@ where
|
||||||
|
|
||||||
import Data.Colour
|
import Data.Colour
|
||||||
import Data.Colour.SRGB
|
import Data.Colour.SRGB
|
||||||
import RIO
|
|
||||||
import qualified RIO.Text as T
|
import qualified RIO.Text as T
|
||||||
import qualified XMonad.Layout.Decoration as D
|
import qualified XMonad.Layout.Decoration as D
|
||||||
import qualified XMonad.Prompt as P
|
import qualified XMonad.Prompt as P
|
||||||
|
|
|
@ -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)
|
|
|
@ -1,10 +1,11 @@
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
-- Common backlight plugin bits
|
-- Common backlight plugin bits
|
||||||
--
|
--
|
||||||
-- Use the custom DBus interface exported by the XMonad process so I can react
|
-- Use the custom DBus interface exported by the XMonad process so I can react
|
||||||
-- to signals spawned by commands
|
-- to signals spawned by commands
|
||||||
module Xmobar.Plugins.BacklightCommon (startBacklight) where
|
module Xmobar.Plugins.BacklightCommon (startBacklight) where
|
||||||
|
|
||||||
import DBus
|
|
||||||
import Data.Internal.DBus
|
import Data.Internal.DBus
|
||||||
import RIO
|
import RIO
|
||||||
import qualified RIO.Text as T
|
import qualified RIO.Text as T
|
||||||
|
@ -12,17 +13,15 @@ import Xmobar.Plugins.Common
|
||||||
|
|
||||||
startBacklight
|
startBacklight
|
||||||
:: (MonadUnliftIO m, RealFrac a)
|
:: (MonadUnliftIO m, RealFrac a)
|
||||||
=> Maybe BusName
|
=> ((Maybe a -> RIO SimpleApp ()) -> SesClient -> RIO SimpleApp ())
|
||||||
-> Maybe FilePath
|
-> (SesClient -> RIO SimpleApp (Maybe a))
|
||||||
-> ((Maybe a -> DIO SimpleApp SesClient ()) -> DIO SimpleApp SesClient ())
|
|
||||||
-> DIO SimpleApp SesClient (Maybe a)
|
|
||||||
-> T.Text
|
-> T.Text
|
||||||
-> Callback
|
-> Callback
|
||||||
-> m ()
|
-> m ()
|
||||||
startBacklight n name matchSignal callGetBrightness icon cb = do
|
startBacklight matchSignal callGetBrightness icon cb = do
|
||||||
withDBusClientConnection cb n name $ \c -> withDIO c $ do
|
withDBusClientConnection cb $ \c -> do
|
||||||
matchSignal dpy
|
matchSignal dpy c
|
||||||
dpy =<< callGetBrightness
|
dpy =<< callGetBrightness c
|
||||||
where
|
where
|
||||||
formatBrightness b = return $ T.concat [icon, T.pack $ show (round b :: Integer), "%"]
|
formatBrightness b = return $ T.concat [icon, T.pack $ show (round b :: Integer), "%"]
|
||||||
dpy = displayMaybe cb formatBrightness
|
dpy = displayMaybe cb formatBrightness
|
||||||
|
|
|
@ -1,3 +1,5 @@
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- Bluetooth plugin
|
-- Bluetooth plugin
|
||||||
--
|
--
|
||||||
|
@ -7,18 +9,28 @@
|
||||||
-- Manager. The adapter is located at path "/org/bluez/hci<X>" where X is
|
-- Manager. The adapter is located at path "/org/bluez/hci<X>" where X is
|
||||||
-- usually 0, and each device is "/org/bluez/hci<X>/<MAC_ADDRESS>".
|
-- usually 0, and each device is "/org/bluez/hci<X>/<MAC_ADDRESS>".
|
||||||
--
|
--
|
||||||
-- Simple and somewhat crude way to do this is to have two monitors, one
|
-- This plugin will reflect if the adapter is powered and if any device is
|
||||||
-- watching the powered state of the adaptor and one listening for connection
|
-- connected to it. The rough outline for this procedure:
|
||||||
-- changes. The former is easy since this is just one /org/bluez/hciX. For the
|
-- 1) get the adapter from the object manager
|
||||||
-- latter, each 'Connected' property is embedded in each individual device path
|
-- 2) get all devices associated with the adapter using the object interface
|
||||||
-- on `org.bluez.Device1', so just watch the entire bluez bus for property
|
-- 3) determine if the adapter is powered
|
||||||
-- changes and filter those that correspond to the aforementioned
|
-- 4) determine if any devices are connected
|
||||||
-- interface/property. Track all this in a state which keeps the powered
|
-- 5) format the icon; powered vs not powered controls the color and connected
|
||||||
-- property and a running list of connected devices.
|
-- 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
|
-- 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
|
-- adapter changing.
|
||||||
-- attention to devices associated with it.
|
|
||||||
|
|
||||||
module Xmobar.Plugins.Bluetooth
|
module Xmobar.Plugins.Bluetooth
|
||||||
( Bluetooth (..)
|
( Bluetooth (..)
|
||||||
|
@ -30,12 +42,11 @@ where
|
||||||
import DBus
|
import DBus
|
||||||
import DBus.Client
|
import DBus.Client
|
||||||
import Data.Internal.DBus
|
import Data.Internal.DBus
|
||||||
import Data.Internal.XIO
|
import Data.Internal.Dependency
|
||||||
import RIO
|
import RIO
|
||||||
import RIO.FilePath
|
import RIO.FilePath
|
||||||
import RIO.List
|
import RIO.List
|
||||||
import qualified RIO.Map as M
|
import qualified RIO.Map as M
|
||||||
import qualified RIO.Set as S
|
|
||||||
import qualified RIO.Text as T
|
import qualified RIO.Text as T
|
||||||
import XMonad.Internal.DBus.Common
|
import XMonad.Internal.DBus.Common
|
||||||
import Xmobar
|
import Xmobar
|
||||||
|
@ -54,28 +65,31 @@ data Bluetooth = Bluetooth Icons Colors deriving (Read, Show)
|
||||||
instance Exec Bluetooth where
|
instance Exec Bluetooth where
|
||||||
alias (Bluetooth _ _) = T.unpack btAlias
|
alias (Bluetooth _ _) = T.unpack btAlias
|
||||||
start (Bluetooth icons colors) cb =
|
start (Bluetooth icons colors) cb =
|
||||||
withDBusClientConnection cb Nothing (Just "bluetooth.log") $
|
withDBusClientConnection cb $ startAdapter icons colors cb
|
||||||
startAdapter icons colors cb
|
|
||||||
|
|
||||||
startAdapter
|
startAdapter
|
||||||
:: Icons
|
:: MonadUnliftIO m
|
||||||
|
=> Icons
|
||||||
-> Colors
|
-> Colors
|
||||||
-> Callback
|
-> Callback
|
||||||
-> NamedSysConnection
|
-> SysClient
|
||||||
-> RIO SimpleApp ()
|
-> m ()
|
||||||
startAdapter is cs cb cl = do
|
startAdapter is cs cb cl = do
|
||||||
|
ot <- getBtObjectTree cl
|
||||||
state <- newMVar emptyState
|
state <- newMVar emptyState
|
||||||
let dpy cb' = displayIcon cb' (iconFormatter is cs)
|
let dpy = displayIcon cb (iconFormatter is cs) state
|
||||||
mapRIO (PluginEnv cl state dpy cb) $ do
|
forM_ (findAdapter ot) $ \adapter -> do
|
||||||
ot <- getBtObjectTree
|
-- set up adapter
|
||||||
case findAdaptor ot of
|
initAdapter state adapter cl
|
||||||
Nothing -> logError "could not find bluetooth adapter"
|
-- TODO this step could fail; at least warn the user...
|
||||||
Just adaptor -> do
|
void $ addAdaptorListener state dpy adapter cl
|
||||||
initAdapterState adaptor
|
-- set up devices on the adapter (and listeners for adding/removing devices)
|
||||||
initDevicesState adaptor ot
|
let devices = findDevices adapter ot
|
||||||
startAdaptorListener adaptor
|
addDeviceAddedListener state dpy adapter cl
|
||||||
startConnectedListener adaptor
|
addDeviceRemovedListener state dpy adapter cl
|
||||||
pluginDisplay
|
forM_ devices $ \d -> addAndInitDevice state dpy d cl
|
||||||
|
-- after setting things up, show the icon based on the initialized state
|
||||||
|
dpy
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- Icon Display
|
-- Icon Display
|
||||||
|
@ -87,9 +101,9 @@ type IconFormatter = (Maybe Bool -> Bool -> T.Text)
|
||||||
|
|
||||||
type Icons = (T.Text, T.Text)
|
type Icons = (T.Text, T.Text)
|
||||||
|
|
||||||
displayIcon :: Callback -> IconFormatter -> BTIO ()
|
displayIcon :: MonadUnliftIO m => Callback -> IconFormatter -> MutableBtState -> m ()
|
||||||
displayIcon callback formatter =
|
displayIcon callback formatter =
|
||||||
liftIO . callback . T.unpack . uncurry formatter =<< readState
|
liftIO . callback . T.unpack . uncurry formatter <=< readState
|
||||||
|
|
||||||
-- TODO maybe I want this to fail when any of the device statuses are Nothing
|
-- TODO maybe I want this to fail when any of the device statuses are Nothing
|
||||||
iconFormatter :: Icons -> Colors -> IconFormatter
|
iconFormatter :: Icons -> Colors -> IconFormatter
|
||||||
|
@ -100,52 +114,47 @@ iconFormatter (iconConn, iconDisc) cs powered connected =
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- Connection State
|
-- Connection State
|
||||||
|
--
|
||||||
|
-- The signal handlers all run on separate threads, yet the icon depends on
|
||||||
|
-- the state reflected by all these signals. The best (only?) way to do this is
|
||||||
|
-- is to track the shared state of the bluetooth adaptor and its devices using
|
||||||
|
-- an MVar.
|
||||||
|
|
||||||
type BTIO = PluginIO BtState SysClient
|
data BTDevice = BTDevice
|
||||||
|
{ btDevConnected :: Maybe Bool
|
||||||
|
, btDevSigHandler :: SignalHandler
|
||||||
|
}
|
||||||
|
|
||||||
|
type ConnectedDevices = M.Map ObjectPath BTDevice
|
||||||
|
|
||||||
data BtState = BtState
|
data BtState = BtState
|
||||||
{ btDevices :: S.Set ObjectPath
|
{ btDevices :: ConnectedDevices
|
||||||
, btPowered :: Maybe Bool
|
, btPowered :: Maybe Bool
|
||||||
}
|
}
|
||||||
|
|
||||||
|
type MutableBtState = MVar BtState
|
||||||
|
|
||||||
emptyState :: BtState
|
emptyState :: BtState
|
||||||
emptyState =
|
emptyState =
|
||||||
BtState
|
BtState
|
||||||
{ btDevices = S.empty
|
{ btDevices = M.empty
|
||||||
, btPowered = Nothing
|
, btPowered = Nothing
|
||||||
}
|
}
|
||||||
|
|
||||||
readState :: BTIO (Maybe Bool, Bool)
|
readState :: MonadUnliftIO m => MutableBtState -> m (Maybe Bool, Bool)
|
||||||
readState = do
|
readState state = do
|
||||||
p <- readPowered
|
p <- readPowered state
|
||||||
c <- readDevices
|
c <- readDevices state
|
||||||
return (p, not $ null c)
|
return (p, anyDevicesConnected c)
|
||||||
|
|
||||||
modifyState :: (BtState -> BTIO (BtState, a)) -> BTIO a
|
|
||||||
modifyState f = do
|
|
||||||
m <- asks plugState
|
|
||||||
modifyMVar m f
|
|
||||||
|
|
||||||
beforeDisplay :: BTIO () -> BTIO ()
|
|
||||||
beforeDisplay f = f >> pluginDisplay
|
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- Object manager
|
-- Object manager
|
||||||
|
|
||||||
findAdaptor :: ObjectTree -> Maybe ObjectPath
|
findAdapter :: ObjectTree -> Maybe ObjectPath
|
||||||
findAdaptor = find (("/org/bluez/hci" `isPrefixOf`) . formatObjectPath) . M.keys
|
findAdapter = find (("/org/bluez/hci" `isPrefixOf`) . formatObjectPath) . M.keys
|
||||||
|
|
||||||
-- | Search the object tree for devices which are in a connected state.
|
findDevices :: ObjectPath -> ObjectTree -> [ObjectPath]
|
||||||
-- Return the object path for said devices.
|
findDevices adapter = filter (adaptorHasDevice adapter) . M.keys
|
||||||
findConnectedDevices :: ObjectPath -> ObjectTree -> [ObjectPath]
|
|
||||||
findConnectedDevices adaptor =
|
|
||||||
filter (adaptorHasDevice adaptor) . M.keys . M.filter isConnectedDev
|
|
||||||
where
|
|
||||||
isConnectedDev m = Just True == lookupState m
|
|
||||||
lookupState =
|
|
||||||
fromVariant
|
|
||||||
<=< M.lookup (memberNameT devConnected)
|
|
||||||
<=< M.lookup devInterface
|
|
||||||
|
|
||||||
adaptorHasDevice :: ObjectPath -> ObjectPath -> Bool
|
adaptorHasDevice :: ObjectPath -> ObjectPath -> Bool
|
||||||
adaptorHasDevice adaptor device = case splitPathNoRoot device of
|
adaptorHasDevice adaptor device = case splitPathNoRoot device of
|
||||||
|
@ -155,120 +164,190 @@ adaptorHasDevice adaptor device = case splitPathNoRoot device of
|
||||||
splitPathNoRoot :: ObjectPath -> [FilePath]
|
splitPathNoRoot :: ObjectPath -> [FilePath]
|
||||||
splitPathNoRoot = dropWhile (== "/") . splitDirectories . formatObjectPath
|
splitPathNoRoot = dropWhile (== "/") . splitDirectories . formatObjectPath
|
||||||
|
|
||||||
getBtObjectTree
|
getBtObjectTree :: MonadUnliftIO m => SysClient -> m ObjectTree
|
||||||
:: ( HasClient env
|
getBtObjectTree sys = callGetManagedObjects sys btBus btOMPath
|
||||||
, SafeClient c
|
|
||||||
, MonadReader (env c) m
|
|
||||||
, HasLogFunc (env c)
|
|
||||||
, MonadUnliftIO m
|
|
||||||
)
|
|
||||||
=> m ObjectTree
|
|
||||||
getBtObjectTree = callGetManagedObjects btBus btOMPath
|
|
||||||
|
|
||||||
btOMPath :: ObjectPath
|
btOMPath :: ObjectPath
|
||||||
btOMPath = objectPath_ "/"
|
btOMPath = objectPath_ "/"
|
||||||
|
|
||||||
|
addBtOMListener :: MonadUnliftIO m => SignalCallback m -> SysClient -> m ()
|
||||||
|
addBtOMListener sc = void . addInterfaceAddedListener btBus btOMPath sc
|
||||||
|
|
||||||
|
addDeviceAddedListener
|
||||||
|
:: MonadUnliftIO m
|
||||||
|
=> MutableBtState
|
||||||
|
-> m ()
|
||||||
|
-> ObjectPath
|
||||||
|
-> SysClient
|
||||||
|
-> m ()
|
||||||
|
addDeviceAddedListener state dpy adapter client =
|
||||||
|
addBtOMListener addDevice client
|
||||||
|
where
|
||||||
|
addDevice = pathCallback adapter dpy $ \d ->
|
||||||
|
addAndInitDevice state dpy d client
|
||||||
|
|
||||||
|
addDeviceRemovedListener
|
||||||
|
:: (MonadUnliftIO m)
|
||||||
|
=> MutableBtState
|
||||||
|
-> m ()
|
||||||
|
-> ObjectPath
|
||||||
|
-> SysClient
|
||||||
|
-> m ()
|
||||||
|
addDeviceRemovedListener state dpy adapter sys =
|
||||||
|
addBtOMListener remDevice sys
|
||||||
|
where
|
||||||
|
remDevice = pathCallback adapter dpy $ \d -> do
|
||||||
|
old <- removeDevice state d
|
||||||
|
forM_ old $ liftIO . removeMatch (toClient sys) . btDevSigHandler
|
||||||
|
|
||||||
|
pathCallback :: MonadUnliftIO m => ObjectPath -> m () -> (ObjectPath -> m ()) -> SignalCallback m
|
||||||
|
pathCallback adapter dpy f [device, _] = forM_ (fromVariant device) $ \d ->
|
||||||
|
when (adaptorHasDevice adapter d) $ f d >> dpy
|
||||||
|
pathCallback _ _ _ _ = return ()
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- Adapter
|
-- Adapter
|
||||||
|
|
||||||
-- | Get powered state of adaptor and log the result
|
initAdapter
|
||||||
initAdapterState :: ObjectPath -> BTIO ()
|
:: (MonadUnliftIO m)
|
||||||
initAdapterState adapter = do
|
=> MutableBtState
|
||||||
reply <- callGetPowered adapter
|
-> ObjectPath
|
||||||
putPowered $ fromSingletonVariant reply
|
-> SysClient
|
||||||
|
-> m ()
|
||||||
|
initAdapter state adapter client = do
|
||||||
|
reply <- callGetPowered adapter client
|
||||||
|
putPowered state $ fromSingletonVariant reply
|
||||||
|
|
||||||
matchBTProperty
|
matchBTProperty
|
||||||
:: ( SafeClient c
|
:: (MonadUnliftIO m)
|
||||||
, HasClient env
|
=> SysClient
|
||||||
, MonadReader (env c) m
|
-> ObjectPath
|
||||||
, HasLogFunc (env c)
|
|
||||||
, MonadUnliftIO m
|
|
||||||
)
|
|
||||||
=> ObjectPath
|
|
||||||
-> m (Maybe MatchRule)
|
-> 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
|
addAdaptorListener
|
||||||
startAdaptorListener :: ObjectPath -> BTIO ()
|
:: MonadUnliftIO m
|
||||||
startAdaptorListener adaptor = do
|
=> MutableBtState
|
||||||
res <- matchBTProperty adaptor
|
-> m ()
|
||||||
case res of
|
-> ObjectPath
|
||||||
Just rule -> void $ addMatchCallback rule callback
|
-> SysClient
|
||||||
Nothing -> do
|
-> m (Maybe SignalHandler)
|
||||||
logError $
|
addAdaptorListener state dpy adaptor sys = do
|
||||||
"could not add listener for prop "
|
rule <- matchBTProperty sys adaptor
|
||||||
<> displayMemberName adaptorPowered
|
forM rule $ \r -> addMatchCallback r (procMatch . matchPowered) sys
|
||||||
<> " on path "
|
|
||||||
<> displayObjectPath adaptor
|
|
||||||
where
|
where
|
||||||
callback sig =
|
procMatch = withSignalMatch $ \b -> putPowered state b >> dpy
|
||||||
withNestedDBusClientConnection Nothing Nothing $
|
|
||||||
withSignalMatch procMatch $
|
|
||||||
matchPropertyChanged adaptorInterface adaptorPowered sig
|
|
||||||
procMatch = beforeDisplay . putPowered
|
|
||||||
|
|
||||||
callGetPowered
|
callGetPowered :: MonadUnliftIO m => ObjectPath -> SysClient -> m [Variant]
|
||||||
:: ( HasClient env
|
|
||||||
, MonadReader (env c) m
|
|
||||||
, HasLogFunc (env c)
|
|
||||||
, SafeClient c
|
|
||||||
, MonadUnliftIO m
|
|
||||||
)
|
|
||||||
=> ObjectPath
|
|
||||||
-> m [Variant]
|
|
||||||
callGetPowered adapter =
|
callGetPowered adapter =
|
||||||
callPropertyGet btBus adapter adaptorInterface adaptorPowered
|
callPropertyGet btBus adapter adapterInterface $
|
||||||
|
memberName_ $
|
||||||
|
T.unpack adaptorPowered
|
||||||
|
|
||||||
putPowered :: Maybe Bool -> BTIO ()
|
matchPowered :: [Variant] -> SignalMatch Bool
|
||||||
putPowered ds = modifyState $ \s -> return (s {btPowered = ds}, ())
|
matchPowered = matchPropertyChanged adapterInterface adaptorPowered
|
||||||
|
|
||||||
readPowered :: BTIO (Maybe Bool)
|
putPowered :: MonadUnliftIO m => MutableBtState -> Maybe Bool -> m ()
|
||||||
readPowered = fmap btPowered $ readMVar =<< asks plugState
|
putPowered m ds = modifyMVar_ m (\s -> return s {btPowered = ds})
|
||||||
|
|
||||||
adaptorInterface :: InterfaceName
|
readPowered :: MonadUnliftIO m => MutableBtState -> m (Maybe Bool)
|
||||||
adaptorInterface = interfaceName_ "org.bluez.Adapter1"
|
readPowered = fmap btPowered . readMVar
|
||||||
|
|
||||||
adaptorPowered :: MemberName
|
adapterInterface :: InterfaceName
|
||||||
|
adapterInterface = interfaceName_ "org.bluez.Adapter1"
|
||||||
|
|
||||||
|
adaptorPowered :: T.Text
|
||||||
adaptorPowered = "Powered"
|
adaptorPowered = "Powered"
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- Devices
|
-- Devices
|
||||||
|
|
||||||
initDevicesState :: ObjectPath -> ObjectTree -> BTIO ()
|
addAndInitDevice
|
||||||
initDevicesState adaptor ot = do
|
:: MonadUnliftIO m
|
||||||
let devices = findConnectedDevices adaptor ot
|
=> MutableBtState
|
||||||
modifyState $ \s -> return (s {btDevices = S.fromList devices}, ())
|
-> 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 ()
|
initDevice
|
||||||
startConnectedListener adaptor = do
|
:: MonadUnliftIO m
|
||||||
reply <- matchPropertyFull btBus Nothing
|
=> MutableBtState
|
||||||
case reply of
|
-> SignalHandler
|
||||||
Just rule -> do
|
-> ObjectPath
|
||||||
void $ addMatchCallbackSignal rule callback
|
-> SysClient
|
||||||
logInfo $ "Started listening for device connections on " <> adaptor_
|
-> m ()
|
||||||
Nothing -> logError "Could not listen for connection changes"
|
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
|
where
|
||||||
adaptor_ = displayWrapQuote $ displayObjectPath adaptor
|
procMatch = withSignalMatch $ \c -> updateDevice state device c >> dpy
|
||||||
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}, ())
|
|
||||||
|
|
||||||
readDevices :: BTIO (S.Set ObjectPath)
|
matchConnected :: [Variant] -> SignalMatch Bool
|
||||||
readDevices = fmap btDevices $ readMVar =<< asks plugState
|
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
|
||||||
devInterface = interfaceName_ "org.bluez.Device1"
|
devInterface = interfaceName_ "org.bluez.Device1"
|
||||||
|
|
||||||
devConnected :: MemberName
|
devConnected :: T.Text
|
||||||
devConnected = "Connected"
|
devConnected = "Connected"
|
||||||
|
|
|
@ -1,3 +1,5 @@
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- Clevo Keyboard plugin
|
-- Clevo Keyboard plugin
|
||||||
--
|
--
|
||||||
|
@ -10,7 +12,6 @@ module Xmobar.Plugins.ClevoKeyboard
|
||||||
)
|
)
|
||||||
where
|
where
|
||||||
|
|
||||||
import RIO
|
|
||||||
import qualified RIO.Text as T
|
import qualified RIO.Text as T
|
||||||
import XMonad.Internal.DBus.Brightness.ClevoKeyboard
|
import XMonad.Internal.DBus.Brightness.ClevoKeyboard
|
||||||
import Xmobar
|
import Xmobar
|
||||||
|
@ -24,9 +25,4 @@ ckAlias = "clevokeyboard"
|
||||||
instance Exec ClevoKeyboard where
|
instance Exec ClevoKeyboard where
|
||||||
alias (ClevoKeyboard _) = T.unpack ckAlias
|
alias (ClevoKeyboard _) = T.unpack ckAlias
|
||||||
start (ClevoKeyboard icon) =
|
start (ClevoKeyboard icon) =
|
||||||
startBacklight
|
startBacklight matchSignalCK callGetBrightnessCK icon
|
||||||
(Just "org.xmobar.clevo")
|
|
||||||
(Just "clevo_kbd.log")
|
|
||||||
matchSignalCK
|
|
||||||
callGetBrightnessCK
|
|
||||||
icon
|
|
||||||
|
|
|
@ -1,52 +1,27 @@
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
module Xmobar.Plugins.Common
|
module Xmobar.Plugins.Common
|
||||||
( colorText
|
( colorText
|
||||||
, startListener
|
, startListener
|
||||||
, procSignalMatch
|
, procSignalMatch
|
||||||
, na
|
, na
|
||||||
, fromSingletonVariant
|
, fromSingletonVariant
|
||||||
, withNestedDBusClientConnection
|
|
||||||
, withDBusClientConnection
|
, withDBusClientConnection
|
||||||
, Callback
|
, Callback
|
||||||
, Colors (..)
|
, Colors (..)
|
||||||
, displayMaybe
|
, displayMaybe
|
||||||
, displayMaybe'
|
, displayMaybe'
|
||||||
, xmobarFGColor
|
, xmobarFGColor
|
||||||
, PluginEnv (..)
|
|
||||||
, PluginIO
|
|
||||||
, pluginDisplay
|
|
||||||
)
|
)
|
||||||
where
|
where
|
||||||
|
|
||||||
import DBus
|
import DBus
|
||||||
import DBus.Client
|
import DBus.Client
|
||||||
import Data.Internal.DBus
|
import Data.Internal.DBus
|
||||||
import Data.Internal.XIO
|
|
||||||
import RIO
|
import RIO
|
||||||
import qualified RIO.Text as T
|
import qualified RIO.Text as T
|
||||||
import XMonad.Hooks.DynamicLog (xmobarColor)
|
import XMonad.Hooks.DynamicLog (xmobarColor)
|
||||||
|
|
||||||
data PluginEnv s c = PluginEnv
|
|
||||||
{ plugClient :: !(NamedConnection c)
|
|
||||||
, plugState :: !(MVar s)
|
|
||||||
, plugDisplay :: !(Callback -> PluginIO s c ())
|
|
||||||
, plugCallback :: !Callback
|
|
||||||
, plugEnv :: !SimpleApp
|
|
||||||
}
|
|
||||||
|
|
||||||
pluginDisplay :: PluginIO s c ()
|
|
||||||
pluginDisplay = do
|
|
||||||
cb <- asks plugCallback
|
|
||||||
dpy <- asks plugDisplay
|
|
||||||
dpy cb
|
|
||||||
|
|
||||||
type PluginIO s c = RIO (PluginEnv s c)
|
|
||||||
|
|
||||||
instance HasClient (PluginEnv s) where
|
|
||||||
clientL = lens plugClient (\x y -> x {plugClient = y})
|
|
||||||
|
|
||||||
instance HasLogFunc (PluginEnv s c) where
|
|
||||||
logFuncL = lens plugEnv (\x y -> x {plugEnv = y}) . logFuncL
|
|
||||||
|
|
||||||
-- use string here since all the callbacks in xmobar use strings :(
|
-- use string here since all the callbacks in xmobar use strings :(
|
||||||
type Callback = String -> IO ()
|
type Callback = String -> IO ()
|
||||||
|
|
||||||
|
@ -57,22 +32,18 @@ data Colors = Colors
|
||||||
deriving (Eq, Show, Read)
|
deriving (Eq, Show, Read)
|
||||||
|
|
||||||
startListener
|
startListener
|
||||||
:: ( HasClient env
|
:: (MonadUnliftIO m, SafeClient c, IsVariant a)
|
||||||
, MonadReader (env c) m
|
|
||||||
, MonadUnliftIO m
|
|
||||||
, SafeClient c
|
|
||||||
, IsVariant a
|
|
||||||
)
|
|
||||||
=> MatchRule
|
=> MatchRule
|
||||||
-> m [Variant]
|
-> (c -> m [Variant])
|
||||||
-> ([Variant] -> SignalMatch a)
|
-> ([Variant] -> SignalMatch a)
|
||||||
-> (a -> m T.Text)
|
-> (a -> m T.Text)
|
||||||
-> Callback
|
-> Callback
|
||||||
|
-> c
|
||||||
-> m ()
|
-> m ()
|
||||||
startListener rule getProp fromSignal toColor cb = do
|
startListener rule getProp fromSignal toColor cb client = do
|
||||||
reply <- getProp
|
reply <- getProp client
|
||||||
displayMaybe cb toColor $ fromSingletonVariant reply
|
displayMaybe cb toColor $ fromSingletonVariant reply
|
||||||
void $ addMatchCallback rule (procMatch . fromSignal)
|
void $ addMatchCallback rule (procMatch . fromSignal) client
|
||||||
where
|
where
|
||||||
procMatch = procSignalMatch cb toColor
|
procMatch = procSignalMatch cb toColor
|
||||||
|
|
||||||
|
@ -99,42 +70,6 @@ displayMaybe' cb = maybe (liftIO $ cb $ T.unpack na)
|
||||||
withDBusClientConnection
|
withDBusClientConnection
|
||||||
:: (MonadUnliftIO m, SafeClient c)
|
:: (MonadUnliftIO m, SafeClient c)
|
||||||
=> Callback
|
=> Callback
|
||||||
-> Maybe BusName
|
-> (c -> RIO SimpleApp ())
|
||||||
-> Maybe FilePath
|
|
||||||
-> (NamedConnection c -> RIO SimpleApp ())
|
|
||||||
-> m ()
|
-> m ()
|
||||||
withDBusClientConnection cb n logfile f =
|
withDBusClientConnection cb f = runSimpleApp $ displayMaybe' cb f =<< getDBusClient
|
||||||
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
|
|
||||||
|
|
|
@ -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)
|
|
@ -1,3 +1,5 @@
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- Intel backlight plugin
|
-- Intel backlight plugin
|
||||||
--
|
--
|
||||||
|
@ -10,7 +12,6 @@ module Xmobar.Plugins.IntelBacklight
|
||||||
)
|
)
|
||||||
where
|
where
|
||||||
|
|
||||||
import RIO
|
|
||||||
import qualified RIO.Text as T
|
import qualified RIO.Text as T
|
||||||
import XMonad.Internal.DBus.Brightness.IntelBacklight
|
import XMonad.Internal.DBus.Brightness.IntelBacklight
|
||||||
import Xmobar
|
import Xmobar
|
||||||
|
@ -24,9 +25,4 @@ blAlias = "intelbacklight"
|
||||||
instance Exec IntelBacklight where
|
instance Exec IntelBacklight where
|
||||||
alias (IntelBacklight _) = T.unpack blAlias
|
alias (IntelBacklight _) = T.unpack blAlias
|
||||||
start (IntelBacklight icon) =
|
start (IntelBacklight icon) =
|
||||||
startBacklight
|
startBacklight matchSignalIB callGetBrightnessIB icon
|
||||||
(Just "org.xmobar.intelbacklight")
|
|
||||||
(Just "intel_backlight.log")
|
|
||||||
matchSignalIB
|
|
||||||
callGetBrightnessIB
|
|
||||||
icon
|
|
||||||
|
|
|
@ -1,3 +1,5 @@
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- Screensaver plugin
|
-- Screensaver plugin
|
||||||
--
|
--
|
||||||
|
@ -10,8 +12,6 @@ module Xmobar.Plugins.Screensaver
|
||||||
)
|
)
|
||||||
where
|
where
|
||||||
|
|
||||||
import Data.Internal.DBus
|
|
||||||
import RIO
|
|
||||||
import qualified RIO.Text as T
|
import qualified RIO.Text as T
|
||||||
import XMonad.Internal.DBus.Screensaver
|
import XMonad.Internal.DBus.Screensaver
|
||||||
import Xmobar
|
import Xmobar
|
||||||
|
@ -24,13 +24,9 @@ ssAlias = "screensaver"
|
||||||
|
|
||||||
instance Exec Screensaver where
|
instance Exec Screensaver where
|
||||||
alias (Screensaver _) = T.unpack ssAlias
|
alias (Screensaver _) = T.unpack ssAlias
|
||||||
start (Screensaver (text, colors)) cb =
|
start (Screensaver (text, colors)) cb = do
|
||||||
withDBusClientConnection
|
withDBusClientConnection cb $ \sys -> do
|
||||||
cb
|
matchSignal display sys
|
||||||
(Just "org.xmobar.screensaver")
|
display =<< callQuery sys
|
||||||
(Just "screensaver.log")
|
|
||||||
$ \cl -> withDIO cl $ do
|
|
||||||
matchSignal dpy
|
|
||||||
dpy =<< callQuery
|
|
||||||
where
|
where
|
||||||
dpy = displayMaybe cb $ return . (\s -> colorText colors s text)
|
display = displayMaybe cb $ return . (\s -> colorText colors s text)
|
||||||
|
|
|
@ -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
|
69
package.yaml
69
package.yaml
|
@ -9,47 +9,9 @@ extra-source-files:
|
||||||
- README.md
|
- README.md
|
||||||
- fourmolu.yaml
|
- fourmolu.yaml
|
||||||
- make_pkgs
|
- make_pkgs
|
||||||
- runtime_pkgs
|
- icons/*
|
||||||
- assets/icons/*
|
|
||||||
- assets/sound/*
|
|
||||||
- scripts/*
|
- scripts/*
|
||||||
|
- sound/*
|
||||||
default-extensions:
|
|
||||||
- OverloadedStrings
|
|
||||||
- FlexibleContexts
|
|
||||||
- FlexibleInstances
|
|
||||||
- InstanceSigs
|
|
||||||
- MultiParamTypeClasses
|
|
||||||
- EmptyCase
|
|
||||||
- LambdaCase
|
|
||||||
- MultiWayIf
|
|
||||||
- NamedFieldPuns
|
|
||||||
- TupleSections
|
|
||||||
- DeriveFoldable
|
|
||||||
- DeriveFunctor
|
|
||||||
- DeriveGeneric
|
|
||||||
- DeriveLift
|
|
||||||
- DeriveTraversable
|
|
||||||
- DerivingStrategies
|
|
||||||
- DeriveDataTypeable
|
|
||||||
- EmptyDataDecls
|
|
||||||
- PartialTypeSignatures
|
|
||||||
- GeneralizedNewtypeDeriving
|
|
||||||
- StandaloneDeriving
|
|
||||||
- BangPatterns
|
|
||||||
- TypeOperators
|
|
||||||
- ScopedTypeVariables
|
|
||||||
- TypeApplications
|
|
||||||
- ConstraintKinds
|
|
||||||
- RankNTypes
|
|
||||||
- GADTs
|
|
||||||
- DefaultSignatures
|
|
||||||
- NoImplicitPrelude
|
|
||||||
- FunctionalDependencies
|
|
||||||
- DataKinds
|
|
||||||
- TypeFamilies
|
|
||||||
- BinaryLiterals
|
|
||||||
- ViewPatterns
|
|
||||||
|
|
||||||
dependencies:
|
dependencies:
|
||||||
- rio >= 0.1.21.0
|
- rio >= 0.1.21.0
|
||||||
|
@ -73,21 +35,14 @@ dependencies:
|
||||||
- typed-process >= 0.2.8.0
|
- typed-process >= 0.2.8.0
|
||||||
- network >= 3.1.2.7
|
- network >= 3.1.2.7
|
||||||
- unliftio >= 0.2.21.0
|
- unliftio >= 0.2.21.0
|
||||||
- optparse-applicative >= 0.16.1.0
|
|
||||||
|
|
||||||
ghc-options:
|
|
||||||
- -Wall
|
|
||||||
- -Wcompat
|
|
||||||
- -Widentities
|
|
||||||
- -Wincomplete-record-updates
|
|
||||||
- -Wincomplete-uni-patterns
|
|
||||||
- -Wredundant-constraints
|
|
||||||
- -Wpartial-fields
|
|
||||||
- -Werror
|
|
||||||
- -O2
|
|
||||||
|
|
||||||
library:
|
library:
|
||||||
source-dirs: lib/
|
source-dirs: lib/
|
||||||
|
ghc-options:
|
||||||
|
- -Wall
|
||||||
|
- -Werror
|
||||||
|
- -Wpartial-fields
|
||||||
|
- -O2
|
||||||
|
|
||||||
executables:
|
executables:
|
||||||
xmobar: &bin
|
xmobar: &bin
|
||||||
|
@ -97,15 +52,21 @@ executables:
|
||||||
- xmonad-config
|
- xmonad-config
|
||||||
ghc-options:
|
ghc-options:
|
||||||
- -threaded
|
- -threaded
|
||||||
|
- -Wall
|
||||||
|
- -Werror
|
||||||
|
- -Wpartial-fields
|
||||||
|
- -O2
|
||||||
xmonad:
|
xmonad:
|
||||||
<<: *bin
|
<<: *bin
|
||||||
main: xmonad.hs
|
main: xmonad.hs
|
||||||
ghc-options:
|
ghc-options:
|
||||||
- -threaded
|
- -threaded
|
||||||
|
- -Wall
|
||||||
|
- -Werror
|
||||||
|
- -Wpartial-fields
|
||||||
|
- -O2
|
||||||
# this is needed to avoid writing super complex layout types
|
# this is needed to avoid writing super complex layout types
|
||||||
- -fno-warn-missing-signatures
|
- -fno-warn-missing-signatures
|
||||||
vbox-start:
|
vbox-start:
|
||||||
<<: *bin
|
<<: *bin
|
||||||
main: vbox-start.hs
|
main: vbox-start.hs
|
||||||
ghc-options:
|
|
||||||
- -threaded
|
|
||||||
|
|
|
@ -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
|
|
||||||
|
|
|
@ -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
|
|
|
@ -17,8 +17,8 @@
|
||||||
#
|
#
|
||||||
# resolver: ./custom-snapshot.yaml
|
# resolver: ./custom-snapshot.yaml
|
||||||
# resolver: https://example.com/snapshots/2018-01-01.yaml
|
# resolver: https://example.com/snapshots/2018-01-01.yaml
|
||||||
resolver: lts-19.33
|
#resolver: lts-17.4
|
||||||
#resolver: nightly-2022-03-03
|
resolver: nightly-2022-03-03
|
||||||
|
|
||||||
# User packages to be built.
|
# User packages to be built.
|
||||||
# Various formats can be used as shown in the example below.
|
# Various formats can be used as shown in the example below.
|
||||||
|
|
Loading…
Reference in New Issue