include "session is done" in the session transcript

Including the process exit status.

And cleaner Role.User shutdown sequence.

4 files changed, 54 insertions, 39 deletions

diff --git a/Replay.hs b/Replay.hs
index 9612d5b..1993ce3 100644
--- a/Replay.hs
+++ b/Replay.hs
@@ -3,7 +3,6 @@ module Replay where
 import Types
 import Log
 import CmdLine
-import Session
 
 import qualified Data.ByteString as B
 import System.IO
@@ -12,7 +11,7 @@ import Control.Concurrent.Thread.Delay
 replay :: ReplayOpts -> IO ()
 replay opts = go Nothing =<< streamLog (replayLogFile opts)
   where
-	go _ [] = sessionDone
+	go _ [] = return ()
 	go prevts (Right l:ls) = do
 		case prevts of
 			Nothing -> return ()
diff --git a/Role/User.hs b/Role/User.hs
index fdf4e53..94625c2 100644
--- a/Role/User.hs
+++ b/Role/User.hs
@@ -26,25 +26,33 @@ import System.IO
 import System.Environment
 
 run :: UserOpts -> IO ExitCode
-run os = do
-	(cmd, cmdparams) <- shellCommand os
-	fromMaybe (ExitFailure 101) <$> go cmd cmdparams startSession
+run os = fromMaybe (ExitFailure 101) <$> connect
   where
-	go cmd cmdparams startmsg = do
+	connect = do
 		putStr "Connecting to debug-me server..."
 		hFlush stdout
-		runClientApp $ clientApp (InitMode mempty) User developerMessages $ \ichan ochan sid -> do
+		runClientApp $ clientApp (InitMode mempty) User developerMessages $ \ochan ichan sid -> do
 			let url = sessionIDUrl sid "localhost" 8081
 			putStrLn ""
 			putStrLn "Others can connect to this session and help you debug by running:"
 			putStrLn $ "  debug-me --debug " ++ url
 			hFlush stdout
-			runWithPty cmd cmdparams $ \(p, ph) -> do
-				uthread <- async (user startmsg p ichan ochan)
-				exitstatus <- waitForProcess ph
-				cancel uthread
-				sessionDone
-				return exitstatus
+			withLogger "debug-me.log" $ go ochan ichan
+	go ochan ichan logger = do
+		(cmd, cmdparams) <- shellCommand os
+		runWithPty cmd cmdparams $ \(p, ph) -> do
+			us <- startProtocol startSession ochan logger
+			p1 <- async $ sendPtyOutput p ochan us logger
+			p2 <- async $ sendPtyInput ichan ochan p us logger
+				`race` forwardTtyInputToPty p
+			exitstatus <- waitForProcess ph
+			displayOutput ochan us logger $
+				rawLine "" <>
+				rawLine (endSession exitstatus)
+			atomically $ closeTMChan ichan
+			cancel p1
+			_ <- waitCatch p2
+			return exitstatus
 
 developerMessages :: LogMessage -> Maybe (Message Entered)
 developerMessages (Developer m) = Just m
@@ -64,9 +72,9 @@ data UserState = UserState
 	, userSigVerifier :: SigVerifier
 	}
 
-user :: B.ByteString -> Pty -> TMChan (Message Seen) -> TMChan (Message Entered) -> IO ()
-user starttxt p ochan ichan = withLogger "debug-me.log" $ \logger -> do
-	-- Start by establishing our session key, and displaying the starttxt.
+-- | Start by establishing our session key, and displaying the starttxt.
+startProtocol :: B.ByteString -> TMChan (Message Seen) -> Logger -> IO (TVar UserState)
+startProtocol starttxt ochan logger = do
 	let initialmessage msg = do
 		atomically $ writeTMChan ochan msg
 		logger $ User msg
@@ -74,22 +82,18 @@ user starttxt p ochan ichan = withLogger "debug-me.log" $ \logger -> do
 	pk <- myPublicKey sk
 	let c = mkSigned sk $ Control (SessionKey pk)
 	initialmessage $ ControlMessage c
