diff options
author | Joey Hess <joeyh@joeyh.name> | 2017-04-24 14:44:57 -0400 |
---|---|---|
committer | Joey Hess <joeyh@joeyh.name> | 2017-04-24 14:44:57 -0400 |
commit | 7b2bcfab392d387b89c3c251f0c9a8b9c0203aa8 (patch) | |
tree | d96e09b920b878538bddb7b1c46f186dde7c2242 /WebSockets.hs | |
parent | 50da1dee420cc6071fe8697de25df49142cce8d5 (diff) | |
download | debug-me-7b2bcfab392d387b89c3c251f0c9a8b9c0203aa8.tar.gz |
better workaround for https://github.com/jaspervdj/websockets/issues/142
Diffstat (limited to 'WebSockets.hs')
-rw-r--r-- | WebSockets.hs | 19 |
1 files changed, 13 insertions, 6 deletions
diff --git a/WebSockets.hs b/WebSockets.hs index 4b05fdb..ea6e251 100644 --- a/WebSockets.hs +++ b/WebSockets.hs @@ -37,13 +37,20 @@ connectionOptions = defaultConnectionOptions PermessageDeflateCompression defaultPermessageDeflate } -runClientApp :: ClientApp () -> IO () -runClientApp app = catchJust catchconnclosed - (runClientWith "localhost" 8081 "/" connectionOptions [] app) - (\_ -> return ()) +-- For some reason, runClient throws ConnectionClosed +-- when the server hangs up cleanly. Catch this unwanted exception. +-- See https://github.com/jaspervdj/websockets/issues/142 +runClientApp :: ClientApp a -> IO (Maybe a) +runClientApp app = do + rv <- newEmptyTMVarIO + let go conn = do + r <- app conn + atomically $ putTMVar rv r + catchJust catchconnclosed + (runClientWith "localhost" 8081 "/" connectionOptions [] go) + (\_ -> return ()) + atomically (tryReadTMVar rv) where - -- For some reason, runClient throws ConnectionClosed - -- when the server hangs up cleanly. Catch this unwanted exception. catchconnclosed ConnectionClosed = Just () catchconnclosed _ = Nothing |