Compare commits

...

11 Commits

10 changed files with 236 additions and 156 deletions

View File

@ -28,13 +28,13 @@ module Data.Internal.DBus
)
where
import Control.Exception
import Control.Monad
import DBus
import DBus.Client
import Data.Bifunctor
import qualified Data.Map.Strict as M
import Data.Maybe
import RIO
import qualified RIO.Text as T
--------------------------------------------------------------------------------
@ -43,23 +43,23 @@ import qualified RIO.Text as T
class SafeClient c where
toClient :: c -> Client
getDBusClient :: IO (Maybe c)
getDBusClient :: MonadUnliftIO m => m (Maybe c)
disconnectDBusClient :: c -> IO ()
disconnectDBusClient = disconnect . toClient
disconnectDBusClient :: MonadUnliftIO m => c -> m ()
disconnectDBusClient = liftIO . disconnect . toClient
withDBusClient :: (c -> IO a) -> IO (Maybe a)
withDBusClient :: MonadUnliftIO m => (c -> m a) -> m (Maybe a)
withDBusClient f = do
client <- getDBusClient
forM client $ \c -> do
r <- f c
disconnect (toClient c)
liftIO $ disconnect (toClient c)
return r
withDBusClient_ :: (c -> IO ()) -> IO ()
withDBusClient_ :: MonadUnliftIO m => (c -> m ()) -> m ()
withDBusClient_ = void . withDBusClient
fromDBusClient :: (c -> a) -> IO (Maybe a)
fromDBusClient :: MonadUnliftIO m => (c -> a) -> m (Maybe a)
fromDBusClient f = withDBusClient (return . f)
newtype SysClient = SysClient Client
@ -76,11 +76,11 @@ instance SafeClient SesClient where
getDBusClient = fmap SesClient <$> getDBusClient' False
getDBusClient' :: Bool -> IO (Maybe Client)
getDBusClient' :: MonadUnliftIO m => Bool -> m (Maybe Client)
getDBusClient' sys = do
res <- try $ if sys then connectSystem else connectSession
res <- try $ liftIO $ if sys then connectSystem else connectSession
case res of
Left e -> putStrLn (clientErrorMessage e) >> return Nothing
Left e -> liftIO $ putStrLn (clientErrorMessage e) >> return Nothing
Right c -> return $ Just c
--------------------------------------------------------------------------------
@ -88,19 +88,20 @@ getDBusClient' sys = do
type MethodBody = Either T.Text [Variant]
callMethod' :: SafeClient c => c -> MethodCall -> IO MethodBody
callMethod' :: (MonadUnliftIO m, SafeClient c) => c -> MethodCall -> m MethodBody
callMethod' cl =
fmap (bimap (T.pack . methodErrorMessage) methodReturnBody)
liftIO
. fmap (bimap (T.pack . methodErrorMessage) methodReturnBody)
. call (toClient cl)
callMethod
:: SafeClient c
:: (MonadUnliftIO m, SafeClient c)
=> c
-> BusName
-> ObjectPath
-> InterfaceName
-> MemberName
-> IO MethodBody
-> m MethodBody
callMethod client bus path iface = callMethod' client . methodCallBus bus path iface
methodCallBus :: BusName -> ObjectPath -> InterfaceName -> MemberName -> MethodCall
@ -115,7 +116,7 @@ methodCallBus b p i m =
dbusInterface :: InterfaceName
dbusInterface = interfaceName_ "org.freedesktop.DBus"
callGetNameOwner :: SafeClient c => c -> BusName -> IO (Maybe BusName)
callGetNameOwner :: (MonadUnliftIO m, SafeClient c) => c -> BusName -> m (Maybe BusName)
callGetNameOwner cl name = bodyToMaybe <$> callMethod' cl mc
where
mc =
@ -136,15 +137,16 @@ bodyToMaybe = either (const Nothing) fromSingletonVariant
--------------------------------------------------------------------------------
-- Signals
type SignalCallback = [Variant] -> IO ()
type SignalCallback m = [Variant] -> m ()
addMatchCallback
:: SafeClient c
:: (MonadUnliftIO m, SafeClient c)
=> MatchRule
-> SignalCallback
-> SignalCallback m
-> c
-> IO SignalHandler
addMatchCallback rule cb cl = addMatch (toClient cl) rule $ cb . signalBody
-> m SignalHandler
addMatchCallback rule cb cl = withRunInIO $ \run -> do
addMatch (toClient cl) rule $ run . cb . signalBody
matchSignal
:: Maybe BusName
@ -161,13 +163,13 @@ matchSignal b p i m =
}
matchSignalFull
:: SafeClient c
:: (MonadUnliftIO m, SafeClient c)
=> c
-> BusName
-> Maybe ObjectPath
-> Maybe InterfaceName
-> Maybe MemberName
-> IO (Maybe MatchRule)
-> m (Maybe MatchRule)
matchSignalFull client b p i m =
fmap (\o -> matchSignal (Just o) p i m) <$> callGetNameOwner client b
@ -181,34 +183,35 @@ propertySignal :: MemberName
propertySignal = memberName_ "PropertiesChanged"
callPropertyGet
:: SafeClient c
:: (MonadUnliftIO m, SafeClient c)
=> BusName
-> ObjectPath
-> InterfaceName
-> MemberName
-> c
-> IO [Variant]
-> m [Variant]
callPropertyGet bus path iface property cl =
fmap (either (const []) (: [])) $
getProperty (toClient cl) $
methodCallBus bus path iface property
liftIO $
fmap (either (const []) (: [])) $
getProperty (toClient cl) $
methodCallBus bus path iface property
matchProperty :: Maybe BusName -> Maybe ObjectPath -> MatchRule
matchProperty b p =
matchSignal b p (Just propertyInterface) (Just propertySignal)
matchPropertyFull
:: SafeClient c
:: (MonadUnliftIO m, SafeClient c)
=> c
-> BusName
-> Maybe ObjectPath
-> IO (Maybe MatchRule)
-> m (Maybe MatchRule)
matchPropertyFull cl b p =
matchSignalFull cl b p (Just propertyInterface) (Just propertySignal)
data SignalMatch a = Match a | NoMatch | Failure deriving (Eq, Show)
withSignalMatch :: (Maybe a -> IO ()) -> SignalMatch a -> IO ()
withSignalMatch :: MonadUnliftIO m => (Maybe a -> m ()) -> SignalMatch a -> m ()
withSignalMatch f (Match x) = f (Just x)
withSignalMatch f Failure = f Nothing
withSignalMatch _ NoMatch = return ()
@ -250,43 +253,43 @@ omInterfacesRemoved :: MemberName
omInterfacesRemoved = memberName_ "InterfacesRemoved"
callGetManagedObjects
:: SafeClient c
:: (MonadUnliftIO m, SafeClient c)
=> c
-> BusName
-> ObjectPath
-> IO ObjectTree
-> m ObjectTree
callGetManagedObjects cl bus path =
either (const M.empty) (fromMaybe M.empty . fromSingletonVariant)
<$> callMethod cl bus path omInterface getManagedObjects
addInterfaceChangedListener
:: SafeClient c
:: (MonadUnliftIO m, SafeClient c)
=> BusName
-> MemberName
-> ObjectPath
-> SignalCallback
-> SignalCallback m
-> c
-> IO (Maybe SignalHandler)
-> m (Maybe SignalHandler)
addInterfaceChangedListener bus prop path sc cl = do
rule <- matchSignalFull cl bus (Just path) (Just omInterface) (Just prop)
forM rule $ \r -> addMatchCallback r sc cl
addInterfaceAddedListener
:: SafeClient c
:: (MonadUnliftIO m, SafeClient c)
=> BusName
-> ObjectPath
-> SignalCallback
-> SignalCallback m
-> c
-> IO (Maybe SignalHandler)
-> m (Maybe SignalHandler)
addInterfaceAddedListener bus =
addInterfaceChangedListener bus omInterfacesAdded
addInterfaceRemovedListener
:: SafeClient c
:: (MonadUnliftIO m, SafeClient c)
=> BusName
-> ObjectPath
-> SignalCallback
-> SignalCallback m
-> c
-> IO (Maybe SignalHandler)
-> m (Maybe SignalHandler)
addInterfaceRemovedListener bus =
addInterfaceChangedListener bus omInterfacesRemoved

