From 75c8b6b9745ea8e64383e28d3f18b1609be00fa3 Mon Sep 17 00:00:00 2001
From: Joey Hess <joeyh@joeyh.name>
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.
---
 Role/Developer.hs  | 65 ++++++++++++++++++++++++++++--------------------------
 Role/Downloader.hs | 31 ++++++++++++++++++++++++++
 2 files changed, 65 insertions(+), 31 deletions(-)
 create mode 100644 Role/Downloader.hs

(limited to 'Role')

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
-- 
cgit v1.2.3