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.

1 files changed, 38 insertions, 1 deletions

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