Compare commits
No commits in common. "master" and "fix_rio_run" have entirely different histories.
master
...
fix_rio_ru
|
@ -1,3 +1,6 @@
|
|||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
|
||||
-- | Start a VirtualBox instance with a sentinel wrapper process.
|
||||
--
|
||||
-- The only reason why this is needed is because I want to manage virtualboxes
|
||||
|
|
121
bin/xmobar.hs
121
bin/xmobar.hs
|
@ -1,3 +1,5 @@
|
|||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
-- | Xmobar binary
|
||||
--
|
||||
-- Features:
|
||||
|
@ -11,14 +13,14 @@ module Main (main) where
|
|||
|
||||
import Data.Internal.DBus
|
||||
import Data.Internal.XIO
|
||||
import GHC.Enum (enumFrom)
|
||||
import Options.Applicative
|
||||
import RIO hiding (hFlush)
|
||||
import RIO.FilePath
|
||||
import qualified RIO.ByteString.Lazy as BL
|
||||
import RIO.List
|
||||
import qualified RIO.NonEmpty as NE
|
||||
import RIO.Process
|
||||
import qualified RIO.Text as T
|
||||
import XMonad.Core hiding (config)
|
||||
import XMonad.Internal.Command.Desktop
|
||||
import XMonad.Internal.Command.Power
|
||||
import XMonad.Internal.DBus.Brightness.ClevoKeyboard
|
||||
import XMonad.Internal.DBus.Brightness.IntelBacklight
|
||||
|
@ -29,12 +31,13 @@ import Xmobar hiding
|
|||
( iconOffset
|
||||
, run
|
||||
)
|
||||
import Xmobar.Plugins.ActiveConnection
|
||||
import Xmobar.Plugins.Bluetooth
|
||||
import Xmobar.Plugins.ClevoKeyboard
|
||||
import Xmobar.Plugins.Common
|
||||
import Xmobar.Plugins.Device
|
||||
import Xmobar.Plugins.IntelBacklight
|
||||
import Xmobar.Plugins.Screensaver
|
||||
import Xmobar.Plugins.VPN
|
||||
|
||||
main :: IO ()
|
||||
main = parse >>= xio
|
||||
|
@ -64,7 +67,7 @@ parseTest =
|
|||
xio :: XOpts -> IO ()
|
||||
xio o = case o of
|
||||
XDeps -> hRunXIO False stderr printDeps
|
||||
XTest -> hRunXIO False stderr $ withDBus_ Nothing Nothing evalConfig
|
||||
XTest -> hRunXIO False stderr $ withDBus_ evalConfig
|
||||
XRun -> runXIO "xmobar.log" run
|
||||
|
||||
run :: XIO ()
|
||||
|
@ -76,8 +79,8 @@ run = do
|
|||
-- 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
|
||||
withDBus_ $ \db -> do
|
||||
c <- evalConfig db
|
||||
liftIO $ xmobar c
|
||||
|
||||
evalConfig :: DBusState -> XIO Config
|
||||
|
@ -89,7 +92,7 @@ evalConfig db = do
|
|||
return $ config bf ifs ios cs d
|
||||
|
||||
printDeps :: XIO ()
|
||||
printDeps = withDBus_ Nothing Nothing $ \db ->
|
||||
printDeps = withDBus_ $ \db ->
|
||||
mapM_ logInfo $
|
||||
fmap showFulfillment $
|
||||
sort $
|
||||
|
@ -118,7 +121,7 @@ iconFont =
|
|||
fontSometimes
|
||||
"XMobar Icon Font"
|
||||
"Symbols Nerd Font"
|
||||
[Package Official "ttf-nerd-fonts-symbols"]
|
||||
[Package Official "ttf-nerd-fonts-symbols-2048-em"]
|
||||
|
||||
-- | Offsets for the icons in the bar (relative to the text offset)
|
||||
iconOffset :: BarFont -> Int
|
||||
|
@ -164,7 +167,7 @@ config bf ifs ios br confDir =
|
|||
, pickBroadest = False
|
||||
, persistent = True
|
||||
, -- store the icons with the xmonad/xmobar stack project
|
||||
iconRoot = confDir </> "assets" </> "icons"
|
||||
iconRoot = confDir ++ "/icons"
|
||||
, commands = csRunnable <$> concatRegions br
|
||||
}
|
||||
|
||||
|
@ -219,11 +222,11 @@ getWireless =
|
|||
xpfWireless
|
||||
[Subfeature (IORoot wirelessCmd $ Only readWireless) "sysfs path"]
|
||||
|
||||
getEthernet :: Maybe NamedSysConnection -> BarFeature
|
||||
getEthernet cl = iconDBus_ "ethernet status indicator" xpfEthernet root (Only_ devDep)
|
||||
getEthernet :: Maybe SysClient -> BarFeature
|
||||
getEthernet cl = iconDBus "ethernet status indicator" xpfEthernet root tree
|
||||
where
|
||||
root useIcon tree' =
|
||||
DBusRoot_ (const $ ethernetCmd useIcon) tree' cl
|
||||
root useIcon tree' = DBusRoot (const . ethernetCmd useIcon) tree' cl
|
||||
tree = And1 (Only readEthernet) (Only_ devDep)
|
||||
|
||||
getBattery :: BarFeature
|
||||
getBattery = iconIO_ "battery level indicator" xpfBattery root tree
|
||||
|
@ -235,12 +238,18 @@ getBattery = iconIO_ "battery level indicator" xpfBattery root tree
|
|||
io $
|
||||
fmap (Msg LevelError) <$> hasBattery
|
||||
|
||||
getVPN :: Maybe NamedSysConnection -> BarFeature
|
||||
getVPN cl = iconDBus_ "VPN status indicator" xpfVPN root (Only_ devDep)
|
||||
getVPN :: Maybe SysClient -> BarFeature
|
||||
getVPN cl = iconDBus_ "VPN status indicator" xpfVPN root $ toAnd_ vpnDep test
|
||||
where
|
||||
root useIcon tree = DBusRoot_ (const $ vpnCmd useIcon) tree cl
|
||||
test =
|
||||
DBusIO $
|
||||
IOTest_
|
||||
"Use nmcli to test if VPN is present"
|
||||
networkManagerPkgs
|
||||
vpnPresent
|
||||
|
||||
getBt :: Maybe NamedSysConnection -> BarFeature
|
||||
getBt :: Maybe SysClient -> BarFeature
|
||||
getBt = xmobarDBus "bluetooth status indicator" xpfBluetooth btDep btCmd
|
||||
|
||||
getAlsa :: BarFeature
|
||||
|
@ -251,7 +260,7 @@ getAlsa =
|
|||
where
|
||||
root useIcon = IORoot_ (alsaCmd useIcon)
|
||||
|
||||
getBl :: Maybe NamedSesConnection -> BarFeature
|
||||
getBl :: Maybe SesClient -> BarFeature
|
||||
getBl =
|
||||
xmobarDBus
|
||||
"Intel backlight indicator"
|
||||
|
@ -259,7 +268,7 @@ getBl =
|
|||
intelBacklightSignalDep
|
||||
blCmd
|
||||
|
||||
getCk :: Maybe NamedSesConnection -> BarFeature
|
||||
getCk :: Maybe SesClient -> BarFeature
|
||||
getCk =
|
||||
xmobarDBus
|
||||
"Clevo keyboard indicator"
|
||||
|
@ -267,7 +276,7 @@ getCk =
|
|||
clevoKeyboardSignalDep
|
||||
ckCmd
|
||||
|
||||
getSs :: Maybe NamedSesConnection -> BarFeature
|
||||
getSs :: Maybe SesClient -> BarFeature
|
||||
getSs = xmobarDBus "screensaver indicator" (const True) ssSignalDep ssCmd
|
||||
|
||||
getLock :: Always CmdSpec
|
||||
|
@ -284,7 +293,7 @@ xmobarDBus
|
|||
-> XPQuery
|
||||
-> DBusDependency_ c
|
||||
-> (Fontifier -> CmdSpec)
|
||||
-> Maybe (NamedConnection c)
|
||||
-> Maybe c
|
||||
-> BarFeature
|
||||
xmobarDBus n q dep cmd cl = iconDBus_ n q root (Only_ dep)
|
||||
where
|
||||
|
@ -298,16 +307,18 @@ iconIO_
|
|||
-> BarFeature
|
||||
iconIO_ = iconSometimes' And_ Only_
|
||||
|
||||
-- iconDBus
|
||||
-- :: T.Text
|
||||
-- -> XPQuery
|
||||
-- -> (Fontifier -> DBusTree c p -> Root CmdSpec)
|
||||
-- -> DBusTree c p
|
||||
-- -> BarFeature
|
||||
-- iconDBus = iconSometimes' And1 $ Only_ . DBusIO
|
||||
iconDBus
|
||||
:: SafeClient c
|
||||
=> T.Text
|
||||
-> XPQuery
|
||||
-> (Fontifier -> DBusTree c p -> Root CmdSpec)
|
||||
-> DBusTree c p
|
||||
-> BarFeature
|
||||
iconDBus = iconSometimes' And1 $ Only_ . DBusIO
|
||||
|
||||
iconDBus_
|
||||
:: T.Text
|
||||
:: SafeClient c
|
||||
=> T.Text
|
||||
-> XPQuery
|
||||
-> (Fontifier -> DBusTree_ c -> Root CmdSpec)
|
||||
-> DBusTree_ c
|
||||
|
@ -369,19 +380,13 @@ wirelessCmd iface =
|
|||
, "<icon=wifi_%%.xpm/>"
|
||||
]
|
||||
|
||||
ethernetCmd :: Fontifier -> CmdSpec
|
||||
ethernetCmd = connCmd "\xf0e8" "ETH" ("vlan" :| ["802-3-ethernet"])
|
||||
|
||||
vpnCmd :: Fontifier -> CmdSpec
|
||||
vpnCmd = connCmd "\xf023" "VPN" ("tun" :| [])
|
||||
|
||||
connCmd :: T.Text -> T.Text -> NE.NonEmpty T.Text -> Fontifier -> CmdSpec
|
||||
connCmd icon abbr contypes fontify =
|
||||
ethernetCmd :: Fontifier -> T.Text -> CmdSpec
|
||||
ethernetCmd fontify iface =
|
||||
CmdSpec
|
||||
{ csAlias = connAlias contypes
|
||||
{ csAlias = iface
|
||||
, csRunnable =
|
||||
Run $
|
||||
ActiveConnection (contypes, fontify IconMedium icon abbr, colors)
|
||||
Device (iface, fontify IconMedium "\xf0e8" "ETH", colors)
|
||||
}
|
||||
|
||||
batteryCmd :: Fontifier -> CmdSpec
|
||||
|
@ -417,13 +422,20 @@ batteryCmd fontify =
|
|||
, fontify' "\xf1e6" "AC"
|
||||
]
|
||||
|
||||
vpnCmd :: Fontifier -> CmdSpec
|
||||
vpnCmd fontify =
|
||||
CmdSpec
|
||||
{ csAlias = vpnAlias
|
||||
, csRunnable = Run $ VPN (fontify IconMedium "\xf023" "VPN", colors)
|
||||
}
|
||||
|
||||
btCmd :: Fontifier -> CmdSpec
|
||||
btCmd fontify =
|
||||
CmdSpec
|
||||
{ csAlias = btAlias
|
||||
, csRunnable =
|
||||
Run $
|
||||
Bluetooth (fontify' "\x0f00b1" "+", fontify' "\x0f00af" "-") colors
|
||||
Bluetooth (fontify' "\xf5b0" "+", fontify' "\xf5ae" "-") colors
|
||||
}
|
||||
where
|
||||
fontify' i = fontify IconLarge i . T.append "BT"
|
||||
|
@ -464,7 +476,7 @@ ckCmd :: Fontifier -> CmdSpec
|
|||
ckCmd fontify =
|
||||
CmdSpec
|
||||
{ csAlias = ckAlias
|
||||
, csRunnable = Run $ ClevoKeyboard $ fontify IconSmall "\xf11c" "KB: "
|
||||
, csRunnable = Run $ ClevoKeyboard $ fontify IconSmall "\xf40b" "KB: "
|
||||
}
|
||||
|
||||
ssCmd :: Fontifier -> CmdSpec
|
||||
|
@ -500,8 +512,8 @@ lockCmd fontify =
|
|||
]
|
||||
}
|
||||
where
|
||||
numIcon = fontify' "\x0f03a6" "N"
|
||||
capIcon = fontify' "\x0f0bf1" "C"
|
||||
numIcon = fontify' "\xf8a5" "N"
|
||||
capIcon = fontify' "\xf657" "C"
|
||||
fontify' = fontify IconXLarge
|
||||
disabledColor = xmobarFGColor XT.backdropFgColor
|
||||
|
||||
|
@ -512,6 +524,29 @@ dateCmd =
|
|||
, csRunnable = Run $ Date "%Y-%m-%d %H:%M:%S " "date" 10
|
||||
}
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- low-level testing functions
|
||||
|
||||
vpnPresent :: XIO (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
|
||||
--
|
||||
|
|
|
@ -1,3 +1,9 @@
|
|||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- XMonad binary
|
||||
|
||||
|
@ -21,7 +27,7 @@ import System.Process
|
|||
( getPid
|
||||
, getProcessExitCode
|
||||
)
|
||||
import XMonad hiding (display)
|
||||
import XMonad
|
||||
import XMonad.Actions.CopyWindow
|
||||
import XMonad.Actions.CycleWS
|
||||
import XMonad.Actions.PhysicalScreens
|
||||
|
@ -45,7 +51,6 @@ import XMonad.Internal.DBus.Removable
|
|||
import XMonad.Internal.DBus.Screensaver
|
||||
import XMonad.Internal.Shell hiding (proc)
|
||||
import qualified XMonad.Internal.Theme as XT
|
||||
import XMonad.Layout.Decoration
|
||||
import XMonad.Layout.MultiToggle
|
||||
import XMonad.Layout.NoBorders
|
||||
import XMonad.Layout.NoFrillsDecoration
|
||||
|
@ -139,21 +144,21 @@ run = do
|
|||
, normalBorderColor = T.unpack XT.bordersColor
|
||||
, focusedBorderColor = T.unpack XT.selectedBordersColor
|
||||
}
|
||||
runXMonad conf
|
||||
io $ runXMonad conf
|
||||
where
|
||||
startDynWorkspaces fs = do
|
||||
dws <- catMaybes <$> mapM evalSometimes (fsDynWorkspaces fs)
|
||||
void $ async $ runWorkspaceMon dws
|
||||
return dws
|
||||
|
||||
runXMonad :: (LayoutClass l Window, Read (l Window)) => XConfig l -> XIO ()
|
||||
runXMonad :: (LayoutClass l Window, Read (l Window)) => XConfig l -> IO ()
|
||||
runXMonad conf = do
|
||||
dirs <- getCreateDirectories
|
||||
liftIO $ launch conf dirs
|
||||
launch conf dirs
|
||||
|
||||
getCreateDirectories :: XIO Directories
|
||||
getCreateDirectories :: IO Directories
|
||||
getCreateDirectories = do
|
||||
ds <- liftIO getDirectories
|
||||
ds <- getDirectories
|
||||
mapM_ (createIfMissing ds) [dataDir, cfgDir, cacheDir]
|
||||
return ds
|
||||
where
|
||||
|
@ -161,14 +166,14 @@ getCreateDirectories = do
|
|||
let d = f ds
|
||||
r <- tryIO $ createDirectoryIfMissing True d
|
||||
case r of
|
||||
(Left e) -> logError $ display e
|
||||
(Left e) -> print e
|
||||
_ -> return ()
|
||||
|
||||
data FeatureSet = FeatureSet
|
||||
{ fsKeys :: (XIO () -> IO ()) -> X () -> DBusState -> [KeyGroup FeatureX]
|
||||
, fsDBusExporters :: [Maybe NamedSesConnection -> Sometimes (XIO (), XIO ())]
|
||||
, fsDBusExporters :: [Maybe SesClient -> Sometimes (XIO (), XIO ())]
|
||||
, fsPowerMon :: SometimesIO
|
||||
, fsRemovableMon :: Maybe NamedSysConnection -> SometimesIO
|
||||
, fsRemovableMon :: Maybe SysClient -> SometimesIO
|
||||
, fsDaemons :: [Sometimes (XIO (Process () () ()))]
|
||||
, fsACPIHandler :: Always (String -> X ())
|
||||
, fsTabbedTheme :: Always Theme
|
||||
|
@ -183,7 +188,7 @@ tabbedFeature = Always "theme for tabbed windows" $ Option sf fallback
|
|||
niceTheme = IORoot XT.tabbedTheme $ fontTree XT.defFontFamily defFontPkgs
|
||||
fallback = Always_ $ FallbackAlone $ XT.tabbedTheme XT.fallbackFont
|
||||
|
||||
features :: Maybe NamedSysConnection -> FeatureSet
|
||||
features :: Maybe SysClient -> FeatureSet
|
||||
features cl =
|
||||
FeatureSet
|
||||
{ fsKeys = externalBindings
|
||||
|
@ -251,7 +256,7 @@ stopChildDaemons = mapM_ stop
|
|||
liftIO $ killNoWait p
|
||||
|
||||
printDeps :: XIO ()
|
||||
printDeps = withDBus_ Nothing Nothing $ \db -> do
|
||||
printDeps = withDBus_ $ \db -> do
|
||||
runIO <- askRunInIO
|
||||
let mockCleanup = runCleanup runIO mockClean db
|
||||
let bfs =
|
||||
|
@ -292,7 +297,7 @@ runCleanup runIO ts db = liftIO $ runIO $ do
|
|||
mapM_ stopXmobar $ clXmobar ts
|
||||
stopChildDaemons $ clChildren ts
|
||||
sequence_ $ clDBusUnexporters ts
|
||||
disconnectDBus db
|
||||
disconnectDBusX db
|
||||
|
||||
-- | Kill a process (group) after xmonad has already started
|
||||
-- This is necessary (as opposed to 'stopProcess' from rio) because a) xmonad
|
||||
|
@ -345,6 +350,9 @@ vmTag = "VM"
|
|||
xsaneTag :: String
|
||||
xsaneTag = "XSANE"
|
||||
|
||||
f5Tag :: String
|
||||
f5Tag = "F5VPN"
|
||||
|
||||
gimpDynamicWorkspace :: Sometimes DynWorkspace
|
||||
gimpDynamicWorkspace = sometimesIO_ "gimp workspace" "gimp" tree dw
|
||||
where
|
||||
|
@ -417,11 +425,31 @@ xsaneDynamicWorkspace =
|
|||
}
|
||||
c = "Xsane"
|
||||
|
||||
f5vpnDynamicWorkspace :: Sometimes DynWorkspace
|
||||
f5vpnDynamicWorkspace =
|
||||
Sometimes
|
||||
"F5 VPN workspace"
|
||||
xpfF5VPN
|
||||
[Subfeature (IORoot_ dw tree) "f5vpn"]
|
||||
where
|
||||
tree = Only_ $ sysExe [Package AUR "f5vpn"] "f5vpn"
|
||||
dw =
|
||||
DynWorkspace
|
||||
{ dwName = "F5Vpn"
|
||||
, dwTag = f5Tag
|
||||
, dwClass = c
|
||||
, dwHook = [className =? c -?> appendShift f5Tag]
|
||||
, dwKey = 'i'
|
||||
, dwCmd = Just skip
|
||||
}
|
||||
c = "F5 VPN"
|
||||
|
||||
allDWs' :: [Sometimes DynWorkspace]
|
||||
allDWs' =
|
||||
[ xsaneDynamicWorkspace
|
||||
, vmDynamicWorkspace
|
||||
, gimpDynamicWorkspace
|
||||
, f5vpnDynamicWorkspace
|
||||
]
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
@ -436,10 +464,6 @@ myLayouts tt =
|
|||
mkToggle (single HIDE) $
|
||||
tall ||| fulltab ||| full
|
||||
where
|
||||
addTopBar
|
||||
:: (Eq a)
|
||||
=> l a
|
||||
-> ModifiedLayout (Decoration NoFrillsDecoration DefaultShrinker) l a
|
||||
addTopBar = noFrillsDeco shrinkText tt
|
||||
tall =
|
||||
renamed [Replace "Tall"] $
|
||||
|
@ -832,9 +856,8 @@ externalBindings runIO cleanup db =
|
|||
, -- M-<F1> reserved for showing the keymap
|
||||
KeyBinding "M-<F2>" "restart xmonad" restartf
|
||||
, KeyBinding "M-<F3>" "recompile xmonad" recompilef
|
||||
, KeyBinding "M-<F7>" "select autorandr profile" $ Left $ toX runAutorandrMenu
|
||||
, KeyBinding "M-<F8>" "toggle wifi" $ Left $ toX runToggleWifi
|
||||
, KeyBinding "M-<F9>" "toggle network" $ Left $ toX runToggleNetworking
|
||||
, KeyBinding "M-<F8>" "select autorandr profile" $ Left $ toX runAutorandrMenu
|
||||
, KeyBinding "M-<F9>" "toggle ethernet" $ Left $ toX runToggleEthernet
|
||||
, KeyBinding "M-<F10>" "toggle bluetooth" $ Left $ toX $ runToggleBluetooth sys
|
||||
, KeyBinding "M-<F11>" "toggle screensaver" $ Left $ toX $ callToggle ses
|
||||
, KeyBinding "M-<F12>" "switch gpu" $ Left runOptimusPrompt
|
||||
|
|
|
@ -1,3 +1,7 @@
|
|||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Common internal DBus functions
|
||||
|
||||
|
@ -5,17 +9,11 @@ module Data.Internal.DBus
|
|||
( SafeClient (..)
|
||||
, SysClient (..)
|
||||
, SesClient (..)
|
||||
, NamedConnection (..)
|
||||
, NamedSesConnection
|
||||
, NamedSysConnection
|
||||
, DBusEnv (..)
|
||||
, DIO
|
||||
, HasClient (..)
|
||||
, releaseBusName
|
||||
, withDIO
|
||||
, addMatchCallback
|
||||
, addMatchCallbackSignal
|
||||
, matchSignalFull
|
||||
, matchProperty
|
||||
, matchPropertyFull
|
||||
, matchPropertyChanged
|
||||
|
@ -41,10 +39,6 @@ module Data.Internal.DBus
|
|||
, displayMemberName
|
||||
, displayInterfaceName
|
||||
, displayWrapQuote
|
||||
, busNameT
|
||||
, interfaceNameT
|
||||
, memberNameT
|
||||
, objectPathT
|
||||
)
|
||||
where
|
||||
|
||||
|
@ -59,129 +53,48 @@ import qualified RIO.Text as T
|
|||
--------------------------------------------------------------------------------
|
||||
-- Type-safe client
|
||||
|
||||
data NamedConnection c = NamedConnection
|
||||
{ ncClient :: !Client
|
||||
, ncHumanName :: !(Maybe BusName)
|
||||
--, ncUniqueName :: !BusName
|
||||
, ncType :: !c
|
||||
}
|
||||
|
||||
type NamedSesConnection = NamedConnection SesClient
|
||||
|
||||
type NamedSysConnection = NamedConnection SysClient
|
||||
|
||||
class SafeClient c where
|
||||
toClient :: c -> Client
|
||||
|
||||
getDBusClient
|
||||
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
|
||||
=> Maybe BusName
|
||||
-> m (Maybe (NamedConnection c))
|
||||
=> m (Maybe c)
|
||||
|
||||
disconnectDBusClient
|
||||
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
|
||||
=> NamedConnection c
|
||||
-> m ()
|
||||
disconnectDBusClient c = do
|
||||
releaseBusName c
|
||||
liftIO $ disconnect $ ncClient c
|
||||
disconnectDBusClient :: MonadUnliftIO m => c -> m ()
|
||||
disconnectDBusClient = liftIO . disconnect . toClient
|
||||
|
||||
withDBusClient
|
||||
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
|
||||
=> Maybe BusName
|
||||
-> (NamedConnection c -> m a)
|
||||
=> (c -> m a)
|
||||
-> m (Maybe a)
|
||||
withDBusClient n f =
|
||||
bracket (getDBusClient n) (mapM (liftIO . disconnect . ncClient)) $ mapM f
|
||||
withDBusClient f =
|
||||
bracket getDBusClient (mapM (liftIO . disconnect . toClient)) $ mapM f
|
||||
|
||||
withDBusClient_
|
||||
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
|
||||
=> Maybe BusName
|
||||
-> (NamedConnection c -> m ())
|
||||
=> (c -> m ())
|
||||
-> m ()
|
||||
withDBusClient_ n = void . withDBusClient n
|
||||
withDBusClient_ = void . withDBusClient
|
||||
|
||||
fromDBusClient
|
||||
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
|
||||
=> Maybe BusName
|
||||
-> (NamedConnection c -> a)
|
||||
=> (c -> a)
|
||||
-> m (Maybe a)
|
||||
fromDBusClient n f = withDBusClient n (return . f)
|
||||
fromDBusClient f = withDBusClient (return . f)
|
||||
|
||||
data SysClient = SysClient
|
||||
newtype SysClient = SysClient Client
|
||||
|
||||
instance SafeClient SysClient where
|
||||
getDBusClient = connectToDBusWithName True SysClient
|
||||
toClient (SysClient cl) = cl
|
||||
|
||||
data SesClient = SesClient
|
||||
getDBusClient = fmap SysClient <$> getDBusClient' True
|
||||
|
||||
newtype SesClient = SesClient Client
|
||||
|
||||
instance SafeClient SesClient where
|
||||
-- TODO wet
|
||||
getDBusClient = connectToDBusWithName False SesClient
|
||||
toClient (SesClient cl) = cl
|
||||
|
||||
connectToDBusWithName
|
||||
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
|
||||
=> Bool
|
||||
-> c
|
||||
-> Maybe BusName
|
||||
-> m (Maybe (NamedConnection c))
|
||||
connectToDBusWithName sys t n = do
|
||||
clRes <- getDBusClient' sys
|
||||
case clRes of
|
||||
Nothing -> do
|
||||
logError "could not get client"
|
||||
return Nothing
|
||||
Just cl -> do
|
||||
--helloRes <- liftIO $ callHello cl
|
||||
--case helloRes of
|
||||
-- Nothing -> do
|
||||
-- logError "count not get unique name"
|
||||
-- return Nothing
|
||||
-- Just unique -> do
|
||||
n' <- maybe (return Nothing) (`requestBusName` cl) n
|
||||
return $
|
||||
Just $
|
||||
NamedConnection
|
||||
{ ncClient = cl
|
||||
, ncHumanName = n'
|
||||
-- , ncUniqueName = unique
|
||||
, ncType = t
|
||||
}
|
||||
|
||||
releaseBusName
|
||||
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
|
||||
=> NamedConnection c
|
||||
-> m ()
|
||||
releaseBusName NamedConnection {ncClient, ncHumanName} = do
|
||||
-- TODO this might error?
|
||||
case ncHumanName of
|
||||
Just n -> do
|
||||
liftIO $ void $ releaseName ncClient n
|
||||
logInfo $ "released bus name: " <> displayBusName n
|
||||
Nothing -> return ()
|
||||
|
||||
requestBusName
|
||||
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
|
||||
=> BusName
|
||||
-> Client
|
||||
-> m (Maybe BusName)
|
||||
requestBusName n cl = do
|
||||
res <- try $ liftIO $ requestName cl n []
|
||||
case res of
|
||||
Left e -> do
|
||||
logError $ displayBytesUtf8 $ BC.pack $ clientErrorMessage e
|
||||
return Nothing
|
||||
Right r -> do
|
||||
let msg
|
||||
| r == NamePrimaryOwner = "registering name"
|
||||
| r == NameAlreadyOwner = "this process already owns name"
|
||||
| r == NameInQueue
|
||||
|| r == NameExists =
|
||||
"another process owns name"
|
||||
-- this should never happen
|
||||
| otherwise = "unknown error when requesting name"
|
||||
logInfo $ msg <> ": " <> displayBusName n
|
||||
case r of
|
||||
NamePrimaryOwner -> return $ Just n
|
||||
_ -> return Nothing
|
||||
getDBusClient = fmap SesClient <$> getDBusClient' False
|
||||
|
||||
getDBusClient'
|
||||
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
|
||||
|
@ -195,28 +108,19 @@ getDBusClient' sys = do
|
|||
return Nothing
|
||||
Right c -> return $ Just c
|
||||
|
||||
--callHello :: Client -> IO (Maybe BusName)
|
||||
--callHello cl = do
|
||||
-- reply <- call_ cl $ methodCallBus dbusName dbusPath dbusInterface "Hello"
|
||||
-- case methodReturnBody reply of
|
||||
-- [name] | Just nameStr <- fromVariant name -> do
|
||||
-- busName <- parseBusName nameStr
|
||||
-- return $ Just busName
|
||||
-- _ -> return Nothing
|
||||
--
|
||||
data DBusEnv env c = DBusEnv {dClient :: !(NamedConnection c), dEnv :: !env}
|
||||
data DBusEnv env c = DBusEnv {dClient :: !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
|
||||
instance SafeClient c => HasLogFunc (DBusEnv SimpleApp c) where
|
||||
logFuncL = lens dEnv (\x y -> x {dEnv = y}) . logFuncL
|
||||
|
||||
withDIO
|
||||
:: (MonadUnliftIO m, MonadReader env m)
|
||||
=> NamedConnection c
|
||||
:: (MonadUnliftIO m, MonadReader env m, SafeClient c)
|
||||
=> c
|
||||
-> DIO env c a
|
||||
-> m a
|
||||
withDIO cl x = do
|
||||
|
@ -224,7 +128,7 @@ withDIO cl x = do
|
|||
runRIO (DBusEnv cl env) x
|
||||
|
||||
class HasClient env where
|
||||
clientL :: SafeClient c => Lens' (env c) (NamedConnection c)
|
||||
clientL :: SafeClient c => Lens' (env c) c
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Methods
|
||||
|
@ -236,7 +140,7 @@ callMethod'
|
|||
=> MethodCall
|
||||
-> m MethodBody
|
||||
callMethod' mc = do
|
||||
cl <- ncClient <$> view clientL
|
||||
cl <- toClient <$> view clientL
|
||||
liftIO $ bimap (T.pack . methodErrorMessage) methodReturnBody <$> call cl mc
|
||||
|
||||
callMethod
|
||||
|
@ -298,21 +202,9 @@ bodyToMaybe = either (const Nothing) fromSingletonVariant
|
|||
|
||||
type SignalCallback m = [Variant] -> m ()
|
||||
|
||||
addMatchCallbackSignal
|
||||
:: ( MonadReader (env c) m
|
||||
, MonadUnliftIO m
|
||||
, SafeClient c
|
||||
, HasClient env
|
||||
)
|
||||
=> MatchRule
|
||||
-> (Signal -> m ())
|
||||
-> m SignalHandler
|
||||
addMatchCallbackSignal rule cb = do
|
||||
cl <- ncClient <$> view clientL
|
||||
withRunInIO $ \run -> addMatch cl rule $ run . cb
|
||||
|
||||
addMatchCallback
|
||||
:: ( MonadReader (env c) m
|
||||
, HasLogFunc (env c)
|
||||
, MonadUnliftIO m
|
||||
, SafeClient c
|
||||
, HasClient env
|
||||
|
@ -320,7 +212,10 @@ addMatchCallback
|
|||
=> MatchRule
|
||||
-> SignalCallback m
|
||||
-> m SignalHandler
|
||||
addMatchCallback rule cb = addMatchCallbackSignal rule (cb . signalBody)
|
||||
addMatchCallback rule cb = do
|
||||
cl <- toClient <$> view clientL
|
||||
withRunInIO $ \run -> do
|
||||
addMatch cl rule $ run . cb . signalBody
|
||||
|
||||
matchSignal
|
||||
:: Maybe BusName
|
||||
|
@ -389,7 +284,7 @@ callPropertyGet
|
|||
-> MemberName
|
||||
-> m [Variant]
|
||||
callPropertyGet bus path iface property = do
|
||||
cl <- ncClient <$> view clientL
|
||||
cl <- toClient <$> view clientL
|
||||
res <- liftIO $ getProperty cl $ methodCallBus bus path iface property
|
||||
case res of
|
||||
Left err -> do
|
||||
|
@ -424,26 +319,26 @@ withSignalMatch _ NoMatch = return ()
|
|||
matchPropertyChanged
|
||||
:: IsVariant a
|
||||
=> InterfaceName
|
||||
-> MemberName
|
||||
-> T.Text
|
||||
-> [Variant]
|
||||
-> SignalMatch a
|
||||
matchPropertyChanged iface property [sigIface, sigValues, _] =
|
||||
let i = fromVariant sigIface :: Maybe T.Text
|
||||
v = fromVariant sigValues :: Maybe (M.Map T.Text Variant)
|
||||
in case (i, v) of
|
||||
(Just i', Just v') ->
|
||||
if i' == interfaceNameT iface
|
||||
then
|
||||
maybe NoMatch Match $
|
||||
fromVariant =<< M.lookup (memberNameT property) v'
|
||||
matchPropertyChanged iface property [i, body, _] =
|
||||
let i' = (fromVariant i :: Maybe T.Text)
|
||||
b = toMap body
|
||||
in case (i', b) of
|
||||
(Just i'', Just b') ->
|
||||
if i'' == T.pack (formatInterfaceName iface)
|
||||
then maybe NoMatch Match $ fromVariant =<< M.lookup property b'
|
||||
else NoMatch
|
||||
_ -> Failure
|
||||
where
|
||||
toMap v = fromVariant v :: Maybe (M.Map T.Text Variant)
|
||||
matchPropertyChanged _ _ _ = Failure
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Object Manager
|
||||
|
||||
type ObjectTree = M.Map ObjectPath (M.Map InterfaceName (M.Map T.Text Variant))
|
||||
type ObjectTree = M.Map ObjectPath (M.Map T.Text (M.Map T.Text Variant))
|
||||
|
||||
omInterface :: InterfaceName
|
||||
omInterface = interfaceName_ "org.freedesktop.DBus.ObjectManager"
|
||||
|
@ -473,11 +368,7 @@ callGetManagedObjects bus path = do
|
|||
Left err -> do
|
||||
logError $ Utf8Builder $ encodeUtf8Builder err
|
||||
return M.empty
|
||||
Right v ->
|
||||
return $
|
||||
fmap (M.mapKeys interfaceName_) $
|
||||
fromMaybe M.empty $
|
||||
fromSingletonVariant v
|
||||
Right v -> return $ fromMaybe M.empty $ fromSingletonVariant v
|
||||
|
||||
addInterfaceChangedListener
|
||||
:: ( MonadReader (env c) m
|
||||
|
@ -541,14 +432,14 @@ addInterfaceRemovedListener bus =
|
|||
-- Interface export/unexport
|
||||
|
||||
exportPair
|
||||
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
|
||||
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m, SafeClient c)
|
||||
=> ObjectPath
|
||||
-> (Client -> m Interface)
|
||||
-> NamedConnection c
|
||||
-> c
|
||||
-> (m (), m ())
|
||||
exportPair path toIface cl = (up, down)
|
||||
where
|
||||
cl_ = ncClient cl
|
||||
cl_ = toClient cl
|
||||
up = do
|
||||
logInfo $ "adding interface: " <> path_
|
||||
i <- toIface cl_
|
||||
|
@ -561,18 +452,6 @@ exportPair path toIface cl = (up, down)
|
|||
--------------------------------------------------------------------------------
|
||||
-- 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
|
||||
|
||||
|
|
|
@ -1,3 +1,12 @@
|
|||
{-# LANGUAGE DeriveFunctor #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Functions for handling dependencies
|
||||
|
||||
|
@ -100,7 +109,6 @@ import qualified DBus.Introspection as I
|
|||
import Data.Aeson hiding (Error, Result)
|
||||
import Data.Aeson.Key
|
||||
import Data.Internal.DBus
|
||||
import qualified Data.Text.IO as TI
|
||||
import Data.Yaml
|
||||
import GHC.IO.Exception (ioe_description)
|
||||
import RIO hiding (bracket, fromString)
|
||||
|
@ -132,9 +140,9 @@ runXIO logfile x = withLogFile logfile $ \h -> hRunXIO True h x
|
|||
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"
|
||||
catchIO (withFile p AppendMode f) $ \e -> do
|
||||
liftIO $ print e
|
||||
liftIO $ putStrLn "could not open log file, falling back to stderr"
|
||||
f stderr
|
||||
|
||||
hRunXIO :: Bool -> Handle -> XIO a -> IO a
|
||||
|
@ -288,18 +296,8 @@ type SubfeatureRoot a = Subfeature (Root a)
|
|||
data Root a
|
||||
= forall p. IORoot (p -> a) (IOTree p)
|
||||
| IORoot_ a IOTree_
|
||||
| forall c p.
|
||||
SafeClient c =>
|
||||
DBusRoot
|
||||
(p -> NamedConnection c -> a)
|
||||
(DBusTree c p)
|
||||
(Maybe (NamedConnection c))
|
||||
| forall c.
|
||||
SafeClient c =>
|
||||
DBusRoot_
|
||||
(NamedConnection c -> a)
|
||||
(DBusTree_ c)
|
||||
(Maybe (NamedConnection c))
|
||||
| forall c p. SafeClient c => DBusRoot (p -> c -> a) (DBusTree c p) (Maybe c)
|
||||
| forall c. SafeClient c => DBusRoot_ (c -> a) (DBusTree_ c) (Maybe c)
|
||||
|
||||
instance Functor Root where
|
||||
fmap f (IORoot a t) = IORoot (f . a) t
|
||||
|
@ -427,7 +425,7 @@ data XEnv = XEnv
|
|||
instance HasLogFunc XEnv where
|
||||
logFuncL = lens xLogFun (\x y -> x {xLogFun = y})
|
||||
|
||||
instance HasLogFunc (DBusEnv XEnv c) where
|
||||
instance SafeClient c => HasLogFunc (DBusEnv XEnv c) where
|
||||
logFuncL = lens dEnv (\x y -> x {dEnv = y}) . logFuncL
|
||||
|
||||
instance HasProcessContext XEnv where
|
||||
|
@ -468,8 +466,7 @@ data XPFeatures = XPFeatures
|
|||
, xpfIntelBacklight :: Bool
|
||||
, xpfClevoBacklight :: Bool
|
||||
, xpfBattery :: Bool
|
||||
, xpfEthPrefix :: Maybe Text
|
||||
, xpfWifiPrefix :: Maybe Text
|
||||
, xpfF5VPN :: Bool
|
||||
}
|
||||
|
||||
instance FromJSON XPFeatures where
|
||||
|
@ -496,9 +493,7 @@ instance FromJSON XPFeatures where
|
|||
<*> o
|
||||
.:+ "battery"
|
||||
<*> o
|
||||
.:? "ethPrefix"
|
||||
<*> o
|
||||
.:? "wifiPrefix"
|
||||
.:+ "f5vpn"
|
||||
|
||||
defParams :: XParams
|
||||
defParams =
|
||||
|
@ -521,8 +516,7 @@ defXPFeatures =
|
|||
, xpfIntelBacklight = False
|
||||
, xpfClevoBacklight = False
|
||||
, xpfBattery = False
|
||||
, xpfEthPrefix = Nothing
|
||||
, xpfWifiPrefix = Nothing
|
||||
, xpfF5VPN = False
|
||||
}
|
||||
|
||||
type XPQuery = XPFeatures -> Bool
|
||||
|
@ -533,7 +527,7 @@ getParams = do
|
|||
maybe (return defParams) (liftIO . decodeYaml) p
|
||||
where
|
||||
decodeYaml p =
|
||||
either (\e -> TI.putStrLn (T.pack $ show e) >> return defParams) return
|
||||
either (\e -> print e >> return defParams) return
|
||||
=<< decodeFileEither p
|
||||
|
||||
getParamFile :: MonadIO m => m (Maybe FilePath)
|
||||
|
@ -833,16 +827,16 @@ testFont fam = maybe pass (Left . (: [])) <$> shellTest "fc-list" args msg
|
|||
-- start with "en" and wireless interfaces always start with "wl"
|
||||
|
||||
readEthernet :: IODependency T.Text
|
||||
readEthernet = readInterface "get ethernet interface" (fromMaybe "en" . xpfEthPrefix)
|
||||
readEthernet = readInterface "get ethernet interface" isEthernet
|
||||
|
||||
readWireless :: IODependency T.Text
|
||||
readWireless = readInterface "get wireless interface" (fromMaybe "wl" . xpfWifiPrefix)
|
||||
readWireless = readInterface "get wireless interface" isWireless
|
||||
|
||||
-- isWireless :: T.Text -> Bool
|
||||
-- isWireless = T.isPrefixOf "wl"
|
||||
isWireless :: T.Text -> Bool
|
||||
isWireless = T.isPrefixOf "wl"
|
||||
|
||||
-- isEthernet :: T.Text -> Bool
|
||||
-- isEthernet = T.isPrefixOf "en"
|
||||
isEthernet :: T.Text -> Bool
|
||||
isEthernet = T.isPrefixOf "en"
|
||||
|
||||
listInterfaces :: MonadUnliftIO m => m [T.Text]
|
||||
listInterfaces =
|
||||
|
@ -854,12 +848,11 @@ sysfsNet = "/sys/class/net"
|
|||
|
||||
-- ASSUME there are no (non-base) packages required to make these interfaces
|
||||
-- work (all at the kernel level)
|
||||
readInterface :: T.Text -> (XPFeatures -> Text) -> IODependency T.Text
|
||||
readInterface :: T.Text -> (T.Text -> Bool) -> IODependency T.Text
|
||||
readInterface n f = IORead n [] go
|
||||
where
|
||||
go = do
|
||||
p <- asks (f . xpFeatures . xParams)
|
||||
ns <- filter (T.isPrefixOf p) <$> listInterfaces
|
||||
go = io $ do
|
||||
ns <- filter f <$> listInterfaces
|
||||
case ns of
|
||||
[] -> return $ Left [Msg LevelError "no interfaces found"]
|
||||
(x : xs) -> do
|
||||
|
@ -895,10 +888,10 @@ introspectInterface = interfaceName_ "org.freedesktop.DBus.Introspectable"
|
|||
introspectMethod :: MemberName
|
||||
introspectMethod = memberName_ "Introspect"
|
||||
|
||||
testDBusDep_ :: SafeClient c => NamedConnection c -> DBusDependency_ c -> XIO MResult_
|
||||
testDBusDep_ :: SafeClient c => c -> DBusDependency_ c -> XIO MResult_
|
||||
testDBusDep_ c d = memoizeMVar $ testDBusDepNoCache_ c d
|
||||
|
||||
testDBusDepNoCache_ :: SafeClient c => NamedConnection c -> DBusDependency_ c -> XIO Result_
|
||||
testDBusDepNoCache_ :: SafeClient c => c -> DBusDependency_ c -> XIO Result_
|
||||
testDBusDepNoCache_ cl (Bus _ bus) = do
|
||||
ret <- withDIO cl $ callMethod queryBus queryPath queryIface queryMem
|
||||
return $ case ret of
|
||||
|
@ -1029,11 +1022,11 @@ sometimesExeArgs fn n ful sys path args =
|
|||
|
||||
sometimesDBus
|
||||
:: SafeClient c
|
||||
=> Maybe (NamedConnection c)
|
||||
=> Maybe c
|
||||
-> T.Text
|
||||
-> T.Text
|
||||
-> Tree_ (DBusDependency_ c)
|
||||
-> (NamedConnection c -> a)
|
||||
-> (c -> a)
|
||||
-> Sometimes a
|
||||
sometimesDBus c fn n t x = sometimes1 fn n $ DBusRoot_ x t c
|
||||
|
||||
|
@ -1047,7 +1040,7 @@ sometimesEndpoint
|
|||
-> ObjectPath
|
||||
-> InterfaceName
|
||||
-> MemberName
|
||||
-> Maybe (NamedConnection c)
|
||||
-> Maybe c
|
||||
-> Sometimes (m ())
|
||||
sometimesEndpoint fn name ful busname path iface mem cl =
|
||||
sometimesDBus cl fn name deps cmd
|
||||
|
|
|
@ -1,3 +1,5 @@
|
|||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Dmenu (Rofi) Commands
|
||||
|
||||
|
@ -146,7 +148,7 @@ runAppMenu = spawnDmenuCmd "app launcher" ["-show", "drun"]
|
|||
runWinMenu :: MonadUnliftIO m => Sometimes (m ())
|
||||
runWinMenu = spawnDmenuCmd "window switcher" ["-show", "window"]
|
||||
|
||||
runNetMenu :: MonadUnliftIO m => Maybe NamedSysConnection -> Sometimes (m ())
|
||||
runNetMenu :: MonadUnliftIO m => Maybe SysClient -> Sometimes (m ())
|
||||
runNetMenu cl =
|
||||
Sometimes
|
||||
"network control menu"
|
||||
|
@ -171,7 +173,7 @@ runAutorandrMenu = sometimesIO_ "autorandr menu" "rofi autorandr" tree cmd
|
|||
--------------------------------------------------------------------------------
|
||||
-- Password manager
|
||||
|
||||
runBwMenu :: MonadUnliftIO m => Maybe NamedSesConnection -> Sometimes (m ())
|
||||
runBwMenu :: MonadUnliftIO m => Maybe SesClient -> Sometimes (m ())
|
||||
runBwMenu cl = sometimesDBus cl "password manager" "rofi bitwarden" tree cmd
|
||||
where
|
||||
cmd _ =
|
||||
|
@ -208,7 +210,7 @@ runClipMenu = sometimesIO_ "clipboard manager" "rofi greenclip" tree act
|
|||
-- Shortcut menu
|
||||
|
||||
runShowKeys
|
||||
:: (MonadReader env m, MonadUnliftIO m)
|
||||
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
|
||||
=> Always ([((KeyMask, KeySym), NamedAction)] -> m ())
|
||||
runShowKeys =
|
||||
Always "keyboard menu" $
|
||||
|
@ -223,7 +225,7 @@ runShowKeys =
|
|||
defNoteError {body = Just $ Text "could not display keymap"}
|
||||
|
||||
showKeysDMenu
|
||||
:: (MonadReader env m, MonadUnliftIO m)
|
||||
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
|
||||
=> SubfeatureRoot ([((KeyMask, KeySym), NamedAction)] -> m ())
|
||||
showKeysDMenu =
|
||||
Subfeature
|
||||
|
@ -232,7 +234,7 @@ showKeysDMenu =
|
|||
}
|
||||
|
||||
showKeys
|
||||
:: (MonadReader env m, MonadUnliftIO m)
|
||||
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
|
||||
=> [((KeyMask, KeySym), NamedAction)]
|
||||
-> m ()
|
||||
showKeys kbs = do
|
||||
|
|
|
@ -1,3 +1,5 @@
|
|||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- General commands
|
||||
|
||||
|
@ -19,8 +21,7 @@ module XMonad.Internal.Command.Desktop
|
|||
, runVolumeUp
|
||||
, runVolumeMute
|
||||
, runToggleBluetooth
|
||||
, runToggleNetworking
|
||||
, runToggleWifi
|
||||
, runToggleEthernet
|
||||
, runRestart
|
||||
, runRecompile
|
||||
, runAreaCapture
|
||||
|
@ -59,13 +60,13 @@ import XMonad.Operations
|
|||
-- My Executables
|
||||
|
||||
myTerm :: FilePath
|
||||
myTerm = "alacritty"
|
||||
myTerm = "urxvt"
|
||||
|
||||
myCalc :: FilePath
|
||||
myCalc = "bc"
|
||||
|
||||
myBrowser :: FilePath
|
||||
myBrowser = "firefox"
|
||||
myBrowser = "brave"
|
||||
|
||||
myEditor :: FilePath
|
||||
myEditor = "emacsclient"
|
||||
|
@ -93,7 +94,8 @@ myNotificationCtrl = "dunstctl"
|
|||
|
||||
myTermPkgs :: [Fulfillment]
|
||||
myTermPkgs =
|
||||
[ Package Official "alacritty"
|
||||
[ Package Official "rxvt-unicode"
|
||||
, Package Official "urxvt-perls"
|
||||
]
|
||||
|
||||
myEditorPkgs :: [Fulfillment]
|
||||
|
@ -108,9 +110,6 @@ bluetoothPkgs = [Package Official "bluez-utils"]
|
|||
networkManagerPkgs :: [Fulfillment]
|
||||
networkManagerPkgs = [Package Official "networkmanager"]
|
||||
|
||||
nmcli :: IODependency_
|
||||
nmcli = sysExe networkManagerPkgs "nmcli"
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Misc constants
|
||||
|
||||
|
@ -121,7 +120,7 @@ volumeChangeSound = "smb_fireball.wav"
|
|||
-- Some nice apps
|
||||
|
||||
runTerm :: MonadUnliftIO m => Sometimes (m ())
|
||||
runTerm = sometimesExe "terminal" "alacritty" myTermPkgs True myTerm
|
||||
runTerm = sometimesExe "terminal" "urxvt" myTermPkgs True myTerm
|
||||
|
||||
runTMux :: MonadUnliftIO m => Sometimes (m ())
|
||||
runTMux = sometimesIO_ "terminal multiplexer" "tmux" deps act
|
||||
|
@ -209,7 +208,7 @@ runStopPlay = runMultimediaIfInstalled "stop playback" "stop"
|
|||
-- Volume Commands
|
||||
|
||||
soundDir :: FilePath
|
||||
soundDir = "assets" </> "sound"
|
||||
soundDir = "sound"
|
||||
|
||||
playSound :: MonadIO m => FilePath -> m ()
|
||||
playSound file = do
|
||||
|
@ -249,7 +248,7 @@ runNotificationCmd
|
|||
:: MonadUnliftIO m
|
||||
=> T.Text
|
||||
-> T.Text
|
||||
-> Maybe NamedSesConnection
|
||||
-> Maybe SesClient
|
||||
-> Sometimes (m ())
|
||||
runNotificationCmd n arg cl =
|
||||
sometimesDBus cl (T.unwords [n, "control"]) "dunstctl" tree cmd
|
||||
|
@ -261,37 +260,37 @@ runNotificationCmd n arg cl =
|
|||
Method_ $
|
||||
memberName_ "NotificationAction"
|
||||
|
||||
runNotificationClose :: MonadUnliftIO m => Maybe NamedSesConnection -> Sometimes (m ())
|
||||
runNotificationClose :: MonadUnliftIO m => Maybe SesClient -> Sometimes (m ())
|
||||
runNotificationClose = runNotificationCmd "close notification" "close"
|
||||
|
||||
runNotificationCloseAll :: MonadUnliftIO m => Maybe NamedSesConnection -> Sometimes (m ())
|
||||
runNotificationCloseAll :: MonadUnliftIO m => Maybe SesClient -> Sometimes (m ())
|
||||
runNotificationCloseAll =
|
||||
runNotificationCmd "close all notifications" "close-all"
|
||||
|
||||
runNotificationHistory :: MonadUnliftIO m => Maybe NamedSesConnection -> Sometimes (m ())
|
||||
runNotificationHistory :: MonadUnliftIO m => Maybe SesClient -> Sometimes (m ())
|
||||
runNotificationHistory =
|
||||
runNotificationCmd "see notification history" "history-pop"
|
||||
|
||||
runNotificationContext :: MonadUnliftIO m => Maybe NamedSesConnection -> Sometimes (m ())
|
||||
runNotificationContext :: MonadUnliftIO m => Maybe SesClient -> Sometimes (m ())
|
||||
runNotificationContext =
|
||||
runNotificationCmd "open notification context" "context"
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- System commands
|
||||
|
||||
-- needed to lookup/prompt for passwords/keys for wifi connections and some VPNs
|
||||
runNetAppDaemon :: Maybe NamedSysConnection -> Sometimes (XIO (P.Process () () ()))
|
||||
-- this is required for some vpn's to work properly with network-manager
|
||||
runNetAppDaemon :: Maybe SysClient -> Sometimes (XIO (P.Process () () ()))
|
||||
runNetAppDaemon cl =
|
||||
Sometimes
|
||||
"network applet"
|
||||
(\x -> xpfVPN x || xpfWireless x)
|
||||
xpfVPN
|
||||
[Subfeature (DBusRoot_ cmd tree cl) "NM-applet"]
|
||||
where
|
||||
tree = toAnd_ app $ Bus networkManagerPkgs networkManagerBus
|
||||
app = DBusIO $ sysExe [Package Official "network-manager-applet"] "nm-applet"
|
||||
cmd _ = P.proc "nm-applet" [] (P.startProcess . P.setCreateGroup True)
|
||||
|
||||
runToggleBluetooth :: MonadUnliftIO m => Maybe NamedSysConnection -> Sometimes (m ())
|
||||
runToggleBluetooth :: MonadUnliftIO m => Maybe SysClient -> Sometimes (m ())
|
||||
runToggleBluetooth cl =
|
||||
Sometimes
|
||||
"bluetooth toggle"
|
||||
|
@ -308,35 +307,27 @@ runToggleBluetooth cl =
|
|||
#!>> fmtCmd myBluetooth ["power", "$a", ">", "/dev/null"]
|
||||
#!&& fmtNotifyCmd defNoteInfo {body = Just $ Text "bluetooth powered $a"}
|
||||
|
||||
runToggleNetworking :: MonadUnliftIO m => Sometimes (m ())
|
||||
runToggleNetworking =
|
||||
runToggleEthernet :: MonadUnliftIO m => Sometimes (m ())
|
||||
runToggleEthernet =
|
||||
Sometimes
|
||||
"network toggle"
|
||||
(\x -> xpfEthernet x || xpfWireless x)
|
||||
"ethernet toggle"
|
||||
xpfEthernet
|
||||
[Subfeature root "nmcli"]
|
||||
where
|
||||
root = IORoot_ cmd $ Only_ nmcli
|
||||
cmd =
|
||||
root =
|
||||
IORoot cmd $
|
||||
And1 (Only readEthernet) $
|
||||
Only_ $
|
||||
sysExe networkManagerPkgs "nmcli"
|
||||
-- TODO make this less noisy
|
||||
cmd iface =
|
||||
S.spawn $
|
||||
fmtCmd "nmcli" ["networking"]
|
||||
#!| "grep -q enabled"
|
||||
#!&& "a=off"
|
||||
#!|| "a=on"
|
||||
#!>> fmtCmd "nmcli" ["networking", "$a"]
|
||||
#!&& fmtNotifyCmd defNoteInfo {body = Just $ Text "networking switched $a"}
|
||||
|
||||
runToggleWifi :: MonadUnliftIO m => Sometimes (m ())
|
||||
runToggleWifi = Sometimes "wifi toggle" xpfWireless [Subfeature root "nmcli"]
|
||||
where
|
||||
root = IORoot_ cmd $ Only_ nmcli
|
||||
cmd =
|
||||
S.spawn $
|
||||
fmtCmd "nmcli" ["radio", "wifi"]
|
||||
#!| "grep -q enabled"
|
||||
#!&& "a=off"
|
||||
#!|| "a=on"
|
||||
#!>> fmtCmd "nmcli" ["radio", "wifi", "$a"]
|
||||
#!&& fmtNotifyCmd defNoteInfo {body = Just $ Text "wifi switched $a"}
|
||||
fmtCmd "nmcli" ["-g", "GENERAL.STATE", "device", "show", iface]
|
||||
#!| "grep -q disconnected"
|
||||
#!&& "a=connect"
|
||||
#!|| "a=disconnect"
|
||||
#!>> fmtCmd "nmcli" ["device", "$a", iface]
|
||||
#!&& fmtNotifyCmd defNoteInfo {body = Just $ Text "ethernet \"$a\"ed"}
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Configuration commands
|
||||
|
@ -377,7 +368,7 @@ runFlameshot
|
|||
:: MonadUnliftIO m
|
||||
=> T.Text
|
||||
-> T.Text
|
||||
-> Maybe NamedSesConnection
|
||||
-> Maybe SesClient
|
||||
-> Sometimes (m ())
|
||||
runFlameshot n mode cl = sometimesDBus cl n (T.pack myCapture) tree cmd
|
||||
where
|
||||
|
@ -389,15 +380,15 @@ runFlameshot n mode cl = sometimesDBus cl n (T.pack myCapture) tree cmd
|
|||
|
||||
-- TODO this will steal focus from the current window (and puts it
|
||||
-- in the root window?) ...need to fix
|
||||
runAreaCapture :: MonadUnliftIO m => Maybe NamedSesConnection -> Sometimes (m ())
|
||||
runAreaCapture :: MonadUnliftIO m => Maybe SesClient -> Sometimes (m ())
|
||||
runAreaCapture = runFlameshot "screen area capture" "gui"
|
||||
|
||||
-- myWindowCap = "screencap -w" --external script
|
||||
|
||||
runDesktopCapture :: MonadUnliftIO m => Maybe NamedSesConnection -> Sometimes (m ())
|
||||
runDesktopCapture :: MonadUnliftIO m => Maybe SesClient -> Sometimes (m ())
|
||||
runDesktopCapture = runFlameshot "fullscreen capture" "full"
|
||||
|
||||
runScreenCapture :: MonadUnliftIO m => Maybe NamedSesConnection -> Sometimes (m ())
|
||||
runScreenCapture :: MonadUnliftIO m => Maybe SesClient -> Sometimes (m ())
|
||||
runScreenCapture = runFlameshot "screen capture" "screen"
|
||||
|
||||
runCaptureBrowser :: MonadUnliftIO m => Sometimes (m ())
|
||||
|
|
|
@ -1,3 +1,5 @@
|
|||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Commands for controlling power
|
||||
|
||||
|
@ -89,8 +91,7 @@ runAutolock = sometimesIO_ "automatic screen lock" "xss-lock" tree cmd
|
|||
And_ (Only_ $ sysExe [Package Official "xss-lock"] "xss-lock") $
|
||||
Only_ $
|
||||
IOSometimes_ runScreenLock
|
||||
cmd = P.proc "xss-lock" args (P.startProcess . P.setCreateGroup True)
|
||||
args = ["--ignore-sleep", "--", "screenlock", "true"]
|
||||
cmd = P.proc "xss-lock" ["--ignore-sleep", "screenlock"] (P.startProcess . P.setCreateGroup True)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Confirmation prompts
|
||||
|
@ -179,20 +180,17 @@ data PowerMaybeAction
|
|||
| Reboot
|
||||
deriving (Eq)
|
||||
|
||||
fromPMA :: PowerMaybeAction -> Int
|
||||
fromPMA a = case a of
|
||||
Poweroff -> 0
|
||||
Shutdown -> 1
|
||||
Hibernate -> 2
|
||||
Reboot -> 3
|
||||
instance Enum PowerMaybeAction where
|
||||
toEnum 0 = Poweroff
|
||||
toEnum 1 = Shutdown
|
||||
toEnum 2 = Hibernate
|
||||
toEnum 3 = Reboot
|
||||
toEnum _ = errorWithoutStackTrace "Main.Enum.PowerMaybeAction.toEnum: bad argument"
|
||||
|
||||
toPMA :: Int -> Maybe PowerMaybeAction
|
||||
toPMA x = case x of
|
||||
0 -> Just Poweroff
|
||||
1 -> Just Shutdown
|
||||
2 -> Just Hibernate
|
||||
3 -> Just Reboot
|
||||
_ -> Nothing
|
||||
fromEnum Poweroff = 0
|
||||
fromEnum Shutdown = 1
|
||||
fromEnum Hibernate = 2
|
||||
fromEnum Reboot = 3
|
||||
|
||||
data PowerPrompt = PowerPrompt
|
||||
|
||||
|
@ -224,11 +222,9 @@ powerPrompt lock fb = mkXPrompt PowerPrompt theme comp executeMaybeAction
|
|||
, (xK_Return, quit)
|
||||
, (xK_Escape, quit)
|
||||
]
|
||||
sendMaybeAction a = setInput (show $ fromPMA a) >> setSuccess True >> setDone True
|
||||
executeMaybeAction a = case toPMA =<< readMaybe a of
|
||||
Just Poweroff -> liftIO runPowerOff
|
||||
Just Shutdown -> lock >> liftIO runSuspend
|
||||
Just Hibernate -> lock >> liftIO runHibernate
|
||||
Just Reboot -> liftIO runReboot
|
||||
-- TODO log an error here since this should never happen
|
||||
Nothing -> skip
|
||||
sendMaybeAction a = setInput (show $ fromEnum a) >> setSuccess True >> setDone True
|
||||
executeMaybeAction a = case toEnum $ read a of
|
||||
Poweroff -> liftIO runPowerOff
|
||||
Shutdown -> lock >> liftIO runSuspend
|
||||
Hibernate -> lock >> liftIO runHibernate
|
||||
Reboot -> liftIO runReboot
|
||||
|
|
|
@ -1,3 +1,6 @@
|
|||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Concurrent module to handle events from acpid
|
||||
|
||||
|
@ -30,18 +33,15 @@ data ACPIEvent
|
|||
| LidClose
|
||||
deriving (Eq)
|
||||
|
||||
fromACPIEvent :: ACPIEvent -> Int
|
||||
fromACPIEvent x = case x of
|
||||
Power -> 0
|
||||
Sleep -> 1
|
||||
LidClose -> 2
|
||||
instance Enum ACPIEvent where
|
||||
toEnum 0 = Power
|
||||
toEnum 1 = Sleep
|
||||
toEnum 2 = LidClose
|
||||
toEnum _ = errorWithoutStackTrace "ACPI.Enum.ACPIEvent.toEnum: bad argument"
|
||||
|
||||
toACPIEvent :: Int -> Maybe ACPIEvent
|
||||
toACPIEvent x = case x of
|
||||
0 -> Just Power
|
||||
1 -> Just Sleep
|
||||
2 -> Just LidClose
|
||||
_ -> Nothing
|
||||
fromEnum Power = 0
|
||||
fromEnum Sleep = 1
|
||||
fromEnum LidClose = 2
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Internal functions
|
||||
|
@ -64,7 +64,7 @@ parseLine line =
|
|||
|
||||
-- | Send an ACPIEvent to the X server as a ClientMessage
|
||||
sendACPIEvent :: ACPIEvent -> IO ()
|
||||
sendACPIEvent = sendXMsg ACPI . show . fromACPIEvent
|
||||
sendACPIEvent = sendXMsg ACPI . show . fromEnum
|
||||
|
||||
isDischarging :: IO (Maybe Bool)
|
||||
isDischarging = do
|
||||
|
@ -91,7 +91,7 @@ socketDep = Only_ $ pathR acpiPath [Package Official "acpid"]
|
|||
-- Xmonad's event hook)
|
||||
handleACPI :: FontBuilder -> X () -> String -> X ()
|
||||
handleACPI fb lock tag = do
|
||||
let acpiTag = toACPIEvent =<< readMaybe tag :: Maybe ACPIEvent
|
||||
let acpiTag = toEnum <$> readMaybe tag :: Maybe ACPIEvent
|
||||
forM_ acpiTag $ \case
|
||||
Power -> powerPrompt lock fb
|
||||
Sleep -> suspendPrompt fb
|
||||
|
|
|
@ -28,7 +28,6 @@ import Graphics.X11.Xlib.Atom
|
|||
import Graphics.X11.Xlib.Display
|
||||
import Graphics.X11.Xlib.Event
|
||||
import Graphics.X11.Xlib.Extras
|
||||
import RIO
|
||||
import XMonad.Internal.IO
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
@ -43,18 +42,14 @@ data XMsgType
|
|||
| Unknown
|
||||
deriving (Eq, Show)
|
||||
|
||||
fromXMsgType :: XMsgType -> Int
|
||||
fromXMsgType x = case x of
|
||||
ACPI -> 0
|
||||
Workspace -> 1
|
||||
Unknown -> 2
|
||||
instance Enum XMsgType where
|
||||
toEnum 0 = ACPI
|
||||
toEnum 1 = Workspace
|
||||
toEnum _ = errorWithoutStackTrace "ACPI.Enum.ACPIEvent.toEnum: bad argument"
|
||||
|
||||
toXMsgType :: Int -> Maybe XMsgType
|
||||
toXMsgType x = case x of
|
||||
0 -> Just ACPI
|
||||
1 -> Just Workspace
|
||||
2 -> Just Unknown
|
||||
_ -> Nothing
|
||||
fromEnum ACPI = 0
|
||||
fromEnum Workspace = 1
|
||||
fromEnum Unknown = 2
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Exported API
|
||||
|
@ -63,9 +58,9 @@ toXMsgType x = case x of
|
|||
-- type and payload
|
||||
splitXMsg :: (Integral a) => [a] -> (XMsgType, String)
|
||||
splitXMsg [] = (Unknown, "")
|
||||
splitXMsg (x : xs) = (fromMaybe Unknown xtype, tag)
|
||||
splitXMsg (x : xs) = (xtype, tag)
|
||||
where
|
||||
xtype = toXMsgType $ fromIntegral x
|
||||
xtype = toEnum $ fromIntegral x
|
||||
tag = chr . fromIntegral <$> takeWhile (/= 0) xs
|
||||
|
||||
-- | Emit a ClientMessage event to the X server with the given type and payloud
|
||||
|
@ -91,5 +86,5 @@ sendXMsg xtype tag = withOpenDisplay $ \dpy -> do
|
|||
setClientMessageEvent' e root bITMAP 8 (x : t)
|
||||
sendEvent dpy root False substructureNotifyMask e
|
||||
where
|
||||
x = fromIntegral $ fromXMsgType xtype
|
||||
x = fromIntegral $ fromEnum xtype
|
||||
t = fmap (fromIntegral . fromEnum) tag
|
||||
|
|
|
@ -1,3 +1,5 @@
|
|||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Automatically Manage Dynamic Workspaces
|
||||
-- This is a somewhat convoluted wrapper for the Dymamic Workspaces module
|
||||
|
|
|
@ -1,3 +1,6 @@
|
|||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- VirtualBox-specific functions
|
||||
|
||||
|
@ -33,7 +36,7 @@ vmInstanceConfig vmName = do
|
|||
vmDirectory :: IO (Either String String)
|
||||
vmDirectory = do
|
||||
p <- vmConfig
|
||||
s <- tryIO $ readFileUtf8 p
|
||||
s <- tryIO $ readFile p
|
||||
return $ case s of
|
||||
(Left _) -> Left "could not read VirtualBox config file"
|
||||
(Right x) ->
|
||||
|
|
|
@ -1,3 +1,6 @@
|
|||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- DBus module for Clevo Keyboard control
|
||||
|
||||
|
@ -117,7 +120,7 @@ clevoKeyboardSignalDep =
|
|||
|
||||
exportClevoKeyboard
|
||||
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
|
||||
=> Maybe NamedSesConnection
|
||||
=> Maybe SesClient
|
||||
-> Sometimes (m (), m ())
|
||||
exportClevoKeyboard =
|
||||
brightnessExporter
|
||||
|
@ -128,7 +131,7 @@ exportClevoKeyboard =
|
|||
|
||||
clevoKeyboardControls
|
||||
:: (HasClient (DBusEnv env), MonadReader env m, MonadUnliftIO m)
|
||||
=> Maybe NamedSesConnection
|
||||
=> Maybe SesClient
|
||||
-> BrightnessControls m
|
||||
clevoKeyboardControls = brightnessControls xpfClevoBacklight clevoKeyboardConfig
|
||||
|
||||
|
@ -139,6 +142,7 @@ callGetBrightnessCK = callGetBrightness clevoKeyboardConfig
|
|||
|
||||
matchSignalCK
|
||||
:: ( SafeClient c
|
||||
, HasLogFunc (env c)
|
||||
, HasClient env
|
||||
, MonadReader (env c) m
|
||||
, MonadUnliftIO m
|
||||
|
|
|
@ -1,3 +1,7 @@
|
|||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- DBus module for DBus brightness controls
|
||||
|
||||
|
@ -53,7 +57,7 @@ brightnessControls
|
|||
:: (HasClient (DBusEnv env), MonadReader env m, MonadUnliftIO m)
|
||||
=> XPQuery
|
||||
-> BrightnessConfig m a b
|
||||
-> Maybe NamedSesConnection
|
||||
-> Maybe SesClient
|
||||
-> BrightnessControls m
|
||||
brightnessControls q bc cl =
|
||||
BrightnessControls
|
||||
|
@ -76,14 +80,15 @@ callGetBrightness
|
|||
-> m (Maybe n)
|
||||
callGetBrightness BrightnessConfig {bcPath = p, bcInterface = i} =
|
||||
either (const Nothing) bodyGetBrightness
|
||||
<$> callMethod xmonadSesBusName p i memGet
|
||||
<$> callMethod xmonadBusName p i memGet
|
||||
|
||||
signalDep :: BrightnessConfig m a b -> DBusDependency_ c
|
||||
signalDep :: BrightnessConfig m a b -> DBusDependency_ SesClient
|
||||
signalDep BrightnessConfig {bcPath = p, bcInterface = i} =
|
||||
Endpoint [] xmonadSesBusName p i $ Signal_ memCur
|
||||
Endpoint [] xmonadBusName p i $ Signal_ memCur
|
||||
|
||||
matchSignal
|
||||
:: ( HasClient env
|
||||
, HasLogFunc (env c)
|
||||
, MonadReader (env c) m
|
||||
, MonadUnliftIO m
|
||||
, SafeClient c
|
||||
|
@ -112,18 +117,18 @@ brightnessExporter
|
|||
-> [Fulfillment]
|
||||
-> [IODependency_]
|
||||
-> BrightnessConfig m a b
|
||||
-> Maybe NamedSesConnection
|
||||
-> Maybe SesClient
|
||||
-> Sometimes (m (), m ())
|
||||
brightnessExporter q ful deps bc@BrightnessConfig {bcName = n} cl =
|
||||
Sometimes (T.append n " DBus Interface") q [Subfeature root "exporter"]
|
||||
where
|
||||
root = DBusRoot_ (exportBrightnessControlsInner bc) tree cl
|
||||
tree = listToAnds (Bus ful xmonadSesBusName) $ fmap DBusIO deps
|
||||
tree = listToAnds (Bus ful xmonadBusName) $ fmap DBusIO deps
|
||||
|
||||
exportBrightnessControlsInner
|
||||
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m, RealFrac b)
|
||||
=> BrightnessConfig m a b
|
||||
-> NamedSesConnection
|
||||
-> SesClient
|
||||
-> (m (), m ())
|
||||
exportBrightnessControlsInner bc = cmd
|
||||
where
|
||||
|
@ -172,7 +177,7 @@ emitBrightness BrightnessConfig {bcPath = p, bcInterface = i} client cur =
|
|||
callBacklight
|
||||
:: (MonadReader env m, HasClient (DBusEnv env), MonadUnliftIO m)
|
||||
=> XPQuery
|
||||
-> Maybe NamedSesConnection
|
||||
-> Maybe SesClient
|
||||
-> BrightnessConfig m a b
|
||||
-> T.Text
|
||||
-> MemberName
|
||||
|
@ -180,8 +185,8 @@ callBacklight
|
|||
callBacklight q cl BrightnessConfig {bcPath = p, bcInterface = i, bcName = n} controlName m =
|
||||
Sometimes (T.unwords [n, controlName]) q [Subfeature root "method call"]
|
||||
where
|
||||
root = DBusRoot_ cmd (Only_ $ Endpoint [] xmonadSesBusName p i $ Method_ m) cl
|
||||
cmd c = void $ withDIO c $ callMethod xmonadSesBusName p i m
|
||||
root = DBusRoot_ cmd (Only_ $ Endpoint [] xmonadBusName p i $ Method_ m) cl
|
||||
cmd c = void $ withDIO c $ callMethod xmonadBusName p i m
|
||||
|
||||
bodyGetBrightness :: Num a => [Variant] -> Maybe a
|
||||
bodyGetBrightness [b] = fromIntegral <$> (fromVariant b :: Maybe Int32)
|
||||
|
|
|
@ -1,3 +1,6 @@
|
|||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- DBus module for Intel Backlight control
|
||||
|
||||
|
@ -103,7 +106,7 @@ intelBacklightSignalDep =
|
|||
|
||||
exportIntelBacklight
|
||||
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
|
||||
=> Maybe NamedSesConnection
|
||||
=> Maybe SesClient
|
||||
-> Sometimes (m (), m ())
|
||||
exportIntelBacklight =
|
||||
brightnessExporter
|
||||
|
@ -114,7 +117,7 @@ exportIntelBacklight =
|
|||
|
||||
intelBacklightControls
|
||||
:: (HasClient (DBusEnv env), MonadReader env m, MonadUnliftIO m)
|
||||
=> Maybe NamedSesConnection
|
||||
=> Maybe SesClient
|
||||
-> BrightnessControls m
|
||||
intelBacklightControls = brightnessControls xpfIntelBacklight intelBacklightConfig
|
||||
|
||||
|
@ -125,6 +128,7 @@ callGetBrightnessIB = callGetBrightness intelBacklightConfig
|
|||
|
||||
matchSignalIB
|
||||
:: ( SafeClient c
|
||||
, HasLogFunc (env c)
|
||||
, HasClient env
|
||||
, MonadReader (env c) m
|
||||
, MonadUnliftIO m
|
||||
|
|
|
@ -2,8 +2,7 @@
|
|||
-- High-level interface for managing XMonad's DBus
|
||||
|
||||
module XMonad.Internal.DBus.Common
|
||||
( xmonadSesBusName
|
||||
, xmonadSysBusName
|
||||
( xmonadBusName
|
||||
, btBus
|
||||
, notifyBus
|
||||
, notifyPath
|
||||
|
@ -13,11 +12,8 @@ where
|
|||
|
||||
import DBus
|
||||
|
||||
xmonadSesBusName :: BusName
|
||||
xmonadSesBusName = busName_ "org.xmonad.session"
|
||||
|
||||
xmonadSysBusName :: BusName
|
||||
xmonadSysBusName = busName_ "org.xmonad.system"
|
||||
xmonadBusName :: BusName
|
||||
xmonadBusName = busName_ "org.xmonad"
|
||||
|
||||
btBus :: BusName
|
||||
btBus = busName_ "org.bluez"
|
||||
|
|
|
@ -1,3 +1,6 @@
|
|||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- High-level interface for managing XMonad's DBus
|
||||
|
||||
|
@ -10,8 +13,9 @@ module XMonad.Internal.DBus.Control
|
|||
, withDBus
|
||||
, withDBus_
|
||||
, connectDBus
|
||||
, connectDBusX
|
||||
, disconnectDBus
|
||||
-- , disconnectDBusX
|
||||
, disconnectDBusX
|
||||
, getDBusClient
|
||||
, withDBusClient
|
||||
, withDBusClient_
|
||||
|
@ -25,6 +29,7 @@ import DBus.Client
|
|||
import Data.Internal.DBus
|
||||
import Data.Internal.XIO
|
||||
import RIO
|
||||
import qualified RIO.Text as T
|
||||
import XMonad.Internal.DBus.Brightness.ClevoKeyboard
|
||||
import XMonad.Internal.DBus.Brightness.IntelBacklight
|
||||
import XMonad.Internal.DBus.Common
|
||||
|
@ -32,8 +37,8 @@ import XMonad.Internal.DBus.Screensaver
|
|||
|
||||
-- | Current connections to the DBus (session and system buses)
|
||||
data DBusState = DBusState
|
||||
{ dbSesClient :: Maybe NamedSesConnection
|
||||
, dbSysClient :: Maybe NamedSysConnection
|
||||
{ dbSesClient :: Maybe SesClient
|
||||
, dbSysClient :: Maybe SysClient
|
||||
}
|
||||
|
||||
withDBusX_
|
||||
|
@ -45,79 +50,59 @@ withDBusX_ = void . withDBusX
|
|||
withDBusX
|
||||
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
|
||||
=> (DBusState -> m a)
|
||||
-> m a
|
||||
withDBusX = withDBus (Just xmonadSesBusName) Nothing
|
||||
-> m (Maybe a)
|
||||
withDBusX f = withDBus $ \db -> do
|
||||
forM (dbSesClient db) $ \ses -> do
|
||||
bracket_ (requestXMonadName ses) (releaseXMonadName ses) $ f db
|
||||
|
||||
withDBus_
|
||||
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
|
||||
=> Maybe BusName
|
||||
-> Maybe BusName
|
||||
-> (DBusState -> m a)
|
||||
=> (DBusState -> m a)
|
||||
-> m ()
|
||||
withDBus_ sesname sysname = void . withDBus sesname sysname
|
||||
withDBus_ = void . withDBus
|
||||
|
||||
withDBus
|
||||
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
|
||||
=> Maybe BusName
|
||||
-> Maybe BusName
|
||||
-> (DBusState -> m a)
|
||||
=> (DBusState -> m a)
|
||||
-> m a
|
||||
withDBus sesname sysname = bracket (connectDBus sesname sysname) disconnectDBus
|
||||
withDBus = bracket connectDBus disconnectDBus
|
||||
|
||||
-- | Connect to the DBus
|
||||
connectDBus
|
||||
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
|
||||
=> Maybe BusName
|
||||
-> Maybe BusName
|
||||
-> m DBusState
|
||||
connectDBus sesname sysname = do
|
||||
ses <- getDBusClient sesname
|
||||
sys <- getDBusClient sysname
|
||||
=> m DBusState
|
||||
connectDBus = do
|
||||
ses <- getDBusClient
|
||||
sys <- getDBusClient
|
||||
return DBusState {dbSesClient = ses, dbSysClient = sys}
|
||||
|
||||
-- | Disconnect from the DBus
|
||||
disconnectDBus
|
||||
disconnectDBus :: MonadUnliftIO m => DBusState -> m ()
|
||||
disconnectDBus db = disc dbSesClient >> disc dbSysClient
|
||||
where
|
||||
disc f = maybe (return ()) disconnectDBusClient $ f db
|
||||
|
||||
-- | Connect to the DBus and request the XMonad name
|
||||
connectDBusX
|
||||
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
|
||||
=> m DBusState
|
||||
connectDBusX = do
|
||||
db <- connectDBus
|
||||
forM_ (dbSesClient db) requestXMonadName
|
||||
return db
|
||||
|
||||
-- | Disconnect from DBus and release the XMonad name
|
||||
disconnectDBusX
|
||||
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
|
||||
=> DBusState
|
||||
-> m ()
|
||||
disconnectDBus db = disc dbSesClient >> disc dbSysClient
|
||||
where
|
||||
disc
|
||||
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m, SafeClient c)
|
||||
=> (DBusState -> Maybe (NamedConnection c))
|
||||
-> m ()
|
||||
disc f = maybe (return ()) disconnectDBusClient $ f db
|
||||
|
||||
-- -- | Connect to the DBus and request the XMonad name
|
||||
-- connectDBusX
|
||||
-- :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
|
||||
-- => m DBusState
|
||||
-- connectDBusX = do
|
||||
-- db <- connectDBus
|
||||
-- requestXMonadName2 db
|
||||
-- return db
|
||||
|
||||
-- -- | Disconnect from DBus and release the XMonad name
|
||||
-- disconnectDBusX
|
||||
-- :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
|
||||
-- => DBusState
|
||||
-- -> m ()
|
||||
-- disconnectDBusX db = do
|
||||
-- forM_ (dbSesClient db) releaseBusName
|
||||
-- forM_ (dbSysClient db) releaseBusName
|
||||
-- disconnectDBus db
|
||||
|
||||
-- requestXMonadName2
|
||||
-- :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
|
||||
-- => DBusState
|
||||
-- -> m ()
|
||||
-- requestXMonadName2 db = do
|
||||
-- forM_ (dbSesClient db) requestXMonadName
|
||||
-- forM_ (dbSysClient db) requestXMonadName
|
||||
disconnectDBusX db = do
|
||||
forM_ (dbSesClient db) releaseXMonadName
|
||||
disconnectDBus db
|
||||
|
||||
withDBusInterfaces
|
||||
:: DBusState
|
||||
-> [Maybe NamedSesConnection -> Sometimes (XIO (), XIO ())]
|
||||
-> [Maybe SesClient -> Sometimes (XIO (), XIO ())]
|
||||
-> ([XIO ()] -> XIO a)
|
||||
-> XIO a
|
||||
withDBusInterfaces db interfaces = bracket up sequence
|
||||
|
@ -130,59 +115,35 @@ withDBusInterfaces db interfaces = bracket up sequence
|
|||
-- | All exporter features to be assigned to the DBus
|
||||
dbusExporters
|
||||
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
|
||||
=> [Maybe NamedSesConnection -> Sometimes (m (), m ())]
|
||||
=> [Maybe SesClient -> Sometimes (m (), m ())]
|
||||
dbusExporters = [exportScreensaver, exportIntelBacklight, exportClevoKeyboard]
|
||||
|
||||
-- releaseXMonadName
|
||||
-- :: (SafeClient c, MonadReader env m, HasLogFunc env, MonadUnliftIO m)
|
||||
-- => c
|
||||
-- -> m ()
|
||||
-- releaseXMonadName cl = do
|
||||
-- -- TODO this might error?
|
||||
-- liftIO $ void $ releaseName (toClient cl) xmonadBusName
|
||||
-- logInfo "released xmonad name"
|
||||
releaseXMonadName
|
||||
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
|
||||
=> SesClient
|
||||
-> m ()
|
||||
releaseXMonadName ses = do
|
||||
-- TODO this might error?
|
||||
liftIO $ void $ releaseName (toClient ses) xmonadBusName
|
||||
logInfo "released xmonad name"
|
||||
|
||||
-- releaseBusName
|
||||
-- :: (SafeClient c, MonadReader env m, HasLogFunc env, MonadUnliftIO m)
|
||||
-- => BusName
|
||||
-- -> c
|
||||
-- -> m ()
|
||||
-- releaseBusName n cl = do
|
||||
-- -- TODO this might error?
|
||||
-- liftIO $ void $ releaseName (toClient cl) n
|
||||
-- logInfo $ "released bus name: " <> displayBusName n
|
||||
|
||||
-- requestBusName
|
||||
-- :: (SafeClient c, MonadReader env m, HasLogFunc env, MonadUnliftIO m)
|
||||
-- => BusName
|
||||
-- -> c
|
||||
-- -> m ()
|
||||
-- requestBusName n cl = do
|
||||
-- res <- try $ liftIO $ requestName (toClient cl) n []
|
||||
-- case res of
|
||||
-- Left e -> logError $ displayBytesUtf8 $ BC.pack $ clientErrorMessage e
|
||||
-- Right r -> do
|
||||
-- let msg
|
||||
-- | r == NamePrimaryOwner = "registering name"
|
||||
-- | r == NameAlreadyOwner = "this process already owns name"
|
||||
-- | r == NameInQueue
|
||||
-- || r == NameExists =
|
||||
-- "another process owns name"
|
||||
-- -- this should never happen
|
||||
-- | otherwise = "unknown error when requesting name"
|
||||
-- logInfo $ msg <> ": " <> displayBusName n
|
||||
|
||||
-- requestXMonadName
|
||||
-- :: (SafeClient c, MonadReader env m, HasLogFunc env, MonadUnliftIO m)
|
||||
-- => c
|
||||
-- -> m ()
|
||||
-- requestXMonadName cl = do
|
||||
-- res <- liftIO $ requestName (toClient cl) xmonadBusName []
|
||||
-- let msg
|
||||
-- | res == NamePrimaryOwner = "registering name"
|
||||
-- | res == NameAlreadyOwner = "this process already owns name"
|
||||
-- | res == NameInQueue
|
||||
-- || res == NameExists =
|
||||
-- "another process owns name"
|
||||
-- | otherwise = "unknown error when requesting name"
|
||||
-- logInfo $ msg <> ": " <> displayBusName xmonadBusName
|
||||
requestXMonadName
|
||||
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
|
||||
=> SesClient
|
||||
-> m ()
|
||||
requestXMonadName ses = do
|
||||
res <- liftIO $ requestName (toClient ses) 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 <> ": " <> xn
|
||||
where
|
||||
xn =
|
||||
Utf8Builder $
|
||||
encodeUtf8Builder $
|
||||
T.pack $
|
||||
formatBusName xmonadBusName
|
||||
|
|
|
@ -1,3 +1,6 @@
|
|||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Module for monitoring removable drive events
|
||||
--
|
||||
|
@ -80,10 +83,11 @@ playSoundMaybe p b = when b $ io $ playSound p
|
|||
-- enable the udisks2 service at boot; however this is not default behavior.
|
||||
listenDevices
|
||||
:: ( HasClient (DBusEnv env)
|
||||
, HasLogFunc (DBusEnv env SysClient)
|
||||
, MonadReader env m
|
||||
, MonadUnliftIO m
|
||||
)
|
||||
=> NamedSysConnection
|
||||
=> SysClient
|
||||
-> m ()
|
||||
listenDevices cl = do
|
||||
addMatch' memAdded driveInsertedSound addedHasDrive
|
||||
|
@ -95,10 +99,11 @@ listenDevices cl = do
|
|||
|
||||
runRemovableMon
|
||||
:: ( HasClient (DBusEnv env)
|
||||
, HasLogFunc (DBusEnv env SysClient)
|
||||
, MonadReader env m
|
||||
, MonadUnliftIO m
|
||||
)
|
||||
=> Maybe NamedSysConnection
|
||||
=> Maybe SysClient
|
||||
-> Sometimes (m ())
|
||||
runRemovableMon cl =
|
||||
sometimesDBus cl "removeable device monitor" "dbus monitor" deps listenDevices
|
||||
|
|
|
@ -1,3 +1,6 @@
|
|||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- DBus module for X11 screensave/DPMS control
|
||||
|
||||
|
@ -93,7 +96,7 @@ bodyGetCurrentState _ = Nothing
|
|||
|
||||
exportScreensaver
|
||||
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
|
||||
=> Maybe NamedSesConnection
|
||||
=> Maybe SesClient
|
||||
-> Sometimes (m (), m ())
|
||||
exportScreensaver ses =
|
||||
sometimesDBus ses "screensaver toggle" "xset" (toAnd_ bus ssx) cmd
|
||||
|
@ -119,19 +122,19 @@ exportScreensaver ses =
|
|||
}
|
||||
]
|
||||
}
|
||||
bus = Bus [] xmonadSesBusName
|
||||
bus = Bus [] xmonadBusName
|
||||
ssx = DBusIO $ sysExe [Package Official "xorg-xset"] ssExecutable
|
||||
|
||||
callToggle
|
||||
:: (HasClient (DBusEnv env), MonadReader env m, MonadUnliftIO m)
|
||||
=> Maybe NamedSesConnection
|
||||
=> Maybe SesClient
|
||||
-> Sometimes (m ())
|
||||
callToggle =
|
||||
sometimesEndpoint
|
||||
"screensaver toggle"
|
||||
"dbus switch"
|
||||
[]
|
||||
xmonadSesBusName
|
||||
xmonadBusName
|
||||
ssPath
|
||||
interface
|
||||
memToggle
|
||||
|
@ -140,11 +143,12 @@ callQuery
|
|||
:: (HasClient env, MonadReader (env SesClient) m, MonadUnliftIO m)
|
||||
=> m (Maybe SSState)
|
||||
callQuery = do
|
||||
reply <- callMethod xmonadSesBusName ssPath interface memQuery
|
||||
reply <- callMethod xmonadBusName ssPath interface memQuery
|
||||
return $ either (const Nothing) bodyGetCurrentState reply
|
||||
|
||||
matchSignal
|
||||
:: ( HasClient env
|
||||
:: ( HasLogFunc (env SesClient)
|
||||
, HasClient env
|
||||
, MonadReader (env SesClient) m
|
||||
, MonadUnliftIO m
|
||||
)
|
||||
|
@ -157,4 +161,4 @@ matchSignal cb =
|
|||
(cb . bodyGetCurrentState)
|
||||
|
||||
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
|
||||
--
|
||||
|
@ -39,7 +41,7 @@ import System.Process
|
|||
-- read
|
||||
|
||||
readInt :: MonadIO m => (Read a, Integral a) => FilePath -> m a
|
||||
readInt = fmap (fromMaybe 0 . readMaybe . takeWhile isDigit . T.unpack) . readFileUtf8
|
||||
readInt = fmap (read . takeWhile isDigit . T.unpack) . readFileUtf8
|
||||
|
||||
readBool :: MonadIO m => FilePath -> m Bool
|
||||
readBool = fmap (== (1 :: Int)) . readInt
|
||||
|
@ -47,7 +49,7 @@ readBool = fmap (== (1 :: Int)) . readInt
|
|||
--------------------------------------------------------------------------------
|
||||
-- write
|
||||
|
||||
writeInt :: (MonadIO m, Show a) => FilePath -> a -> m ()
|
||||
writeInt :: MonadIO m => (Show a, Integral a) => FilePath -> a -> m ()
|
||||
writeInt f = writeFileUtf8 f . T.pack . show
|
||||
|
||||
writeBool :: MonadIO m => FilePath -> Bool -> m ()
|
||||
|
@ -60,7 +62,7 @@ writeBool f b = writeInt f ((if b then 1 else 0) :: Int)
|
|||
-- value. Assume that the file being read has a min of 0 and an unchanging max
|
||||
-- given by a runtime argument, which is scaled linearly to the range 0-100
|
||||
-- (percent).
|
||||
rawToPercent :: (Integral a, Integral b, RealFrac c) => (a, a) -> b -> c
|
||||
rawToPercent :: (Integral a, Integral b, Read b, RealFrac c) => (a, a) -> b -> c
|
||||
rawToPercent (lower, upper) raw =
|
||||
100 * (fromIntegral raw - fromIntegral lower) / fromIntegral (upper - lower)
|
||||
|
||||
|
|
|
@ -1,3 +1,5 @@
|
|||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Functions for formatting and sending notifications
|
||||
--
|
||||
|
|
|
@ -1,3 +1,5 @@
|
|||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
-- Functions for formatting and spawning shell commands
|
||||
|
||||
module XMonad.Internal.Shell
|
||||
|
@ -83,7 +85,10 @@ spawn :: MonadIO m => T.Text -> m ()
|
|||
spawn = X.spawn . T.unpack
|
||||
|
||||
-- | Run 'XMonad.Run.Utils.spawnPipe' with 'Text' input.
|
||||
spawnPipe :: MonadUnliftIO m => T.Text -> m Handle
|
||||
spawnPipe
|
||||
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
|
||||
=> T.Text
|
||||
-> m Handle
|
||||
spawnPipe = liftIO . XR.spawnPipe . T.unpack
|
||||
|
||||
-- spawnPipeRW
|
||||
|
|
|
@ -1,3 +1,5 @@
|
|||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Theme for XMonad and Xmobar
|
||||
|
||||
|
@ -31,7 +33,6 @@ where
|
|||
|
||||
import Data.Colour
|
||||
import Data.Colour.SRGB
|
||||
import RIO
|
||||
import qualified RIO.Text as T
|
||||
import qualified XMonad.Layout.Decoration as D
|
||||
import qualified XMonad.Prompt as P
|
||||
|
|
|
@ -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
|
||||
--
|
||||
-- Use the custom DBus interface exported by the XMonad process so I can react
|
||||
-- to signals spawned by commands
|
||||
module Xmobar.Plugins.BacklightCommon (startBacklight) where
|
||||
|
||||
import DBus
|
||||
import Data.Internal.DBus
|
||||
import RIO
|
||||
import qualified RIO.Text as T
|
||||
|
@ -12,15 +13,14 @@ import Xmobar.Plugins.Common
|
|||
|
||||
startBacklight
|
||||
:: (MonadUnliftIO m, RealFrac a)
|
||||
=> Maybe BusName
|
||||
-> Maybe FilePath
|
||||
=> Maybe FilePath
|
||||
-> ((Maybe a -> DIO SimpleApp SesClient ()) -> DIO SimpleApp SesClient ())
|
||||
-> DIO SimpleApp SesClient (Maybe a)
|
||||
-> T.Text
|
||||
-> Callback
|
||||
-> m ()
|
||||
startBacklight n name matchSignal callGetBrightness icon cb = do
|
||||
withDBusClientConnection cb n name $ \c -> withDIO c $ do
|
||||
startBacklight name matchSignal callGetBrightness icon cb = do
|
||||
withDBusClientConnection cb name $ \c -> withDIO c $ do
|
||||
matchSignal dpy
|
||||
dpy =<< callGetBrightness
|
||||
where
|
||||
|
|
|
@ -1,3 +1,5 @@
|
|||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Bluetooth plugin
|
||||
--
|
||||
|
@ -7,18 +9,28 @@
|
|||
-- Manager. The adapter is located at path "/org/bluez/hci<X>" where X is
|
||||
-- usually 0, and each device is "/org/bluez/hci<X>/<MAC_ADDRESS>".
|
||||
--
|
||||
-- Simple and somewhat crude way to do this is to have two monitors, one
|
||||
-- watching the powered state of the adaptor and one listening for connection
|
||||
-- changes. The former is easy since this is just one /org/bluez/hciX. For the
|
||||
-- latter, each 'Connected' property is embedded in each individual device path
|
||||
-- on `org.bluez.Device1', so just watch the entire bluez bus for property
|
||||
-- changes and filter those that correspond to the aforementioned
|
||||
-- interface/property. Track all this in a state which keeps the powered
|
||||
-- property and a running list of connected devices.
|
||||
-- This plugin will reflect if the adapter is powered and if any device is
|
||||
-- connected to it. The rough outline for this procedure:
|
||||
-- 1) get the adapter from the object manager
|
||||
-- 2) get all devices associated with the adapter using the object interface
|
||||
-- 3) determine if the adapter is powered
|
||||
-- 4) determine if any devices are connected
|
||||
-- 5) format the icon; powered vs not powered controls the color and connected
|
||||
-- vs not connected controls the icon (connected bluetooth symbol has two
|
||||
-- dots flanking it)
|
||||
--
|
||||
-- Step 3 can be accomplished using the "org.bluez.Adapter1" interface and
|
||||
-- querying the "Powered" property. Step 4 can be done using the
|
||||
-- "org.bluez.Device1" interface and the "Connected" property for each device
|
||||
-- path. Since these are properties, we can asynchronously read changes to them
|
||||
-- via the "PropertiesChanged" signal.
|
||||
--
|
||||
-- If any devices are added/removed, steps 2-4 will need to be redone and any
|
||||
-- listeners will need to be updated. (TODO not sure which signals to use in
|
||||
-- determining if a device is added)
|
||||
--
|
||||
-- TODO also not sure if I need to care about multiple adapters and/or the
|
||||
-- adapter changing. For now it should just get the first adaptor and only pay
|
||||
-- attention to devices associated with it.
|
||||
-- adapter changing.
|
||||
|
||||
module Xmobar.Plugins.Bluetooth
|
||||
( Bluetooth (..)
|
||||
|
@ -35,7 +47,6 @@ import RIO
|
|||
import RIO.FilePath
|
||||
import RIO.List
|
||||
import qualified RIO.Map as M
|
||||
import qualified RIO.Set as S
|
||||
import qualified RIO.Text as T
|
||||
import XMonad.Internal.DBus.Common
|
||||
import Xmobar
|
||||
|
@ -54,28 +65,32 @@ data Bluetooth = Bluetooth Icons Colors deriving (Read, Show)
|
|||
instance Exec Bluetooth where
|
||||
alias (Bluetooth _ _) = T.unpack btAlias
|
||||
start (Bluetooth icons colors) cb =
|
||||
withDBusClientConnection cb Nothing (Just "bluetooth.log") $
|
||||
startAdapter icons colors cb
|
||||
withDBusClientConnection cb (Just "bluetooth.log") $ startAdapter icons colors cb
|
||||
|
||||
startAdapter
|
||||
:: Icons
|
||||
-> Colors
|
||||
-> Callback
|
||||
-> NamedSysConnection
|
||||
-> SysClient
|
||||
-> RIO SimpleApp ()
|
||||
startAdapter is cs cb cl = do
|
||||
state <- newMVar emptyState
|
||||
let dpy cb' = displayIcon cb' (iconFormatter is cs)
|
||||
mapRIO (PluginEnv cl state dpy cb) $ do
|
||||
let dpy = displayIcon cb (iconFormatter is cs)
|
||||
mapRIO (BTEnv cl state dpy) $ do
|
||||
ot <- getBtObjectTree
|
||||
case findAdaptor ot of
|
||||
case findAdapter ot of
|
||||
Nothing -> logError "could not find bluetooth adapter"
|
||||
Just adaptor -> do
|
||||
initAdapterState adaptor
|
||||
initDevicesState adaptor ot
|
||||
startAdaptorListener adaptor
|
||||
startConnectedListener adaptor
|
||||
pluginDisplay
|
||||
Just adapter -> do
|
||||
-- set up adapter
|
||||
initAdapter adapter
|
||||
void $ addAdaptorListener adapter
|
||||
-- set up devices on the adapter (and listeners for adding/removing devices)
|
||||
let devices = findDevices adapter ot
|
||||
addDeviceAddedListener adapter
|
||||
addDeviceRemovedListener adapter
|
||||
forM_ devices $ \d -> addAndInitDevice d
|
||||
-- after setting things up, show the icon based on the initialized state
|
||||
dpy
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Icon Display
|
||||
|
@ -100,18 +115,43 @@ iconFormatter (iconConn, iconDisc) cs powered connected =
|
|||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Connection State
|
||||
--
|
||||
-- The signal handlers all run on separate threads, yet the icon depends on
|
||||
-- the state reflected by all these signals. The best (only?) way to do this is
|
||||
-- is to track the shared state of the bluetooth adaptor and its devices using
|
||||
-- an MVar.
|
||||
|
||||
type BTIO = PluginIO BtState SysClient
|
||||
data BTEnv c = BTEnv
|
||||
{ btClient :: !c
|
||||
, btState :: !(MVar BtState)
|
||||
, btDisplay :: !(BTIO ())
|
||||
, btEnv :: !SimpleApp
|
||||
}
|
||||
|
||||
instance HasClient BTEnv where
|
||||
clientL = lens btClient (\x y -> x {btClient = y})
|
||||
|
||||
instance HasLogFunc (BTEnv a) where
|
||||
logFuncL = lens btEnv (\x y -> x {btEnv = y}) . logFuncL
|
||||
|
||||
type BTIO = RIO (BTEnv SysClient)
|
||||
|
||||
data BTDevice = BTDevice
|
||||
{ btDevConnected :: Maybe Bool
|
||||
, btDevSigHandler :: SignalHandler
|
||||
}
|
||||
|
||||
type ConnectedDevices = M.Map ObjectPath BTDevice
|
||||
|
||||
data BtState = BtState
|
||||
{ btDevices :: S.Set ObjectPath
|
||||
{ btDevices :: ConnectedDevices
|
||||
, btPowered :: Maybe Bool
|
||||
}
|
||||
|
||||
emptyState :: BtState
|
||||
emptyState =
|
||||
BtState
|
||||
{ btDevices = S.empty
|
||||
{ btDevices = M.empty
|
||||
, btPowered = Nothing
|
||||
}
|
||||
|
||||
|
@ -119,33 +159,24 @@ readState :: BTIO (Maybe Bool, Bool)
|
|||
readState = do
|
||||
p <- readPowered
|
||||
c <- readDevices
|
||||
return (p, not $ null c)
|
||||
return (p, anyDevicesConnected c)
|
||||
|
||||
modifyState :: (BtState -> BTIO (BtState, a)) -> BTIO a
|
||||
modifyState f = do
|
||||
m <- asks plugState
|
||||
m <- asks btState
|
||||
modifyMVar m f
|
||||
|
||||
beforeDisplay :: BTIO () -> BTIO ()
|
||||
beforeDisplay f = f >> pluginDisplay
|
||||
beforeDisplay f = f >> join (asks btDisplay)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Object manager
|
||||
|
||||
findAdaptor :: ObjectTree -> Maybe ObjectPath
|
||||
findAdaptor = find (("/org/bluez/hci" `isPrefixOf`) . formatObjectPath) . M.keys
|
||||
findAdapter :: ObjectTree -> Maybe ObjectPath
|
||||
findAdapter = find (("/org/bluez/hci" `isPrefixOf`) . formatObjectPath) . M.keys
|
||||
|
||||
-- | Search the object tree for devices which are in a connected state.
|
||||
-- Return the object path for said devices.
|
||||
findConnectedDevices :: ObjectPath -> ObjectTree -> [ObjectPath]
|
||||
findConnectedDevices adaptor =
|
||||
filter (adaptorHasDevice adaptor) . M.keys . M.filter isConnectedDev
|
||||
where
|
||||
isConnectedDev m = Just True == lookupState m
|
||||
lookupState =
|
||||
fromVariant
|
||||
<=< M.lookup (memberNameT devConnected)
|
||||
<=< M.lookup devInterface
|
||||
findDevices :: ObjectPath -> ObjectTree -> [ObjectPath]
|
||||
findDevices adapter = filter (adaptorHasDevice adapter) . M.keys
|
||||
|
||||
adaptorHasDevice :: ObjectPath -> ObjectPath -> Bool
|
||||
adaptorHasDevice adaptor device = case splitPathNoRoot device of
|
||||
|
@ -168,14 +199,49 @@ getBtObjectTree = callGetManagedObjects btBus btOMPath
|
|||
btOMPath :: ObjectPath
|
||||
btOMPath = objectPath_ "/"
|
||||
|
||||
addBtOMListener
|
||||
:: ( HasClient env
|
||||
, SafeClient c
|
||||
, MonadReader (env c) m
|
||||
, HasLogFunc (env c)
|
||||
, MonadUnliftIO m
|
||||
)
|
||||
=> SignalCallback m
|
||||
-> m ()
|
||||
addBtOMListener sc = void $ addInterfaceAddedListener btBus btOMPath sc
|
||||
|
||||
addDeviceAddedListener :: ObjectPath -> BTIO ()
|
||||
addDeviceAddedListener adapter = addBtOMListener addDevice
|
||||
where
|
||||
addDevice = pathCallback adapter $ \d ->
|
||||
addAndInitDevice d
|
||||
|
||||
addDeviceRemovedListener :: ObjectPath -> BTIO ()
|
||||
addDeviceRemovedListener adapter =
|
||||
addBtOMListener remDevice
|
||||
where
|
||||
remDevice = pathCallback adapter $ \d -> do
|
||||
old <- removeDevice d
|
||||
cl <- asks btClient
|
||||
forM_ old $ liftIO . removeMatch (toClient cl) . btDevSigHandler
|
||||
|
||||
pathCallback :: ObjectPath -> (ObjectPath -> BTIO ()) -> SignalCallback BTIO
|
||||
pathCallback adapter f [device, _] = forM_ (fromVariant device) $ \d -> do
|
||||
when (adaptorHasDevice adapter d) $ beforeDisplay $ f d
|
||||
pathCallback _ _ _ = return ()
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Adapter
|
||||
|
||||
-- | Get powered state of adaptor and log the result
|
||||
initAdapterState :: ObjectPath -> BTIO ()
|
||||
initAdapterState adapter = do
|
||||
initAdapter :: ObjectPath -> BTIO ()
|
||||
initAdapter adapter = do
|
||||
reply <- callGetPowered adapter
|
||||
logInfo $ "initializing adapter at path " <> adapter_
|
||||
-- TODO this could fail if the variant is something weird; the only
|
||||
-- indication I will get is "NA"
|
||||
putPowered $ fromSingletonVariant reply
|
||||
where
|
||||
adapter_ = displayWrapQuote $ displayObjectPath adapter
|
||||
|
||||
matchBTProperty
|
||||
:: ( SafeClient c
|
||||
|
@ -188,23 +254,40 @@ matchBTProperty
|
|||
-> m (Maybe MatchRule)
|
||||
matchBTProperty p = matchPropertyFull btBus (Just p)
|
||||
|
||||
-- | Start a listener that monitors changes to the powered state of an adaptor
|
||||
startAdaptorListener :: ObjectPath -> BTIO ()
|
||||
startAdaptorListener adaptor = do
|
||||
res <- matchBTProperty adaptor
|
||||
withBTPropertyRule
|
||||
:: ( SafeClient c
|
||||
, MonadReader (env c) m
|
||||
, HasLogFunc (env c)
|
||||
, HasClient env
|
||||
, MonadUnliftIO m
|
||||
, IsVariant a
|
||||
)
|
||||
=> ObjectPath
|
||||
-> (Maybe a -> m ())
|
||||
-> InterfaceName
|
||||
-> T.Text
|
||||
-> m (Maybe SignalHandler)
|
||||
withBTPropertyRule path update iface prop = do
|
||||
res <- matchBTProperty path
|
||||
case res of
|
||||
Just rule -> void $ addMatchCallback rule callback
|
||||
Just rule -> Just <$> addMatchCallback rule (signalToUpdate . matchConnected)
|
||||
Nothing -> do
|
||||
logError $
|
||||
"could not add listener for prop "
|
||||
<> displayMemberName adaptorPowered
|
||||
<> prop_
|
||||
<> " on path "
|
||||
<> displayObjectPath adaptor
|
||||
<> path_
|
||||
return Nothing
|
||||
where
|
||||
path_ = displayObjectPath path
|
||||
prop_ = Utf8Builder $ encodeUtf8Builder prop
|
||||
signalToUpdate = withSignalMatch update
|
||||
matchConnected = matchPropertyChanged iface prop
|
||||
|
||||
addAdaptorListener :: ObjectPath -> BTIO (Maybe SignalHandler)
|
||||
addAdaptorListener adaptor =
|
||||
withBTPropertyRule adaptor procMatch adapterInterface adaptorPowered
|
||||
where
|
||||
callback sig =
|
||||
withNestedDBusClientConnection Nothing Nothing $
|
||||
withSignalMatch procMatch $
|
||||
matchPropertyChanged adaptorInterface adaptorPowered sig
|
||||
procMatch = beforeDisplay . putPowered
|
||||
|
||||
callGetPowered
|
||||
|
@ -217,58 +300,88 @@ callGetPowered
|
|||
=> ObjectPath
|
||||
-> m [Variant]
|
||||
callGetPowered adapter =
|
||||
callPropertyGet btBus adapter adaptorInterface adaptorPowered
|
||||
callPropertyGet btBus adapter adapterInterface $
|
||||
memberName_ $
|
||||
T.unpack adaptorPowered
|
||||
|
||||
putPowered :: Maybe Bool -> BTIO ()
|
||||
putPowered ds = modifyState $ \s -> return (s {btPowered = ds}, ())
|
||||
|
||||
readPowered :: BTIO (Maybe Bool)
|
||||
readPowered = fmap btPowered $ readMVar =<< asks plugState
|
||||
readPowered = fmap btPowered $ readMVar =<< asks btState
|
||||
|
||||
adaptorInterface :: InterfaceName
|
||||
adaptorInterface = interfaceName_ "org.bluez.Adapter1"
|
||||
adapterInterface :: InterfaceName
|
||||
adapterInterface = interfaceName_ "org.bluez.Adapter1"
|
||||
|
||||
adaptorPowered :: MemberName
|
||||
adaptorPowered :: T.Text
|
||||
adaptorPowered = "Powered"
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Devices
|
||||
|
||||
initDevicesState :: ObjectPath -> ObjectTree -> BTIO ()
|
||||
initDevicesState adaptor ot = do
|
||||
let devices = findConnectedDevices adaptor ot
|
||||
modifyState $ \s -> return (s {btDevices = S.fromList devices}, ())
|
||||
|
||||
startConnectedListener :: ObjectPath -> BTIO ()
|
||||
startConnectedListener adaptor = do
|
||||
reply <- matchPropertyFull btBus Nothing
|
||||
case reply of
|
||||
Just rule -> do
|
||||
void $ addMatchCallbackSignal rule callback
|
||||
logInfo $ "Started listening for device connections on " <> adaptor_
|
||||
Nothing -> logError "Could not listen for connection changes"
|
||||
addAndInitDevice :: ObjectPath -> BTIO ()
|
||||
addAndInitDevice device = do
|
||||
res <- addDeviceListener device
|
||||
case res of
|
||||
Just handler -> do
|
||||
logInfo $ "initializing device at path " <> device_
|
||||
initDevice handler device
|
||||
Nothing -> logError $ "could not initialize device at path " <> device_
|
||||
where
|
||||
adaptor_ = displayWrapQuote $ displayObjectPath adaptor
|
||||
callback sig =
|
||||
withNestedDBusClientConnection Nothing Nothing $ do
|
||||
let devpath = signalPath sig
|
||||
when (adaptorHasDevice adaptor devpath) $
|
||||
withSignalMatch (update devpath) $
|
||||
matchConnected $
|
||||
signalBody sig
|
||||
matchConnected = matchPropertyChanged devInterface devConnected
|
||||
update _ Nothing = return ()
|
||||
update devpath (Just x) = do
|
||||
let f = if x then S.insert else S.delete
|
||||
beforeDisplay $
|
||||
modifyState $
|
||||
\s -> return (s {btDevices = f devpath $ btDevices s}, ())
|
||||
device_ = displayWrapQuote $ displayObjectPath device
|
||||
|
||||
readDevices :: BTIO (S.Set ObjectPath)
|
||||
readDevices = fmap btDevices $ readMVar =<< asks plugState
|
||||
initDevice :: SignalHandler -> ObjectPath -> BTIO ()
|
||||
initDevice sh device = do
|
||||
reply <- callGetConnected device
|
||||
void $
|
||||
insertDevice device $
|
||||
BTDevice
|
||||
{ btDevConnected = fromVariant =<< listToMaybe reply
|
||||
, btDevSigHandler = sh
|
||||
}
|
||||
|
||||
addDeviceListener :: ObjectPath -> BTIO (Maybe SignalHandler)
|
||||
addDeviceListener device =
|
||||
withBTPropertyRule device procMatch devInterface devConnected
|
||||
where
|
||||
procMatch = beforeDisplay . void . updateDevice device
|
||||
|
||||
callGetConnected
|
||||
:: ( SafeClient c
|
||||
, HasClient env
|
||||
, MonadReader (env c) m
|
||||
, HasLogFunc (env c)
|
||||
, MonadUnliftIO m
|
||||
)
|
||||
=> ObjectPath
|
||||
-> m [Variant]
|
||||
callGetConnected p =
|
||||
callPropertyGet btBus p devInterface $
|
||||
memberName_ (T.unpack devConnected)
|
||||
|
||||
insertDevice :: ObjectPath -> BTDevice -> BTIO Bool
|
||||
insertDevice device dev = modifyState $ \s -> do
|
||||
let new = M.insert device dev $ btDevices s
|
||||
return (s {btDevices = new}, anyDevicesConnected new)
|
||||
|
||||
updateDevice :: ObjectPath -> Maybe Bool -> BTIO Bool
|
||||
updateDevice device status = modifyState $ \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 :: ObjectPath -> BTIO (Maybe BTDevice)
|
||||
removeDevice device = modifyState $ \s -> do
|
||||
let devs = btDevices s
|
||||
return (s {btDevices = M.delete device devs}, M.lookup device devs)
|
||||
|
||||
readDevices :: BTIO ConnectedDevices
|
||||
readDevices = fmap btDevices $ readMVar =<< asks btState
|
||||
|
||||
devInterface :: InterfaceName
|
||||
devInterface = interfaceName_ "org.bluez.Device1"
|
||||
|
||||
devConnected :: MemberName
|
||||
devConnected :: T.Text
|
||||
devConnected = "Connected"
|
||||
|
|
|
@ -1,3 +1,5 @@
|
|||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Clevo Keyboard plugin
|
||||
--
|
||||
|
@ -10,7 +12,6 @@ module Xmobar.Plugins.ClevoKeyboard
|
|||
)
|
||||
where
|
||||
|
||||
import RIO
|
||||
import qualified RIO.Text as T
|
||||
import XMonad.Internal.DBus.Brightness.ClevoKeyboard
|
||||
import Xmobar
|
||||
|
@ -24,9 +25,4 @@ ckAlias = "clevokeyboard"
|
|||
instance Exec ClevoKeyboard where
|
||||
alias (ClevoKeyboard _) = T.unpack ckAlias
|
||||
start (ClevoKeyboard icon) =
|
||||
startBacklight
|
||||
(Just "org.xmobar.clevo")
|
||||
(Just "clevo_kbd.log")
|
||||
matchSignalCK
|
||||
callGetBrightnessCK
|
||||
icon
|
||||
startBacklight (Just "clevo_kbd.log") matchSignalCK callGetBrightnessCK icon
|
||||
|
|
|
@ -1,19 +1,17 @@
|
|||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module Xmobar.Plugins.Common
|
||||
( colorText
|
||||
, startListener
|
||||
, procSignalMatch
|
||||
, na
|
||||
, fromSingletonVariant
|
||||
, withNestedDBusClientConnection
|
||||
, withDBusClientConnection
|
||||
, Callback
|
||||
, Colors (..)
|
||||
, displayMaybe
|
||||
, displayMaybe'
|
||||
, xmobarFGColor
|
||||
, PluginEnv (..)
|
||||
, PluginIO
|
||||
, pluginDisplay
|
||||
)
|
||||
where
|
||||
|
||||
|
@ -25,28 +23,6 @@ import RIO
|
|||
import qualified RIO.Text as T
|
||||
import XMonad.Hooks.DynamicLog (xmobarColor)
|
||||
|
||||
data PluginEnv s c = PluginEnv
|
||||
{ plugClient :: !(NamedConnection c)
|
||||
, plugState :: !(MVar s)
|
||||
, plugDisplay :: !(Callback -> PluginIO s c ())
|
||||
, plugCallback :: !Callback
|
||||
, plugEnv :: !SimpleApp
|
||||
}
|
||||
|
||||
pluginDisplay :: PluginIO s c ()
|
||||
pluginDisplay = do
|
||||
cb <- asks plugCallback
|
||||
dpy <- asks plugDisplay
|
||||
dpy cb
|
||||
|
||||
type PluginIO s c = RIO (PluginEnv s c)
|
||||
|
||||
instance HasClient (PluginEnv s) where
|
||||
clientL = lens plugClient (\x y -> x {plugClient = y})
|
||||
|
||||
instance HasLogFunc (PluginEnv s c) where
|
||||
logFuncL = lens plugEnv (\x y -> x {plugEnv = y}) . logFuncL
|
||||
|
||||
-- use string here since all the callbacks in xmobar use strings :(
|
||||
type Callback = String -> IO ()
|
||||
|
||||
|
@ -57,7 +33,8 @@ data Colors = Colors
|
|||
deriving (Eq, Show, Read)
|
||||
|
||||
startListener
|
||||
:: ( HasClient env
|
||||
:: ( HasLogFunc (env c)
|
||||
, HasClient env
|
||||
, MonadReader (env c) m
|
||||
, MonadUnliftIO m
|
||||
, SafeClient c
|
||||
|
@ -99,42 +76,14 @@ displayMaybe' cb = maybe (liftIO $ cb $ T.unpack na)
|
|||
withDBusClientConnection
|
||||
:: (MonadUnliftIO m, SafeClient c)
|
||||
=> Callback
|
||||
-> Maybe BusName
|
||||
-> Maybe FilePath
|
||||
-> (NamedConnection c -> RIO SimpleApp ())
|
||||
-> (c -> RIO SimpleApp ())
|
||||
-> m ()
|
||||
withDBusClientConnection cb n logfile f =
|
||||
withDBusClientConnection cb logfile f =
|
||||
maybe (run stderr) (`withLogFile` run) logfile
|
||||
where
|
||||
run h = do
|
||||
logOpts <- setLogVerboseFormat True . setLogUseTime True <$> logOptionsHandle h False
|
||||
withLogFunc logOpts $ \lf -> do
|
||||
env <- mkSimpleApp lf Nothing
|
||||
runRIO env $ displayMaybe' cb f =<< getDBusClient n
|
||||
|
||||
-- | Run a plugin action with a new DBus client and logfile path. This is
|
||||
-- necessary for DBus callbacks which run in separate threads, which will
|
||||
-- usually fire when the parent thread already exited and killed off its DBus
|
||||
-- connection and closed its logfile. NOTE: unlike 'withDBusClientConnection'
|
||||
-- this function will open and new logfile and client connection and close both
|
||||
-- on completion. 'withDBusClientConnection' will only close the log file but
|
||||
-- keep the client connection active upon termination; this client will only be
|
||||
-- killed when the entire process is killed. This distinction is important
|
||||
-- because callbacks only need ephemeral connections, while listeners (started
|
||||
-- with 'withDBusClientConnection') need long-lasting connections.
|
||||
withNestedDBusClientConnection
|
||||
:: (MonadUnliftIO m, SafeClient c, MonadReader (PluginEnv s c) m)
|
||||
=> Maybe BusName
|
||||
-> Maybe FilePath
|
||||
-> PluginIO s c ()
|
||||
-> m ()
|
||||
withNestedDBusClientConnection n logfile f = do
|
||||
dpy <- asks plugDisplay
|
||||
s <- asks plugState
|
||||
cb <- asks plugCallback
|
||||
let run h = do
|
||||
logOpts <- setLogVerboseFormat True . setLogUseTime True <$> logOptionsHandle h False
|
||||
withLogFunc logOpts $ \lf -> do
|
||||
env <- mkSimpleApp lf Nothing
|
||||
runRIO env $ withDBusClient_ n $ \cl -> mapRIO (PluginEnv cl s dpy cb) f
|
||||
maybe (run stderr) (`withLogFile` run) logfile
|
||||
runRIO env $ displayMaybe' cb f =<< getDBusClient
|
||||
|
|
|
@ -0,0 +1,89 @@
|
|||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- 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.XIO
|
||||
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
|
||||
:: (SafeClient c, HasClient env, MonadReader (env c) m, MonadUnliftIO m)
|
||||
=> T.Text
|
||||
-> m (Maybe ObjectPath)
|
||||
getDevice iface = bodyToMaybe <$> callMethod' mc
|
||||
where
|
||||
mc =
|
||||
(methodCallBus networkManagerBus nmPath nmInterface getByIP)
|
||||
{ methodCallBody = [toVariant iface]
|
||||
}
|
||||
|
||||
getDeviceConnected
|
||||
:: ( SafeClient c
|
||||
, HasClient env
|
||||
, MonadReader (env c) m
|
||||
, HasLogFunc (env c)
|
||||
, MonadUnliftIO m
|
||||
)
|
||||
=> ObjectPath
|
||||
-> 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 =
|
||||
withDBusClientConnection cb logName $ \(sys :: SysClient) -> withDIO sys $ do
|
||||
path <- getDevice iface
|
||||
displayMaybe' cb listener path
|
||||
where
|
||||
logName = Just $ T.unpack $ T.concat ["device@", iface, ".log"]
|
||||
listener path = do
|
||||
res <- matchPropertyFull networkManagerBus (Just path)
|
||||
case res of
|
||||
Just rule -> startListener rule (getDeviceConnected path) matchStatus chooseColor' cb
|
||||
Nothing -> logError "could not start listener"
|
||||
chooseColor' = return . (\s -> colorText colors s text) . (> 1)
|
|
@ -1,3 +1,5 @@
|
|||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Intel backlight plugin
|
||||
--
|
||||
|
@ -10,7 +12,6 @@ module Xmobar.Plugins.IntelBacklight
|
|||
)
|
||||
where
|
||||
|
||||
import RIO
|
||||
import qualified RIO.Text as T
|
||||
import XMonad.Internal.DBus.Brightness.IntelBacklight
|
||||
import Xmobar
|
||||
|
@ -24,9 +25,4 @@ blAlias = "intelbacklight"
|
|||
instance Exec IntelBacklight where
|
||||
alias (IntelBacklight _) = T.unpack blAlias
|
||||
start (IntelBacklight icon) =
|
||||
startBacklight
|
||||
(Just "org.xmobar.intelbacklight")
|
||||
(Just "intel_backlight.log")
|
||||
matchSignalIB
|
||||
callGetBrightnessIB
|
||||
icon
|
||||
startBacklight (Just "intel_backlight.log") matchSignalIB callGetBrightnessIB icon
|
||||
|
|
|
@ -1,3 +1,5 @@
|
|||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Screensaver plugin
|
||||
--
|
||||
|
@ -11,7 +13,6 @@ module Xmobar.Plugins.Screensaver
|
|||
where
|
||||
|
||||
import Data.Internal.DBus
|
||||
import RIO
|
||||
import qualified RIO.Text as T
|
||||
import XMonad.Internal.DBus.Screensaver
|
||||
import Xmobar
|
||||
|
@ -25,11 +26,7 @@ ssAlias = "screensaver"
|
|||
instance Exec Screensaver where
|
||||
alias (Screensaver _) = T.unpack ssAlias
|
||||
start (Screensaver (text, colors)) cb =
|
||||
withDBusClientConnection
|
||||
cb
|
||||
(Just "org.xmobar.screensaver")
|
||||
(Just "screensaver.log")
|
||||
$ \cl -> withDIO cl $ do
|
||||
withDBusClientConnection cb (Just "screensaver.log") $ \cl -> withDIO cl $ do
|
||||
matchSignal dpy
|
||||
dpy =<< callQuery
|
||||
where
|
||||
|
|
|
@ -0,0 +1,173 @@
|
|||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# 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.XIO
|
||||
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 (Just "vpn.log") $ \c -> do
|
||||
let dpy = displayMaybe cb iconFormatter . Just =<< readState
|
||||
s <- newEmptyMVar
|
||||
mapRIO (VEnv c s dpy) $ do
|
||||
initState
|
||||
vpnAddedListener addedCallback
|
||||
vpnRemovedListener removedCallback
|
||||
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.
|
||||
|
||||
data VEnv c = VEnv
|
||||
{ vClient :: !c
|
||||
, vState :: !(MVar VPNState)
|
||||
, vDisplay :: !(VIO ())
|
||||
, vEnv :: !SimpleApp
|
||||
}
|
||||
|
||||
instance SafeClient c => HasLogFunc (VEnv c) where
|
||||
logFuncL = lens vEnv (\x y -> x {vEnv = y}) . logFuncL
|
||||
|
||||
instance HasClient VEnv where
|
||||
clientL = lens vClient (\x y -> x {vClient = y})
|
||||
|
||||
type VIO = RIO (VEnv SysClient)
|
||||
|
||||
type VPNState = S.Set ObjectPath
|
||||
|
||||
initState :: VIO ()
|
||||
initState = do
|
||||
ot <- getVPNObjectTree
|
||||
s <- asks vState
|
||||
putMVar s $ findTunnels ot
|
||||
|
||||
readState :: VIO Bool
|
||||
readState = fmap (not . null) . readMVar =<< asks vState
|
||||
|
||||
updateState :: (ObjectPath -> VPNState -> VPNState) -> ObjectPath -> VIO ()
|
||||
updateState f op = do
|
||||
s <- asks vState
|
||||
modifyMVar_ s $ return . f op
|
||||
|
||||
beforeDisplay :: VIO () -> VIO ()
|
||||
beforeDisplay f = f >> join (asks vDisplay)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Tunnel Device Detection
|
||||
|
||||
getVPNObjectTree
|
||||
:: ( SafeClient c
|
||||
, HasClient env
|
||||
, MonadReader (env c) m
|
||||
, HasLogFunc (env c)
|
||||
, MonadUnliftIO m
|
||||
)
|
||||
=> m ObjectTree
|
||||
getVPNObjectTree = callGetManagedObjects vpnBus vpnPath
|
||||
|
||||
findTunnels :: ObjectTree -> VPNState
|
||||
findTunnels = S.fromList . M.keys . M.filter (elem vpnDeviceTun . M.keys)
|
||||
|
||||
vpnAddedListener
|
||||
:: ( SafeClient c
|
||||
, HasClient env
|
||||
, MonadReader (env c) m
|
||||
, HasLogFunc (env c)
|
||||
, MonadUnliftIO m
|
||||
)
|
||||
=> SignalCallback m
|
||||
-> m ()
|
||||
vpnAddedListener cb = void $ addInterfaceAddedListener vpnBus vpnPath cb
|
||||
|
||||
vpnRemovedListener
|
||||
:: ( SafeClient c
|
||||
, HasClient env
|
||||
, MonadReader (env c) m
|
||||
, HasLogFunc (env c)
|
||||
, MonadUnliftIO m
|
||||
)
|
||||
=> SignalCallback m
|
||||
-> m ()
|
||||
vpnRemovedListener cb = void $ addInterfaceRemovedListener vpnBus vpnPath cb
|
||||
|
||||
addedCallback :: SignalCallback VIO
|
||||
addedCallback [device, added] =
|
||||
beforeDisplay $
|
||||
updateDevice S.insert device $
|
||||
M.keys $
|
||||
fromMaybe M.empty added'
|
||||
where
|
||||
added' = fromVariant added :: Maybe (M.Map T.Text (M.Map T.Text Variant))
|
||||
addedCallback _ = return ()
|
||||
|
||||
removedCallback :: SignalCallback VIO
|
||||
removedCallback [device, interfaces] =
|
||||
beforeDisplay $
|
||||
updateDevice S.delete device $
|
||||
fromMaybe [] $
|
||||
fromVariant interfaces
|
||||
removedCallback _ = return ()
|
||||
|
||||
updateDevice
|
||||
:: (ObjectPath -> VPNState -> VPNState)
|
||||
-> Variant
|
||||
-> [T.Text]
|
||||
-> VIO ()
|
||||
updateDevice f device interfaces =
|
||||
when (vpnDeviceTun `elem` interfaces) $
|
||||
forM_ d $
|
||||
updateState f
|
||||
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
|
68
package.yaml
68
package.yaml
|
@ -9,47 +9,9 @@ extra-source-files:
|
|||
- README.md
|
||||
- fourmolu.yaml
|
||||
- make_pkgs
|
||||
- runtime_pkgs
|
||||
- assets/icons/*
|
||||
- assets/sound/*
|
||||
- icons/*
|
||||
- scripts/*
|
||||
|
||||
default-extensions:
|
||||
- OverloadedStrings
|
||||
- FlexibleContexts
|
||||
- FlexibleInstances
|
||||
- InstanceSigs
|
||||
- MultiParamTypeClasses
|
||||
- EmptyCase
|
||||
- LambdaCase
|
||||
- MultiWayIf
|
||||
- NamedFieldPuns
|
||||
- TupleSections
|
||||
- DeriveFoldable
|
||||
- DeriveFunctor
|
||||
- DeriveGeneric
|
||||
- DeriveLift
|
||||
- DeriveTraversable
|
||||
- DerivingStrategies
|
||||
- DeriveDataTypeable
|
||||
- EmptyDataDecls
|
||||
- PartialTypeSignatures
|
||||
- GeneralizedNewtypeDeriving
|
||||
- StandaloneDeriving
|
||||
- BangPatterns
|
||||
- TypeOperators
|
||||
- ScopedTypeVariables
|
||||
- TypeApplications
|
||||
- ConstraintKinds
|
||||
- RankNTypes
|
||||
- GADTs
|
||||
- DefaultSignatures
|
||||
- NoImplicitPrelude
|
||||
- FunctionalDependencies
|
||||
- DataKinds
|
||||
- TypeFamilies
|
||||
- BinaryLiterals
|
||||
- ViewPatterns
|
||||
- sound/*
|
||||
|
||||
dependencies:
|
||||
- rio >= 0.1.21.0
|
||||
|
@ -75,19 +37,13 @@ dependencies:
|
|||
- unliftio >= 0.2.21.0
|
||||
- optparse-applicative >= 0.16.1.0
|
||||
|
||||
ghc-options:
|
||||
- -Wall
|
||||
- -Wcompat
|
||||
- -Widentities
|
||||
- -Wincomplete-record-updates
|
||||
- -Wincomplete-uni-patterns
|
||||
- -Wredundant-constraints
|
||||
- -Wpartial-fields
|
||||
- -Werror
|
||||
- -O2
|
||||
|
||||
library:
|
||||
source-dirs: lib/
|
||||
ghc-options:
|
||||
- -Wall
|
||||
- -Werror
|
||||
- -Wpartial-fields
|
||||
- -O2
|
||||
|
||||
executables:
|
||||
xmobar: &bin
|
||||
|
@ -97,15 +53,21 @@ executables:
|
|||
- xmonad-config
|
||||
ghc-options:
|
||||
- -threaded
|
||||
- -Wall
|
||||
- -Werror
|
||||
- -Wpartial-fields
|
||||
- -O2
|
||||
xmonad:
|
||||
<<: *bin
|
||||
main: xmonad.hs
|
||||
ghc-options:
|
||||
- -threaded
|
||||
- -Wall
|
||||
- -Werror
|
||||
- -Wpartial-fields
|
||||
- -O2
|
||||
# this is needed to avoid writing super complex layout types
|
||||
- -fno-warn-missing-signatures
|
||||
vbox-start:
|
||||
<<: *bin
|
||||
main: vbox-start.hs
|
||||
ghc-options:
|
||||
- -threaded
|
||||
|
|
|
@ -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: https://example.com/snapshots/2018-01-01.yaml
|
||||
resolver: lts-19.33
|
||||
#resolver: nightly-2022-03-03
|
||||
#resolver: lts-17.4
|
||||
resolver: nightly-2022-03-03
|
||||
|
||||
# User packages to be built.
|
||||
# Various formats can be used as shown in the example below.
|
||||
|
|
Loading…
Reference in New Issue