ENH hold client in monad

This commit is contained in:
Nathan Dwarshuis 2023-01-03 22:18:55 -05:00
parent f95079ba5e
commit a0cdcce146
13 changed files with 385 additions and 199 deletions

View File

@ -1,3 +1,5 @@
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE OverloadedStrings #-}
--------------------------------------------------------------------------------
@ -7,6 +9,10 @@ module Data.Internal.DBus
( SafeClient (..)
, SysClient (..)
, SesClient (..)
, DBusEnv (..)
, DIO
, HasClient (..)
, withDIO
, addMatchCallback
, matchProperty
, matchPropertyFull
@ -102,26 +108,49 @@ getDBusClient' sys = do
return Nothing
Right c -> return $ Just c
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 SafeClient c => HasLogFunc (DBusEnv SimpleApp c) where
logFuncL = lens dEnv (\x y -> x {dEnv = y}) . logFuncL
withDIO
:: (MonadUnliftIO m, MonadReader env m, SafeClient c)
=> c
-> DIO env c a
-> m a
withDIO cl x = do
env <- ask
runRIO (DBusEnv cl env) x
class HasClient env where
clientL :: SafeClient c => Lens' (env c) c
--------------------------------------------------------------------------------
-- Methods
type MethodBody = Either T.Text [Variant]
callMethod' :: (MonadUnliftIO m, SafeClient c) => c -> MethodCall -> m MethodBody
callMethod' cl =
liftIO
. fmap (bimap (T.pack . methodErrorMessage) methodReturnBody)
. call (toClient cl)
callMethod'
:: (SafeClient c, MonadUnliftIO m, MonadReader (env c) m, HasClient env)
=> MethodCall
-> m MethodBody
callMethod' mc = do
cl <- toClient <$> view clientL
liftIO $ bimap (T.pack . methodErrorMessage) methodReturnBody <$> call cl mc
callMethod
:: (MonadUnliftIO m, SafeClient c)
=> c
-> BusName
:: (SafeClient c, MonadUnliftIO m, MonadReader (env c) m, HasClient env)
=> BusName
-> ObjectPath
-> InterfaceName
-> MemberName
-> m MethodBody
callMethod client bus path iface = callMethod' client . methodCallBus bus path iface
callMethod bus path iface = callMethod' . methodCallBus bus path iface
methodCallBus :: BusName -> ObjectPath -> InterfaceName -> MemberName -> MethodCall
methodCallBus b p i m =
@ -136,12 +165,16 @@ dbusInterface :: InterfaceName
dbusInterface = interfaceName_ "org.freedesktop.DBus"
callGetNameOwner
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m, SafeClient c)
=> c
-> BusName
:: ( SafeClient c
, MonadUnliftIO m
, MonadReader (env c) m
, HasClient env
, HasLogFunc (env c)
)
=> BusName
-> m (Maybe BusName)
callGetNameOwner cl name = do
res <- callMethod' cl mc
callGetNameOwner name = do
res <- callMethod' mc
case res of
Left err -> do
logError $ Utf8Builder $ encodeUtf8Builder err
@ -170,13 +203,19 @@ bodyToMaybe = either (const Nothing) fromSingletonVariant
type SignalCallback m = [Variant] -> m ()
addMatchCallback
:: (MonadUnliftIO m, SafeClient c)
:: ( MonadReader (env c) m
, HasLogFunc (env c)
, MonadUnliftIO m
, SafeClient c
, HasClient env
)
=> MatchRule
-> SignalCallback m
-> c
-> m SignalHandler
addMatchCallback rule cb cl = withRunInIO $ \run -> do
addMatch (toClient cl) rule $ run . cb . signalBody
addMatchCallback rule cb = do
cl <- toClient <$> view clientL
withRunInIO $ \run -> do
addMatch cl rule $ run . cb . signalBody
matchSignal
:: Maybe BusName
@ -193,15 +232,19 @@ matchSignal b p i m =
}
matchSignalFull
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m, SafeClient c)
=> c
-> BusName
:: ( MonadReader (env c) m
, HasLogFunc (env c)
, MonadUnliftIO m
, SafeClient c
, HasClient env
)
=> BusName
-> Maybe ObjectPath
-> Maybe InterfaceName
-> Maybe MemberName
-> m (Maybe MatchRule)
matchSignalFull client b p i m = do
res <- callGetNameOwner client b
matchSignalFull b p i m = do
res <- callGetNameOwner b
case res of
Just o -> return $ Just $ matchSignal (Just o) p i m
Nothing -> do
@ -229,15 +272,20 @@ propertySignal :: MemberName
propertySignal = memberName_ "PropertiesChanged"
callPropertyGet
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m, SafeClient c)
:: ( HasClient env
, MonadReader (env c) m
, HasLogFunc (env c)
, MonadUnliftIO m
, SafeClient c
)
=> BusName
-> ObjectPath
-> InterfaceName
-> MemberName
-> c
-> m [Variant]
callPropertyGet bus path iface property cl = do
res <- liftIO $ getProperty (toClient cl) $ methodCallBus bus path iface property
callPropertyGet bus path iface property = do
cl <- toClient <$> view clientL
res <- liftIO $ getProperty cl $ methodCallBus bus path iface property
case res of
Left err -> do
logError $ displayBytesUtf8 $ BC.pack $ methodErrorMessage err
@ -249,13 +297,17 @@ matchProperty b p =
matchSignal b p (Just propertyInterface) (Just propertySignal)
matchPropertyFull
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m, SafeClient c)
=> c
-> BusName
:: ( MonadReader (env c) m
, HasLogFunc (env c)
, MonadUnliftIO m
, SafeClient c
, HasClient env
)
=> BusName
-> Maybe ObjectPath
-> m (Maybe MatchRule)
matchPropertyFull cl b p =
matchSignalFull cl b p (Just propertyInterface) (Just propertySignal)
matchPropertyFull b p =
matchSignalFull b p (Just propertyInterface) (Just propertySignal)
data SignalMatch a = Match a | NoMatch | Failure deriving (Eq, Show)
@ -301,13 +353,17 @@ omInterfacesRemoved :: MemberName
omInterfacesRemoved = memberName_ "InterfacesRemoved"
callGetManagedObjects
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m, SafeClient c)
=> c
-> BusName
:: ( MonadReader (env c) m
, HasLogFunc (env c)
, MonadUnliftIO m
, SafeClient c
, HasClient env
)
=> BusName
-> ObjectPath
-> m ObjectTree
callGetManagedObjects cl bus path = do
res <- callMethod cl bus path omInterface getManagedObjects
callGetManagedObjects bus path = do
res <- callMethod bus path omInterface getManagedObjects
case res of
Left err -> do
logError $ Utf8Builder $ encodeUtf8Builder err
@ -315,15 +371,19 @@ callGetManagedObjects cl bus path = do
Right v -> return $ fromMaybe M.empty $ fromSingletonVariant v
addInterfaceChangedListener
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m, SafeClient c)
:: ( MonadReader (env c) m
, HasLogFunc (env c)
, MonadUnliftIO m
, SafeClient c
, HasClient env
)
=> BusName
-> MemberName
-> ObjectPath
-> SignalCallback m
-> c
-> m (Maybe SignalHandler)
addInterfaceChangedListener bus prop path sc cl = do
res <- matchSignalFull cl bus (Just path) (Just omInterface) (Just prop)
addInterfaceChangedListener bus prop path sc = do
res <- matchSignalFull bus (Just path) (Just omInterface) (Just prop)
case res of
Nothing -> do
logError $
@ -334,28 +394,36 @@ addInterfaceChangedListener bus prop path sc cl = do
<> " on bus "
<> bus_
return Nothing
Just rule -> Just <$> addMatchCallback rule sc cl
Just rule -> Just <$> addMatchCallback rule sc
where
bus_ = "'" <> displayBusName bus <> "'"
path_ = "'" <> displayObjectPath path <> "'"
prop_ = "'" <> displayMemberName prop <> "'"
addInterfaceAddedListener
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m, SafeClient c)
:: ( MonadReader (env c) m
, HasLogFunc (env c)
, MonadUnliftIO m
, SafeClient c
, HasClient env
)
=> BusName
-> ObjectPath
-> SignalCallback m
-> c
-> m (Maybe SignalHandler)
addInterfaceAddedListener bus =
addInterfaceChangedListener bus omInterfacesAdded
addInterfaceRemovedListener
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m, SafeClient c)
:: ( MonadReader (env c) m
, HasLogFunc (env c)
, MonadUnliftIO m
, SafeClient c
, HasClient env
)
=> BusName
-> ObjectPath
-> SignalCallback m
-> c
-> m (Maybe SignalHandler)
addInterfaceRemovedListener bus =
addInterfaceChangedListener bus omInterfacesRemoved