View File

@ -13,11 +13,10 @@ module XMonad.Internal.DBus.Brightness.ClevoKeyboard
)
where
import Control.Monad (when)
import DBus
import Data.Int (Int32)
import Data.Internal.DBus
import Data.Internal.Dependency
import RIO
import RIO.FilePath
import XMonad.Internal.DBus.Brightness.Common
import XMonad.Internal.IO
@ -127,8 +126,12 @@ exportClevoKeyboard =
clevoKeyboardControls :: Maybe SesClient -> BrightnessControls
clevoKeyboardControls = brightnessControls xpfClevoBacklight clevoKeyboardConfig
callGetBrightnessCK :: SesClient -> IO (Maybe Brightness)
callGetBrightnessCK :: MonadUnliftIO m => SesClient -> m (Maybe Brightness)
callGetBrightnessCK = callGetBrightness clevoKeyboardConfig
matchSignalCK :: (Maybe Brightness -> IO ()) -> SesClient -> IO ()
matchSignalCK
:: MonadUnliftIO m
=> (Maybe Brightness -> m ())
-> SesClient
-> m ()
matchSignalCK = matchSignal clevoKeyboardConfig

View File

@ -14,13 +14,12 @@ module XMonad.Internal.DBus.Brightness.Common
)
where
import Control.Monad (void)
import DBus
import DBus.Client
import qualified DBus.Introspection as I
import Data.Int (Int32)
import Data.Internal.DBus
import Data.Internal.Dependency
import RIO
import qualified RIO.Text as T
import XMonad.Core (io)
import XMonad.Internal.DBus.Common
@ -69,10 +68,10 @@ brightnessControls q bc cl =
cb = callBacklight q cl bc
callGetBrightness
:: (SafeClient c, Num n)
:: (MonadUnliftIO m, SafeClient c, Num n)
=> BrightnessConfig a b
-> c
-> IO (Maybe n)
-> m (Maybe n)
callGetBrightness BrightnessConfig {bcPath = p, bcInterface = i} client =
either (const Nothing) bodyGetBrightness
<$> callMethod client xmonadBusName p i memGet
@ -82,11 +81,11 @@ signalDep BrightnessConfig {bcPath = p, bcInterface = i} =
Endpoint [] xmonadBusName p i $ Signal_ memCur
matchSignal
:: (SafeClient c, Num n)
:: (MonadUnliftIO m, SafeClient c, Num n)
=> BrightnessConfig a b
-> (Maybe n -> IO ())
-> (Maybe n -> m ())
-> c
-> IO ()
-> m ()
matchSignal BrightnessConfig {bcPath = p, bcInterface = i} cb =
void . addMatchCallback brMatcher (cb . bodyGetBrightness)
where
@ -115,7 +114,11 @@ brightnessExporter q ful deps bc@BrightnessConfig {bcName = n} cl =
root = DBusRoot_ (exportBrightnessControls' bc) tree cl
tree = listToAnds (Bus ful xmonadBusName) $ fmap DBusIO deps
exportBrightnessControls' :: RealFrac b => BrightnessConfig a b -> SesClient -> FIO ()
exportBrightnessControls'
:: (MonadUnliftIO m, RealFrac b)
=> BrightnessConfig a b
-> SesClient
-> m ()
exportBrightnessControls' bc cl = io $ do
let ses = toClient cl
maxval <- bcGetMax bc -- assume the max value will never change
@ -148,9 +151,14 @@ exportBrightnessControls' bc cl = io $ do
]
}
emitBrightness :: RealFrac b => BrightnessConfig a b -> Client -> b -> IO ()
emitBrightness
:: (MonadUnliftIO m, RealFrac b)
=> BrightnessConfig a b
-> Client
-> b
-> m ()
emitBrightness BrightnessConfig {bcPath = p, bcInterface = i} client cur =
emit client $ sig {signalBody = [toVariant (round cur :: Int32)]}
liftIO $ emit client $ sig {signalBody = [toVariant (round cur :: Int32)]}
where
sig = signal p i memCur

