diff --git a/lib/Data/Internal/DBus.hs b/lib/Data/Internal/DBus.hs index 888bd39..0fa93be 100644 --- a/lib/Data/Internal/DBus.hs +++ b/lib/Data/Internal/DBus.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE OverloadedStrings #-} + -------------------------------------------------------------------------------- -- Common internal DBus functions @@ -25,6 +27,7 @@ module Data.Internal.DBus , addInterfaceRemovedListener , fromSingletonVariant , bodyToMaybe + , exportPair ) where @@ -302,3 +305,24 @@ addInterfaceRemovedListener -> m (Maybe SignalHandler) addInterfaceRemovedListener bus = 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 diff --git a/lib/XMonad/Internal/DBus/Screensaver.hs b/lib/XMonad/Internal/DBus/Screensaver.hs index 4cc6c4a..8d385d6 100644 --- a/lib/XMonad/Internal/DBus/Screensaver.hs +++ b/lib/XMonad/Internal/DBus/Screensaver.hs @@ -98,25 +98,19 @@ exportScreensaver => Maybe SesClient -> Sometimes (m (), m ()) 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 - up cl = - let cl' = toClient cl - in liftIO $ withRunInIO $ \run -> - export - cl' - ssPath - defaultInterface - { interfaceName = interface - , interfaceMethods = - [ autoMethod memToggle $ run $ emitState cl' =<< toggle - , autoMethod memQuery (run query) - ] - , interfaceSignals = [sig] - } - down cl = do - logInfo "removing screensaver interface" - liftIO $ unexport (toClient cl) ssPath + cmd = exportPair ssPath $ \cl_ -> do + liftIO $ withRunInIO $ \run -> + return $ + defaultInterface + { interfaceName = interface + , interfaceMethods = + [ autoMethod memToggle $ run $ emitState cl_ =<< toggle + , autoMethod memQuery (run query) + ] + , interfaceSignals = [sig] + } sig = I.Signal { I.signalName = memState