clean up connection closing

For some reason, runClient throws ConnectionClosed on apparently clean
shutdown. This happens even though clientApp uses sendClose, and the
server receives it and shuts down entirely cleanly.

1 files changed, 6 insertions, 4 deletions

diff --git a/Role/User.hs b/Role/User.hs
index 3eb2ebc..ef56a6a 100644
--- a/Role/User.hs
+++ b/Role/User.hs
@@ -19,6 +19,7 @@ import System.Exit
 import qualified Data.ByteString as B
 import Data.List.NonEmpty (NonEmpty(..), toList)
 import Data.Monoid
+import Data.Maybe
 import Data.Time.Clock.POSIX
 import System.IO
 import System.Environment
@@ -26,13 +27,12 @@ import System.Environment
 run :: UserOpts -> IO ExitCode
 run os = do
 	(cmd, cmdparams) <- shellCommand os
-	exitstatus <- go cmd cmdparams startSession
-	sessionDone
-	return exitstatus
+	go cmd cmdparams startSession
   where
 	go cmd cmdparams startmsg = do
 		putStr "Connecting to debug-me server..."
 		hFlush stdout
+		esv <- newEmptyTMVarIO
 		runClientApp $ clientApp (InitMode mempty) $ \ichan ochan sid -> do
 			let url = sessionIDUrl sid "localhost" 8081
 			putStrLn ""
@@ -42,7 +42,9 @@ run os = do
 				uthread <- async (user startmsg p ichan ochan)
 				exitstatus <- waitForProcess ph
 				cancel uthread
-				return exitstatus
+				atomically $ putTMVar esv exitstatus
+		sessionDone
+		fromMaybe (ExitFailure 101) <$> atomically (tryReadTMVar esv)
 
 shellCommand :: UserOpts -> IO (String, [String])
 shellCommand os = case cmdToRun os of