diff options
author | Joey Hess <joeyh@joeyh.name> | 2017-04-22 00:40:37 -0400 |
---|---|---|
committer | Joey Hess <joeyh@joeyh.name> | 2017-04-22 00:40:37 -0400 |
commit | aa2771b7615b91ba60249f6164c01dbda26c56e7 (patch) | |
tree | d02e180f9240bd9bb7f681ec6a4f9f3cec007ac0 /Role/User.hs | |
parent | 03c44e0d50008d2cd304efee017cd9709ddd2779 (diff) | |
download | debug-me-aa2771b7615b91ba60249f6164c01dbda26c56e7.tar.gz |
Loop user input and output between Pty and outer Tty
Diffstat (limited to 'Role/User.hs')
-rw-r--r-- | Role/User.hs | 22 |
1 files changed, 19 insertions, 3 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) |