diff options
Diffstat (limited to 'Pty.hs')
-rw-r--r-- | Pty.hs | 74 |
1 files changed, 30 insertions, 44 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) |