diff options
| -rw-r--r-- | Pty.hs | 74 | ||||
| -rw-r--r-- | TODO | 2 | ||||
| -rw-r--r-- | debug-me.cabal | 2 | ||||
| -rw-r--r-- | debug-me.hs | 25 | ||||
| -rw-r--r-- | stack.yaml | 1 |
5 files changed, 40 insertions, 64 deletions
@@ -1,50 +1,27 @@ -module Pty where +module Pty (Pty, runWithPty, readPty, writePty) where -import System.Posix.Terminal import System.Posix +import System.Posix.Pty hiding (setTerminalAttributes, getTerminalAttributes) +import qualified System.Console.Terminal.Size as Console +import System.Posix.Signals.Exts import System.Process -import System.IO import Control.Exception -data Master a = Master a - -data Slave a = Slave a - -data Pty = Pty - { ptyMaster :: Master Handle - , ptySlave :: Slave Handle - } - -openPty :: TerminalAttributes -> IO Pty -openPty attrs = do - (master, slave) <- openPseudoTerminal - setTerminalAttributes slave attrs Immediately - hmaster <- fdToHandle master - hslave <- fdToHandle slave - return $ Pty (Master hmaster) (Slave hslave) - --- | Make a CreateProcess run on a Pty. -onPty :: Pty -> CreateProcess -> CreateProcess -onPty (Pty _ (Slave slave)) p = p - { std_in = UseHandle slave - , std_out = UseHandle slave - , std_err = UseHandle slave - , close_fds = True - -- New session makes job control work in bash, etc. - , new_session = True - , create_group = True - -- ctrl-c should be sent to the process for handling. - , delegate_ctlc = True - } - --- | Runs an action with a child pty opened. While doing so, the --- outer pty has echo disabled (so the child can echo), and has raw mode --- enabled (so the child pty can see all special characters). -withChildPty :: (Pty -> IO a) -> IO a -withChildPty a = bracket setup cleanup go +-- | Run a program on a Pty. +-- +-- While doing so, the outer pty has echo disabled (so the child can echo), +-- and has raw mode enabled (so the child pty can see all special characters). +-- +-- A SIGWINCH handler is installed, to forward resizes to the Pty. +runWithPty :: String -> [String] -> ((Pty, ProcessHandle) -> IO a) -> IO a +runWithPty cmd params a = bracket setup cleanup go where setup = do as <- getTerminalAttributes stdInput + sz <- Console.size + (p, ph) <- spawnWithPty Nothing True cmd params + (maybe 80 Console.width sz, maybe 25 Console.height sz) + _ <- installHandler windowChange (Catch (forwardresize p)) Nothing -- This is similar to cfmakeraw(3). let masteras = as `withoutMode` IgnoreBreak @@ -63,8 +40,17 @@ withChildPty a = bracket setup cleanup go `withoutMode` ExtendedFunctions `withoutMode` EnableParity setTerminalAttributes stdInput masteras Immediately - return as - cleanup as = setTerminalAttributes stdInput as Immediately - go as = do - p <- openPty as - a p + return (p, ph, as) + cleanup (p, ph, as) = do + -- Needed in case the provided action throws an exception + -- before it waits for the process. + terminateProcess ph + closePty p + _ <- installHandler windowChange Default Nothing + setTerminalAttributes stdInput as Immediately + go (p, ph, _) = a (p, ph) + forwardresize p = do + msz <- Console.size + case msz of + Nothing -> return () + Just sz -> resizePty p (Console.width sz, Console.height sz) @@ -1,6 +1,6 @@ +* control-d does not exit debug-me * Uncommenting the networkDelay in sendPtyOutput exposes a bug in the Activity chain construction. -* set pty size, and forward resizes to the pty (setting new size and SIGWINCH) * potential DOS where developer sends Activity Entered that all refer back to the first Activity Seen. This requires the user side to keep a Backlog containing all later Activity Seen, so uses diff --git a/debug-me.cabal b/debug-me.cabal index cf9143c..88e36ac 100644 --- a/debug-me.cabal +++ b/debug-me.cabal @@ -29,6 +29,8 @@ Executable debug-me , process (>= 1.4) , async (>= 2.1) , stm (>= 2.4) + , posix-pty (>= 0.2.1) + , terminal-size (>= 0.3) Other-Modules: Hash Pty diff --git a/debug-me.hs b/debug-me.hs index 4c034b9..a5115cd 100644 --- a/debug-me.hs +++ b/debug-me.hs @@ -24,9 +24,7 @@ main = do putStrLn ">>> debug-me is exiting..." exitWith exitstatus where - go = withChildPty $ \p -> do - (Nothing, Nothing, Nothing, ph) <- createProcess $ - onPty p (proc "bash" []) + go = runWithPty "bash" [] $ \(p, ph) -> do ichan <- newTChanIO ochan <- newTChanIO dthread <- async (developer ichan ochan) @@ -38,7 +36,7 @@ main = do -- | 800 ms is about the latency to geosync orbit networkDelay :: IO () -networkDelay = threadDelay 800000 -- 150000 -- 800000 +networkDelay = threadDelay 150000 -- 800000 developer :: TChan (Activity Entered) -> TChan (Activity Seen) -> IO () developer ichan ochan = do @@ -127,17 +125,8 @@ data Backlog = Backlog (NonEmpty (HashPointer, Activity Seen)) sendPtyOutput :: Pty -> TChan (Activity Seen) -> TVar Backlog -> ProcessHandle -> IO () sendPtyOutput p ochan backlog ph = go where - Master h = ptyMaster p go = do - b <- B.hGetSome h 1024 - if b == B.empty - then do - terminateProcess ph - return () - else do - -- networkDelay - send b - send b = do + b <- readPty p atomically $ do Backlog (bl@((prevhash, _) :| _)) <- readTVar backlog let seen = Seen b @@ -151,7 +140,6 @@ sendPtyOutput p ochan backlog ph = go sendPtyInput :: TChan (Activity Entered) -> Pty -> TVar Backlog -> IO () sendPtyInput ichan p backlog = go where - Master h = ptyMaster p go = do networkDelay mb <- atomically $ do @@ -168,8 +156,7 @@ sendPtyInput ichan p backlog = go return (Left ("illegal entry", newact, bl')) case mb of Right b -> do - B.hPut h b - hFlush h + writePty p b go Left e -> do -- print e @@ -201,11 +188,11 @@ truncateBacklog (Backlog bl) _ = Backlog bl -- concatenation of all activities after that one, up to the most recent -- Seen activity. isLegal :: Activity Entered -> Backlog -> Bool -isLegal (Activity entered hp sig) (Backlog (last@(lastseenhash, _lastseen) :| bl)) +isLegal (Activity entered hp sig) (Backlog (lastseen@(lastseenhash, _lastseen) :| bl)) | lastseenhash == hp = True | B.null (echoData entered) = False -- optimisation | any (== hp) (map fst bl) = - let sincehp = reverse (last : takeWhile (\(h, _) -> h /= hp) bl) + let sincehp = reverse (lastseen : takeWhile (\(h, _) -> h /= hp) bl) in echoData entered == mconcat (map (seenData . activityContent . snd) sincehp) | otherwise = False isLegal _ _ = False @@ -2,4 +2,5 @@ packages: - '.' resolver: lts-8.9 extra-deps: +- posix-pty-0.2.1 explicit-setup-deps: |