From 5d3e80aeec03af9a5b271757e31a802d8fcb3eeb Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sun, 30 Apr 2017 19:28:15 -0400 Subject: add --use-server option for user --- WebSockets.hs | 15 ++++++++++++--- 1 file changed, 12 insertions(+), 3 deletions(-) (limited to 'WebSockets.hs') 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 -- cgit v1.2.3