View File

@ -14,9 +14,9 @@ module XMonad.Internal.DBus.Brightness.IntelBacklight
where
import DBus
import Data.Int (Int32)
import Data.Internal.DBus
import Data.Internal.Dependency
import RIO
import RIO.FilePath
import XMonad.Internal.DBus.Brightness.Common
import XMonad.Internal.IO
@ -110,8 +110,12 @@ exportIntelBacklight =
intelBacklightControls :: Maybe SesClient -> BrightnessControls
intelBacklightControls = brightnessControls xpfIntelBacklight intelBacklightConfig
callGetBrightnessIB :: SesClient -> IO (Maybe Brightness)
callGetBrightnessIB :: MonadUnliftIO m => SesClient -> m (Maybe Brightness)
callGetBrightnessIB = callGetBrightness intelBacklightConfig
matchSignalIB :: (Maybe Brightness -> IO ()) -> SesClient -> IO ()
matchSignalIB
:: MonadUnliftIO m
=> (Maybe Brightness -> m ())
-> SesClient
-> m ()
matchSignalIB = matchSignal intelBacklightConfig

View File

@ -18,11 +18,11 @@ module XMonad.Internal.DBus.Control
)
where
import Control.Monad
import DBus
import DBus.Client
import Data.Internal.DBus
import Data.Internal.Dependency
import RIO
import XMonad.Internal.DBus.Brightness.ClevoKeyboard
import XMonad.Internal.DBus.Brightness.IntelBacklight
import XMonad.Internal.DBus.Common
@ -35,27 +35,27 @@ data DBusState = DBusState
}
-- | Connect to the DBus
connectDBus :: IO DBusState
connectDBus :: MonadUnliftIO m => m DBusState
connectDBus = do
ses <- getDBusClient
sys <- getDBusClient
return DBusState {dbSesClient = ses, dbSysClient = sys}
-- | Disconnect from the DBus
disconnectDBus :: DBusState -> IO ()
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 :: IO DBusState
connectDBusX :: MonadUnliftIO m => m DBusState
connectDBusX = do
db <- connectDBus
forM_ (dbSesClient db) requestXMonadName
return db
-- | Disconnect from DBus and release the XMonad name
disconnectDBusX :: DBusState -> IO ()
disconnectDBusX :: MonadUnliftIO m => DBusState -> m ()
disconnectDBusX db = do
forM_ (dbSesClient db) releaseXMonadName
disconnectDBus db
@ -64,12 +64,12 @@ disconnectDBusX db = do
dbusExporters :: [Maybe SesClient -> SometimesIO]
dbusExporters = [exportScreensaver, exportIntelBacklight, exportClevoKeyboard]
releaseXMonadName :: SesClient -> IO ()
releaseXMonadName ses = void $ releaseName (toClient ses) xmonadBusName
releaseXMonadName :: MonadUnliftIO m => SesClient -> m ()
releaseXMonadName ses = liftIO $ void $ releaseName (toClient ses) xmonadBusName
requestXMonadName :: SesClient -> IO ()
requestXMonadName :: MonadUnliftIO m => SesClient -> m ()
requestXMonadName ses = do
res <- requestName (toClient ses) xmonadBusName []
res <- liftIO $ requestName (toClient ses) xmonadBusName []
-- TODO if the client is not released on shutdown the owner will be different
let msg
| res == NamePrimaryOwner = Nothing
@ -78,6 +78,6 @@ requestXMonadName ses = do
|| res == NameExists =
Just $ "another process owns " ++ xn
| otherwise = Just $ "unknown error when requesting " ++ xn
forM_ msg putStrLn
liftIO $ forM_ msg putStrLn
where
xn = "'" ++ formatBusName xmonadBusName ++ "'"

