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 | |
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.
-rw-r--r-- | Role/User.hs | 10 | ||||
-rw-r--r-- | TODO | 1 | ||||
-rw-r--r-- | WebSockets.hs | 12 |
3 files changed, 16 insertions, 7 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 @@ -21,7 +21,6 @@ multiple developers, as each time a developer gets an Activity Seen, they can update their state to use the Activity Entered that it points to. - * --watch and --download only get Seen messages, not Entered messages, because the server does not send Developer messages to them. To fix, need a way to avoid looping Entered messages sent by a developer diff --git a/WebSockets.hs b/WebSockets.hs index 25f2162..0ec0c10 100644 --- a/WebSockets.hs +++ b/WebSockets.hs @@ -15,8 +15,15 @@ import qualified Data.Text as T import Data.List import Data.Maybe -runClientApp :: ClientApp a -> IO a -runClientApp = runClient "localhost" 8081 "/" +runClientApp :: ClientApp () -> IO () +runClientApp app = catchJust catchconnclosed + (runClient "localhost" 8081 "/" app) + (\_ -> return ()) + where + -- For some reason, runClient throws ConnectionClosed + -- when the server hangs up cleanly. Catch this unwanted exception. + catchconnclosed ConnectionClosed = Just () + catchconnclosed _ = Nothing -- | Make a client that sends and receives Messages over a websocket. clientApp @@ -39,6 +46,7 @@ clientApp mode a conn = do Just <$> atomically (readTChan schan) return (schan, rchan, sthread, rthread) cleanup (_, _, sthread, rthread) = do + sendClose conn ("done" :: T.Text) cancel sthread cancel rthread go sid (schan, rchan, _, _) = a schan rchan sid |