diff options
| -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 |