diff options
author | Joey Hess <joeyh@joeyh.name> | 2017-04-22 01:13:37 -0400 |
---|---|---|
committer | Joey Hess <joeyh@joeyh.name> | 2017-04-22 01:13:37 -0400 |
commit | 5a48331ca8852c3c9fe500fb66ef7436ae0dc20d (patch) | |
tree | 0fab5b254f7f56048a29c00d723012557ce72b0a /Role | |
parent | aa2771b7615b91ba60249f6164c01dbda26c56e7 (diff) | |
download | debug-me-5a48331ca8852c3c9fe500fb66ef7436ae0dc20d.tar.gz |
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.
Diffstat (limited to 'Role')
-rw-r--r-- | Role/User.hs | 10 |
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 |