From a835e9e4b410d98bcae0c0f5be485e6daac407d4 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Tue, 25 Apr 2017 00:21:44 -0400 Subject: include "session is done" in the session transcript Including the process exit status. And cleaner Role.User shutdown sequence. --- Replay.hs | 3 +-- Role/User.hs | 68 +++++++++++++++++++++++++++++++++++------------------------- Session.hs | 13 ++++++++---- TODO | 9 ++++---- 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 -- cgit v1.2.3