add --use-server option for user

9 files changed, 44 insertions, 13 deletions

diff --git a/CmdLine.hs b/CmdLine.hs
index 5512e75..0046b4c 100644
--- a/CmdLine.hs
+++ b/CmdLine.hs
@@ -6,6 +6,7 @@
 module CmdLine where
 
 import Types
+import ServerList
 
 import Data.Monoid
 import Options.Applicative
@@ -29,6 +30,7 @@ data Mode
 
 data UserOpts = UserOpts
 	{ cmdToRun :: Maybe String
+	, useServer :: URI
 	}
 
 data DeveloperOpts = DeveloperOpts
@@ -82,6 +84,13 @@ parseMode = (UserMode <$> parseuser)
 			<> metavar "command"
 			<> help "program to run (default: login shell)"
 			))
+		<*> option readurl
+			( long "use-server"
+			<> metavar "url"
+			<> value defaultServerUrl
+			<> showDefault
+			<> help "url of debug-me server to use"
+			)
 	parsedeveloper = DeveloperOpts
 		<$> argument readurl
 			( metavar "url"
diff --git a/Role/Developer.hs b/Role/Developer.hs
index b1975c4..604ac6d 100644
--- a/Role/Developer.hs
+++ b/Role/Developer.hs
@@ -51,7 +51,7 @@ run' runner url = do
 		let connect = ConnectMode $ T.pack $ show url
 		dsv <- newEmptyTMVarIO
 		return $ clientApp connect Developer Just $ runner dsv
-	void $ runClientApp app
+	void $ runClientApp url app
 
 developer :: TMVar (TVar DeveloperState) -> TMChan (Message Entered) -> TMChan (MissingHashes AnyMessage) -> SessionID -> IO ()
 developer dsv ichan ochan sid = withSessionLogger (Just "remote") sid $ \logger -> do
diff --git a/Role/User.hs b/Role/User.hs
index 1bc3aa2..e1138c2 100644
--- a/Role/User.hs
+++ b/Role/User.hs
@@ -49,8 +49,9 @@ run os = fromMaybe (ExitFailure 101) <$> connect
 		putStr "Connecting to debug-me server..."
 		hFlush stdout
 		usv <- newEmptyTMVarIO
-		runClientApp $ clientApp (InitMode email) User developerMessages $ \ochan ichan sid -> do
-			let url = sessionIDUrl sid "localhost" 8081
+		let app = clientApp (InitMode email) User developerMessages
+		runClientApp (useServer os) $ app $ \ochan ichan sid -> do
+			let url = sessionIDUrl sid (useServer os)
 			putStrLn ""
 			putStrLn "Others can connect to this session and help you debug by running:"
 			putStrLn $ "  debug-me " ++ show url
diff --git a/ServerList.hs b/ServerList.hs
new file mode 100644
index 0000000..685bc65
--- /dev/null
+++ b/ServerList.hs
@@ -0,0 +1,13 @@
+{- Copyright 2017 Joey Hess <id@joeyh.name>
+ -
+ - Licensed under the GNU AGPL version 3 or higher.
+ -}
+
+module ServerList where
+
+import Network.URI
+import Data.Maybe
+
+defaultServerUrl :: URI
+defaultServerUrl = fromMaybe (error "internal url parse error") $
+	parseURI "http://localhost:8081/"
diff --git a/SessionID.hs b/SessionID.hs
index 0a2f339..7592e81 100644
--- a/SessionID.hs
+++ b/SessionID.hs
@@ -18,9 +18,7 @@ import JSON
 import System.FilePath
 import System.IO
 import System.Directory
-import Network.Wai.Handler.Warp (Port)
 import Data.List
-import Data.Maybe
 import Data.UUID
 import Data.UUID.V4
 import Network.URI
@@ -79,7 +77,5 @@ withSessionID dir a = do
 	cleanup hv = hClose =<< atomically (readTVar hv)
 	go sid hv = a (hv, sid)
 
-sessionIDUrl :: SessionID -> String -> Port -> URI
-sessionIDUrl (SessionID f) host port = 
-	fromMaybe (error "internal url parse failure") $ parseURI $
-		"http://" ++ host ++ ":" ++ show port ++ "/" ++ f
+sessionIDUrl :: SessionID -> URI -> URI
+sessionIDUrl (SessionID f) serverurl = serverurl { uriPath = f }
diff --git a/TODO b/TODO
index 5ef506c..a80d893 100644
--- a/TODO
+++ b/TODO
@@ -43,7 +43,6 @@
 * Make control-backslash immediately end the debug-me session.
 * Need to spin up a debug-me server and make debug-me use it by default,
   not localhost.
-* Add option or config file to control what server(s) to use.
 
 Low priority:
 
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
 
diff --git a/debug-me.1 b/debug-me.1
index c3366cd..1bdd5fc 100644
--- a/debug-me.1
+++ b/debug-me.1
@@ -39,6 +39,9 @@ will keep most developers honest.
 .IP "--run cmd"
 Normally debug-me will run your login shell. To run some other command,
 use this option.
+.IP "--use-server url"
+Specify a debug-me server to use. Not normally needed since there is a
+default server.
 .SH DEVELOPER OPTIONS
 .IP url
 Connect to a debug-me session on the specified url, to see and interact
diff --git a/debug-me.cabal b/debug-me.cabal
index 01b0557..ffeefed 100644
--- a/debug-me.cabal
+++ b/debug-me.cabal
@@ -102,6 +102,7 @@ Executable debug-me
     Role.Watcher
     Session
     Server
+    ServerList
     SessionID
     Types
     Val