-	let starttxt' = starttxt <> "\r\n"
+	let starttxt' = rawLine starttxt
 	let act = mkSigned sk $ Activity (Seen (Val starttxt')) Nothing
 	let startmsg = ActivityMessage act
 	B.hPut stdout starttxt'
 	hFlush stdout
 	initialmessage startmsg
 	l <- mkLog (User startmsg) <$> getPOSIXTime
-	us <- newTVarIO $ UserState
+	newTVarIO $ UserState
 		{ backLog = l :| []
 		, userSessionKey = sk
 		, userSigVerifier = mempty
 		}
-	_ <- sendPtyOutput p ochan us logger
-		`concurrently` sendPtyInput ichan ochan p us logger
-			`concurrently` forwardTtyInputToPty p
-	return ()
 
 -- | Forward things the user types to the Pty.
 forwardTtyInputToPty :: Pty -> IO ()
@@ -107,16 +111,24 @@ sendPtyOutput :: Pty -> TMChan (Message Seen) -> TVar UserState -> Logger -> IO
 sendPtyOutput p ochan us logger = go
   where
 	go = do
-		b <- readPty p
-		B.hPut stdout b
-		hFlush stdout
-		now <- getPOSIXTime
-		l <- atomically $ do
-			let seen = Seen (Val b)
-			sendDeveloper ochan us seen now
-		logger $ User l
+		displayOutput ochan us logger =<< readPty p
 		go
 
+-- | Display to Tty and send out the TMChan.
+displayOutput :: TMChan (Message Seen) -> TVar UserState -> Logger -> B.ByteString -> IO ()
+displayOutput ochan us logger b = do
+	B.hPut stdout b
+	hFlush stdout
+	now <- getPOSIXTime
+	l <- atomically $ do
+		let seen = Seen (Val b)
+		sendDeveloper ochan us seen now
+	logger $ User l
+
+-- | Since the Tty is in raw mode, need \r before \n
+rawLine :: B.ByteString -> B.ByteString
+rawLine b = b <> "\r\n"
+
 class SendableToDeveloper t where
 	sendDeveloper :: TMChan (Message Seen) -> TVar UserState -> t -> POSIXTime -> STM (Message Seen)
 
diff --git a/Session.hs b/Session.hs
index 5840cee..a80cad5 100644
--- a/Session.hs
+++ b/Session.hs
@@ -3,11 +3,16 @@
 module Session where
 
 import qualified Data.ByteString as B
+import qualified Data.ByteString.Char8 as B8
+import System.Exit
+import Data.Monoid
 
 startSession :: B.ByteString
 startSession = ">>> debug-me session started"
 
-sessionDone :: IO ()
-sessionDone = do
-	putStrLn ""
-	putStrLn ">>> debug-me session ended"
+endSession :: ExitCode -> B.ByteString
+endSession ec = ">>> debug-me session ended (" <> B8.pack (show n) <> ")"
+  where
+	n = case ec of
+		ExitSuccess -> 0
+		ExitFailure c -> c
diff --git a/TODO b/TODO
index 280b3eb..837fcdd 100644
--- a/TODO
+++ b/TODO
@@ -23,14 +23,13 @@
   to.
 * When Role.Developer.processSessionStart throws an error, it's caught
   somewhere, and the process exits quietly with exit code 0.
-* The "debug me session is done" is only shown to the user;
-  it ought to be included in the session log.
 * --watch and --download only get Seen messages, not Entered messages,
   because the server does not send Developer messages to them.
   To fix, need a way to avoid looping Entered messages sent by a developer
   back to themselves.
-* Improve error message when developer fails to connect due to the session
-  ID being invalid or expired.
+* --download gets a log without pauses, because timestamps are not
+  included in the wire protocol. Perhaps move the log timestamp to
+  data LogMessage?
 * Use protobuf for serialization, to make non-haskell implementations
   easier?
 * Leave the prevMessage out of Activity serialization to save BW.
@@ -41,7 +40,7 @@
   matter.)
 * loadLog should verify the hashes (and signatures) in the log, and
   refuse to use logs that are not valid proofs of a session.
-  (--replay and --graphvis need this; server's use of locaLog does not)
+  (--replay and --graphvis need this; server's use of loadLog does not)
 * gpg key downloading, web of trust checking, prompting
   Alternatively, let debug-me be started with a gpg key,
   this way a project's website can instruct their users to