From 7d1e4826ae45a2663bb981eda6ba2741aa8519df Mon Sep 17 00:00:00 2001
From: Jens Nolte <git@queezle.net>
Date: Tue, 7 Sep 2021 19:43:45 +0200
Subject: [PATCH] Improve connection error handling
---
src/Quasar/Wayland/Connection.hs | 25 +++++++++++++++++--------
1 file changed, 17 insertions(+), 8 deletions(-)
diff --git a/src/Quasar/Wayland/Connection.hs b/src/Quasar/Wayland/Connection.hs
index 2ba630e..ebb020b 100644
--- a/src/Quasar/Wayland/Connection.hs
+++ b/src/Quasar/Wayland/Connection.hs
@@ -30,6 +30,10 @@ instance IsResourceManager (WaylandConnection s) where
instance IsDisposable (WaylandConnection s) where
toDisposable connection = toDisposable connection.resourceManager
+data SocketClosed = SocketClosed
+ deriving stock Show
+ deriving anyclass Exception
+
newWaylandConnection :: forall s m. MonadResourceManager m => Callback s STM I_wl_display -> Socket -> m (WaylandConnection s)
newWaylandConnection wlDisplayCallback socket = do
protocolStateVar <- liftIO $ newTVarIO $ initialProtocolState wlDisplayCallback
@@ -48,8 +52,8 @@ newWaylandConnection wlDisplayCallback socket = do
registerDisposeAction $ closeConnection connection
runUnlimitedAsync do
- async $ liftIO $ waylandConnectionSendThread connection `catchAll` \ex -> traceIO (displayException ex) >> void (dispose resourceManager)
- async $ liftIO $ waylandConnectionReceiveThread connection `catchAll` \ex -> traceIO (displayException ex) >> void (dispose resourceManager)
+ connectionThread connection $ sendThread connection
+ connectionThread connection $ receiveThread connection
-- HACK to send first message (queued internally)
stepProtocol connection $ feedInput ""
@@ -68,21 +72,26 @@ stepProtocol connection step = liftIO do
Left ex -> throwM (ex :: SomeException)
Right result -> pure result
+connectionThread :: MonadAsync m => WaylandConnection s -> IO () -> m ()
+connectionThread connection work = async_ $ liftIO $ work `catches` [ignoreCancelTask, handleAll]
+ where
+ ignoreCancelTask = Handler (throwM :: CancelTask -> IO a)
+ handleAll = Handler (\(ex :: SomeException) -> traceIO (displayException ex) >> void (dispose connection))
-waylandConnectionSendThread :: WaylandConnection s -> IO ()
-waylandConnectionSendThread connection = forever do
+sendThread :: WaylandConnection s -> IO ()
+sendThread connection = forever do
bytes <- atomically $ takeTMVar connection.outboxVar
- traceIO $ "Sending data: " <> show (BSL.length bytes) <> " bytes"
+ traceIO $ "Sending " <> show (BSL.length bytes) <> " bytes"
SocketL.sendAll connection.socket bytes
-waylandConnectionReceiveThread :: WaylandConnection s -> IO ()
-waylandConnectionReceiveThread connection = forever do
+receiveThread :: WaylandConnection s -> IO ()
+receiveThread connection = forever do
bytes <- Socket.recv connection.socket 4096
when (BS.length bytes == 0) do
- fail "Socket is closed"
+ throwM SocketClosed
traceIO $ "Received " <> show (BS.length bytes) <> " bytes"
--
GitLab