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.

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
diff --git a/TODO b/TODO
index 15aae5c..09e46db 100644
--- a/TODO
+++ b/TODO
@@ -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