View File

@ -1,5 +1,7 @@
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
@ -404,9 +406,15 @@ data XEnv = XEnv
instance HasLogFunc XEnv where
logFuncL = lens xLogFun (\x y -> x {xLogFun = y})
instance SafeClient c => HasLogFunc (DBusEnv XEnv c) where
logFuncL = lens dEnv (\x y -> x {dEnv = y}) . logFuncL
instance HasProcessContext XEnv where
processContextL = lens xProcCxt (\x y -> x {xProcCxt = y})
instance HasClient (DBusEnv XEnv) where
clientL = lens dClient (\x y -> x {dClient = y})
data XParams = XParams
{ xpLogLevel :: LogLevel
, xpFeatures :: XPFeatures
@ -865,8 +873,8 @@ testDBusDep_ :: SafeClient c => c -> DBusDependency_ c -> XIO MResult_
testDBusDep_ c d = memoizeMVar $ testDBusDepNoCache_ c d
testDBusDepNoCache_ :: SafeClient c => c -> DBusDependency_ c -> XIO Result_
testDBusDepNoCache_ cl (Bus _ bus) = io $ do
ret <- callMethod cl queryBus queryPath queryIface queryMem
testDBusDepNoCache_ cl (Bus _ bus) = do
ret <- withDIO cl $ callMethod queryBus queryPath queryIface queryMem
return $ case ret of
Left e -> Left [Msg LevelError e]
Right b ->
@ -885,8 +893,10 @@ testDBusDepNoCache_ cl (Bus _ bus) = io $ do
queryMem = memberName_ "ListNames"
bodyGetNames [v] = fromMaybe [] $ fromVariant v :: [T.Text]
bodyGetNames _ = []
testDBusDepNoCache_ cl (Endpoint _ busname objpath iface mem) = io $ do
ret <- callMethod cl busname objpath introspectInterface introspectMethod
testDBusDepNoCache_ cl (Endpoint _ busname objpath iface mem) = do
ret <-
withDIO cl $
callMethod busname objpath introspectInterface introspectMethod
return $ case ret of
Left e -> Left [Msg LevelError e]
Right body -> procBody body
@ -1001,8 +1011,9 @@ sometimesDBus
-> Sometimes a
sometimesDBus c fn n t x = sometimes1 fn n $ DBusRoot_ x t c
-- TODO do I need to hardcode XEnv?
sometimesEndpoint
:: (SafeClient c, MonadIO m)
:: (HasClient (DBusEnv env), SafeClient c, MonadReader env m, MonadUnliftIO m)
=> T.Text
-> T.Text
-> [Fulfillment]
@ -1016,7 +1027,7 @@ sometimesEndpoint fn name ful busname path iface mem cl =
sometimesDBus cl fn name deps cmd
where
deps = Only_ $ Endpoint ful busname path iface $ Method_ mem
cmd c = io $ void $ callMethod c busname path iface mem
cmd c = void $ withDIO c $ callMethod busname path iface mem
--------------------------------------------------------------------------------
-- Dependency Tree Constructors

View File

@ -1,3 +1,4 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
--------------------------------------------------------------------------------
@ -128,15 +129,24 @@ exportClevoKeyboard =
[stateFileDep, brightnessFileDep]
clevoKeyboardConfig
clevoKeyboardControls :: MonadUnliftIO m => Maybe SesClient -> BrightnessControls m
clevoKeyboardControls
:: (HasClient (DBusEnv env), MonadReader env m, MonadUnliftIO m)
=> Maybe SesClient
-> BrightnessControls m
clevoKeyboardControls = brightnessControls xpfClevoBacklight clevoKeyboardConfig
callGetBrightnessCK :: MonadUnliftIO m => SesClient -> m (Maybe Brightness)
callGetBrightnessCK
:: (SafeClient c, HasClient env, MonadReader (env c) m, MonadUnliftIO m)
=> m (Maybe Brightness)
callGetBrightnessCK = callGetBrightness clevoKeyboardConfig
matchSignalCK
:: MonadUnliftIO m
:: ( SafeClient c
, HasLogFunc (env c)
, HasClient env
, MonadReader (env c) m
, MonadUnliftIO m
)
=> (Maybe Brightness -> m ())
-> SesClient
-> m ()
matchSignalCK = matchSignal clevoKeyboardConfig

View File

@ -1,3 +1,4 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}
@ -22,7 +23,6 @@ import Data.Internal.DBus
import Data.Internal.XIO
import RIO
import qualified RIO.Text as T
import XMonad.Core (io)
import XMonad.Internal.DBus.Common
--------------------------------------------------------------------------------
@ -54,7 +54,7 @@ data BrightnessControls m = BrightnessControls
}
brightnessControls
:: MonadUnliftIO m
:: (HasClient (DBusEnv env), MonadReader env m, MonadUnliftIO m)
=> XPQuery
-> BrightnessConfig m a b
-> Maybe SesClient
@ -70,26 +70,35 @@ brightnessControls q bc cl =
cb = callBacklight q cl bc
callGetBrightness
:: (MonadUnliftIO m, SafeClient c, Num n)
:: ( HasClient env
, MonadReader (env c) m
, MonadUnliftIO m
, SafeClient c
, Num n
)
=> BrightnessConfig m a b
-> c
-> m (Maybe n)
callGetBrightness BrightnessConfig {bcPath = p, bcInterface = i} client =
callGetBrightness BrightnessConfig {bcPath = p, bcInterface = i} =
either (const Nothing) bodyGetBrightness
<$> callMethod client xmonadBusName p i memGet
<$> callMethod xmonadBusName p i memGet
signalDep :: BrightnessConfig m a b -> DBusDependency_ SesClient
signalDep BrightnessConfig {bcPath = p, bcInterface = i} =
Endpoint [] xmonadBusName p i $ Signal_ memCur
matchSignal
:: (MonadUnliftIO m, SafeClient c, Num n)
:: ( HasClient env
, HasLogFunc (env c)
, MonadReader (env c) m
, MonadUnliftIO m
, SafeClient c
, Num n
)
=> BrightnessConfig m a b
-> (Maybe n -> m ())
-> c
-> m ()
matchSignal BrightnessConfig {bcPath = p, bcInterface = i} cb =
void . addMatchCallback brMatcher (cb . bodyGetBrightness)
void $ addMatchCallback brMatcher (cb . bodyGetBrightness)
where
-- TODO add busname to this
brMatcher =
@ -166,27 +175,18 @@ emitBrightness BrightnessConfig {bcPath = p, bcInterface = i} client cur =
sig = signal p i memCur
callBacklight
:: MonadUnliftIO m
:: (MonadReader env m, HasClient (DBusEnv env), MonadUnliftIO m)
=> XPQuery
-> Maybe SesClient
-> BrightnessConfig m a b
-> T.Text
-> MemberName
-> Sometimes (m ())
callBacklight
q
cl
BrightnessConfig
{ bcPath = p
, bcInterface = i
, bcName = n
}
controlName
m =
callBacklight q cl BrightnessConfig {bcPath = p, bcInterface = i, bcName = n} controlName m =
Sometimes (T.unwords [n, controlName]) q [Subfeature root "method call"]
where
root = DBusRoot_ cmd (Only_ $ Endpoint [] xmonadBusName p i $ Method_ m) cl
cmd c = io $ void $ callMethod c xmonadBusName p i m
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,4 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
--------------------------------------------------------------------------------
@ -114,15 +115,24 @@ exportIntelBacklight =
[curFileDep, maxFileDep]
intelBacklightConfig
intelBacklightControls :: MonadUnliftIO m => Maybe SesClient -> BrightnessControls m
intelBacklightControls
:: (HasClient (DBusEnv env), MonadReader env m, MonadUnliftIO m)
=> Maybe SesClient
-> BrightnessControls m
intelBacklightControls = brightnessControls xpfIntelBacklight intelBacklightConfig
callGetBrightnessIB :: MonadUnliftIO m => SesClient -> m (Maybe Brightness)
callGetBrightnessIB
:: (SafeClient c, HasClient env, MonadReader (env c) m, MonadUnliftIO m)
=> m (Maybe Brightness)
callGetBrightnessIB = callGetBrightness intelBacklightConfig
matchSignalIB
:: MonadUnliftIO m
:: ( SafeClient c
, HasLogFunc (env c)
, HasClient env
, MonadReader (env c) m
, MonadUnliftIO m
)
=> (Maybe Brightness -> m ())
-> SesClient
-> m ()
matchSignalIB = matchSignal intelBacklightConfig

