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.

8 files changed, 98 insertions, 43 deletions

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