Compare commits

..

No commits in common. "master" and "fix_rio_run" have entirely different histories.

49 changed files with 941 additions and 993 deletions

View File

@ -1,3 +1,6 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
-- | Start a VirtualBox instance with a sentinel wrapper process.
--
-- The only reason why this is needed is because I want to manage virtualboxes

View File

@ -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
--

View File

@ -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

View File

@ -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

View File

@ -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

View File

@ -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

View File

@ -1,3 +1,5 @@
{-# LANGUAGE OverloadedStrings #-}
--------------------------------------------------------------------------------
-- General commands
@ -19,8 +21,7 @@ module XMonad.Internal.Command.Desktop
, runVolumeUp
, runVolumeMute
, runToggleBluetooth
, runToggleNetworking
, runToggleWifi
, runToggleEthernet
, runRestart
, runRecompile
, runAreaCapture
@ -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 ())

View File

@ -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

View File

@ -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

View File

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

View File

@ -1,3 +1,5 @@
{-# LANGUAGE OverloadedStrings #-}
--------------------------------------------------------------------------------
-- Automatically Manage Dynamic Workspaces
-- This is a somewhat convoluted wrapper for the Dymamic Workspaces module

View File

@ -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) ->

View File

@ -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

View File

@ -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)

View File

@ -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

View File

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

View File

@ -1,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

View File

@ -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

View File

@ -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

View File

@ -1,3 +1,5 @@
{-# LANGUAGE ViewPatterns #-}
--------------------------------------------------------------------------------
-- Random IO-ish functions used throughtout xmonad
--
@ -39,7 +41,7 @@ import System.Process
-- read
readInt :: MonadIO m => (Read a, Integral a) => FilePath -> m a
readInt = fmap (fromMaybe 0 . readMaybe . takeWhile isDigit . T.unpack) . readFileUtf8
readInt = fmap (read . takeWhile isDigit . T.unpack) . readFileUtf8
readBool :: MonadIO m => FilePath -> m Bool
readBool = fmap (== (1 :: Int)) . readInt
@ -47,7 +49,7 @@ readBool = fmap (== (1 :: Int)) . readInt
--------------------------------------------------------------------------------
-- write
writeInt :: (MonadIO m, Show a) => FilePath -> a -> m ()
writeInt :: MonadIO m => (Show a, Integral a) => FilePath -> a -> m ()
writeInt f = writeFileUtf8 f . T.pack . show
writeBool :: MonadIO m => FilePath -> Bool -> m ()
@ -60,7 +62,7 @@ writeBool f b = writeInt f ((if b then 1 else 0) :: Int)
-- value. Assume that the file being read has a min of 0 and an unchanging max
-- given by a runtime argument, which is scaled linearly to the range 0-100
-- (percent).
rawToPercent :: (Integral a, Integral b, RealFrac c) => (a, a) -> b -> c
rawToPercent :: (Integral a, Integral b, Read b, RealFrac c) => (a, a) -> b -> c
rawToPercent (lower, upper) raw =
100 * (fromIntegral raw - fromIntegral lower) / fromIntegral (upper - lower)

View File

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

View File

@ -1,3 +1,5 @@
{-# LANGUAGE OverloadedStrings #-}
-- Functions for formatting and spawning shell commands
module XMonad.Internal.Shell
@ -83,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

View File

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

View File

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

View File

@ -1,10 +1,11 @@
{-# LANGUAGE OverloadedStrings #-}
-- Common backlight plugin bits
--
-- Use the custom DBus interface exported by the XMonad process so I can react
-- to signals spawned by commands
module Xmobar.Plugins.BacklightCommon (startBacklight) where
import DBus
import Data.Internal.DBus
import RIO
import qualified RIO.Text as T
@ -12,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

View File

@ -1,3 +1,5 @@
{-# LANGUAGE OverloadedStrings #-}
--------------------------------------------------------------------------------
-- Bluetooth plugin
--
@ -7,18 +9,28 @@
-- Manager. The adapter is located at path "/org/bluez/hci<X>" where X is
-- usually 0, and each device is "/org/bluez/hci<X>/<MAC_ADDRESS>".
--
-- Simple and somewhat crude way to do this is to have two monitors, one
-- watching the powered state of the adaptor and one listening for connection
-- changes. The former is easy since this is just one /org/bluez/hciX. For the
-- latter, each 'Connected' property is embedded in each individual device path
-- on `org.bluez.Device1', so just watch the entire bluez bus for property
-- changes and filter those that correspond to the aforementioned
-- interface/property. Track all this in a state which keeps the powered
-- property and a running list of connected devices.
-- This plugin will reflect if the adapter is powered and if any device is
-- connected to it. The rough outline for this procedure:
-- 1) get the adapter from the object manager
-- 2) get all devices associated with the adapter using the object interface
-- 3) determine if the adapter is powered
-- 4) determine if any devices are connected
-- 5) format the icon; powered vs not powered controls the color and connected
-- vs not connected controls the icon (connected bluetooth symbol has two
-- dots flanking it)
--
-- Step 3 can be accomplished using the "org.bluez.Adapter1" interface and
-- querying the "Powered" property. Step 4 can be done using the
-- "org.bluez.Device1" interface and the "Connected" property for each device
-- path. Since these are properties, we can asynchronously read changes to them
-- via the "PropertiesChanged" signal.
--
-- If any devices are added/removed, steps 2-4 will need to be redone and any
-- listeners will need to be updated. (TODO not sure which signals to use in
-- determining if a device is added)
--
-- TODO also not sure if I need to care about multiple adapters and/or the
-- adapter changing. For now it should just get the first adaptor and only pay
-- attention to devices associated with it.
-- adapter changing.
module Xmobar.Plugins.Bluetooth
( Bluetooth (..)
@ -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"

View File

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

View File

@ -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

View File

@ -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)

View File

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

View File

@ -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

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

@ -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

View File

@ -9,47 +9,9 @@ extra-source-files:
- README.md
- fourmolu.yaml
- make_pkgs
- runtime_pkgs
- assets/icons/*
- assets/sound/*
- icons/*
- scripts/*
default-extensions:
- OverloadedStrings
- FlexibleContexts
- FlexibleInstances
- InstanceSigs
- MultiParamTypeClasses
- EmptyCase
- LambdaCase
- MultiWayIf
- NamedFieldPuns
- TupleSections
- DeriveFoldable
- DeriveFunctor
- DeriveGeneric
- DeriveLift
- DeriveTraversable
- DerivingStrategies
- DeriveDataTypeable
- EmptyDataDecls
- PartialTypeSignatures
- GeneralizedNewtypeDeriving
- StandaloneDeriving
- BangPatterns
- TypeOperators
- ScopedTypeVariables
- TypeApplications
- ConstraintKinds
- RankNTypes
- GADTs
- DefaultSignatures
- NoImplicitPrelude
- FunctionalDependencies
- DataKinds
- TypeFamilies
- BinaryLiterals
- ViewPatterns
- sound/*
dependencies:
- rio >= 0.1.21.0
@ -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

View File

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

View File

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

View File

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