From 58e71d656c3cfb6862647cdf215676b529a00c93 Mon Sep 17 00:00:00 2001
From: Joey Hess <joeyh@joeyh.name>
Date: Tue, 11 Apr 2017 15:31:50 -0400
Subject: 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.
---
 Pty.hs | 70 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 70 insertions(+)
 create mode 100644 Pty.hs

(limited to 'Pty.hs')

diff --git a/Pty.hs b/Pty.hs
new file mode 100644
index 0000000..efdacd2
--- /dev/null
+++ b/Pty.hs
@@ -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
-- 
cgit v1.2.3