View File

@ -1,3 +1,4 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
--------------------------------------------------------------------------------
@ -80,17 +81,31 @@ playSoundMaybe p b = when b $ io $ playSound p
-- If it not already, we won't see any signals from the dbus until it is
-- started (it will work after it is started however). It seems safe to simply
-- enable the udisks2 service at boot; however this is not default behavior.
listenDevices :: MonadUnliftIO m => SysClient -> m ()
listenDevices
:: ( HasClient (DBusEnv env)
, HasLogFunc (DBusEnv env SysClient)
, MonadReader env m
, MonadUnliftIO m
)
=> SysClient
-> m ()
listenDevices cl = do
addMatch' memAdded driveInsertedSound addedHasDrive
addMatch' memRemoved driveRemovedSound removedHasDrive
where
addMatch' m p f = do
let rule = ruleUdisks {matchMember = Just m}
void $ addMatchCallback rule (playSoundMaybe p . f) cl
void $ withDIO cl $ addMatchCallback rule (playSoundMaybe p . f)
runRemovableMon :: MonadUnliftIO m => Maybe SysClient -> Sometimes (m ())
runRemovableMon
:: ( HasClient (DBusEnv env)
, HasLogFunc (DBusEnv env SysClient)
, MonadReader env m
, MonadUnliftIO m
)
=> Maybe SysClient
-> Sometimes (m ())
runRemovableMon cl =
sometimesDBus cl "removeable device monitor" "dbus monitor" deps $ io . listenDevices
sometimesDBus cl "removeable device monitor" "dbus monitor" deps listenDevices
where
deps = toAnd_ addedDep removedDep