View File

@ -7,20 +7,21 @@
module Xmobar.Plugins.BacklightCommon (startBacklight) where
import Data.Internal.DBus
import RIO
import qualified RIO.Text as T
import Xmobar.Plugins.Common
startBacklight
:: RealFrac a
=> ((Maybe a -> IO ()) -> SesClient -> IO ())
-> (SesClient -> IO (Maybe a))
:: (MonadUnliftIO m, RealFrac a)
=> ((Maybe a -> m ()) -> SesClient -> m ())
-> (SesClient -> m (Maybe a))
-> T.Text
-> Callback
-> IO ()
-> m ()
startBacklight matchSignal callGetBrightness icon cb = do
withDBusClientConnection cb $ \c -> do
matchSignal display c
display =<< callGetBrightness c
matchSignal dpy c
dpy =<< callGetBrightness c
where
formatBrightness b = return $ T.concat [icon, T.pack $ show (round b :: Integer), "%"]
display = displayMaybe cb formatBrightness
dpy = displayMaybe cb formatBrightness

View File

@ -39,7 +39,6 @@ module Xmobar.Plugins.Bluetooth
)
where
import Control.Concurrent.MVar
import Control.Monad
import DBus
import DBus.Client
@ -49,6 +48,7 @@ import Data.List
import Data.List.Split
import qualified Data.Map as M
import Data.Maybe
import RIO
import qualified RIO.Text as T
import XMonad.Internal.DBus.Common
import Xmobar
@ -69,23 +69,29 @@ instance Exec Bluetooth where
start (Bluetooth icons colors) cb =
withDBusClientConnection cb $ startAdapter icons colors cb
startAdapter :: Icons -> Colors -> Callback -> SysClient -> IO ()
startAdapter
:: MonadUnliftIO m
=> Icons
-> Colors
-> Callback
-> SysClient
-> m ()
startAdapter is cs cb cl = do
ot <- getBtObjectTree cl
state <- newMVar emptyState
let display = displayIcon cb (iconFormatter is cs) state
let dpy = displayIcon cb (iconFormatter is cs) state
forM_ (findAdapter ot) $ \adapter -> do
-- set up adapter
initAdapter state adapter cl
-- TODO this step could fail; at least warn the user...
void $ addAdaptorListener state display adapter cl
void $ addAdaptorListener state dpy adapter cl
-- set up devices on the adapter (and listeners for adding/removing devices)
let devices = findDevices adapter ot
addDeviceAddedListener state display adapter cl
addDeviceRemovedListener state display adapter cl
forM_ devices $ \d -> addAndInitDevice state display d cl
addDeviceAddedListener state dpy adapter cl
addDeviceRemovedListener state dpy adapter cl
forM_ devices $ \d -> addAndInitDevice state dpy d cl
-- after setting things up, show the icon based on the initialized state
display
dpy
--------------------------------------------------------------------------------
-- Icon Display
@ -97,9 +103,9 @@ type IconFormatter = (Maybe Bool -> Bool -> T.Text)
type Icons = (T.Text, T.Text)
displayIcon :: Callback -> IconFormatter -> MutableBtState -> IO ()
displayIcon :: MonadUnliftIO m => Callback -> IconFormatter -> MutableBtState -> m ()
displayIcon callback formatter =
callback . T.unpack . uncurry formatter <=< readState
liftIO . callback . T.unpack . uncurry formatter <=< readState
-- TODO maybe I want this to fail when any of the device statuses are Nothing
iconFormatter :: Icons -> Colors -> IconFormatter
@ -137,7 +143,7 @@ emptyState =
, btPowered = Nothing
}
readState :: MutableBtState -> IO (Maybe Bool, Bool)
readState :: MonadUnliftIO m => MutableBtState -> m (Maybe Bool, Bool)
readState state = do
p <- readPowered state
c <- readDevices state
@ -160,59 +166,81 @@ adaptorHasDevice adaptor device = case splitPath device of
splitPath :: ObjectPath -> [T.Text]
splitPath = fmap T.pack . splitOn "/" . dropWhile (== '/') . formatObjectPath
getBtObjectTree :: SysClient -> IO ObjectTree
getBtObjectTree :: MonadUnliftIO m => SysClient -> m ObjectTree
getBtObjectTree sys = callGetManagedObjects sys btBus btOMPath
btOMPath :: ObjectPath
btOMPath = objectPath_ "/"
addBtOMListener :: SignalCallback -> SysClient -> IO ()
addBtOMListener :: MonadUnliftIO m => SignalCallback m -> SysClient -> m ()
addBtOMListener sc = void . addInterfaceAddedListener btBus btOMPath sc
addDeviceAddedListener :: MutableBtState -> IO () -> ObjectPath -> SysClient -> IO ()
addDeviceAddedListener state display adapter client =
addDeviceAddedListener
:: MonadUnliftIO m
=> MutableBtState
-> m ()
-> ObjectPath
-> SysClient
-> m ()
addDeviceAddedListener state dpy adapter client =
addBtOMListener addDevice client
where
addDevice = pathCallback adapter display $ \d ->
addAndInitDevice state display d client
addDevice = pathCallback adapter dpy $ \d ->
addAndInitDevice state dpy d client
addDeviceRemovedListener :: MutableBtState -> IO () -> ObjectPath -> SysClient -> IO ()
addDeviceRemovedListener state display adapter sys =
addDeviceRemovedListener
:: (MonadUnliftIO m)
=> MutableBtState
-> m ()
-> ObjectPath
-> SysClient
-> m ()
addDeviceRemovedListener state dpy adapter sys =
addBtOMListener remDevice sys
where
remDevice = pathCallback adapter display $ \d -> do
remDevice = pathCallback adapter dpy $ \d -> do
old <- removeDevice state d
forM_ old $ removeMatch (toClient sys) . btDevSigHandler
forM_ old $ liftIO . removeMatch (toClient sys) . btDevSigHandler
pathCallback :: ObjectPath -> IO () -> (ObjectPath -> IO ()) -> SignalCallback
pathCallback adapter display f [device, _] = forM_ (fromVariant device) $ \d ->
when (adaptorHasDevice adapter d) $ f d >> display
pathCallback :: MonadUnliftIO m => ObjectPath -> m () -> (ObjectPath -> m ()) -> SignalCallback m
pathCallback adapter dpy f [device, _] = forM_ (fromVariant device) $ \d ->
when (adaptorHasDevice adapter d) $ f d >> dpy
pathCallback _ _ _ _ = return ()
--------------------------------------------------------------------------------
-- Adapter
initAdapter :: MutableBtState -> ObjectPath -> SysClient -> IO ()
initAdapter
:: (MonadUnliftIO m)
=> MutableBtState
-> ObjectPath
-> SysClient
-> m ()
initAdapter state adapter client = do
reply <- callGetPowered adapter client
putPowered state $ fromSingletonVariant reply
matchBTProperty :: SysClient -> ObjectPath -> IO (Maybe MatchRule)
matchBTProperty
:: (MonadUnliftIO m)
=> SysClient
-> ObjectPath
-> m (Maybe MatchRule)
matchBTProperty sys p = matchPropertyFull sys btBus (Just p)
addAdaptorListener
:: MutableBtState
-> IO ()
:: MonadUnliftIO m
=> MutableBtState
-> m ()
-> ObjectPath
-> SysClient
-> IO (Maybe SignalHandler)
addAdaptorListener state display adaptor sys = do
-> m (Maybe SignalHandler)
addAdaptorListener state dpy adaptor sys = do
rule <- matchBTProperty sys adaptor
forM rule $ \r -> addMatchCallback r (procMatch . matchPowered) sys
where
procMatch = withSignalMatch $ \b -> putPowered state b >> display
procMatch = withSignalMatch $ \b -> putPowered state b >> dpy
callGetPowered :: ObjectPath -> SysClient -> IO [Variant]
callGetPowered :: MonadUnliftIO m => ObjectPath -> SysClient -> m [Variant]
callGetPowered adapter =
callPropertyGet btBus adapter adapterInterface $
memberName_ $
@ -221,10 +249,10 @@ callGetPowered adapter =
matchPowered :: [Variant] -> SignalMatch Bool
matchPowered = matchPropertyChanged adapterInterface adaptorPowered
putPowered :: MutableBtState -> Maybe Bool -> IO ()
putPowered :: MonadUnliftIO m => MutableBtState -> Maybe Bool -> m ()
putPowered m ds = modifyMVar_ m (\s -> return s {btPowered = ds})
readPowered :: MutableBtState -> IO (Maybe Bool)
readPowered :: MonadUnliftIO m => MutableBtState -> m (Maybe Bool)
readPowered = fmap btPowered . readMVar
adapterInterface :: InterfaceName
@ -236,13 +264,25 @@ adaptorPowered = "Powered"
--------------------------------------------------------------------------------
-- Devices
addAndInitDevice :: MutableBtState -> IO () -> ObjectPath -> SysClient -> IO ()
addAndInitDevice state display device client = do
sh <- addDeviceListener state display device client
addAndInitDevice
:: MonadUnliftIO m
=> MutableBtState
-> m ()
-> ObjectPath
-> SysClient
-> m ()
addAndInitDevice state dpy device client = do
sh <- addDeviceListener state dpy device client
-- TODO add some intelligent error messages here
forM_ sh $ \s -> initDevice state s device client
initDevice :: MutableBtState -> SignalHandler -> ObjectPath -> SysClient -> IO ()
initDevice
:: MonadUnliftIO m
=> MutableBtState
-> SignalHandler
-> ObjectPath
-> SysClient
-> m ()
initDevice state sh device sys = do
reply <- callGetConnected device sys
void $
@ -253,31 +293,42 @@ initDevice state sh device sys = do
}
addDeviceListener
:: MutableBtState
-> IO ()
:: MonadUnliftIO m
=> MutableBtState
-> m ()
-> ObjectPath
-> SysClient
-> IO (Maybe SignalHandler)
addDeviceListener state display device sys = do
-> m (Maybe SignalHandler)
addDeviceListener state dpy device sys = do
rule <- matchBTProperty sys device
forM rule $ \r -> addMatchCallback r (procMatch . matchConnected) sys
where
procMatch = withSignalMatch $ \c -> updateDevice state device c >> display
procMatch = withSignalMatch $ \c -> updateDevice state device c >> dpy
matchConnected :: [Variant] -> SignalMatch Bool
matchConnected = matchPropertyChanged devInterface devConnected
callGetConnected :: ObjectPath -> SysClient -> IO [Variant]
callGetConnected :: MonadUnliftIO m => ObjectPath -> SysClient -> m [Variant]
callGetConnected p =
callPropertyGet btBus p devInterface $
memberName_ (T.unpack devConnected)
insertDevice :: MutableBtState -> ObjectPath -> BTDevice -> IO Bool
insertDevice
:: MonadUnliftIO m
=> MutableBtState
-> ObjectPath
-> BTDevice
-> m Bool
insertDevice m device dev = modifyMVar m $ \s -> do
let new = M.insert device dev $ btDevices s
return (s {btDevices = new}, anyDevicesConnected new)
updateDevice :: MutableBtState -> ObjectPath -> Maybe Bool -> IO Bool
updateDevice
:: MonadUnliftIO m
=> MutableBtState
-> ObjectPath
-> Maybe Bool
-> m Bool
updateDevice m device status = modifyMVar m $ \s -> do
let new = M.update (\d -> Just d {btDevConnected = status}) device $ btDevices s
return (s {btDevices = new}, anyDevicesConnected new)
@ -285,12 +336,16 @@ updateDevice m device status = modifyMVar m $ \s -> do
anyDevicesConnected :: ConnectedDevices -> Bool
anyDevicesConnected = or . mapMaybe btDevConnected . M.elems
removeDevice :: MutableBtState -> ObjectPath -> IO (Maybe BTDevice)
removeDevice
:: MonadUnliftIO m
=> MutableBtState
-> ObjectPath
-> m (Maybe BTDevice)
removeDevice m device = modifyMVar m $ \s -> do
let devs = btDevices s
return (s {btDevices = M.delete device devs}, M.lookup device devs)
readDevices :: MutableBtState -> IO ConnectedDevices
readDevices :: MonadUnliftIO m => MutableBtState -> m ConnectedDevices
readDevices = fmap btDevices . readMVar
devInterface :: InterfaceName

