add --use-server option for user

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