View File

@ -1,3 +1,4 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
--------------------------------------------------------------------------------
@ -124,7 +125,10 @@ exportScreensaver ses =
bus = Bus [] xmonadBusName
ssx = DBusIO $ sysExe [Package Official "xorg-xset"] ssExecutable
callToggle :: MonadUnliftIO m => Maybe SesClient -> Sometimes (m ())
callToggle
:: (HasClient (DBusEnv env), MonadReader env m, MonadUnliftIO m)
=> Maybe SesClient
-> Sometimes (m ())
callToggle =
sometimesEndpoint
"screensaver toggle"
@ -135,18 +139,26 @@ callToggle =
interface
memToggle
callQuery :: MonadUnliftIO m => SesClient -> m (Maybe SSState)
callQuery ses = do
reply <- callMethod ses xmonadBusName ssPath interface memQuery
callQuery
:: (HasClient env, MonadReader (env SesClient) m, MonadUnliftIO m)
=> m (Maybe SSState)
callQuery = do
reply <- callMethod xmonadBusName ssPath interface memQuery
return $ either (const Nothing) bodyGetCurrentState reply
matchSignal :: MonadUnliftIO m => (Maybe SSState -> m ()) -> SesClient -> m ()
matchSignal cb ses =
matchSignal
:: ( HasLogFunc (env SesClient)
, HasClient env
, MonadReader (env SesClient) m
, MonadUnliftIO m
)
=> (Maybe SSState -> m ())
-> m ()
matchSignal cb =
void $
addMatchCallback
ruleCurrentState
(cb . bodyGetCurrentState)
ses
ssSignalDep :: DBusDependency_ SesClient
ssSignalDep = Endpoint [] xmonadBusName ssPath interface $ Signal_ memState

