From 5a48331ca8852c3c9fe500fb66ef7436ae0dc20d Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sat, 22 Apr 2017 01:13:37 -0400 Subject: 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. --- Role/User.hs | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) (limited to 'Role/User.hs') 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 -- cgit v1.2.3