control window and chatting

Works!

1 files changed, 34 insertions, 10 deletions

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)