View File

@ -14,15 +14,15 @@ import Xmobar.Plugins.Common
startBacklight
:: (MonadUnliftIO m, RealFrac a)
=> Utf8Builder
-> ((Maybe a -> RIO SimpleApp ()) -> SesClient -> RIO SimpleApp ())
-> (SesClient -> RIO SimpleApp (Maybe a))
-> ((Maybe a -> DIO SimpleApp SesClient ()) -> DIO SimpleApp SesClient ())
-> DIO SimpleApp SesClient (Maybe a)
-> T.Text
-> Callback
-> m ()
startBacklight name matchSignal callGetBrightness icon cb = do
withDBusClientConnection cb name $ \c -> do
matchSignal dpy c
dpy =<< callGetBrightness c
withDBusClientConnection cb name $ \c -> withDIO c $ do
matchSignal dpy
dpy =<< callGetBrightness
where
formatBrightness b = return $ T.concat [icon, T.pack $ show (round b :: Integer), "%"]
dpy = displayMaybe cb formatBrightness

View File

@ -76,19 +76,19 @@ startAdapter
startAdapter is cs cb cl = do
state <- newMVar emptyState
let dpy = displayIcon cb (iconFormatter is cs)
mapRIO (BTEnv state dpy) $ do
ot <- getBtObjectTree cl
mapRIO (BTEnv cl state dpy) $ do
ot <- getBtObjectTree
case findAdapter ot of
Nothing -> logError "could not find bluetooth adapter"
Just adapter -> do
-- set up adapter
initAdapter adapter cl
void $ addAdaptorListener adapter cl
initAdapter adapter
void $ addAdaptorListener adapter
-- set up devices on the adapter (and listeners for adding/removing devices)
let devices = findDevices adapter ot
addDeviceAddedListener adapter cl
addDeviceRemovedListener adapter cl
forM_ devices $ \d -> addAndInitDevice d cl
addDeviceAddedListener adapter
addDeviceRemovedListener adapter
forM_ devices $ \d -> addAndInitDevice d
-- after setting things up, show the icon based on the initialized state
dpy
@ -121,16 +121,20 @@ iconFormatter (iconConn, iconDisc) cs powered connected =
-- is to track the shared state of the bluetooth adaptor and its devices using
-- an MVar.
data BTEnv = BTEnv
{ btState :: !(MVar BtState)
data BTEnv c = BTEnv
{ btClient :: !c
, btState :: !(MVar BtState)
, btDisplay :: !(BTIO ())
, btEnv :: !SimpleApp
}
instance HasLogFunc BTEnv where
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
type BTIO = RIO (BTEnv SysClient)
data BTDevice = BTDevice
{ btDevConnected :: Maybe Bool
@ -183,34 +187,43 @@ splitPathNoRoot :: ObjectPath -> [FilePath]
splitPathNoRoot = dropWhile (== "/") . splitDirectories . formatObjectPath
getBtObjectTree
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
=> SysClient
-> m ObjectTree
getBtObjectTree sys = callGetManagedObjects sys btBus btOMPath
:: ( HasClient env
, SafeClient c
, MonadReader (env c) m
, HasLogFunc (env c)
, MonadUnliftIO m
)
=> m ObjectTree
getBtObjectTree = callGetManagedObjects btBus btOMPath
btOMPath :: ObjectPath
btOMPath = objectPath_ "/"
addBtOMListener
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
:: ( HasClient env
, SafeClient c
, MonadReader (env c) m
, HasLogFunc (env c)
, MonadUnliftIO m
)
=> SignalCallback m
-> SysClient
-> m ()
addBtOMListener sc = void . addInterfaceAddedListener btBus btOMPath sc
addBtOMListener sc = void $ addInterfaceAddedListener btBus btOMPath sc
addDeviceAddedListener :: ObjectPath -> SysClient -> BTIO ()
addDeviceAddedListener adapter client = addBtOMListener addDevice client
addDeviceAddedListener :: ObjectPath -> BTIO ()
addDeviceAddedListener adapter = addBtOMListener addDevice
where
addDevice = pathCallback adapter $ \d ->
addAndInitDevice d client
addAndInitDevice d
addDeviceRemovedListener :: ObjectPath -> SysClient -> BTIO ()
addDeviceRemovedListener adapter sys =
addBtOMListener remDevice sys
addDeviceRemovedListener :: ObjectPath -> BTIO ()
addDeviceRemovedListener adapter =
addBtOMListener remDevice
where
remDevice = pathCallback adapter $ \d -> do
old <- removeDevice d
forM_ old $ liftIO . removeMatch (toClient sys) . btDevSigHandler
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
@ -220,9 +233,9 @@ pathCallback _ _ _ = return ()
--------------------------------------------------------------------------------
-- Adapter
initAdapter :: ObjectPath -> SysClient -> BTIO ()
initAdapter adapter client = do
reply <- callGetPowered adapter client
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"
@ -231,24 +244,33 @@ initAdapter adapter client = do
adapter_ = displayWrapQuote $ displayObjectPath adapter
matchBTProperty
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
=> SysClient
-> ObjectPath
:: ( SafeClient c
, HasClient env
, MonadReader (env c) m
, HasLogFunc (env c)
, MonadUnliftIO m
)
=> ObjectPath
-> m (Maybe MatchRule)
matchBTProperty sys p = matchPropertyFull sys btBus (Just p)
matchBTProperty p = matchPropertyFull btBus (Just p)
withBTPropertyRule
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m, IsVariant a)
=> SysClient
-> ObjectPath
:: ( 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 cl path update iface prop = do
res <- matchBTProperty cl path
withBTPropertyRule path update iface prop = do
res <- matchBTProperty path
case res of
Just rule -> Just <$> addMatchCallback rule (signalToUpdate . matchConnected) cl
Just rule -> Just <$> addMatchCallback rule (signalToUpdate . matchConnected)
Nothing -> do
logError $
"could not add listener for prop "
@ -262,16 +284,20 @@ withBTPropertyRule cl path update iface prop = do
signalToUpdate = withSignalMatch update
matchConnected = matchPropertyChanged iface prop
addAdaptorListener :: ObjectPath -> SysClient -> BTIO (Maybe SignalHandler)
addAdaptorListener adaptor sys =
withBTPropertyRule sys adaptor procMatch adapterInterface adaptorPowered
addAdaptorListener :: ObjectPath -> BTIO (Maybe SignalHandler)
addAdaptorListener adaptor =
withBTPropertyRule adaptor procMatch adapterInterface adaptorPowered
where
procMatch = beforeDisplay . putPowered
callGetPowered
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
:: ( HasClient env
, MonadReader (env c) m
, HasLogFunc (env c)
, SafeClient c
, MonadUnliftIO m
)
=> ObjectPath
-> SysClient
-> m [Variant]
callGetPowered adapter =
callPropertyGet btBus adapter adapterInterface $
@ -293,20 +319,20 @@ adaptorPowered = "Powered"
--------------------------------------------------------------------------------
-- Devices
addAndInitDevice :: ObjectPath -> SysClient -> BTIO ()
addAndInitDevice device client = do
res <- addDeviceListener device client
addAndInitDevice :: ObjectPath -> BTIO ()
addAndInitDevice device = do
res <- addDeviceListener device
case res of
Just handler -> do
logInfo $ "initializing device at path " <> device_
initDevice handler device client
initDevice handler device
Nothing -> logError $ "could not initialize device at path " <> device_
where
device_ = displayWrapQuote $ displayObjectPath device
initDevice :: SignalHandler -> ObjectPath -> SysClient -> BTIO ()
initDevice sh device sys = do
reply <- callGetConnected device sys
initDevice :: SignalHandler -> ObjectPath -> BTIO ()
initDevice sh device = do
reply <- callGetConnected device
void $
insertDevice device $
BTDevice
@ -314,16 +340,20 @@ initDevice sh device sys = do
, btDevSigHandler = sh
}
addDeviceListener :: ObjectPath -> SysClient -> BTIO (Maybe SignalHandler)
addDeviceListener device sys =
withBTPropertyRule sys device procMatch devInterface devConnected
addDeviceListener :: ObjectPath -> BTIO (Maybe SignalHandler)
addDeviceListener device =
withBTPropertyRule device procMatch devInterface devConnected
where
procMatch = beforeDisplay . void . updateDevice device
callGetConnected
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
:: ( SafeClient c
, HasClient env
, MonadReader (env c) m
, HasLogFunc (env c)
, MonadUnliftIO m
)
=> ObjectPath
-> SysClient
-> m [Variant]
callGetConnected p =
callPropertyGet btBus p devInterface $

View File

@ -32,18 +32,23 @@ data Colors = Colors
deriving (Eq, Show, Read)
startListener
:: (MonadUnliftIO m, SafeClient c, IsVariant a)
:: ( HasLogFunc (env c)
, HasClient env
, MonadReader (env c) m
, MonadUnliftIO m
, SafeClient c
, IsVariant a
)
=> MatchRule
-> (c -> m [Variant])
-> m [Variant]
-> ([Variant] -> SignalMatch a)
-> (a -> m T.Text)
-> Callback
-> c
-> m ()
startListener rule getProp fromSignal toColor cb client = do
reply <- getProp client
startListener rule getProp fromSignal toColor cb = do
reply <- getProp
displayMaybe cb toColor $ fromSingletonVariant reply
void $ addMatchCallback rule (procMatch . fromSignal) client
void $ addMatchCallback rule (procMatch . fromSignal)
where
procMatch = procSignalMatch cb toColor

View File

@ -1,4 +1,5 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
--------------------------------------------------------------------------------
-- Device plugin
@ -44,8 +45,11 @@ devDep =
Endpoint networkManagerPkgs networkManagerBus nmPath nmInterface $
Method_ getByIP
getDevice :: MonadUnliftIO m => SysClient -> T.Text -> m (Maybe ObjectPath)
getDevice sys iface = bodyToMaybe <$> callMethod' sys mc
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)
@ -53,9 +57,13 @@ getDevice sys iface = bodyToMaybe <$> callMethod' sys mc
}
getDeviceConnected
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
:: ( SafeClient c
, HasClient env
, MonadReader (env c) m
, HasLogFunc (env c)
, MonadUnliftIO m
)
=> ObjectPath
-> SysClient
-> m [Variant]
getDeviceConnected path =
callPropertyGet networkManagerBus path nmDeviceInterface $
@ -68,14 +76,14 @@ matchStatus = matchPropertyChanged nmDeviceInterface devSignal
instance Exec Device where
alias (Device (iface, _, _)) = T.unpack iface
start (Device (iface, text, colors)) cb =
withDBusClientConnection cb logName $ \sys -> do
path <- getDevice sys iface
displayMaybe' cb (listener sys) path
withDBusClientConnection cb logName $ \(sys :: SysClient) -> withDIO sys $ do
path <- getDevice iface
displayMaybe' cb listener path
where
logName = "device@" <> Utf8Builder (encodeUtf8Builder iface)
listener sys path = do
res <- matchPropertyFull sys networkManagerBus (Just path)
listener path = do
res <- matchPropertyFull networkManagerBus (Just path)
case res of
Just rule -> startListener rule (getDeviceConnected path) matchStatus chooseColor' cb sys
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

