From e683f156b7eb8e761c254704538914d86f309801 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Fri, 28 Apr 2017 17:00:17 -0400 Subject: control window and chatting Works! --- CmdLine.hs | 21 ++++++-- ControlSocket.hs | 141 +++++++++++++++++++++++++++++++++++++++++++++++++++++ DotDir.hs | 12 +++++ Hash.hs | 1 + Log.hs | 8 ++- ProtocolBuffers.hs | 14 ++++++ Role/Developer.hs | 39 +++++++++++++-- Role/User.hs | 44 +++++++++++++---- Session.hs | 4 +- Types.hs | 5 ++ debug-me.1 | 22 ++++----- debug-me.cabal | 4 ++ debug-me.hs | 2 + 13 files changed, 279 insertions(+), 38 deletions(-) create mode 100644 ControlSocket.hs create mode 100644 DotDir.hs diff --git a/CmdLine.hs b/CmdLine.hs index a2f900b..42c28ee 100644 --- a/CmdLine.hs +++ b/CmdLine.hs @@ -16,6 +16,7 @@ data Mode | GraphvizMode GraphvizOpts | ReplayMode ReplayOpts | ServerMode ServerOpts + | ControlMode ControlOpts data UserOpts = UserOpts { gpgOpts :: [String] @@ -50,6 +51,10 @@ data ServerOpts = ServerOpts , serverPort :: Port } +data ControlOpts = ControlOpts + { controlWindow :: Bool + } + parseCmdLine :: Parser CmdLine parseCmdLine = CmdLine <$> parseMode @@ -61,6 +66,7 @@ parseMode = (UserMode <$> parseuser) <|> (WatchMode <$> parsewatch) <|> (GraphvizMode <$> parsegraphviz) <|> (ServerMode <$> parseserver) + <|> (ControlMode <$> parsecontrol) where parseuser = UserOpts <$> many (option str @@ -71,6 +77,12 @@ parseMode = (UserMode <$> parseuser) <*> optional ((,) <$> strArgument (metavar "cmd") <*> many (strArgument (metavar "opts"))) + parsedeveloper = DeveloperOpts + <$> option str + ( long "debug" + <> metavar "url" + <> help "debug a user on the given url" + ) parsegraphviz = GraphvizOpts <$> option str ( long "graphviz" @@ -112,11 +124,10 @@ parseMode = (UserMode <$> parseuser) <> showDefault <> help "port for server to listen on" ) - parsedeveloper = DeveloperOpts - <$> option str - ( long "debug" - <> metavar "url" - <> help "debug a user on the given url" + parsecontrol = ControlOpts + <$> switch + ( long "control" + <> help "control running debug-me session" ) getCmdLine :: IO CmdLine diff --git a/ControlSocket.hs b/ControlSocket.hs new file mode 100644 index 0000000..186d359 --- /dev/null +++ b/ControlSocket.hs @@ -0,0 +1,141 @@ +{-# LANGUAGE DeriveGeneric #-} + +-- | debug-me session control unix socket + +module ControlSocket where + +import Types +import DotDir +import JSON + +import System.IO +import System.Posix +import System.FilePath +import Control.Concurrent.Async +import Control.Concurrent.STM +import Control.Concurrent.STM.TMChan +import Control.Exception +import qualified Network.Socket as S +import qualified Data.ByteString.Lazy as L +import Data.Char + +data ControlInput + = ControlInputAction ControlAction + deriving (Show, Generic) + +data ControlOutput + = ControlOutputAction ControlAction + | ControlWindowOpened + deriving (Show, Generic) + +instance ToJSON ControlInput +instance FromJSON ControlInput +instance ToJSON ControlOutput +instance FromJSON ControlOutput + +defaultSocketFile :: IO FilePath +defaultSocketFile = ( "control") <$> dotDir + +-- | Opens the control window, or if that can't be done, tells the user +-- to run debug-me --control. +-- +-- Returns once either of the TMChans is closed. +openControlWindow :: IO (TMChan ControlInput, TMChan ControlOutput) +openControlWindow = do + putStrLn "You need to open another shell prompt, and run: debug-me --control" + controlsocket <- defaultSocketFile + ichan <- newTMChanIO + ochan <- newTMChanIO + _ <- async $ serveControlSocket controlsocket ichan ochan + -- Wait for message from control process. + v <- atomically $ readTMChan ochan + case v of + Just ControlWindowOpened -> return () + _ -> error "unexpected message from control process" + return (ichan, ochan) + +-- | Serve connections to the control socket, feeding data between it and +-- the TMChans. +-- +-- Returns once either of the TMChans is closed. +serveControlSocket :: FilePath -> TMChan ControlInput -> TMChan ControlOutput -> IO () +serveControlSocket socketfile ichan ochan = do + _ <- bracket setup cleanup serve + `race` waitclose + return () + where + setup = do + -- Delete any existing socket file. + removeLink socketfile + soc <- S.socket S.AF_UNIX S.Stream S.defaultProtocol + S.bind soc (S.SockAddrUnix socketfile) + setFileMode socketfile (unionFileModes ownerWriteMode ownerReadMode) + S.listen soc 2 + return soc + cleanup = S.close + serve soc = do + (sconn, _) <- S.accept soc + conn <- S.socketToHandle sconn ReadWriteMode + hSetBinaryMode conn True + _ <- async $ sendToConn conn ichan + `race` receiveFromConn conn ochan + serve soc + waitclose = atomically $ do + ic <- isClosedTMChan ichan + oc <- isClosedTMChan ochan + if ic || oc + then return () + else retry + +-- | Connects to the control socket and feeds data between it and the +-- TMChans. +-- +-- Returns when the socket server exits or the TMChan ControlInput is +-- closed. +connectControlSocket :: FilePath -> TMChan ControlInput -> TMChan ControlOutput -> IO () +connectControlSocket socketfile ichan ochan = bracket setup cleanup connected + where + setup = do + soc <- S.socket S.AF_UNIX S.Stream S.defaultProtocol + S.connect soc (S.SockAddrUnix socketfile) + conn <- S.socketToHandle soc ReadWriteMode + hSetBinaryMode conn True + return conn + cleanup conn = do + hClose conn + atomically $ do + closeTMChan ichan + closeTMChan ochan + connected conn = do + _ <- sendToConn conn ochan + `race` receiveFromConn conn ichan + return () + +sendToConn :: ToJSON a => Handle -> TMChan a -> IO () +sendToConn conn chan = go =<< atomically (readTMChan chan) + where + go Nothing = return () + go (Just v) = do + L.hPut conn (encode v) + hPutStr conn "\n" + hFlush conn + sendToConn conn chan + +receiveFromConn :: FromJSON a => Handle -> TMChan a -> IO () +receiveFromConn conn chan = withLines conn go + where + go [] = return () + go (l:ls) + | L.null l = go ls + | otherwise = case decode l of + Nothing -> error "internal control message parse error" + Just v -> do + atomically $ writeTMChan chan v + go ls + +withLines :: Handle -> ([L.ByteString] -> IO a) -> IO a +withLines conn a = do + ls <- L.split nl <$> L.hGetContents conn + a ls + where + nl = fromIntegral (ord '\n') diff --git a/DotDir.hs b/DotDir.hs new file mode 100644 index 0000000..f6dbb58 --- /dev/null +++ b/DotDir.hs @@ -0,0 +1,12 @@ +module DotDir where + +import System.Posix +import System.Directory +import System.FilePath + +dotDir :: IO FilePath +dotDir = do + home <- homeDirectory <$> (getUserEntryForID =<< getEffectiveUserID) + let dir = home ".debug-me" + createDirectoryIfMissing False dir + return dir diff --git a/Hash.hs b/Hash.hs index 3cc8d94..43dd597 100644 --- a/Hash.hs +++ b/Hash.hs @@ -50,6 +50,7 @@ instance Hashable ControlAction where hash (SessionKey pk) = hash $ Tagged "SessionKey" pk hash (SessionKeyAccepted pk) = hash $ Tagged "SessionKeyAccepted" pk hash (SessionKeyRejected pk) = hash $ Tagged "SessionKeyRejected" pk + hash (ChatMessage u m) = hash $ Tagged "ChatMessage" [hash u, hash m] instance Hashable Signature where hash (Ed25519Signature s) = hash $ Tagged "Ed25519Signature" s diff --git a/Log.hs b/Log.hs index cfbffea..ac250a1 100644 --- a/Log.hs +++ b/Log.hs @@ -7,12 +7,12 @@ import Hash import Memory import JSON import SessionID +import DotDir import Data.Char import Data.Time.Clock.POSIX import qualified Data.ByteString.Lazy as L import System.IO -import System.Posix import System.Directory import System.FilePath import Control.Exception @@ -55,16 +55,14 @@ type Timestamp = POSIXTime type Logger = AnyMessage -> IO () logDir :: IO FilePath -logDir = do - home <- homeDirectory <$> (getUserEntryForID =<< getEffectiveUserID) - return $ home ".debug-me" "log" +logDir = ( "log") <$> dotDir withSessionLogger :: SessionID -> (Logger -> IO a) -> IO a withSessionLogger sessionid a = bracket setup cleanup go where setup = do dir <- logDir - createDirectoryIfMissing True dir + createDirectoryIfMissing False dir let logfile = sessionLogFile dir sessionid putStrLn $ "** debug-me is logging to " ++ logfile return logfile diff --git a/ProtocolBuffers.hs b/ProtocolBuffers.hs index 53dfca0..51cc552 100644 --- a/ProtocolBuffers.hs +++ b/ProtocolBuffers.hs @@ -7,6 +7,9 @@ - The message types in here define protocol buffers, so should be changed - with care. These messages correspond to the main data types in the Types - module. + - + - Note that the type level numbers used with fields should never be + - changed. -} module ProtocolBuffers where @@ -63,6 +66,10 @@ data ControlActionP { sessionKeyAcceptedP :: Required 14 (Message PublicKeyP) } | SessionKeyRejectedP { sessionKeyRejectedP :: Required 15 (Message PublicKeyP) } + | ChatMessageP + { chatMessageSenderName :: Required 16 (Value B.ByteString) + , chatMessage :: Required 17 (Value B.ByteString) + } deriving (Generic) data SignatureP @@ -166,6 +173,10 @@ instance ProtocolBuffer ControlActionP T.ControlAction where { sessionKeyAcceptedP = putField $ toProtocolBuffer t } toProtocolBuffer (T.SessionKeyRejected t) = SessionKeyRejectedP { sessionKeyRejectedP = putField $ toProtocolBuffer t } + toProtocolBuffer (T.ChatMessage sendername t) = ChatMessageP + { chatMessageSenderName = putField (val sendername) + , chatMessage = putField (val t) + } fromProtocolBuffer p@(RejectedP {}) = T.Rejected $ fromProtocolBuffer $ getField $ rejectedP p fromProtocolBuffer p@(SessionKeyP {}) = T.SessionKey $ @@ -174,6 +185,9 @@ instance ProtocolBuffer ControlActionP T.ControlAction where fromProtocolBuffer $ getField $ sessionKeyAcceptedP p fromProtocolBuffer p@(SessionKeyRejectedP {}) = T.SessionKeyRejected $ fromProtocolBuffer $ getField $ sessionKeyRejectedP p + fromProtocolBuffer p@(ChatMessageP {}) = T.ChatMessage + (Val $ getField $ chatMessageSenderName p) + (Val $ getField $ chatMessage p) instance ProtocolBuffer SignatureP T.Signature where toProtocolBuffer (T.Ed25519Signature t) = Ed25519SignatureP diff --git a/Role/Developer.hs b/Role/Developer.hs index 726a53d..448e04e 100644 --- a/Role/Developer.hs +++ b/Role/Developer.hs @@ -19,6 +19,7 @@ import WebSockets import SessionID import Pty import PrevActivity +import ControlSocket import Control.Concurrent.Async import Control.Concurrent.STM @@ -47,13 +48,15 @@ run' runner url = do developer :: TMVar (TVar DeveloperState) -> TMChan (Message Entered) -> TMChan AnyMessage -> SessionID -> IO () developer dsv ichan ochan sid = withSessionLogger sid $ \logger -> do + (controlinput, controloutput) <- openControlWindow (devstate, startoutput) <- processSessionStart ochan logger dsv emitOutput startoutput ok <- authUser ichan ochan devstate logger if ok then inRawMode $ void $ sendTtyInput ichan devstate logger - `race` sendTtyOutput ochan devstate logger + `race` sendTtyOutput ochan devstate controlinput logger + `race` sendControlOutput controloutput ichan devstate logger else hPutStrLn stderr "\nUser did not grant access to their terminal." data DeveloperState = DeveloperState @@ -126,19 +129,43 @@ sendTtyInput ichan devstate logger = go logger $ Developer $ ActivityMessage act go +sendControlOutput :: TMChan ControlOutput -> TMChan (Message Entered) -> TVar DeveloperState -> Logger -> IO () +sendControlOutput controloutput ichan devstate logger = loop + where + loop = go =<< atomically (readTMChan controloutput) + go Nothing = return () + go (Just ControlWindowOpened) = loop + go (Just (ControlOutputAction c)) = do + msg <- atomically $ do + ds <- readTVar devstate + let msg = ControlMessage $ + mkSigned (developerSessionKey ds) (Control c) + writeTMChan ichan msg + return msg + logger (Developer msg) + loop + -- | Read activity from the TMChan and display it to the developer. -sendTtyOutput :: TMChan AnyMessage -> TVar DeveloperState -> Logger -> IO () -sendTtyOutput ochan devstate logger = go +-- +-- Control messages are forwarded on to the ControlInput. +sendTtyOutput :: TMChan AnyMessage -> TVar DeveloperState -> TMChan ControlInput -> Logger -> IO () +sendTtyOutput ochan devstate controlinput logger = go where go = do ts <- getPOSIXTime v <- atomically $ getServerMessage ochan devstate ts case v of Nothing -> return () - Just (o, l) -> do - logger l + Just (o, msg) -> do + logger msg emitOutput o + forwardcontrol msg go + forwardcontrol msg = case msg of + User (ControlMessage c) -> fwd c + Developer (ControlMessage c) -> fwd c + _ -> return () + fwd = atomically . writeTMChan controlinput . ControlInputAction . control -- | Present our session key to the user. -- Wait for them to accept or reject it, while displaying any Seen data @@ -252,6 +279,8 @@ getServerMessage ochan devstate ts = do return (GotControl c) processuser _ (ControlMessage (Control c@(SessionKeyRejected _) _)) = return (GotControl c) + processuser _ (ControlMessage (Control c@(ChatMessage _ _) _)) = + return (GotControl c) processdeveloper ds (ActivityMessage a) = do let msghash = hash a diff --git a/Role/User.hs b/Role/User.hs index 4ecb31f..24d85c3 100644 --- a/Role/User.hs +++ b/Role/User.hs @@ -12,6 +12,7 @@ import CmdLine import WebSockets import SessionID import PrevActivity +import ControlSocket import Control.Concurrent.Async import Control.Concurrent.STM @@ -30,6 +31,7 @@ run :: UserOpts -> IO ExitCode run os = fromMaybe (ExitFailure 101) <$> connect where connect = do + (controlinput, controloutput) <- openControlWindow putStr "Connecting to debug-me server..." hFlush stdout usv <- newEmptyTMVarIO @@ -40,22 +42,28 @@ run os = fromMaybe (ExitFailure 101) <$> connect putStrLn "Others can connect to this session and help you debug by running:" putStrLn $ " debug-me --debug " ++ url hFlush stdout - withSessionLogger sid $ go ochan ichan usv - go ochan ichan usv logger = do + withSessionLogger sid $ go ochan ichan usv controlinput controloutput + go ochan ichan usv controlinput controloutput logger = do (cmd, cmdparams) <- shellCommand os runWithPty cmd cmdparams $ \(p, ph) -> do us <- startProtocol startSession ochan logger atomically $ putTMVar usv us - p1 <- async $ sendPtyOutput p ochan us logger - p2 <- async $ sendPtyInput ichan ochan p us logger + workers <- mapM async + [ sendControlOutput controloutput ochan us logger + , sendPtyOutput p ochan us logger + ] + mainworker <- async $ sendPtyInput ichan ochan controlinput p us logger `race` forwardTtyInputToPty p exitstatus <- waitForProcess ph displayOutput ochan us logger $ rawLine "" <> rawLine (endSession exitstatus) - atomically $ closeTMChan ichan - cancel p1 - _ <- waitCatch p2 + atomically $ do + closeTMChan ichan + closeTMChan controlinput + closeTMChan controloutput + mapM_ cancel workers + _ <- waitCatch mainworker return exitstatus developerMessages :: AnyMessage -> Maybe (Message Entered) @@ -176,9 +184,10 @@ instance SendableToDeveloper ControlAction where return msg -- | Read things to be entered from the TMChan, verify if they're legal, --- and send them to the Pty. -sendPtyInput :: TMChan (Message Entered) -> TMChan (Message Seen) -> Pty -> TVar UserState -> Logger -> IO () -sendPtyInput ichan ochan p us logger = go +-- and send them to the Pty. Also handles control messages from the +-- developer. +sendPtyInput :: TMChan (Message Entered) -> TMChan (Message Seen) -> TMChan ControlInput -> Pty -> TVar UserState -> Logger -> IO () +sendPtyInput ichan ochan controlinput p us logger = go where go = do now <- getPOSIXTime @@ -195,6 +204,9 @@ sendPtyInput ichan ochan p us logger = go SessionKey pk -> do checkDeveloperPublicKey ochan us logger pk go + ChatMessage _ _ -> do + atomically $ writeTMChan controlinput (ControlInputAction c) + go Rejected r -> error $ "User side received a Rejected: " ++ show r SessionKeyAccepted _ -> error "User side received a SessionKeyAccepted" SessionKeyRejected _ -> error "User side received a SessionKeyRejected" @@ -203,6 +215,18 @@ sendPtyInput ichan ochan p us logger = go go Just (BadlySignedMessage _) -> go +sendControlOutput :: TMChan ControlOutput -> TMChan (Message Seen) -> TVar UserState -> Logger -> IO () +sendControlOutput controloutput ochan us logger = loop + where + loop = go =<< atomically (readTMChan controloutput) + go Nothing = return () + go (Just ControlWindowOpened) = loop + go (Just (ControlOutputAction c)) = do + now <- getPOSIXTime + l <- atomically $ sendDeveloper ochan us c now + logger (User l) + loop + data Input = InputMessage (Message Entered) | RejectedMessage (Message Seen) diff --git a/Session.hs b/Session.hs index a80cad5..a09a762 100644 --- a/Session.hs +++ b/Session.hs @@ -8,10 +8,10 @@ import System.Exit import Data.Monoid startSession :: B.ByteString -startSession = ">>> debug-me session started" +startSession = "** debug-me session started" endSession :: ExitCode -> B.ByteString -endSession ec = ">>> debug-me session ended (" <> B8.pack (show n) <> ")" +endSession ec = "** debug-me session ended (" <> B8.pack (show n) <> ")" where n = case ec of ExitSuccess -> 0 diff --git a/Types.hs b/Types.hs index bcd1311..78c59a2 100644 --- a/Types.hs +++ b/Types.hs @@ -91,13 +91,18 @@ data ControlAction -- ^ sent by the user to in response to SessionKey | SessionKeyRejected PublicKey -- ^ sent by the user to in response to SessionKey + | ChatMessage SenderName Val + -- ^ sent by user or developer at any time deriving (Show, Generic) +type SenderName = Val + instance DataSize ControlAction where dataSize (Rejected a) = dataSize a dataSize (SessionKey k) = dataSize k dataSize (SessionKeyAccepted k) = dataSize k dataSize (SessionKeyRejected k) = dataSize k + dataSize (ChatMessage s m) = dataSize s + dataSize m data Hash = Hash { hashMethod :: HashMethod diff --git a/debug-me.1 b/debug-me.1 index 22f32bc..154b5e4 100644 --- a/debug-me.1 +++ b/debug-me.1 @@ -44,17 +44,6 @@ debug-me runs gpg to verify the GPG key of a developer. To pass options to gpg, use --gpg-opt with the option to pass. For example: --gpg-opt=--keyserver=pgpkeys.mit.edu This can be done multiple times. -.IP "--control" -debug-me uses a separate window from the one displaying the debug-me -session to control the session. This control window is where debug-me will -show you the Gnupg keys of developers who connect and let you decide if -they should access the session. You can also chat with the developer -in the control window during the session. -.IP -Normally, the control window will be opened when debug-me starts, -by running a terminal emulator (xterm or gnome-terminal, etc). -If debug-me is not being run in a graphical environment, that won't work, -and you'll need to open another shell and run "debug-me --control" to see it. .SH DEVELOPER OPTIONS .IP "--debug url" Connect to a debug-me session on the specified url. The developer runs @@ -62,6 +51,17 @@ debug-me with this option to see and interact with the user's bug. .IP "--watch url" Connect to a debug-me session on the specified url and display what happens in the session. Your keystrokes will not be sent to the session. +.SH COMMON SESSION OPTIONS +.IP "--control" +debug-me uses a separate window from the one displaying the debug-me +session, to control the session. This control window is where debug-me +shows the user what developers want to connect to the session. +The user and developer can also chat using the control window. +.IP +Normally, the control window will be opened when debug-me starts, +by running a terminal emulator (xterm or gnome-terminal, etc). +If debug-me is not being run in a graphical environment, that won't work, +and you'll need to open another shell prompt and run "debug-me --control" to see it. .SH LOG FILE OPTIONS .IP "--download url" Download a debug-me log file from the specified url. Note that if the diff --git a/debug-me.cabal b/debug-me.cabal index 254590c..329b2a9 100644 --- a/debug-me.cabal +++ b/debug-me.cabal @@ -61,9 +61,13 @@ Executable debug-me , uuid (>= 1.3) , protobuf (>= 0.2) , cereal (>= 0.5) + , utf8-string (>= 1.0) Other-Modules: + Control + ControlSocket CmdLine Crypto + DotDir Graphviz Hash JSON diff --git a/debug-me.hs b/debug-me.hs index 9319483..98d2d27 100644 --- a/debug-me.hs +++ b/debug-me.hs @@ -4,6 +4,7 @@ import CmdLine import Graphviz import Replay import Server +import Control import qualified Role.User import qualified Role.Developer import qualified Role.Downloader @@ -23,3 +24,4 @@ main = withSocketsDo $ do GraphvizMode o -> graphviz o ReplayMode o -> replay o ServerMode o -> server o + ControlMode o -> control o -- cgit v1.2.3