From 75c8b6b9745ea8e64383e28d3f18b1609be00fa3 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Fri, 21 Apr 2017 22:23:00 -0400 Subject: add --download mode Nice, was able to reuse all the protocol stuff from Role.Developer for this. This commit was sponsored by Fernando Jimenez on Patreon. --- CmdLine.hs | 12 ++++++++++ Role/Developer.hs | 65 ++++++++++++++++++++++++++++-------------------------- Role/Downloader.hs | 31 ++++++++++++++++++++++++++ Server.hs | 3 ++- SessionID.hs | 23 ++++++++++--------- debug-me.1 | 4 ++++ debug-me.cabal | 1 + debug-me.hs | 2 ++ 8 files changed, 98 insertions(+), 43 deletions(-) create mode 100644 Role/Downloader.hs diff --git a/CmdLine.hs b/CmdLine.hs index 8fd5c9f..9d30eb3 100644 --- a/CmdLine.hs +++ b/CmdLine.hs @@ -11,6 +11,7 @@ data CmdLine = CmdLine data Mode = UserMode UserOpts | DeveloperMode DeveloperOpts + | DownloadMode DownloadOpts | GraphvizMode GraphvizOpts | ReplayMode ReplayOpts | ServerMode ServerOpts @@ -23,6 +24,10 @@ data DeveloperOpts = DeveloperOpts { debugUrl :: String } +data DownloadOpts = DownloadOpts + { downloadUrl :: String + } + data GraphvizOpts = GraphvizOpts { graphvizLogFile :: FilePath , graphvizShowHashes :: Bool @@ -44,6 +49,7 @@ parseMode :: Parser Mode parseMode = (UserMode <$> parseuser) <|> (DeveloperMode <$> parsedeveloper) <|> (ReplayMode <$> parsereplay) + <|> (DownloadMode <$> parsedownload) <|> (GraphvizMode <$> parsegraphviz) <|> (ServerMode <$> parseserver) where @@ -67,6 +73,12 @@ parseMode = (UserMode <$> parseuser) <> metavar "logfile" <> help "replay log file" ) + parsedownload = DownloadOpts + <$> option str + ( long "download" + <> metavar "logfile" + <> help "download log file from server" + ) parseserver = ServerOpts <$> option str ( long "server" diff --git a/Role/Developer.hs b/Role/Developer.hs index 4ff0cda..90f7606 100644 --- a/Role/Developer.hs +++ b/Role/Developer.hs @@ -23,36 +23,7 @@ run os = runClientApp $ clientApp (ConnectMode (T.pack (debugUrl os))) developer developer :: TChan (Message Entered) -> TChan (Message Seen) -> SessionID -> IO () developer ichan ochan _ = inRawMode $ withLogger "debug-me-developer.log" $ \logger -> do - -- Start by reading the initial two messages from the user side, - -- their session key and the startup message. - sessionmsg <- atomically $ readTChan ochan - logger $ User sessionmsg - sigverifier <- case sessionmsg of - ControlMessage c@(Control (SessionKey pk) _) -> - let sv = mkSigVerifier pk - in if verifySigned sv c - then return sv - else error "Badly signed session initialization message" - _ -> error $ "Unexpected session initialization message: " ++ show sessionmsg - startmsg <- atomically $ readTChan ochan - logger $ User startmsg - starthash <- case startmsg of - ActivityMessage act@(Activity (Seen (Val b)) Nothing _) - | verifySigned sigverifier act -> do - B.hPut stdout b - hFlush stdout - return (hash act) - _ -> error $ "Unexpected startup message: " ++ show startmsg - - sk <- genMySessionKey - devstate <- newTVarIO $ DeveloperState - { lastSeen = starthash - , sentSince = mempty - , enteredSince = mempty - , lastActivity = starthash - , developerSessionKey = sk - , developerSigVerifier = sigverifier - } + devstate <- processSessionStart ochan logger ok <- authUser ichan ochan devstate logger if ok then do @@ -150,7 +121,7 @@ data Output emitOutput :: Output -> IO () emitOutput (ProtocolError e) = - error e + error ("Protocol error: " ++ e) emitOutput (TtyOutput b) = do B.hPut stdout b hFlush stdout @@ -241,3 +212,35 @@ isLegalSeen act@(Activity (Seen (Val b)) (Just hp) _) ds where acth = hash act yes ds' = (True, ds') + +-- | Start by reading the initial two messages from the user side, +-- their session key and the startup message. +processSessionStart :: TChan (Message Seen) -> Logger -> IO (TVar DeveloperState) +processSessionStart ochan logger = do + sessionmsg <- atomically $ readTChan ochan + logger $ User sessionmsg + sigverifier <- case sessionmsg of + ControlMessage c@(Control (SessionKey pk) _) -> + let sv = mkSigVerifier pk + in if verifySigned sv c + then return sv + else error "Badly signed session initialization message" + _ -> error $ "Unexpected session initialization message: " ++ show sessionmsg + startmsg <- atomically $ readTChan ochan + logger $ User startmsg + starthash <- case startmsg of + ActivityMessage act@(Activity (Seen (Val b)) Nothing _) + | verifySigned sigverifier act -> do + B.hPut stdout b + hFlush stdout + return (hash act) + _ -> error $ "Unexpected startup message: " ++ show startmsg + sk <- genMySessionKey + newTVarIO $ DeveloperState + { lastSeen = starthash + , sentSince = mempty + , enteredSince = mempty + , lastActivity = starthash + , developerSessionKey = sk + , developerSigVerifier = sigverifier + } diff --git a/Role/Downloader.hs b/Role/Downloader.hs new file mode 100644 index 0000000..3981227 --- /dev/null +++ b/Role/Downloader.hs @@ -0,0 +1,31 @@ +module Role.Downloader where + +import Types +import Log +import CmdLine +import WebSockets +import SessionID + +import Control.Concurrent.STM +import qualified Data.Text as T +import Role.Developer (processSessionStart, getUserMessage, Output(..)) + +run :: DownloadOpts -> IO () +run os = runClientApp $ clientApp (ConnectMode (T.pack (downloadUrl os))) downloader + +downloader :: TChan (Message Entered) -> TChan (Message Seen) -> SessionID -> IO () +downloader _ichan ochan sid = do + let logfile = sessionLogFile "." sid + putStrLn $ "Starting download to " ++ logfile + putStrLn "(Will keep downloading until the debug-me session is done.)" + withLogger logfile $ \logger -> do + st <- processSessionStart ochan logger + go logger st + where + go logger st = do + (o, msg) <- atomically $ getUserMessage ochan st + _ <- logger $ User msg + case o of + ProtocolError e -> error ("Protocol error: " ++ e) + _ -> return () + go logger st diff --git a/Server.hs b/Server.hs index 3dd94be..1de02a4 100644 --- a/Server.hs +++ b/Server.hs @@ -17,6 +17,7 @@ import Control.Concurrent.STM import Control.Concurrent.STM.TMChan import Control.Concurrent.Async import qualified Data.Map as M +import qualified Data.Text as T import Control.Exception import Data.Time.Clock.POSIX @@ -43,7 +44,7 @@ websocketApp o ssv pending_conn = do theirmode <- getMode conn case theirmode of InitMode _ -> user o ssv conn - ConnectMode t -> case mkSessionID t of + ConnectMode t -> case mkSessionID (T.unpack t) of Nothing -> error "Invalid session id!" Just sid -> developer o ssv sid conn diff --git a/SessionID.hs b/SessionID.hs index 3827e1d..d643a28 100644 --- a/SessionID.hs +++ b/SessionID.hs @@ -11,13 +11,13 @@ module SessionID ( import Serialization import System.FilePath -import Data.Text import System.IO import System.Directory import Network.Wai.Handler.Warp (Port) import Network.WebSockets hiding (Message) import qualified Data.Aeson import Data.Maybe +import Data.List import Data.UUID import Data.UUID.V4 @@ -31,21 +31,22 @@ instance FromJSON SessionID instance WebSocketsData SessionID where -- fromDataMessage = fromLazyByteString . fromDataMessage - fromLazyByteString = fromMaybe (error "bad SessionID") . Data.Aeson.decode + fromLazyByteString b = + -- Down't trust a legal SessionID to be deserialized; + -- use smart constructor to verify it's legal. + let SessionID unverified = fromMaybe (error "bad SessionID serialization") (Data.Aeson.decode b) + in fromMaybe (error "illegal SessionID") (mkSessionID unverified) toLazyByteString = Data.Aeson.encode -- | Smart constructor that enforces legal SessionID contents. -- --- The passed Text can either be the bare SessionID, or it can be an URL +-- The passed String can either be the bare SessionID, or it can be an URL -- which ends with the SessionID. -mkSessionID :: Text -> Maybe SessionID -mkSessionID t = - let s = unpack t - in if "http" `isPrefixOf` t - then Just $ SessionID $ takeFileName s - else if takeFileName s == s - then Just $ SessionID s - else Nothing +mkSessionID :: String -> Maybe SessionID +mkSessionID s + | "http" `isPrefixOf` s = Just $ SessionID $ takeFileName s + | takeFileName s == s = Just $ SessionID s + | otherwise = Nothing sessionLogFile :: FilePath -> SessionID -> FilePath sessionLogFile dir (SessionID f) = dir "debug-me." ++ f ++ ".log" diff --git a/debug-me.1 b/debug-me.1 index 1412e21..6f879a2 100644 --- a/debug-me.1 +++ b/debug-me.1 @@ -29,6 +29,10 @@ Connect to a debug-me session on the specified url. The developer runs debug-me with this option to see and interact with the user's bug. .IP "--replay logfile" Replay a debug-me logfile. +.IP "--download url" +Download a debug-me log file from the specified url. Note that if the +debug-me session is still in progress, this will continue downloading +until the session ends. .IP "--graphviz logfile" Uses graphviz to generate a visualization of a debug-me log file. .IP "--show-hashes" diff --git a/debug-me.cabal b/debug-me.cabal index a913db3..9e1e108 100644 --- a/debug-me.cabal +++ b/debug-me.cabal @@ -61,6 +61,7 @@ Executable debug-me Pty Replay Role.Developer + Role.Downloader Role.User Session Serialization diff --git a/debug-me.hs b/debug-me.hs index 25f18b8..ea2d6af 100644 --- a/debug-me.hs +++ b/debug-me.hs @@ -3,6 +3,7 @@ module Main where import CmdLine import qualified Role.User import qualified Role.Developer +import qualified Role.Downloader import Graphviz import Replay import Server @@ -16,6 +17,7 @@ main = withSocketsDo $ do case mode c of UserMode o -> Role.User.run o >>= exitWith DeveloperMode o -> Role.Developer.run o + DownloadMode o -> Role.Downloader.run o GraphvizMode o -> graphviz o ReplayMode o -> replay o ServerMode o -> server o -- cgit v1.2.3