@ -12,6 +12,7 @@ module Xmobar.Plugins.Screensaver
)
where
import Data.Internal.DBus
import qualified RIO.Text as T
import XMonad.Internal.DBus.Screensaver
import Xmobar
@ -25,8 +26,8 @@ ssAlias = "screensaver"
instance Exec Screensaver where
alias (Screensaver _) = T.unpack ssAlias
start (Screensaver (text, colors)) cb =
withDBusClientConnection cb "screensaver" $ \sys -> do
matchSignal dpy sys
dpy =<< callQuery sys
withDBusClientConnection cb "screensaver" $ \cl -> withDIO cl $ do
matchSignal dpy
dpy =<< callQuery
where
dpy = displayMaybe cb $ return . (\s -> colorText colors s text)

View File

@ -1,3 +1,4 @@
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
--------------------------------------------------------------------------------
@ -32,11 +33,12 @@ instance Exec VPN where
alias (VPN _) = T.unpack vpnAlias
start (VPN (text, colors)) cb =
withDBusClientConnection cb "VPN" $ \c -> do
state <- initState c
let dpy = displayMaybe cb iconFormatter . Just =<< readState
mapRIO (VEnv state dpy) $ do
vpnAddedListener addedCallback c
vpnRemovedListener removedCallback c
s <- newMVar S.empty
mapRIO (VEnv c s dpy) $ do
initState
vpnAddedListener addedCallback
vpnRemovedListener removedCallback
dpy
where
iconFormatter b = return $ colorText colors b text
@ -48,28 +50,30 @@ instance Exec VPN where
-- 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 = VEnv
{ vState :: !MutableVPNState
data VEnv c = VEnv
{ vClient :: !c
, vState :: !MutableVPNState
, vDisplay :: !(VIO ())
, vEnv :: !SimpleApp
}
instance HasLogFunc VEnv where
instance HasLogFunc (VEnv SysClient) where
logFuncL = lens vEnv (\x y -> x {vEnv = y}) . logFuncL
type VIO = RIO VEnv
instance HasClient VEnv where
clientL = lens vClient (\x y -> x {vClient = y})
type VIO = RIO (VEnv SysClient)
type VPNState = S.Set ObjectPath
type MutableVPNState = MVar VPNState
initState
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
=> SysClient
-> m MutableVPNState
initState client = do
ot <- getVPNObjectTree client
newMVar $ findTunnels ot
initState :: VIO ()
initState = do
ot <- getVPNObjectTree
s <- asks vState
putMVar s $ findTunnels ot
readState :: VIO Bool
readState = fmap (not . null) . readMVar =<< asks vState
@ -86,27 +90,39 @@ beforeDisplay f = f >> join (asks vDisplay)
-- Tunnel Device Detection
getVPNObjectTree
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
=> SysClient
-> m ObjectTree
getVPNObjectTree sys = callGetManagedObjects sys vpnBus vpnPath
:: ( 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
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
:: ( SafeClient c
, HasClient env
, MonadReader (env c) m
, HasLogFunc (env c)
, MonadUnliftIO m
)
=> SignalCallback m
-> SysClient
-> m ()
vpnAddedListener cb = void . addInterfaceAddedListener vpnBus vpnPath cb
vpnAddedListener cb = void $ addInterfaceAddedListener vpnBus vpnPath cb
vpnRemovedListener
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
:: ( SafeClient c
, HasClient env
, MonadReader (env c) m
, HasLogFunc (env c)
, MonadUnliftIO m
)
=> SignalCallback m
-> SysClient
-> m ()
vpnRemovedListener cb = void . addInterfaceRemovedListener vpnBus vpnPath cb
vpnRemovedListener cb = void $ addInterfaceRemovedListener vpnBus vpnPath cb
addedCallback :: SignalCallback VIO
addedCallback [device, added] =