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 --- CmdLine.hs | 9 +++++++++ Role/Developer.hs | 2 +- Role/User.hs | 5 +++-- ServerList.hs | 13 +++++++++++++ SessionID.hs | 8 ++------ TODO | 1 - WebSockets.hs | 15 ++++++++++++--- debug-me.1 | 3 +++ debug-me.cabal | 1 + 9 files changed, 44 insertions(+), 13 deletions(-) create mode 100644 ServerList.hs 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 + - + - 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 -- cgit v1.2.3