diff options
| -rw-r--r-- | Role/Developer.hs | 4 | ||||
| -rw-r--r-- | Role/User.hs | 8 | ||||
| -rw-r--r-- | WebSockets.hs | 19 |
3 files changed, 19 insertions, 12 deletions
diff --git a/Role/Developer.hs b/Role/Developer.hs index 4248591..0b8fdd9 100644 --- a/Role/Developer.hs +++ b/Role/Developer.hs @@ -17,14 +17,16 @@ import System.IO import qualified Data.ByteString as B import qualified Data.Text as T import Data.List +import Control.Monad run :: DeveloperOpts -> IO () run = run' developer . debugUrl run' :: (TChan (Message Entered) -> TChan (Message Seen) -> SessionID -> IO ()) -> UrlString -> IO () -run' runner url = runClientApp $ clientApp connect Developer userMessages runner +run' runner url = void $ runClientApp app where connect = ConnectMode (T.pack url) + app = clientApp connect Developer userMessages runner userMessages :: LogMessage -> Maybe (Message Seen) userMessages (User m) = Just m diff --git a/Role/User.hs b/Role/User.hs index 1d1702e..49c263c 100644 --- a/Role/User.hs +++ b/Role/User.hs @@ -27,12 +27,11 @@ import System.Environment run :: UserOpts -> IO ExitCode run os = do (cmd, cmdparams) <- shellCommand os - go cmd cmdparams startSession + fromMaybe (ExitFailure 101) <$> go cmd cmdparams startSession where go cmd cmdparams startmsg = do putStr "Connecting to debug-me server..." hFlush stdout - esv <- newEmptyTMVarIO runClientApp $ clientApp (InitMode mempty) User developerMessages $ \ichan ochan sid -> do let url = sessionIDUrl sid "localhost" 8081 putStrLn "" @@ -43,9 +42,8 @@ run os = do uthread <- async (user startmsg p ichan ochan) exitstatus <- waitForProcess ph cancel uthread - atomically $ putTMVar esv exitstatus - sessionDone - fromMaybe (ExitFailure 101) <$> atomically (tryReadTMVar esv) + sessionDone + return exitstatus developerMessages :: LogMessage -> Maybe (Message Entered) developerMessages (Developer m) = Just m diff --git a/WebSockets.hs b/WebSockets.hs index 4b05fdb..ea6e251 100644 --- a/WebSockets.hs +++ b/WebSockets.hs @@ -37,13 +37,20 @@ connectionOptions = defaultConnectionOptions PermessageDeflateCompression defaultPermessageDeflate } -runClientApp :: ClientApp () -> IO () -runClientApp app = catchJust catchconnclosed - (runClientWith "localhost" 8081 "/" connectionOptions [] app) - (\_ -> return ()) +-- For some reason, runClient throws ConnectionClosed +-- when the server hangs up cleanly. Catch this unwanted exception. +-- See https://github.com/jaspervdj/websockets/issues/142 +runClientApp :: ClientApp a -> IO (Maybe a) +runClientApp app = do + rv <- newEmptyTMVarIO + let go conn = do + r <- app conn + atomically $ putTMVar rv r + catchJust catchconnclosed + (runClientWith "localhost" 8081 "/" connectionOptions [] go) + (\_ -> return ()) + atomically (tryReadTMVar rv) where - -- For some reason, runClient throws ConnectionClosed - -- when the server hangs up cleanly. Catch this unwanted exception. catchconnclosed ConnectionClosed = Just () catchconnclosed _ = Nothing |