View File

@ -15,10 +15,10 @@ module Xmobar.Plugins.Common
)
where
import Control.Monad
import DBus
import DBus.Client
import Data.Internal.DBus
import RIO
import qualified RIO.Text as T
import XMonad.Hooks.DynamicLog (xmobarColor)
@ -32,14 +32,14 @@ data Colors = Colors
deriving (Eq, Show, Read)
startListener
:: (SafeClient c, IsVariant a)
:: (MonadUnliftIO m, SafeClient c, IsVariant a)
=> MatchRule
-> (c -> IO [Variant])
-> (c -> m [Variant])
-> ([Variant] -> SignalMatch a)
-> (a -> IO T.Text)
-> (a -> m T.Text)
-> Callback
-> c
-> IO ()
-> m ()
startListener rule getProp fromSignal toColor cb client = do
reply <- getProp client
displayMaybe cb toColor $ fromSingletonVariant reply
@ -47,7 +47,8 @@ startListener rule getProp fromSignal toColor cb client = do
where
procMatch = procSignalMatch cb toColor
procSignalMatch :: Callback -> (a -> IO T.Text) -> SignalMatch a -> IO ()
procSignalMatch
:: MonadUnliftIO m => Callback -> (a -> m T.Text) -> SignalMatch a -> m ()
procSignalMatch cb f = withSignalMatch (displayMaybe cb f)
colorText :: Colors -> Bool -> T.Text -> T.Text
@ -60,11 +61,15 @@ xmobarFGColor c = T.pack . xmobarColor (T.unpack c) "" . T.unpack
na :: T.Text
na = "N/A"
displayMaybe :: Callback -> (a -> IO T.Text) -> Maybe a -> IO ()
displayMaybe cb f = (cb . T.unpack) <=< maybe (return na) f
displayMaybe :: MonadUnliftIO m => Callback -> (a -> m T.Text) -> Maybe a -> m ()
displayMaybe cb f = (liftIO . cb . T.unpack) <=< maybe (return na) f
displayMaybe' :: Callback -> (a -> IO ()) -> Maybe a -> IO ()
displayMaybe' cb = maybe (cb $ T.unpack na)
displayMaybe' :: MonadUnliftIO m => Callback -> (a -> m ()) -> Maybe a -> m ()
displayMaybe' cb = maybe (liftIO $ cb $ T.unpack na)
withDBusClientConnection :: SafeClient c => Callback -> (c -> IO ()) -> IO ()
withDBusClientConnection
:: (MonadUnliftIO m, SafeClient c)
=> Callback
-> (c -> m ())
-> m ()
withDBusClientConnection cb f = displayMaybe' cb f =<< getDBusClient

