ENH use names for dbus connections
This commit is contained in:
parent
171fa489ca
commit
cc5670f2f1
|
@ -63,7 +63,7 @@ parseTest =
|
||||||
xio :: XOpts -> IO ()
|
xio :: XOpts -> IO ()
|
||||||
xio o = case o of
|
xio o = case o of
|
||||||
XDeps -> hRunXIO False stderr printDeps
|
XDeps -> hRunXIO False stderr printDeps
|
||||||
XTest -> hRunXIO False stderr $ withDBus_ evalConfig
|
XTest -> hRunXIO False stderr $ withDBus_ Nothing Nothing evalConfig
|
||||||
XRun -> runXIO "xmobar.log" run
|
XRun -> runXIO "xmobar.log" run
|
||||||
|
|
||||||
run :: XIO ()
|
run :: XIO ()
|
||||||
|
@ -75,8 +75,8 @@ run = do
|
||||||
-- linebuffering it usually only prints the first few characters (even then
|
-- linebuffering it usually only prints the first few characters (even then
|
||||||
-- it only prints 10-20% of the time)
|
-- it only prints 10-20% of the time)
|
||||||
liftIO $ hSetBuffering stderr LineBuffering
|
liftIO $ hSetBuffering stderr LineBuffering
|
||||||
withDBus_ $ \db -> do
|
-- TODO do these dbus things really need to remain connected?
|
||||||
c <- evalConfig db
|
c <- withDBus Nothing Nothing evalConfig
|
||||||
liftIO $ xmobar c
|
liftIO $ xmobar c
|
||||||
|
|
||||||
evalConfig :: DBusState -> XIO Config
|
evalConfig :: DBusState -> XIO Config
|
||||||
|
@ -88,7 +88,7 @@ evalConfig db = do
|
||||||
return $ config bf ifs ios cs d
|
return $ config bf ifs ios cs d
|
||||||
|
|
||||||
printDeps :: XIO ()
|
printDeps :: XIO ()
|
||||||
printDeps = withDBus_ $ \db ->
|
printDeps = withDBus_ Nothing Nothing $ \db ->
|
||||||
mapM_ logInfo $
|
mapM_ logInfo $
|
||||||
fmap showFulfillment $
|
fmap showFulfillment $
|
||||||
sort $
|
sort $
|
||||||
|
@ -218,7 +218,7 @@ getWireless =
|
||||||
xpfWireless
|
xpfWireless
|
||||||
[Subfeature (IORoot wirelessCmd $ Only readWireless) "sysfs path"]
|
[Subfeature (IORoot wirelessCmd $ Only readWireless) "sysfs path"]
|
||||||
|
|
||||||
getEthernet :: Maybe SysClient -> BarFeature
|
getEthernet :: Maybe NamedSysConnection -> BarFeature
|
||||||
getEthernet cl = iconDBus_ "ethernet status indicator" xpfEthernet root (Only_ devDep)
|
getEthernet cl = iconDBus_ "ethernet status indicator" xpfEthernet root (Only_ devDep)
|
||||||
where
|
where
|
||||||
root useIcon tree' =
|
root useIcon tree' =
|
||||||
|
@ -234,12 +234,12 @@ getBattery = iconIO_ "battery level indicator" xpfBattery root tree
|
||||||
io $
|
io $
|
||||||
fmap (Msg LevelError) <$> hasBattery
|
fmap (Msg LevelError) <$> hasBattery
|
||||||
|
|
||||||
getVPN :: Maybe SysClient -> BarFeature
|
getVPN :: Maybe NamedSysConnection -> BarFeature
|
||||||
getVPN cl = iconDBus_ "VPN status indicator" xpfVPN root (Only_ devDep)
|
getVPN cl = iconDBus_ "VPN status indicator" xpfVPN root (Only_ devDep)
|
||||||
where
|
where
|
||||||
root useIcon tree = DBusRoot_ (const $ vpnCmd useIcon) tree cl
|
root useIcon tree = DBusRoot_ (const $ vpnCmd useIcon) tree cl
|
||||||
|
|
||||||
getBt :: Maybe SysClient -> BarFeature
|
getBt :: Maybe NamedSysConnection -> BarFeature
|
||||||
getBt = xmobarDBus "bluetooth status indicator" xpfBluetooth btDep btCmd
|
getBt = xmobarDBus "bluetooth status indicator" xpfBluetooth btDep btCmd
|
||||||
|
|
||||||
getAlsa :: BarFeature
|
getAlsa :: BarFeature
|
||||||
|
@ -250,7 +250,7 @@ getAlsa =
|
||||||
where
|
where
|
||||||
root useIcon = IORoot_ (alsaCmd useIcon)
|
root useIcon = IORoot_ (alsaCmd useIcon)
|
||||||
|
|
||||||
getBl :: Maybe SesClient -> BarFeature
|
getBl :: Maybe NamedSesConnection -> BarFeature
|
||||||
getBl =
|
getBl =
|
||||||
xmobarDBus
|
xmobarDBus
|
||||||
"Intel backlight indicator"
|
"Intel backlight indicator"
|
||||||
|
@ -258,7 +258,7 @@ getBl =
|
||||||
intelBacklightSignalDep
|
intelBacklightSignalDep
|
||||||
blCmd
|
blCmd
|
||||||
|
|
||||||
getCk :: Maybe SesClient -> BarFeature
|
getCk :: Maybe NamedSesConnection -> BarFeature
|
||||||
getCk =
|
getCk =
|
||||||
xmobarDBus
|
xmobarDBus
|
||||||
"Clevo keyboard indicator"
|
"Clevo keyboard indicator"
|
||||||
|
@ -266,7 +266,7 @@ getCk =
|
||||||
clevoKeyboardSignalDep
|
clevoKeyboardSignalDep
|
||||||
ckCmd
|
ckCmd
|
||||||
|
|
||||||
getSs :: Maybe SesClient -> BarFeature
|
getSs :: Maybe NamedSesConnection -> BarFeature
|
||||||
getSs = xmobarDBus "screensaver indicator" (const True) ssSignalDep ssCmd
|
getSs = xmobarDBus "screensaver indicator" (const True) ssSignalDep ssCmd
|
||||||
|
|
||||||
getLock :: Always CmdSpec
|
getLock :: Always CmdSpec
|
||||||
|
@ -283,7 +283,7 @@ xmobarDBus
|
||||||
-> XPQuery
|
-> XPQuery
|
||||||
-> DBusDependency_ c
|
-> DBusDependency_ c
|
||||||
-> (Fontifier -> CmdSpec)
|
-> (Fontifier -> CmdSpec)
|
||||||
-> Maybe c
|
-> Maybe (NamedConnection c)
|
||||||
-> BarFeature
|
-> BarFeature
|
||||||
xmobarDBus n q dep cmd cl = iconDBus_ n q root (Only_ dep)
|
xmobarDBus n q dep cmd cl = iconDBus_ n q root (Only_ dep)
|
||||||
where
|
where
|
||||||
|
|
|
@ -166,9 +166,9 @@ getCreateDirectories = do
|
||||||
|
|
||||||
data FeatureSet = FeatureSet
|
data FeatureSet = FeatureSet
|
||||||
{ fsKeys :: (XIO () -> IO ()) -> X () -> DBusState -> [KeyGroup FeatureX]
|
{ fsKeys :: (XIO () -> IO ()) -> X () -> DBusState -> [KeyGroup FeatureX]
|
||||||
, fsDBusExporters :: [Maybe SesClient -> Sometimes (XIO (), XIO ())]
|
, fsDBusExporters :: [Maybe NamedSesConnection -> Sometimes (XIO (), XIO ())]
|
||||||
, fsPowerMon :: SometimesIO
|
, fsPowerMon :: SometimesIO
|
||||||
, fsRemovableMon :: Maybe SysClient -> SometimesIO
|
, fsRemovableMon :: Maybe NamedSysConnection -> SometimesIO
|
||||||
, fsDaemons :: [Sometimes (XIO (Process () () ()))]
|
, fsDaemons :: [Sometimes (XIO (Process () () ()))]
|
||||||
, fsACPIHandler :: Always (String -> X ())
|
, fsACPIHandler :: Always (String -> X ())
|
||||||
, fsTabbedTheme :: Always Theme
|
, fsTabbedTheme :: Always Theme
|
||||||
|
@ -183,7 +183,7 @@ tabbedFeature = Always "theme for tabbed windows" $ Option sf fallback
|
||||||
niceTheme = IORoot XT.tabbedTheme $ fontTree XT.defFontFamily defFontPkgs
|
niceTheme = IORoot XT.tabbedTheme $ fontTree XT.defFontFamily defFontPkgs
|
||||||
fallback = Always_ $ FallbackAlone $ XT.tabbedTheme XT.fallbackFont
|
fallback = Always_ $ FallbackAlone $ XT.tabbedTheme XT.fallbackFont
|
||||||
|
|
||||||
features :: Maybe SysClient -> FeatureSet
|
features :: Maybe NamedSysConnection -> FeatureSet
|
||||||
features cl =
|
features cl =
|
||||||
FeatureSet
|
FeatureSet
|
||||||
{ fsKeys = externalBindings
|
{ fsKeys = externalBindings
|
||||||
|
@ -251,7 +251,7 @@ stopChildDaemons = mapM_ stop
|
||||||
liftIO $ killNoWait p
|
liftIO $ killNoWait p
|
||||||
|
|
||||||
printDeps :: XIO ()
|
printDeps :: XIO ()
|
||||||
printDeps = withDBus_ $ \db -> do
|
printDeps = withDBus_ Nothing Nothing $ \db -> do
|
||||||
runIO <- askRunInIO
|
runIO <- askRunInIO
|
||||||
let mockCleanup = runCleanup runIO mockClean db
|
let mockCleanup = runCleanup runIO mockClean db
|
||||||
let bfs =
|
let bfs =
|
||||||
|
@ -292,7 +292,7 @@ runCleanup runIO ts db = liftIO $ runIO $ do
|
||||||
mapM_ stopXmobar $ clXmobar ts
|
mapM_ stopXmobar $ clXmobar ts
|
||||||
stopChildDaemons $ clChildren ts
|
stopChildDaemons $ clChildren ts
|
||||||
sequence_ $ clDBusUnexporters ts
|
sequence_ $ clDBusUnexporters ts
|
||||||
disconnectDBusX db
|
disconnectDBus db
|
||||||
|
|
||||||
-- | Kill a process (group) after xmonad has already started
|
-- | Kill a process (group) after xmonad has already started
|
||||||
-- This is necessary (as opposed to 'stopProcess' from rio) because a) xmonad
|
-- This is necessary (as opposed to 'stopProcess' from rio) because a) xmonad
|
||||||
|
|
|
@ -5,9 +5,13 @@ module Data.Internal.DBus
|
||||||
( SafeClient (..)
|
( SafeClient (..)
|
||||||
, SysClient (..)
|
, SysClient (..)
|
||||||
, SesClient (..)
|
, SesClient (..)
|
||||||
|
, NamedConnection (..)
|
||||||
|
, NamedSesConnection
|
||||||
|
, NamedSysConnection
|
||||||
, DBusEnv (..)
|
, DBusEnv (..)
|
||||||
, DIO
|
, DIO
|
||||||
, HasClient (..)
|
, HasClient (..)
|
||||||
|
, releaseBusName
|
||||||
, withDIO
|
, withDIO
|
||||||
, addMatchCallback
|
, addMatchCallback
|
||||||
, addMatchCallbackSignal
|
, addMatchCallbackSignal
|
||||||
|
@ -55,54 +59,129 @@ import qualified RIO.Text as T
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- Type-safe client
|
-- Type-safe client
|
||||||
|
|
||||||
-- data NamedConnection c = NamedConnection
|
data NamedConnection c = NamedConnection
|
||||||
-- { ncClient :: Client
|
{ ncClient :: !Client
|
||||||
-- , ncName :: Maybe BusName
|
, ncHumanName :: !(Maybe BusName)
|
||||||
-- , ncType :: c
|
--, ncUniqueName :: !BusName
|
||||||
-- }
|
, ncType :: !c
|
||||||
|
}
|
||||||
|
|
||||||
|
type NamedSesConnection = NamedConnection SesClient
|
||||||
|
|
||||||
|
type NamedSysConnection = NamedConnection SysClient
|
||||||
|
|
||||||
class SafeClient c where
|
class SafeClient c where
|
||||||
toClient :: c -> Client
|
|
||||||
|
|
||||||
getDBusClient
|
getDBusClient
|
||||||
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
|
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
|
||||||
=> m (Maybe c)
|
=> Maybe BusName
|
||||||
|
-> m (Maybe (NamedConnection c))
|
||||||
|
|
||||||
disconnectDBusClient :: MonadUnliftIO m => c -> m ()
|
disconnectDBusClient
|
||||||
disconnectDBusClient = liftIO . disconnect . toClient
|
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
|
||||||
|
=> NamedConnection c
|
||||||
|
-> m ()
|
||||||
|
disconnectDBusClient c = do
|
||||||
|
releaseBusName c
|
||||||
|
liftIO $ disconnect $ ncClient c
|
||||||
|
|
||||||
withDBusClient
|
withDBusClient
|
||||||
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
|
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
|
||||||
=> (c -> m a)
|
=> Maybe BusName
|
||||||
|
-> (NamedConnection c -> m a)
|
||||||
-> m (Maybe a)
|
-> m (Maybe a)
|
||||||
withDBusClient f =
|
withDBusClient n f =
|
||||||
bracket getDBusClient (mapM (liftIO . disconnect . toClient)) $ mapM f
|
bracket (getDBusClient n) (mapM (liftIO . disconnect . ncClient)) $ mapM f
|
||||||
|
|
||||||
withDBusClient_
|
withDBusClient_
|
||||||
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
|
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
|
||||||
=> (c -> m ())
|
=> Maybe BusName
|
||||||
|
-> (NamedConnection c -> m ())
|
||||||
-> m ()
|
-> m ()
|
||||||
withDBusClient_ = void . withDBusClient
|
withDBusClient_ n = void . withDBusClient n
|
||||||
|
|
||||||
fromDBusClient
|
fromDBusClient
|
||||||
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
|
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
|
||||||
=> (c -> a)
|
=> Maybe BusName
|
||||||
|
-> (NamedConnection c -> a)
|
||||||
-> m (Maybe a)
|
-> m (Maybe a)
|
||||||
fromDBusClient f = withDBusClient (return . f)
|
fromDBusClient n f = withDBusClient n (return . f)
|
||||||
|
|
||||||
newtype SysClient = SysClient Client
|
data SysClient = SysClient
|
||||||
|
|
||||||
instance SafeClient SysClient where
|
instance SafeClient SysClient where
|
||||||
toClient (SysClient cl) = cl
|
getDBusClient = connectToDBusWithName True SysClient
|
||||||
|
|
||||||
getDBusClient = fmap SysClient <$> getDBusClient' True
|
data SesClient = SesClient
|
||||||
|
|
||||||
newtype SesClient = SesClient Client
|
|
||||||
|
|
||||||
instance SafeClient SesClient where
|
instance SafeClient SesClient where
|
||||||
toClient (SesClient cl) = cl
|
-- TODO wet
|
||||||
|
getDBusClient = connectToDBusWithName False SesClient
|
||||||
|
|
||||||
getDBusClient = fmap SesClient <$> getDBusClient' False
|
connectToDBusWithName
|
||||||
|
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
|
||||||
|
=> Bool
|
||||||
|
-> c
|
||||||
|
-> Maybe BusName
|
||||||
|
-> m (Maybe (NamedConnection c))
|
||||||
|
connectToDBusWithName sys t n = do
|
||||||
|
clRes <- getDBusClient' sys
|
||||||
|
case clRes of
|
||||||
|
Nothing -> do
|
||||||
|
logError "could not get client"
|
||||||
|
return Nothing
|
||||||
|
Just cl -> do
|
||||||
|
--helloRes <- liftIO $ callHello cl
|
||||||
|
--case helloRes of
|
||||||
|
-- Nothing -> do
|
||||||
|
-- logError "count not get unique name"
|
||||||
|
-- return Nothing
|
||||||
|
-- Just unique -> do
|
||||||
|
n' <- maybe (return Nothing) (`requestBusName` cl) n
|
||||||
|
return $
|
||||||
|
Just $
|
||||||
|
NamedConnection
|
||||||
|
{ ncClient = cl
|
||||||
|
, ncHumanName = n'
|
||||||
|
-- , ncUniqueName = unique
|
||||||
|
, ncType = t
|
||||||
|
}
|
||||||
|
|
||||||
|
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'
|
getDBusClient'
|
||||||
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
|
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
|
||||||
|
@ -116,7 +195,16 @@ getDBusClient' sys = do
|
||||||
return Nothing
|
return Nothing
|
||||||
Right c -> return $ Just c
|
Right c -> return $ Just c
|
||||||
|
|
||||||
data DBusEnv env c = DBusEnv {dClient :: !c, dEnv :: !env}
|
--callHello :: Client -> IO (Maybe BusName)
|
||||||
|
--callHello cl = do
|
||||||
|
-- reply <- call_ cl $ methodCallBus dbusName dbusPath dbusInterface "Hello"
|
||||||
|
-- case methodReturnBody reply of
|
||||||
|
-- [name] | Just nameStr <- fromVariant name -> do
|
||||||
|
-- busName <- parseBusName nameStr
|
||||||
|
-- return $ Just busName
|
||||||
|
-- _ -> return Nothing
|
||||||
|
--
|
||||||
|
data DBusEnv env c = DBusEnv {dClient :: !(NamedConnection c), dEnv :: !env}
|
||||||
|
|
||||||
type DIO env c = RIO (DBusEnv env c)
|
type DIO env c = RIO (DBusEnv env c)
|
||||||
|
|
||||||
|
@ -128,7 +216,7 @@ instance HasLogFunc (DBusEnv SimpleApp c) where
|
||||||
|
|
||||||
withDIO
|
withDIO
|
||||||
:: (MonadUnliftIO m, MonadReader env m)
|
:: (MonadUnliftIO m, MonadReader env m)
|
||||||
=> c
|
=> NamedConnection c
|
||||||
-> DIO env c a
|
-> DIO env c a
|
||||||
-> m a
|
-> m a
|
||||||
withDIO cl x = do
|
withDIO cl x = do
|
||||||
|
@ -136,7 +224,7 @@ withDIO cl x = do
|
||||||
runRIO (DBusEnv cl env) x
|
runRIO (DBusEnv cl env) x
|
||||||
|
|
||||||
class HasClient env where
|
class HasClient env where
|
||||||
clientL :: SafeClient c => Lens' (env c) c
|
clientL :: SafeClient c => Lens' (env c) (NamedConnection c)
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- Methods
|
-- Methods
|
||||||
|
@ -148,7 +236,7 @@ callMethod'
|
||||||
=> MethodCall
|
=> MethodCall
|
||||||
-> m MethodBody
|
-> m MethodBody
|
||||||
callMethod' mc = do
|
callMethod' mc = do
|
||||||
cl <- toClient <$> view clientL
|
cl <- ncClient <$> view clientL
|
||||||
liftIO $ bimap (T.pack . methodErrorMessage) methodReturnBody <$> call cl mc
|
liftIO $ bimap (T.pack . methodErrorMessage) methodReturnBody <$> call cl mc
|
||||||
|
|
||||||
callMethod
|
callMethod
|
||||||
|
@ -220,7 +308,7 @@ addMatchCallbackSignal
|
||||||
-> (Signal -> m ())
|
-> (Signal -> m ())
|
||||||
-> m SignalHandler
|
-> m SignalHandler
|
||||||
addMatchCallbackSignal rule cb = do
|
addMatchCallbackSignal rule cb = do
|
||||||
cl <- toClient <$> view clientL
|
cl <- ncClient <$> view clientL
|
||||||
withRunInIO $ \run -> addMatch cl rule $ run . cb
|
withRunInIO $ \run -> addMatch cl rule $ run . cb
|
||||||
|
|
||||||
addMatchCallback
|
addMatchCallback
|
||||||
|
@ -301,7 +389,7 @@ callPropertyGet
|
||||||
-> MemberName
|
-> MemberName
|
||||||
-> m [Variant]
|
-> m [Variant]
|
||||||
callPropertyGet bus path iface property = do
|
callPropertyGet bus path iface property = do
|
||||||
cl <- toClient <$> view clientL
|
cl <- ncClient <$> view clientL
|
||||||
res <- liftIO $ getProperty cl $ methodCallBus bus path iface property
|
res <- liftIO $ getProperty cl $ methodCallBus bus path iface property
|
||||||
case res of
|
case res of
|
||||||
Left err -> do
|
Left err -> do
|
||||||
|
@ -453,14 +541,14 @@ addInterfaceRemovedListener bus =
|
||||||
-- Interface export/unexport
|
-- Interface export/unexport
|
||||||
|
|
||||||
exportPair
|
exportPair
|
||||||
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m, SafeClient c)
|
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
|
||||||
=> ObjectPath
|
=> ObjectPath
|
||||||
-> (Client -> m Interface)
|
-> (Client -> m Interface)
|
||||||
-> c
|
-> NamedConnection c
|
||||||
-> (m (), m ())
|
-> (m (), m ())
|
||||||
exportPair path toIface cl = (up, down)
|
exportPair path toIface cl = (up, down)
|
||||||
where
|
where
|
||||||
cl_ = toClient cl
|
cl_ = ncClient cl
|
||||||
up = do
|
up = do
|
||||||
logInfo $ "adding interface: " <> path_
|
logInfo $ "adding interface: " <> path_
|
||||||
i <- toIface cl_
|
i <- toIface cl_
|
||||||
|
|
|
@ -288,8 +288,18 @@ type SubfeatureRoot a = Subfeature (Root a)
|
||||||
data Root a
|
data Root a
|
||||||
= forall p. IORoot (p -> a) (IOTree p)
|
= forall p. IORoot (p -> a) (IOTree p)
|
||||||
| IORoot_ a IOTree_
|
| IORoot_ a IOTree_
|
||||||
| forall c p. SafeClient c => DBusRoot (p -> c -> a) (DBusTree c p) (Maybe c)
|
| forall c p.
|
||||||
| forall c. SafeClient c => DBusRoot_ (c -> a) (DBusTree_ c) (Maybe c)
|
SafeClient c =>
|
||||||
|
DBusRoot
|
||||||
|
(p -> NamedConnection c -> a)
|
||||||
|
(DBusTree c p)
|
||||||
|
(Maybe (NamedConnection c))
|
||||||
|
| forall c.
|
||||||
|
SafeClient c =>
|
||||||
|
DBusRoot_
|
||||||
|
(NamedConnection c -> a)
|
||||||
|
(DBusTree_ c)
|
||||||
|
(Maybe (NamedConnection c))
|
||||||
|
|
||||||
instance Functor Root where
|
instance Functor Root where
|
||||||
fmap f (IORoot a t) = IORoot (f . a) t
|
fmap f (IORoot a t) = IORoot (f . a) t
|
||||||
|
@ -876,10 +886,10 @@ introspectInterface = interfaceName_ "org.freedesktop.DBus.Introspectable"
|
||||||
introspectMethod :: MemberName
|
introspectMethod :: MemberName
|
||||||
introspectMethod = memberName_ "Introspect"
|
introspectMethod = memberName_ "Introspect"
|
||||||
|
|
||||||
testDBusDep_ :: SafeClient c => c -> DBusDependency_ c -> XIO MResult_
|
testDBusDep_ :: SafeClient c => NamedConnection c -> DBusDependency_ c -> XIO MResult_
|
||||||
testDBusDep_ c d = memoizeMVar $ testDBusDepNoCache_ c d
|
testDBusDep_ c d = memoizeMVar $ testDBusDepNoCache_ c d
|
||||||
|
|
||||||
testDBusDepNoCache_ :: SafeClient c => c -> DBusDependency_ c -> XIO Result_
|
testDBusDepNoCache_ :: SafeClient c => NamedConnection c -> DBusDependency_ c -> XIO Result_
|
||||||
testDBusDepNoCache_ cl (Bus _ bus) = do
|
testDBusDepNoCache_ cl (Bus _ bus) = do
|
||||||
ret <- withDIO cl $ callMethod queryBus queryPath queryIface queryMem
|
ret <- withDIO cl $ callMethod queryBus queryPath queryIface queryMem
|
||||||
return $ case ret of
|
return $ case ret of
|
||||||
|
@ -1010,11 +1020,11 @@ sometimesExeArgs fn n ful sys path args =
|
||||||
|
|
||||||
sometimesDBus
|
sometimesDBus
|
||||||
:: SafeClient c
|
:: SafeClient c
|
||||||
=> Maybe c
|
=> Maybe (NamedConnection c)
|
||||||
-> T.Text
|
-> T.Text
|
||||||
-> T.Text
|
-> T.Text
|
||||||
-> Tree_ (DBusDependency_ c)
|
-> Tree_ (DBusDependency_ c)
|
||||||
-> (c -> a)
|
-> (NamedConnection c -> a)
|
||||||
-> Sometimes a
|
-> Sometimes a
|
||||||
sometimesDBus c fn n t x = sometimes1 fn n $ DBusRoot_ x t c
|
sometimesDBus c fn n t x = sometimes1 fn n $ DBusRoot_ x t c
|
||||||
|
|
||||||
|
@ -1028,7 +1038,7 @@ sometimesEndpoint
|
||||||
-> ObjectPath
|
-> ObjectPath
|
||||||
-> InterfaceName
|
-> InterfaceName
|
||||||
-> MemberName
|
-> MemberName
|
||||||
-> Maybe c
|
-> Maybe (NamedConnection c)
|
||||||
-> Sometimes (m ())
|
-> Sometimes (m ())
|
||||||
sometimesEndpoint fn name ful busname path iface mem cl =
|
sometimesEndpoint fn name ful busname path iface mem cl =
|
||||||
sometimesDBus cl fn name deps cmd
|
sometimesDBus cl fn name deps cmd
|
||||||
|
|
|
@ -146,7 +146,7 @@ runAppMenu = spawnDmenuCmd "app launcher" ["-show", "drun"]
|
||||||
runWinMenu :: MonadUnliftIO m => Sometimes (m ())
|
runWinMenu :: MonadUnliftIO m => Sometimes (m ())
|
||||||
runWinMenu = spawnDmenuCmd "window switcher" ["-show", "window"]
|
runWinMenu = spawnDmenuCmd "window switcher" ["-show", "window"]
|
||||||
|
|
||||||
runNetMenu :: MonadUnliftIO m => Maybe SysClient -> Sometimes (m ())
|
runNetMenu :: MonadUnliftIO m => Maybe NamedSysConnection -> Sometimes (m ())
|
||||||
runNetMenu cl =
|
runNetMenu cl =
|
||||||
Sometimes
|
Sometimes
|
||||||
"network control menu"
|
"network control menu"
|
||||||
|
@ -171,7 +171,7 @@ runAutorandrMenu = sometimesIO_ "autorandr menu" "rofi autorandr" tree cmd
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- Password manager
|
-- Password manager
|
||||||
|
|
||||||
runBwMenu :: MonadUnliftIO m => Maybe SesClient -> Sometimes (m ())
|
runBwMenu :: MonadUnliftIO m => Maybe NamedSesConnection -> Sometimes (m ())
|
||||||
runBwMenu cl = sometimesDBus cl "password manager" "rofi bitwarden" tree cmd
|
runBwMenu cl = sometimesDBus cl "password manager" "rofi bitwarden" tree cmd
|
||||||
where
|
where
|
||||||
cmd _ =
|
cmd _ =
|
||||||
|
|
|
@ -246,7 +246,7 @@ runNotificationCmd
|
||||||
:: MonadUnliftIO m
|
:: MonadUnliftIO m
|
||||||
=> T.Text
|
=> T.Text
|
||||||
-> T.Text
|
-> T.Text
|
||||||
-> Maybe SesClient
|
-> Maybe NamedSesConnection
|
||||||
-> Sometimes (m ())
|
-> Sometimes (m ())
|
||||||
runNotificationCmd n arg cl =
|
runNotificationCmd n arg cl =
|
||||||
sometimesDBus cl (T.unwords [n, "control"]) "dunstctl" tree cmd
|
sometimesDBus cl (T.unwords [n, "control"]) "dunstctl" tree cmd
|
||||||
|
@ -258,18 +258,18 @@ runNotificationCmd n arg cl =
|
||||||
Method_ $
|
Method_ $
|
||||||
memberName_ "NotificationAction"
|
memberName_ "NotificationAction"
|
||||||
|
|
||||||
runNotificationClose :: MonadUnliftIO m => Maybe SesClient -> Sometimes (m ())
|
runNotificationClose :: MonadUnliftIO m => Maybe NamedSesConnection -> Sometimes (m ())
|
||||||
runNotificationClose = runNotificationCmd "close notification" "close"
|
runNotificationClose = runNotificationCmd "close notification" "close"
|
||||||
|
|
||||||
runNotificationCloseAll :: MonadUnliftIO m => Maybe SesClient -> Sometimes (m ())
|
runNotificationCloseAll :: MonadUnliftIO m => Maybe NamedSesConnection -> Sometimes (m ())
|
||||||
runNotificationCloseAll =
|
runNotificationCloseAll =
|
||||||
runNotificationCmd "close all notifications" "close-all"
|
runNotificationCmd "close all notifications" "close-all"
|
||||||
|
|
||||||
runNotificationHistory :: MonadUnliftIO m => Maybe SesClient -> Sometimes (m ())
|
runNotificationHistory :: MonadUnliftIO m => Maybe NamedSesConnection -> Sometimes (m ())
|
||||||
runNotificationHistory =
|
runNotificationHistory =
|
||||||
runNotificationCmd "see notification history" "history-pop"
|
runNotificationCmd "see notification history" "history-pop"
|
||||||
|
|
||||||
runNotificationContext :: MonadUnliftIO m => Maybe SesClient -> Sometimes (m ())
|
runNotificationContext :: MonadUnliftIO m => Maybe NamedSesConnection -> Sometimes (m ())
|
||||||
runNotificationContext =
|
runNotificationContext =
|
||||||
runNotificationCmd "open notification context" "context"
|
runNotificationCmd "open notification context" "context"
|
||||||
|
|
||||||
|
@ -277,7 +277,7 @@ runNotificationContext =
|
||||||
-- System commands
|
-- System commands
|
||||||
|
|
||||||
-- this is required for some vpn's to work properly with network-manager
|
-- this is required for some vpn's to work properly with network-manager
|
||||||
runNetAppDaemon :: Maybe SysClient -> Sometimes (XIO (P.Process () () ()))
|
runNetAppDaemon :: Maybe NamedSysConnection -> Sometimes (XIO (P.Process () () ()))
|
||||||
runNetAppDaemon cl =
|
runNetAppDaemon cl =
|
||||||
Sometimes
|
Sometimes
|
||||||
"network applet"
|
"network applet"
|
||||||
|
@ -288,7 +288,7 @@ runNetAppDaemon cl =
|
||||||
app = DBusIO $ sysExe [Package Official "network-manager-applet"] "nm-applet"
|
app = DBusIO $ sysExe [Package Official "network-manager-applet"] "nm-applet"
|
||||||
cmd _ = P.proc "nm-applet" [] (P.startProcess . P.setCreateGroup True)
|
cmd _ = P.proc "nm-applet" [] (P.startProcess . P.setCreateGroup True)
|
||||||
|
|
||||||
runToggleBluetooth :: MonadUnliftIO m => Maybe SysClient -> Sometimes (m ())
|
runToggleBluetooth :: MonadUnliftIO m => Maybe NamedSysConnection -> Sometimes (m ())
|
||||||
runToggleBluetooth cl =
|
runToggleBluetooth cl =
|
||||||
Sometimes
|
Sometimes
|
||||||
"bluetooth toggle"
|
"bluetooth toggle"
|
||||||
|
@ -366,7 +366,7 @@ runFlameshot
|
||||||
:: MonadUnliftIO m
|
:: MonadUnliftIO m
|
||||||
=> T.Text
|
=> T.Text
|
||||||
-> T.Text
|
-> T.Text
|
||||||
-> Maybe SesClient
|
-> Maybe NamedSesConnection
|
||||||
-> Sometimes (m ())
|
-> Sometimes (m ())
|
||||||
runFlameshot n mode cl = sometimesDBus cl n (T.pack myCapture) tree cmd
|
runFlameshot n mode cl = sometimesDBus cl n (T.pack myCapture) tree cmd
|
||||||
where
|
where
|
||||||
|
@ -378,15 +378,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
|
-- TODO this will steal focus from the current window (and puts it
|
||||||
-- in the root window?) ...need to fix
|
-- in the root window?) ...need to fix
|
||||||
runAreaCapture :: MonadUnliftIO m => Maybe SesClient -> Sometimes (m ())
|
runAreaCapture :: MonadUnliftIO m => Maybe NamedSesConnection -> Sometimes (m ())
|
||||||
runAreaCapture = runFlameshot "screen area capture" "gui"
|
runAreaCapture = runFlameshot "screen area capture" "gui"
|
||||||
|
|
||||||
-- myWindowCap = "screencap -w" --external script
|
-- myWindowCap = "screencap -w" --external script
|
||||||
|
|
||||||
runDesktopCapture :: MonadUnliftIO m => Maybe SesClient -> Sometimes (m ())
|
runDesktopCapture :: MonadUnliftIO m => Maybe NamedSesConnection -> Sometimes (m ())
|
||||||
runDesktopCapture = runFlameshot "fullscreen capture" "full"
|
runDesktopCapture = runFlameshot "fullscreen capture" "full"
|
||||||
|
|
||||||
runScreenCapture :: MonadUnliftIO m => Maybe SesClient -> Sometimes (m ())
|
runScreenCapture :: MonadUnliftIO m => Maybe NamedSesConnection -> Sometimes (m ())
|
||||||
runScreenCapture = runFlameshot "screen capture" "screen"
|
runScreenCapture = runFlameshot "screen capture" "screen"
|
||||||
|
|
||||||
runCaptureBrowser :: MonadUnliftIO m => Sometimes (m ())
|
runCaptureBrowser :: MonadUnliftIO m => Sometimes (m ())
|
||||||
|
|
|
@ -117,7 +117,7 @@ clevoKeyboardSignalDep =
|
||||||
|
|
||||||
exportClevoKeyboard
|
exportClevoKeyboard
|
||||||
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
|
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
|
||||||
=> Maybe SesClient
|
=> Maybe NamedSesConnection
|
||||||
-> Sometimes (m (), m ())
|
-> Sometimes (m (), m ())
|
||||||
exportClevoKeyboard =
|
exportClevoKeyboard =
|
||||||
brightnessExporter
|
brightnessExporter
|
||||||
|
@ -128,7 +128,7 @@ exportClevoKeyboard =
|
||||||
|
|
||||||
clevoKeyboardControls
|
clevoKeyboardControls
|
||||||
:: (HasClient (DBusEnv env), MonadReader env m, MonadUnliftIO m)
|
:: (HasClient (DBusEnv env), MonadReader env m, MonadUnliftIO m)
|
||||||
=> Maybe SesClient
|
=> Maybe NamedSesConnection
|
||||||
-> BrightnessControls m
|
-> BrightnessControls m
|
||||||
clevoKeyboardControls = brightnessControls xpfClevoBacklight clevoKeyboardConfig
|
clevoKeyboardControls = brightnessControls xpfClevoBacklight clevoKeyboardConfig
|
||||||
|
|
||||||
|
|
|
@ -53,7 +53,7 @@ brightnessControls
|
||||||
:: (HasClient (DBusEnv env), MonadReader env m, MonadUnliftIO m)
|
:: (HasClient (DBusEnv env), MonadReader env m, MonadUnliftIO m)
|
||||||
=> XPQuery
|
=> XPQuery
|
||||||
-> BrightnessConfig m a b
|
-> BrightnessConfig m a b
|
||||||
-> Maybe SesClient
|
-> Maybe NamedSesConnection
|
||||||
-> BrightnessControls m
|
-> BrightnessControls m
|
||||||
brightnessControls q bc cl =
|
brightnessControls q bc cl =
|
||||||
BrightnessControls
|
BrightnessControls
|
||||||
|
@ -78,7 +78,7 @@ callGetBrightness BrightnessConfig {bcPath = p, bcInterface = i} =
|
||||||
either (const Nothing) bodyGetBrightness
|
either (const Nothing) bodyGetBrightness
|
||||||
<$> callMethod xmonadSesBusName p i memGet
|
<$> callMethod xmonadSesBusName p i memGet
|
||||||
|
|
||||||
signalDep :: BrightnessConfig m a b -> DBusDependency_ SesClient
|
signalDep :: BrightnessConfig m a b -> DBusDependency_ c
|
||||||
signalDep BrightnessConfig {bcPath = p, bcInterface = i} =
|
signalDep BrightnessConfig {bcPath = p, bcInterface = i} =
|
||||||
Endpoint [] xmonadSesBusName p i $ Signal_ memCur
|
Endpoint [] xmonadSesBusName p i $ Signal_ memCur
|
||||||
|
|
||||||
|
@ -112,7 +112,7 @@ brightnessExporter
|
||||||
-> [Fulfillment]
|
-> [Fulfillment]
|
||||||
-> [IODependency_]
|
-> [IODependency_]
|
||||||
-> BrightnessConfig m a b
|
-> BrightnessConfig m a b
|
||||||
-> Maybe SesClient
|
-> Maybe NamedSesConnection
|
||||||
-> Sometimes (m (), m ())
|
-> Sometimes (m (), m ())
|
||||||
brightnessExporter q ful deps bc@BrightnessConfig {bcName = n} cl =
|
brightnessExporter q ful deps bc@BrightnessConfig {bcName = n} cl =
|
||||||
Sometimes (T.append n " DBus Interface") q [Subfeature root "exporter"]
|
Sometimes (T.append n " DBus Interface") q [Subfeature root "exporter"]
|
||||||
|
@ -123,7 +123,7 @@ brightnessExporter q ful deps bc@BrightnessConfig {bcName = n} cl =
|
||||||
exportBrightnessControlsInner
|
exportBrightnessControlsInner
|
||||||
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m, RealFrac b)
|
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m, RealFrac b)
|
||||||
=> BrightnessConfig m a b
|
=> BrightnessConfig m a b
|
||||||
-> SesClient
|
-> NamedSesConnection
|
||||||
-> (m (), m ())
|
-> (m (), m ())
|
||||||
exportBrightnessControlsInner bc = cmd
|
exportBrightnessControlsInner bc = cmd
|
||||||
where
|
where
|
||||||
|
@ -172,7 +172,7 @@ emitBrightness BrightnessConfig {bcPath = p, bcInterface = i} client cur =
|
||||||
callBacklight
|
callBacklight
|
||||||
:: (MonadReader env m, HasClient (DBusEnv env), MonadUnliftIO m)
|
:: (MonadReader env m, HasClient (DBusEnv env), MonadUnliftIO m)
|
||||||
=> XPQuery
|
=> XPQuery
|
||||||
-> Maybe SesClient
|
-> Maybe NamedSesConnection
|
||||||
-> BrightnessConfig m a b
|
-> BrightnessConfig m a b
|
||||||
-> T.Text
|
-> T.Text
|
||||||
-> MemberName
|
-> MemberName
|
||||||
|
|
|
@ -103,7 +103,7 @@ intelBacklightSignalDep =
|
||||||
|
|
||||||
exportIntelBacklight
|
exportIntelBacklight
|
||||||
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
|
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
|
||||||
=> Maybe SesClient
|
=> Maybe NamedSesConnection
|
||||||
-> Sometimes (m (), m ())
|
-> Sometimes (m (), m ())
|
||||||
exportIntelBacklight =
|
exportIntelBacklight =
|
||||||
brightnessExporter
|
brightnessExporter
|
||||||
|
@ -114,7 +114,7 @@ exportIntelBacklight =
|
||||||
|
|
||||||
intelBacklightControls
|
intelBacklightControls
|
||||||
:: (HasClient (DBusEnv env), MonadReader env m, MonadUnliftIO m)
|
:: (HasClient (DBusEnv env), MonadReader env m, MonadUnliftIO m)
|
||||||
=> Maybe SesClient
|
=> Maybe NamedSesConnection
|
||||||
-> BrightnessControls m
|
-> BrightnessControls m
|
||||||
intelBacklightControls = brightnessControls xpfIntelBacklight intelBacklightConfig
|
intelBacklightControls = brightnessControls xpfIntelBacklight intelBacklightConfig
|
||||||
|
|
||||||
|
|
|
@ -14,10 +14,10 @@ where
|
||||||
import DBus
|
import DBus
|
||||||
|
|
||||||
xmonadSesBusName :: BusName
|
xmonadSesBusName :: BusName
|
||||||
xmonadSesBusName = busName_ "org.xmonad.Session"
|
xmonadSesBusName = busName_ "org.xmonad.session"
|
||||||
|
|
||||||
xmonadSysBusName :: BusName
|
xmonadSysBusName :: BusName
|
||||||
xmonadSysBusName = busName_ "org.xmonad.System"
|
xmonadSysBusName = busName_ "org.xmonad.system"
|
||||||
|
|
||||||
btBus :: BusName
|
btBus :: BusName
|
||||||
btBus = busName_ "org.bluez"
|
btBus = busName_ "org.bluez"
|
||||||
|
|
|
@ -11,7 +11,7 @@ module XMonad.Internal.DBus.Control
|
||||||
, withDBus_
|
, withDBus_
|
||||||
, connectDBus
|
, connectDBus
|
||||||
, disconnectDBus
|
, disconnectDBus
|
||||||
, disconnectDBusX
|
-- , disconnectDBusX
|
||||||
, getDBusClient
|
, getDBusClient
|
||||||
, withDBusClient
|
, withDBusClient
|
||||||
, withDBusClient_
|
, withDBusClient_
|
||||||
|
@ -22,7 +22,6 @@ where
|
||||||
|
|
||||||
import DBus
|
import DBus
|
||||||
import DBus.Client
|
import DBus.Client
|
||||||
import qualified Data.ByteString.Char8 as BC
|
|
||||||
import Data.Internal.DBus
|
import Data.Internal.DBus
|
||||||
import Data.Internal.XIO
|
import Data.Internal.XIO
|
||||||
import RIO
|
import RIO
|
||||||
|
@ -33,8 +32,8 @@ import XMonad.Internal.DBus.Screensaver
|
||||||
|
|
||||||
-- | Current connections to the DBus (session and system buses)
|
-- | Current connections to the DBus (session and system buses)
|
||||||
data DBusState = DBusState
|
data DBusState = DBusState
|
||||||
{ dbSesClient :: Maybe SesClient
|
{ dbSesClient :: Maybe NamedSesConnection
|
||||||
, dbSysClient :: Maybe SysClient
|
, dbSysClient :: Maybe NamedSysConnection
|
||||||
}
|
}
|
||||||
|
|
||||||
withDBusX_
|
withDBusX_
|
||||||
|
@ -46,50 +45,47 @@ withDBusX_ = void . withDBusX
|
||||||
withDBusX
|
withDBusX
|
||||||
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
|
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
|
||||||
=> (DBusState -> m a)
|
=> (DBusState -> m a)
|
||||||
-> m (Maybe a)
|
-> m a
|
||||||
withDBusX f = withDBus $ \db -> do
|
withDBusX = withDBus (Just xmonadSesBusName) (Just xmonadSysBusName)
|
||||||
case (dbSesClient db, dbSysClient db) of
|
|
||||||
(Just ses, Just sys) -> do
|
|
||||||
res <-
|
|
||||||
bracket_
|
|
||||||
( do
|
|
||||||
requestBusName xmonadSesBusName ses
|
|
||||||
requestBusName xmonadSysBusName sys
|
|
||||||
)
|
|
||||||
( do
|
|
||||||
releaseBusName xmonadSesBusName ses
|
|
||||||
releaseBusName xmonadSysBusName sys
|
|
||||||
)
|
|
||||||
$ f db
|
|
||||||
return $ Just res
|
|
||||||
_ -> return Nothing
|
|
||||||
|
|
||||||
withDBus_
|
withDBus_
|
||||||
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
|
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
|
||||||
=> (DBusState -> m a)
|
=> Maybe BusName
|
||||||
|
-> Maybe BusName
|
||||||
|
-> (DBusState -> m a)
|
||||||
-> m ()
|
-> m ()
|
||||||
withDBus_ = void . withDBus
|
withDBus_ sesname sysname = void . withDBus sesname sysname
|
||||||
|
|
||||||
withDBus
|
withDBus
|
||||||
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
|
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
|
||||||
=> (DBusState -> m a)
|
=> Maybe BusName
|
||||||
|
-> Maybe BusName
|
||||||
|
-> (DBusState -> m a)
|
||||||
-> m a
|
-> m a
|
||||||
withDBus = bracket connectDBus disconnectDBus
|
withDBus sesname sysname = bracket (connectDBus sesname sysname) disconnectDBus
|
||||||
|
|
||||||
-- | Connect to the DBus
|
-- | Connect to the DBus
|
||||||
connectDBus
|
connectDBus
|
||||||
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
|
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
|
||||||
=> m DBusState
|
=> Maybe BusName
|
||||||
connectDBus = do
|
-> Maybe BusName
|
||||||
ses <- getDBusClient
|
-> m DBusState
|
||||||
sys <- getDBusClient
|
connectDBus sesname sysname = do
|
||||||
|
ses <- getDBusClient sesname
|
||||||
|
sys <- getDBusClient sysname
|
||||||
return DBusState {dbSesClient = ses, dbSysClient = sys}
|
return DBusState {dbSesClient = ses, dbSysClient = sys}
|
||||||
|
|
||||||
-- | Disconnect from the DBus
|
-- | Disconnect from the DBus
|
||||||
disconnectDBus :: MonadUnliftIO m => DBusState -> m ()
|
disconnectDBus
|
||||||
|
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
|
||||||
|
=> DBusState
|
||||||
|
-> m ()
|
||||||
disconnectDBus db = disc dbSesClient >> disc dbSysClient
|
disconnectDBus db = disc dbSesClient >> disc dbSysClient
|
||||||
where
|
where
|
||||||
disc :: (MonadUnliftIO m, SafeClient c) => (DBusState -> Maybe c) -> m ()
|
disc
|
||||||
|
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m, SafeClient c)
|
||||||
|
=> (DBusState -> Maybe (NamedConnection c))
|
||||||
|
-> m ()
|
||||||
disc f = maybe (return ()) disconnectDBusClient $ f db
|
disc f = maybe (return ()) disconnectDBusClient $ f db
|
||||||
|
|
||||||
-- -- | Connect to the DBus and request the XMonad name
|
-- -- | Connect to the DBus and request the XMonad name
|
||||||
|
@ -101,15 +97,15 @@ disconnectDBus db = disc dbSesClient >> disc dbSysClient
|
||||||
-- requestXMonadName2 db
|
-- requestXMonadName2 db
|
||||||
-- return db
|
-- return db
|
||||||
|
|
||||||
-- | Disconnect from DBus and release the XMonad name
|
-- -- | Disconnect from DBus and release the XMonad name
|
||||||
disconnectDBusX
|
-- disconnectDBusX
|
||||||
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
|
-- :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
|
||||||
=> DBusState
|
-- => DBusState
|
||||||
-> m ()
|
-- -> m ()
|
||||||
disconnectDBusX db = do
|
-- disconnectDBusX db = do
|
||||||
forM_ (dbSesClient db) $ releaseBusName xmonadSesBusName
|
-- forM_ (dbSesClient db) releaseBusName
|
||||||
forM_ (dbSysClient db) $ releaseBusName xmonadSysBusName
|
-- forM_ (dbSysClient db) releaseBusName
|
||||||
disconnectDBus db
|
-- disconnectDBus db
|
||||||
|
|
||||||
-- requestXMonadName2
|
-- requestXMonadName2
|
||||||
-- :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
|
-- :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
|
||||||
|
@ -121,7 +117,7 @@ disconnectDBusX db = do
|
||||||
|
|
||||||
withDBusInterfaces
|
withDBusInterfaces
|
||||||
:: DBusState
|
:: DBusState
|
||||||
-> [Maybe SesClient -> Sometimes (XIO (), XIO ())]
|
-> [Maybe NamedSesConnection -> Sometimes (XIO (), XIO ())]
|
||||||
-> ([XIO ()] -> XIO a)
|
-> ([XIO ()] -> XIO a)
|
||||||
-> XIO a
|
-> XIO a
|
||||||
withDBusInterfaces db interfaces = bracket up sequence
|
withDBusInterfaces db interfaces = bracket up sequence
|
||||||
|
@ -134,7 +130,7 @@ withDBusInterfaces db interfaces = bracket up sequence
|
||||||
-- | All exporter features to be assigned to the DBus
|
-- | All exporter features to be assigned to the DBus
|
||||||
dbusExporters
|
dbusExporters
|
||||||
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
|
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
|
||||||
=> [Maybe SesClient -> Sometimes (m (), m ())]
|
=> [Maybe NamedSesConnection -> Sometimes (m (), m ())]
|
||||||
dbusExporters = [exportScreensaver, exportIntelBacklight, exportClevoKeyboard]
|
dbusExporters = [exportScreensaver, exportIntelBacklight, exportClevoKeyboard]
|
||||||
|
|
||||||
-- releaseXMonadName
|
-- releaseXMonadName
|
||||||
|
@ -146,35 +142,35 @@ dbusExporters = [exportScreensaver, exportIntelBacklight, exportClevoKeyboard]
|
||||||
-- liftIO $ void $ releaseName (toClient cl) xmonadBusName
|
-- liftIO $ void $ releaseName (toClient cl) xmonadBusName
|
||||||
-- logInfo "released xmonad name"
|
-- logInfo "released xmonad name"
|
||||||
|
|
||||||
releaseBusName
|
-- releaseBusName
|
||||||
:: (SafeClient c, MonadReader env m, HasLogFunc env, MonadUnliftIO m)
|
-- :: (SafeClient c, MonadReader env m, HasLogFunc env, MonadUnliftIO m)
|
||||||
=> BusName
|
-- => BusName
|
||||||
-> c
|
-- -> c
|
||||||
-> m ()
|
-- -> m ()
|
||||||
releaseBusName n cl = do
|
-- releaseBusName n cl = do
|
||||||
-- TODO this might error?
|
-- -- TODO this might error?
|
||||||
liftIO $ void $ releaseName (toClient cl) n
|
-- liftIO $ void $ releaseName (toClient cl) n
|
||||||
logInfo $ "released bus name: " <> displayBusName n
|
-- logInfo $ "released bus name: " <> displayBusName n
|
||||||
|
|
||||||
requestBusName
|
-- requestBusName
|
||||||
:: (SafeClient c, MonadReader env m, HasLogFunc env, MonadUnliftIO m)
|
-- :: (SafeClient c, MonadReader env m, HasLogFunc env, MonadUnliftIO m)
|
||||||
=> BusName
|
-- => BusName
|
||||||
-> c
|
-- -> c
|
||||||
-> m ()
|
-- -> m ()
|
||||||
requestBusName n cl = do
|
-- requestBusName n cl = do
|
||||||
res <- try $ liftIO $ requestName (toClient cl) n []
|
-- res <- try $ liftIO $ requestName (toClient cl) n []
|
||||||
case res of
|
-- case res of
|
||||||
Left e -> logError $ displayBytesUtf8 $ BC.pack $ clientErrorMessage e
|
-- Left e -> logError $ displayBytesUtf8 $ BC.pack $ clientErrorMessage e
|
||||||
Right r -> do
|
-- Right r -> do
|
||||||
let msg
|
-- let msg
|
||||||
| r == NamePrimaryOwner = "registering name"
|
-- | r == NamePrimaryOwner = "registering name"
|
||||||
| r == NameAlreadyOwner = "this process already owns name"
|
-- | r == NameAlreadyOwner = "this process already owns name"
|
||||||
| r == NameInQueue
|
-- | r == NameInQueue
|
||||||
|| r == NameExists =
|
-- || r == NameExists =
|
||||||
"another process owns name"
|
-- "another process owns name"
|
||||||
-- this should never happen
|
-- -- this should never happen
|
||||||
| otherwise = "unknown error when requesting name"
|
-- | otherwise = "unknown error when requesting name"
|
||||||
logInfo $ msg <> ": " <> displayBusName n
|
-- logInfo $ msg <> ": " <> displayBusName n
|
||||||
|
|
||||||
-- requestXMonadName
|
-- requestXMonadName
|
||||||
-- :: (SafeClient c, MonadReader env m, HasLogFunc env, MonadUnliftIO m)
|
-- :: (SafeClient c, MonadReader env m, HasLogFunc env, MonadUnliftIO m)
|
||||||
|
|
|
@ -83,7 +83,7 @@ listenDevices
|
||||||
, MonadReader env m
|
, MonadReader env m
|
||||||
, MonadUnliftIO m
|
, MonadUnliftIO m
|
||||||
)
|
)
|
||||||
=> SysClient
|
=> NamedSysConnection
|
||||||
-> m ()
|
-> m ()
|
||||||
listenDevices cl = do
|
listenDevices cl = do
|
||||||
addMatch' memAdded driveInsertedSound addedHasDrive
|
addMatch' memAdded driveInsertedSound addedHasDrive
|
||||||
|
@ -98,7 +98,7 @@ runRemovableMon
|
||||||
, MonadReader env m
|
, MonadReader env m
|
||||||
, MonadUnliftIO m
|
, MonadUnliftIO m
|
||||||
)
|
)
|
||||||
=> Maybe SysClient
|
=> Maybe NamedSysConnection
|
||||||
-> Sometimes (m ())
|
-> Sometimes (m ())
|
||||||
runRemovableMon cl =
|
runRemovableMon cl =
|
||||||
sometimesDBus cl "removeable device monitor" "dbus monitor" deps listenDevices
|
sometimesDBus cl "removeable device monitor" "dbus monitor" deps listenDevices
|
||||||
|
|
|
@ -93,7 +93,7 @@ bodyGetCurrentState _ = Nothing
|
||||||
|
|
||||||
exportScreensaver
|
exportScreensaver
|
||||||
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
|
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
|
||||||
=> Maybe SesClient
|
=> Maybe NamedSesConnection
|
||||||
-> Sometimes (m (), m ())
|
-> Sometimes (m (), m ())
|
||||||
exportScreensaver ses =
|
exportScreensaver ses =
|
||||||
sometimesDBus ses "screensaver toggle" "xset" (toAnd_ bus ssx) cmd
|
sometimesDBus ses "screensaver toggle" "xset" (toAnd_ bus ssx) cmd
|
||||||
|
@ -124,7 +124,7 @@ exportScreensaver ses =
|
||||||
|
|
||||||
callToggle
|
callToggle
|
||||||
:: (HasClient (DBusEnv env), MonadReader env m, MonadUnliftIO m)
|
:: (HasClient (DBusEnv env), MonadReader env m, MonadUnliftIO m)
|
||||||
=> Maybe SesClient
|
=> Maybe NamedSesConnection
|
||||||
-> Sometimes (m ())
|
-> Sometimes (m ())
|
||||||
callToggle =
|
callToggle =
|
||||||
sometimesEndpoint
|
sometimesEndpoint
|
||||||
|
|
|
@ -39,7 +39,7 @@ connAlias = T.intercalate "_" . NE.toList
|
||||||
instance Exec ActiveConnection where
|
instance Exec ActiveConnection where
|
||||||
alias (ActiveConnection (contypes, _, _)) = T.unpack $ connAlias contypes
|
alias (ActiveConnection (contypes, _, _)) = T.unpack $ connAlias contypes
|
||||||
start (ActiveConnection (contypes, text, colors)) cb =
|
start (ActiveConnection (contypes, text, colors)) cb =
|
||||||
withDBusClientConnection cb (Just "ethernet.log") $ \c -> do
|
withDBusClientConnection cb Nothing (Just "ethernet.log") $ \c -> do
|
||||||
let dpy cb' = displayMaybe cb' formatter . Just =<< readState
|
let dpy cb' = displayMaybe cb' formatter . Just =<< readState
|
||||||
i <- withDIO c $ initialState contypes
|
i <- withDIO c $ initialState contypes
|
||||||
s <- newMVar i
|
s <- newMVar i
|
||||||
|
@ -60,7 +60,7 @@ instance Exec ActiveConnection where
|
||||||
-- TODO can I recycle the client?
|
-- TODO can I recycle the client?
|
||||||
void $
|
void $
|
||||||
addMatchCallbackSignal rule $ \sig ->
|
addMatchCallbackSignal rule $ \sig ->
|
||||||
withDBusClientConnection cb (Just "ethernet-cb.log") $ \c' ->
|
withDBusClientConnection cb Nothing (Just "ethernet-cb.log") $ \c' ->
|
||||||
mapEnv c' $
|
mapEnv c' $
|
||||||
testActiveType contypes sig
|
testActiveType contypes sig
|
||||||
|
|
||||||
|
|
|
@ -4,6 +4,7 @@
|
||||||
-- to signals spawned by commands
|
-- to signals spawned by commands
|
||||||
module Xmobar.Plugins.BacklightCommon (startBacklight) where
|
module Xmobar.Plugins.BacklightCommon (startBacklight) where
|
||||||
|
|
||||||
|
import DBus
|
||||||
import Data.Internal.DBus
|
import Data.Internal.DBus
|
||||||
import RIO
|
import RIO
|
||||||
import qualified RIO.Text as T
|
import qualified RIO.Text as T
|
||||||
|
@ -11,14 +12,15 @@ import Xmobar.Plugins.Common
|
||||||
|
|
||||||
startBacklight
|
startBacklight
|
||||||
:: (MonadUnliftIO m, RealFrac a)
|
:: (MonadUnliftIO m, RealFrac a)
|
||||||
=> Maybe FilePath
|
=> Maybe BusName
|
||||||
|
-> Maybe FilePath
|
||||||
-> ((Maybe a -> DIO SimpleApp SesClient ()) -> DIO SimpleApp SesClient ())
|
-> ((Maybe a -> DIO SimpleApp SesClient ()) -> DIO SimpleApp SesClient ())
|
||||||
-> DIO SimpleApp SesClient (Maybe a)
|
-> DIO SimpleApp SesClient (Maybe a)
|
||||||
-> T.Text
|
-> T.Text
|
||||||
-> Callback
|
-> Callback
|
||||||
-> m ()
|
-> m ()
|
||||||
startBacklight name matchSignal callGetBrightness icon cb = do
|
startBacklight n name matchSignal callGetBrightness icon cb = do
|
||||||
withDBusClientConnection cb name $ \c -> withDIO c $ do
|
withDBusClientConnection cb n name $ \c -> withDIO c $ do
|
||||||
matchSignal dpy
|
matchSignal dpy
|
||||||
dpy =<< callGetBrightness
|
dpy =<< callGetBrightness
|
||||||
where
|
where
|
||||||
|
|
|
@ -54,13 +54,17 @@ data Bluetooth = Bluetooth Icons Colors deriving (Read, Show)
|
||||||
instance Exec Bluetooth where
|
instance Exec Bluetooth where
|
||||||
alias (Bluetooth _ _) = T.unpack btAlias
|
alias (Bluetooth _ _) = T.unpack btAlias
|
||||||
start (Bluetooth icons colors) cb =
|
start (Bluetooth icons colors) cb =
|
||||||
withDBusClientConnection cb (Just "bluetooth.log") $ startAdapter icons colors cb
|
withDBusClientConnection
|
||||||
|
cb
|
||||||
|
(Just "org.xmonad.bluetooth")
|
||||||
|
(Just "bluetooth.log")
|
||||||
|
$ startAdapter icons colors cb
|
||||||
|
|
||||||
startAdapter
|
startAdapter
|
||||||
:: Icons
|
:: Icons
|
||||||
-> Colors
|
-> Colors
|
||||||
-> Callback
|
-> Callback
|
||||||
-> SysClient
|
-> NamedSysConnection
|
||||||
-> RIO SimpleApp ()
|
-> RIO SimpleApp ()
|
||||||
startAdapter is cs cb cl = do
|
startAdapter is cs cb cl = do
|
||||||
state <- newMVar emptyState
|
state <- newMVar emptyState
|
||||||
|
@ -201,7 +205,7 @@ startAdaptorListener adaptor = do
|
||||||
<> displayObjectPath adaptor
|
<> displayObjectPath adaptor
|
||||||
where
|
where
|
||||||
callback sig =
|
callback sig =
|
||||||
withNestedDBusClientConnection Nothing $
|
withNestedDBusClientConnection Nothing Nothing $
|
||||||
withSignalMatch procMatch $
|
withSignalMatch procMatch $
|
||||||
matchPropertyChanged adaptorInterface adaptorPowered sig
|
matchPropertyChanged adaptorInterface adaptorPowered sig
|
||||||
procMatch = beforeDisplay . putPowered
|
procMatch = beforeDisplay . putPowered
|
||||||
|
@ -249,7 +253,7 @@ startConnectedListener adaptor = do
|
||||||
where
|
where
|
||||||
adaptor_ = displayWrapQuote $ displayObjectPath adaptor
|
adaptor_ = displayWrapQuote $ displayObjectPath adaptor
|
||||||
callback sig =
|
callback sig =
|
||||||
withNestedDBusClientConnection Nothing $ do
|
withNestedDBusClientConnection Nothing Nothing $ do
|
||||||
let devpath = signalPath sig
|
let devpath = signalPath sig
|
||||||
when (adaptorHasDevice adaptor devpath) $
|
when (adaptorHasDevice adaptor devpath) $
|
||||||
withSignalMatch (update devpath) $
|
withSignalMatch (update devpath) $
|
||||||
|
|
|
@ -24,4 +24,9 @@ ckAlias = "clevokeyboard"
|
||||||
instance Exec ClevoKeyboard where
|
instance Exec ClevoKeyboard where
|
||||||
alias (ClevoKeyboard _) = T.unpack ckAlias
|
alias (ClevoKeyboard _) = T.unpack ckAlias
|
||||||
start (ClevoKeyboard icon) =
|
start (ClevoKeyboard icon) =
|
||||||
startBacklight (Just "clevo_kbd.log") matchSignalCK callGetBrightnessCK icon
|
startBacklight
|
||||||
|
(Just "org.xmobar.clevo")
|
||||||
|
(Just "clevo_kbd.log")
|
||||||
|
matchSignalCK
|
||||||
|
callGetBrightnessCK
|
||||||
|
icon
|
||||||
|
|
|
@ -26,7 +26,7 @@ import qualified RIO.Text as T
|
||||||
import XMonad.Hooks.DynamicLog (xmobarColor)
|
import XMonad.Hooks.DynamicLog (xmobarColor)
|
||||||
|
|
||||||
data PluginEnv s c = PluginEnv
|
data PluginEnv s c = PluginEnv
|
||||||
{ plugClient :: !c
|
{ plugClient :: !(NamedConnection c)
|
||||||
, plugState :: !(MVar s)
|
, plugState :: !(MVar s)
|
||||||
, plugDisplay :: !(Callback -> PluginIO s c ())
|
, plugDisplay :: !(Callback -> PluginIO s c ())
|
||||||
, plugCallback :: !Callback
|
, plugCallback :: !Callback
|
||||||
|
@ -99,17 +99,18 @@ displayMaybe' cb = maybe (liftIO $ cb $ T.unpack na)
|
||||||
withDBusClientConnection
|
withDBusClientConnection
|
||||||
:: (MonadUnliftIO m, SafeClient c)
|
:: (MonadUnliftIO m, SafeClient c)
|
||||||
=> Callback
|
=> Callback
|
||||||
|
-> Maybe BusName
|
||||||
-> Maybe FilePath
|
-> Maybe FilePath
|
||||||
-> (c -> RIO SimpleApp ())
|
-> (NamedConnection c -> RIO SimpleApp ())
|
||||||
-> m ()
|
-> m ()
|
||||||
withDBusClientConnection cb logfile f =
|
withDBusClientConnection cb n logfile f =
|
||||||
maybe (run stderr) (`withLogFile` run) logfile
|
maybe (run stderr) (`withLogFile` run) logfile
|
||||||
where
|
where
|
||||||
run h = do
|
run h = do
|
||||||
logOpts <- setLogVerboseFormat True . setLogUseTime True <$> logOptionsHandle h False
|
logOpts <- setLogVerboseFormat True . setLogUseTime True <$> logOptionsHandle h False
|
||||||
withLogFunc logOpts $ \lf -> do
|
withLogFunc logOpts $ \lf -> do
|
||||||
env <- mkSimpleApp lf Nothing
|
env <- mkSimpleApp lf Nothing
|
||||||
runRIO env $ displayMaybe' cb f =<< getDBusClient
|
runRIO env $ displayMaybe' cb f =<< getDBusClient n
|
||||||
|
|
||||||
-- | Run a plugin action with a new DBus client and logfile path.
|
-- | Run a plugin action with a new DBus client and logfile path.
|
||||||
-- This is necessary for DBus callbacks which run in separate threads, which
|
-- This is necessary for DBus callbacks which run in separate threads, which
|
||||||
|
@ -117,11 +118,12 @@ withDBusClientConnection cb logfile f =
|
||||||
-- DBus connection and closed its logfile.
|
-- DBus connection and closed its logfile.
|
||||||
withNestedDBusClientConnection
|
withNestedDBusClientConnection
|
||||||
:: (MonadUnliftIO m, SafeClient c, MonadReader (PluginEnv s c) m)
|
:: (MonadUnliftIO m, SafeClient c, MonadReader (PluginEnv s c) m)
|
||||||
=> Maybe FilePath
|
=> Maybe BusName
|
||||||
|
-> Maybe FilePath
|
||||||
-> PluginIO s c ()
|
-> PluginIO s c ()
|
||||||
-> m ()
|
-> m ()
|
||||||
withNestedDBusClientConnection logfile f = do
|
withNestedDBusClientConnection n logfile f = do
|
||||||
dpy <- asks plugDisplay
|
dpy <- asks plugDisplay
|
||||||
s <- asks plugState
|
s <- asks plugState
|
||||||
cb <- asks plugCallback
|
cb <- asks plugCallback
|
||||||
withDBusClientConnection cb logfile $ \c -> mapRIO (PluginEnv c s dpy cb) f
|
withDBusClientConnection cb n logfile $ \c -> mapRIO (PluginEnv c s dpy cb) f
|
||||||
|
|
|
@ -24,4 +24,9 @@ blAlias = "intelbacklight"
|
||||||
instance Exec IntelBacklight where
|
instance Exec IntelBacklight where
|
||||||
alias (IntelBacklight _) = T.unpack blAlias
|
alias (IntelBacklight _) = T.unpack blAlias
|
||||||
start (IntelBacklight icon) =
|
start (IntelBacklight icon) =
|
||||||
startBacklight (Just "intel_backlight.log") matchSignalIB callGetBrightnessIB icon
|
startBacklight
|
||||||
|
(Just "org.xmobar.intelbacklight")
|
||||||
|
(Just "intel_backlight.log")
|
||||||
|
matchSignalIB
|
||||||
|
callGetBrightnessIB
|
||||||
|
icon
|
||||||
|
|
|
@ -25,7 +25,11 @@ ssAlias = "screensaver"
|
||||||
instance Exec Screensaver where
|
instance Exec Screensaver where
|
||||||
alias (Screensaver _) = T.unpack ssAlias
|
alias (Screensaver _) = T.unpack ssAlias
|
||||||
start (Screensaver (text, colors)) cb =
|
start (Screensaver (text, colors)) cb =
|
||||||
withDBusClientConnection cb (Just "screensaver.log") $ \cl -> withDIO cl $ do
|
withDBusClientConnection
|
||||||
|
cb
|
||||||
|
(Just "org.xmobar.screensaver")
|
||||||
|
(Just "screensaver.log")
|
||||||
|
$ \cl -> withDIO cl $ do
|
||||||
matchSignal dpy
|
matchSignal dpy
|
||||||
dpy =<< callQuery
|
dpy =<< callQuery
|
||||||
where
|
where
|
||||||
|
|
Loading…
Reference in New Issue