ENH don't use putstrln for errors on dbus startup

This commit is contained in:
Nathan Dwarshuis 2022-12-31 23:02:50 -05:00
parent fcb454bc29
commit 8a217d08eb
2 changed files with 36 additions and 10 deletions

View File

@ -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
--------------------------------------------------------------------------------

View File

@ -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