diff options
Diffstat (limited to 'Role/Developer.hs')
-rw-r--r-- | Role/Developer.hs | 39 |
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 |