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 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 TODO           |  3 +++
 debug-me.1     |  0
 debug-me.cabal |  5 +++++
 debug-me.hs    | 39 +++++++++++++++++++++++++++++++-
 5 files changed, 116 insertions(+), 1 deletion(-)
 create mode 100644 Pty.hs
 create mode 100644 TODO
 create mode 100644 debug-me.1

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