diff options
| -rw-r--r-- | Pty.hs | 70 | ||||
| -rw-r--r-- | TODO | 3 | ||||
| -rw-r--r-- | debug-me.1 | 0 | ||||
| -rw-r--r-- | debug-me.cabal | 5 | ||||
| -rw-r--r-- | debug-me.hs | 39 |
5 files changed, 116 insertions, 1 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 @@ -0,0 +1,3 @@ +* for some reason reset is needed after debug-me exits, despite it trying + to clean up the terminal settings +* set pty size, and forward resizes to the pty (setting new size and SIGWINCH) diff --git a/debug-me.1 b/debug-me.1 new file mode 100644 index 0000000..e69de29 --- /dev/null +++ b/debug-me.1 diff --git a/debug-me.cabal b/debug-me.cabal index 25bb469..23edddc 100644 --- a/debug-me.cabal +++ b/debug-me.cabal @@ -15,6 +15,7 @@ License-File: AGPL Extra-Source-Files: CHANGELOG INSTALL + TODO debug-me.1 Executable debug-me @@ -24,8 +25,12 @@ Executable debug-me base (>= 4.5 && < 5.0) , bytestring == 0.10.* , cryptonite (>= 0.20) + , unix (>= 2.7) + , process (>= 1.4) + , async (>= 2.1) Other-Modules: Hash + Pty Types source-repository head diff --git a/debug-me.hs b/debug-me.hs index 553343a..6103545 100644 --- a/debug-me.hs +++ b/debug-me.hs @@ -2,5 +2,42 @@ module Main where import Types import Hash +import Pty -main = print "hi" +import Control.Concurrent.Async +import System.IO +import System.Process +import System.Exit +import qualified Data.ByteString as B + +main :: IO () +main = do + exitstatus <- go + putStrLn "" + putStrLn ">>> debug-me is exiting..." + exitWith exitstatus + where + go = withChildPty $ \p -> do + (Nothing, Nothing, Nothing, ph) <- createProcess $ + onPty p (proc "bash" []) + let Master h = ptyMaster p + hSetBuffering stdin NoBuffering + hSetBuffering h NoBuffering + ithread <- async (forward stdin h ph) + othread <- async (forward h stdout ph) + exitstatus <- waitForProcess ph + cancel ithread + cancel othread + return exitstatus + +forward :: Handle -> Handle -> ProcessHandle -> IO () +forward from to ph = do + b <- B.hGetSome from 1024 + if b == B.empty + then do + terminateProcess ph + return () + else do + B.hPut to b + hFlush to + forward from to ph |