From e683f156b7eb8e761c254704538914d86f309801 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Fri, 28 Apr 2017 17:00:17 -0400 Subject: control window and chatting Works! --- Role/Developer.hs | 39 ++++++++++++++++++++++++++++++++++----- Role/User.hs | 44 ++++++++++++++++++++++++++++++++++---------- 2 files changed, 68 insertions(+), 15 deletions(-) (limited to 'Role') 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) -- cgit v1.2.3