ENH standardize export/unexport pairs
This commit is contained in:
parent
e0a186dd18
commit
b2416153e6
|
@ -1,3 +1,5 @@
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- Common internal DBus functions
|
-- Common internal DBus functions
|
||||||
|
|
||||||
|
@ -25,6 +27,7 @@ module Data.Internal.DBus
|
||||||
, addInterfaceRemovedListener
|
, addInterfaceRemovedListener
|
||||||
, fromSingletonVariant
|
, fromSingletonVariant
|
||||||
, bodyToMaybe
|
, bodyToMaybe
|
||||||
|
, exportPair
|
||||||
)
|
)
|
||||||
where
|
where
|
||||||
|
|
||||||
|
@ -302,3 +305,24 @@ addInterfaceRemovedListener
|
||||||
-> m (Maybe SignalHandler)
|
-> m (Maybe SignalHandler)
|
||||||
addInterfaceRemovedListener bus =
|
addInterfaceRemovedListener bus =
|
||||||
addInterfaceChangedListener bus omInterfacesRemoved
|
addInterfaceChangedListener bus omInterfacesRemoved
|
||||||
|
|
||||||
|
--------------------------------------------------------------------------------
|
||||||
|
-- Interface export/unexport
|
||||||
|
|
||||||
|
exportPair
|
||||||
|
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m, SafeClient c)
|
||||||
|
=> ObjectPath
|
||||||
|
-> (Client -> m Interface)
|
||||||
|
-> c
|
||||||
|
-> (m (), m ())
|
||||||
|
exportPair path toIface cl = (up, down)
|
||||||
|
where
|
||||||
|
cl_ = toClient cl
|
||||||
|
up = do
|
||||||
|
logInfo $ "adding interface: " <> path_
|
||||||
|
i <- toIface cl_
|
||||||
|
liftIO $ export cl_ path i
|
||||||
|
down = do
|
||||||
|
logInfo $ "removing interface: " <> path_
|
||||||
|
liftIO $ unexport cl_ path
|
||||||
|
path_ = Utf8Builder $ encodeUtf8Builder $ T.pack $ formatObjectPath path
|
||||||
|
|
|
@ -98,25 +98,19 @@ exportScreensaver
|
||||||
=> Maybe SesClient
|
=> Maybe SesClient
|
||||||
-> Sometimes (m (), m ())
|
-> Sometimes (m (), m ())
|
||||||
exportScreensaver ses =
|
exportScreensaver ses =
|
||||||
sometimesDBus ses "screensaver toggle" "xset" (toAnd_ bus ssx) $ \cl -> (up cl, down cl)
|
sometimesDBus ses "screensaver toggle" "xset" (toAnd_ bus ssx) cmd
|
||||||
where
|
where
|
||||||
up cl =
|
cmd = exportPair ssPath $ \cl_ -> do
|
||||||
let cl' = toClient cl
|
liftIO $ withRunInIO $ \run ->
|
||||||
in liftIO $ withRunInIO $ \run ->
|
return $
|
||||||
export
|
|
||||||
cl'
|
|
||||||
ssPath
|
|
||||||
defaultInterface
|
defaultInterface
|
||||||
{ interfaceName = interface
|
{ interfaceName = interface
|
||||||
, interfaceMethods =
|
, interfaceMethods =
|
||||||
[ autoMethod memToggle $ run $ emitState cl' =<< toggle
|
[ autoMethod memToggle $ run $ emitState cl_ =<< toggle
|
||||||
, autoMethod memQuery (run query)
|
, autoMethod memQuery (run query)
|
||||||
]
|
]
|
||||||
, interfaceSignals = [sig]
|
, interfaceSignals = [sig]
|
||||||
}
|
}
|
||||||
down cl = do
|
|
||||||
logInfo "removing screensaver interface"
|
|
||||||
liftIO $ unexport (toClient cl) ssPath
|
|
||||||
sig =
|
sig =
|
||||||
I.Signal
|
I.Signal
|
||||||
{ I.signalName = memState
|
{ I.signalName = memState
|
||||||
|
|
Loading…
Reference in New Issue