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
|
class SafeClient c where
|
||||||
toClient :: c -> Client
|
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 :: MonadUnliftIO m => c -> m ()
|
||||||
disconnectDBusClient = liftIO . disconnect . toClient
|
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 =
|
withDBusClient f =
|
||||||
bracket getDBusClient (mapM (liftIO . disconnect . toClient)) $ mapM 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
|
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)
|
fromDBusClient f = withDBusClient (return . f)
|
||||||
|
|
||||||
newtype SysClient = SysClient Client
|
newtype SysClient = SysClient Client
|
||||||
|
@ -69,11 +80,16 @@ instance SafeClient SesClient where
|
||||||
|
|
||||||
getDBusClient = fmap SesClient <$> getDBusClient' False
|
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
|
getDBusClient' sys = do
|
||||||
res <- try $ liftIO $ if sys then connectSystem else connectSession
|
res <- try $ liftIO $ if sys then connectSystem else connectSession
|
||||||
case res of
|
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
|
Right c -> return $ Just c
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
|
|
|
@ -60,14 +60,22 @@ withDBusX f = withDBus $ \db -> do
|
||||||
logInfo "unregistering xmonad from DBus"
|
logInfo "unregistering xmonad from DBus"
|
||||||
releaseXMonadName cl
|
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_ = 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
|
withDBus = bracket connectDBus disconnectDBus
|
||||||
|
|
||||||
-- | Connect to the DBus
|
-- | Connect to the DBus
|
||||||
connectDBus :: MonadUnliftIO m => m DBusState
|
connectDBus
|
||||||
|
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
|
||||||
|
=> m DBusState
|
||||||
connectDBus = do
|
connectDBus = do
|
||||||
ses <- getDBusClient
|
ses <- getDBusClient
|
||||||
sys <- getDBusClient
|
sys <- getDBusClient
|
||||||
|
@ -80,7 +88,9 @@ disconnectDBus db = disc dbSesClient >> disc dbSysClient
|
||||||
disc f = maybe (return ()) disconnectDBusClient $ f db
|
disc f = maybe (return ()) disconnectDBusClient $ f db
|
||||||
|
|
||||||
-- | Connect to the DBus and request the XMonad name
|
-- | 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
|
connectDBusX = do
|
||||||
db <- connectDBus
|
db <- connectDBus
|
||||||
forM_ (dbSesClient db) requestXMonadName
|
forM_ (dbSesClient db) requestXMonadName
|
||||||
|
|
Loading…
Reference in New Issue