control window and chatting

Works!

2 files changed, 68 insertions, 15 deletions

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)