ENH don't use putstrln for errors on dbus startup
This commit is contained in:
parent
fcb454bc29
commit
8a217d08eb
|
@ -40,19 +40,30 @@ import qualified RIO.Text as T
|
|||
class SafeClient c where
|
||||
toClient :: c -> Client
|
||||
|
||||
getDBusClient :: MonadUnliftIO m => m (Maybe c)
|
||||
getDBusClient
|
||||
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
|
||||
=> m (Maybe c)
|
||||
|
||||
disconnectDBusClient :: MonadUnliftIO m => c -> m ()
|
||||
disconnectDBusClient = liftIO . disconnect . toClient
|
||||
|
||||
withDBusClient :: MonadUnliftIO m => (c -> m a) -> m (Maybe a)
|
||||
withDBusClient
|
||||
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
|
||||
=> (c -> m a)
|
||||
-> m (Maybe a)
|
||||
withDBusClient f =
|
||||
bracket getDBusClient (mapM (liftIO . disconnect . toClient)) $ mapM f
|
||||
|
||||
withDBusClient_ :: MonadUnliftIO m => (c -> m ()) -> m ()
|
||||
withDBusClient_
|
||||
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
|
||||
=> (c -> m ())
|
||||
-> m ()
|
||||
withDBusClient_ = void . withDBusClient
|
||||
|
||||
fromDBusClient :: MonadUnliftIO m => (c -> a) -> m (Maybe a)
|
||||
fromDBusClient
|
||||
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
|
||||
=> (c -> a)
|
||||
-> m (Maybe a)
|
||||
fromDBusClient f = withDBusClient (return . f)
|
||||
|
||||
newtype SysClient = SysClient Client
|
||||
|
@ -69,11 +80,16 @@ instance SafeClient SesClient where
|
|||
|
||||
getDBusClient = fmap SesClient <$> getDBusClient' False
|
||||
|
||||
getDBusClient' :: MonadUnliftIO m => Bool -> m (Maybe Client)
|
||||
getDBusClient'
|
||||
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
|
||||
=> Bool
|
||||
-> m (Maybe Client)
|
||||
getDBusClient' sys = do
|
||||
res <- try $ liftIO $ if sys then connectSystem else connectSession
|
||||
case res of
|
||||
Left e -> liftIO $ putStrLn (clientErrorMessage e) >> return Nothing
|
||||
Left e -> do
|
||||
logInfo $ Utf8Builder $ encodeUtf8Builder $ T.pack $ clientErrorMessage e
|
||||
return Nothing
|
||||
Right c -> return $ Just c
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
|
|
@ -60,14 +60,22 @@ withDBusX f = withDBus $ \db -> do
|
|||
logInfo "unregistering xmonad from DBus"
|
||||
releaseXMonadName cl
|
||||
|
||||
withDBus_ :: MonadUnliftIO m => (DBusState -> m a) -> m ()
|
||||
withDBus_
|
||||
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
|
||||
=> (DBusState -> m a)
|
||||
-> m ()
|
||||
withDBus_ = void . withDBus
|
||||
|
||||
withDBus :: MonadUnliftIO m => (DBusState -> m a) -> m a
|
||||
withDBus
|
||||
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
|
||||
=> (DBusState -> m a)
|
||||
-> m a
|
||||
withDBus = bracket connectDBus disconnectDBus
|
||||
|
||||
-- | Connect to the DBus
|
||||
connectDBus :: MonadUnliftIO m => m DBusState
|
||||
connectDBus
|
||||
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
|
||||
=> m DBusState
|
||||
connectDBus = do
|
||||
ses <- getDBusClient
|
||||
sys <- getDBusClient
|
||||
|
@ -80,7 +88,9 @@ disconnectDBus db = disc dbSesClient >> disc dbSysClient
|
|||
disc f = maybe (return ()) disconnectDBusClient $ f db
|
||||
|
||||
-- | Connect to the DBus and request the XMonad name
|
||||
connectDBusX :: MonadUnliftIO m => m DBusState
|
||||
connectDBusX
|
||||
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
|
||||
=> m DBusState
|
||||
connectDBusX = do
|
||||
db <- connectDBus
|
||||
forM_ (dbSesClient db) requestXMonadName
|
||||
|
|
Loading…
Reference in New Issue