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 | |
parent | 1a360fda8bd9fcf29ebb7c8b581a670045c46495 (diff) | |
download | debug-me-5d3e80aeec03af9a5b271757e31a802d8fcb3eeb.tar.gz |
add --use-server option for user
-rw-r--r-- | CmdLine.hs | 9 | ||||
-rw-r--r-- | Role/Developer.hs | 2 | ||||
-rw-r--r-- | Role/User.hs | 5 | ||||
-rw-r--r-- | ServerList.hs | 13 | ||||
-rw-r--r-- | SessionID.hs | 8 | ||||
-rw-r--r-- | TODO | 1 | ||||
-rw-r--r-- | WebSockets.hs | 15 | ||||
-rw-r--r-- | debug-me.1 | 3 | ||||
-rw-r--r-- | debug-me.cabal | 1 |
9 files changed, 44 insertions, 13 deletions
@@ -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 } @@ -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 @@ -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 |