diff options
author | Joey Hess <joeyh@joeyh.name> | 2017-04-11 15:31:50 -0400 |
---|---|---|
committer | Joey Hess <joeyh@joeyh.name> | 2017-04-11 15:31:50 -0400 |
commit | 58e71d656c3cfb6862647cdf215676b529a00c93 (patch) | |
tree | 0b5abf34bb448eaa4242ef5aeb1aae3de7f193ac /Pty.hs | |
parent | bf71e5f4d875806e8f2623d95545c8b7a7c2d8f4 (diff) | |
download | debug-me-58e71d656c3cfb6862647cdf215676b529a00c93.tar.gz |
debug-me is able to run a shell in a slave pty
Lots of terminal mode fun. Has a few warts still, but it works well
enough to be comfortable, and even vim works ok.
This commit was sponsored by John Peloquin on Patreon.
Diffstat (limited to 'Pty.hs')
-rw-r--r-- | Pty.hs | 70 |
1 files changed, 70 insertions, 0 deletions
@@ -0,0 +1,70 @@ +module Pty where + +import System.Posix.Terminal +import System.Posix +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 + where + setup = do + as <- getTerminalAttributes stdInput + -- This is similar to cfmakeraw(3). + let masteras = as + `withoutMode` IgnoreBreak + `withoutMode` InterruptOnBreak + `withoutMode` CheckParity + `withoutMode` StripHighBit + `withoutMode` MapLFtoCR + `withoutMode` IgnoreCR + `withoutMode` MapCRtoLF + `withoutMode` StartStopOutput + `withoutMode` ProcessOutput + `withoutMode` EnableEcho + `withoutMode` EchoLF + `withoutMode` ProcessInput + `withoutMode` KeyboardInterrupts + `withoutMode` ExtendedFunctions + `withoutMode` EnableParity + setTerminalAttributes stdInput masteras Immediately + return as + cleanup as = setTerminalAttributes stdInput as Immediately + go as = do + p <- openPty as + a p |