diff options
author | Joey Hess <joeyh@joeyh.name> | 2017-04-30 19:28:15 -0400 |
---|---|---|
committer | Joey Hess <joeyh@joeyh.name> | 2017-04-30 19:28:15 -0400 |
commit | 5d3e80aeec03af9a5b271757e31a802d8fcb3eeb (patch) | |
tree | f490f691fa1d77b07130dacbda5853eaee3df54b /WebSockets.hs | |
parent | 1a360fda8bd9fcf29ebb7c8b581a670045c46495 (diff) | |
download | debug-me-5d3e80aeec03af9a5b271757e31a802d8fcb3eeb.tar.gz |
add --use-server option for user
Diffstat (limited to 'WebSockets.hs')
-rw-r--r-- | WebSockets.hs | 15 |
1 files changed, 12 insertions, 3 deletions
diff --git a/WebSockets.hs b/WebSockets.hs index e0eac18..98c5946 100644 --- a/WebSockets.hs +++ b/WebSockets.hs @@ -40,7 +40,10 @@ import qualified Data.Text as T import qualified Data.ByteString.Lazy as L import Data.List import Data.Monoid +import Data.Maybe +import Text.Read import Control.Monad +import Network.URI -- | Enable compression. connectionOptions :: ConnectionOptions @@ -52,17 +55,23 @@ connectionOptions = defaultConnectionOptions -- 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 +runClientApp :: URI -> ClientApp a -> IO (Maybe a) +runClientApp serverurl app = do rv <- newEmptyTMVarIO let go conn = do r <- app conn atomically $ putTMVar rv r catchJust catchconnclosed - (runClientWith "localhost" 8081 "/" connectionOptions [] go) + (runClientWith host port endpoint connectionOptions [] go) (\_ -> return ()) atomically (tryReadTMVar rv) where + serverauth = fromMaybe (error "bad server url") (uriAuthority serverurl) + host = uriRegName serverauth + port = case uriPort serverauth of + (':':s) -> fromMaybe 80 (readMaybe s) + _ -> 80 + endpoint = uriPath serverurl catchconnclosed ConnectionClosed = Just () catchconnclosed _ = Nothing |