diff options
| -rw-r--r-- | Role/User.hs | 22 | ||||
| -rw-r--r-- | TODO | 1 |
2 files changed, 19 insertions, 4 deletions
diff --git a/Role/User.hs b/Role/User.hs index 5fb8897..3eb2ebc 100644 --- a/Role/User.hs +++ b/Role/User.hs @@ -19,7 +19,6 @@ import System.Exit import qualified Data.ByteString as B import Data.List.NonEmpty (NonEmpty(..), toList) import Data.Monoid -import Data.Maybe import Data.Time.Clock.POSIX import System.IO import System.Environment @@ -69,8 +68,11 @@ user starttxt p ochan ichan = withLogger "debug-me.log" $ \logger -> do pk <- myPublicKey sk let c = mkSigned sk $ Control (SessionKey pk) initialmessage $ ControlMessage c - let act = mkSigned sk $ Activity (Seen (Val (starttxt <> "\r\n"))) Nothing + let starttxt' = starttxt <> "\r\n" + let act = mkSigned sk $ Activity (Seen (Val starttxt')) Nothing let startmsg = ActivityMessage act + B.hPut stdout starttxt' + hFlush stdout initialmessage startmsg l <- mkLog (User startmsg) <$> getPOSIXTime us <- newTVarIO $ UserState @@ -80,14 +82,28 @@ user starttxt p ochan ichan = withLogger "debug-me.log" $ \logger -> do } _ <- sendPtyOutput p ochan us logger `concurrently` sendPtyInput ichan ochan p us logger + `concurrently` forwardTtyInputToPty p return () --- | Forward things written to the Pty out the TChan. +-- | Forward things the user types to the Pty. +forwardTtyInputToPty :: Pty -> IO () +forwardTtyInputToPty p = do + b <- B.hGetSome stdin 1024 + if B.null b + then return () + else do + writePty p b + forwardTtyInputToPty p + +-- | Forward things written to the Pty out the TChan, and also display +-- it on their Tty. sendPtyOutput :: Pty -> TChan (Message Seen) -> TVar UserState -> Logger -> IO () sendPtyOutput p ochan us logger = go where go = do b <- readPty p + B.hPut stdout b + hFlush stdout now <- getPOSIXTime l <- atomically $ do let seen = Seen (Val b) @@ -26,7 +26,6 @@ because the server does not send Developer messages to them. To fix, need a way to avoid looping Entered messages sent by a developer back to themselves. -* Loop user input and output to their outer pty.. * Improve error message when developer fails to connect due to the session ID being invalid or expored. * Use protobuf for serialization, to make non-haskell implementations |