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

View File

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