control window and chatting

Works!

1 files changed, 34 insertions, 5 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