control window and chatting

Works!

13 files changed, 279 insertions, 38 deletions

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