View File

@ -12,11 +12,11 @@ module Xmobar.Plugins.Device
)
where
import Control.Monad
import DBus
import Data.Internal.DBus
import Data.Internal.Dependency
import Data.Word
import RIO
import qualified RIO.Text as T
import XMonad.Internal.Command.Desktop
import XMonad.Internal.DBus.Common
@ -45,7 +45,7 @@ devDep =
Endpoint networkManagerPkgs networkManagerBus nmPath nmInterface $
Method_ getByIP
getDevice :: SysClient -> T.Text -> IO (Maybe ObjectPath)
getDevice :: MonadUnliftIO m => SysClient -> T.Text -> m (Maybe ObjectPath)
getDevice sys iface = bodyToMaybe <$> callMethod' sys mc
where
mc =
@ -53,7 +53,7 @@ getDevice sys iface = bodyToMaybe <$> callMethod' sys mc
{ methodCallBody = [toVariant iface]
}
getDeviceConnected :: ObjectPath -> SysClient -> IO [Variant]
getDeviceConnected :: MonadUnliftIO m => ObjectPath -> SysClient -> m [Variant]
getDeviceConnected path =
callPropertyGet networkManagerBus path nmDeviceInterface $
memberName_ $

View File

@ -14,14 +14,13 @@ module Xmobar.Plugins.VPN
)
where
import Control.Concurrent.MVar
import Control.Monad
import DBus
import Data.Internal.DBus
import Data.Internal.Dependency
import qualified Data.Map as M
import Data.Maybe
import qualified Data.Set as S
import RIO
import qualified RIO.Text as T
import XMonad.Internal.Command.Desktop
import XMonad.Internal.DBus.Common
@ -35,11 +34,11 @@ instance Exec VPN where
start (VPN (text, colors)) cb =
withDBusClientConnection cb $ \c -> do
state <- initState c
let display = displayMaybe cb iconFormatter . Just =<< readState state
let signalCallback' f = f state display
let dpy = displayMaybe cb iconFormatter . Just =<< readState state
let signalCallback' f = f state dpy
vpnAddedListener (signalCallback' addedCallback) c
vpnRemovedListener (signalCallback' removedCallback) c
display
dpy
where
iconFormatter b = return $ colorText colors b text
@ -54,57 +53,59 @@ type VPNState = S.Set ObjectPath
type MutableVPNState = MVar VPNState
initState :: SysClient -> IO MutableVPNState
initState :: MonadUnliftIO m => SysClient -> m MutableVPNState
initState client = do
ot <- getVPNObjectTree client
newMVar $ findTunnels ot
readState :: MutableVPNState -> IO Bool
readState :: MonadUnliftIO m => MutableVPNState -> m Bool
readState = fmap (not . null) . readMVar
updateState
:: (ObjectPath -> VPNState -> VPNState)
:: MonadUnliftIO m
=> (ObjectPath -> VPNState -> VPNState)
-> MutableVPNState
-> ObjectPath
-> IO ()
-> m ()
updateState f state op = modifyMVar_ state $ return . f op
--------------------------------------------------------------------------------
-- Tunnel Device Detection
getVPNObjectTree :: SysClient -> IO ObjectTree
getVPNObjectTree :: MonadUnliftIO m => SysClient -> m ObjectTree
getVPNObjectTree sys = callGetManagedObjects sys vpnBus vpnPath
findTunnels :: ObjectTree -> VPNState
findTunnels = S.fromList . M.keys . M.filter (elem vpnDeviceTun . M.keys)
vpnAddedListener :: SignalCallback -> SysClient -> IO ()
vpnAddedListener :: MonadUnliftIO m => SignalCallback m -> SysClient -> m ()
vpnAddedListener cb = void . addInterfaceAddedListener vpnBus vpnPath cb
vpnRemovedListener :: SignalCallback -> SysClient -> IO ()
vpnRemovedListener :: MonadUnliftIO m => SignalCallback m -> SysClient -> m ()
vpnRemovedListener cb = void . addInterfaceRemovedListener vpnBus vpnPath cb
addedCallback :: MutableVPNState -> IO () -> SignalCallback
addedCallback state display [device, added] = update >> display
addedCallback :: MonadUnliftIO m => MutableVPNState -> m () -> SignalCallback m
addedCallback state dpy [device, added] = update >> dpy
where
added' = fromVariant added :: Maybe (M.Map T.Text (M.Map T.Text Variant))
is = M.keys $ fromMaybe M.empty added'
update = updateDevice S.insert state device is
addedCallback _ _ _ = return ()
removedCallback :: MutableVPNState -> IO () -> SignalCallback
removedCallback state display [device, interfaces] = update >> display
removedCallback :: MonadUnliftIO m => MutableVPNState -> m () -> SignalCallback m
removedCallback state dpy [device, interfaces] = update >> dpy
where
is = fromMaybe [] $ fromVariant interfaces :: [T.Text]
update = updateDevice S.delete state device is
removedCallback _ _ _ = return ()
updateDevice
:: (ObjectPath -> VPNState -> VPNState)
:: MonadUnliftIO m
=> (ObjectPath -> VPNState -> VPNState)
-> MutableVPNState
-> Variant
-> [T.Text]
-> IO ()
-> m ()
updateDevice f state device interfaces =
when (vpnDeviceTun `elem` interfaces) $
forM_ d $