From cf9eb1f6d1dd9a5a52a9604bff60dcbb766825fe Mon Sep 17 00:00:00 2001
From: Joey Hess <joeyh@joeyh.name>
Date: Thu, 13 Apr 2017 15:45:42 -0400
Subject: use posix-pty, and forward SIGWINCH

I discovered the posix-pty library while looking for a way to forward
SIGWINCH to the slave pty. It's taken care of a lot of nasty pty
handling details, so let's use it!

Unfortunately, this broke control-d exiting debug-me, which used to work
great. I think that the problem is that readPty never returns B.empty,
even on control-d. Or perhaps, posix-pty is doing something to the pty
that prevents control-d getting through.

I kept all the withoutMode code; at least withoutMode EnableEcho
is still needed.

This commit was sponsored by Jochen Bartl on Patreon.
---
 Pty.hs | 74 +++++++++++++++++++++++++++---------------------------------------
 1 file changed, 30 insertions(+), 44 deletions(-)

(limited to 'Pty.hs')

diff --git a/Pty.hs b/Pty.hs
index efdacd2..39e48f0 100644
--- a/Pty.hs
+++ b/Pty.hs
@@ -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)
-- 
cgit v1.2.3