Handle stickers, properly handle exceptions in threads

2 files changed, 10 insertions, 10 deletions

diff --git a/fig-bus/fig-bus.cabal b/fig-bus/fig-bus.cabal
index ec68ef5..327582b 100644
--- a/fig-bus/fig-bus.cabal
+++ b/fig-bus/fig-bus.cabal
@@ -10,12 +10,11 @@ common defaults
 common deps
   build-depends:
       base
+    , async
     , binary
     , bytestring
     , containers
     , directory
-    , containers
-    , directory
     , filepath
     , megaparsec
     , mtl
@@ -42,4 +41,4 @@ executable fig-bus
   build-depends: fig-bus, optparse-applicative
   hs-source-dirs:
     main
-  main-is: Main.hs
\ No newline at end of file
+  main-is: Main.hs
diff --git a/fig-bus/src/Fig/Bus/Client.hs b/fig-bus/src/Fig/Bus/Client.hs
index 6d72ad4..18c1081 100644
--- a/fig-bus/src/Fig/Bus/Client.hs
+++ b/fig-bus/src/Fig/Bus/Client.hs
@@ -7,6 +7,7 @@ import Fig.Prelude
 import System.Exit (exitFailure)
 
 import qualified Control.Concurrent as Conc
+import qualified Control.Concurrent.Async as Async
 
 import Data.ByteString (hPut, hGetLine)
 
@@ -40,18 +41,18 @@ busClient loc@(host, port) onConn onData onQuit = catchFailure . client loc $ pu
       }
   in
     ( do
-        liftIO . void . Conc.forkIO $ onConn cmds
-        forever do
-          line <- throwLeft id . decodeUtf8' =<< liftIO (hGetLine h)
-          case parseSExpr line of
-            Nothing -> throwM . FigBusClientException $ "Server sent malformed s-expression: " <> line
-            Just x -> liftIO $ onData cmds x
+        liftIO $ Async.concurrently_ (onConn cmds) do
+          forever do
+            line <- throwLeft id . decodeUtf8' =<< liftIO (hGetLine h)
+            case parseSExpr line of
+              Nothing -> throwM . FigBusClientException $ "Server sent malformed s-expression: " <> line
+              Just x -> liftIO $ onData cmds x
     , liftIO onQuit
     )
   where
     catchFailure body = catch body \(e :: IOException) -> do
       log $ "Failed to connect to bus at " <> host <> ":" <> port <> ": " <> tshow e
-      liftIO $ exitFailure
+      liftIO exitFailure
 
 _testClient :: IO ()
 _testClient = busClient ("localhost", "32050")