Commit 564f604f authored by Mart Lubbers's avatar Mart Lubbers

Disable echoing on the pty's

parent 34fe1da3
Pipeline #8197 failed with stage
in 1 minute and 21 seconds
......@@ -32,6 +32,8 @@ FD_CLOEXEC :== 1
O_RDWR :== 02
O_NOCTTY :== 0400
TCSANOW :== 0
//Posix API calls
errno :: !*w -> (!Int,!*w)
strerr :: !Int -> Pointer
......@@ -55,6 +57,9 @@ grantpt :: !Int !*w -> (!Int, !*w)
unlockpt :: !Int !*w -> (!Int, !*w)
ptsname :: !Int !*w -> (!Pointer, !*w)
open :: !Pointer !Int !*w -> (!Int, !*w)
tcgetattr :: !Int !Pointer !*w -> (!Int, !*w)
cfmakeraw :: !Pointer !*w -> !*w
tcsetattr :: !Int !Int !Pointer !*w -> (!Int, !*w)
dup2 :: !Int !Int !*w -> (!Int, !*w)
close :: !Int !*w -> (!Int, !*w)
ioctl :: !Int !Int !Pointer !*w -> (!Int, !*w)
......
......@@ -100,11 +100,22 @@ open :: !Pointer !Int !*w -> (!Int, !*w)
open p flags w = code {
ccall open "pI:I:A"
}
tcgetattr :: !Int !Pointer !*w -> (!Int, !*w)
tcgetattr fp f w = code {
ccall tcgetattr "Ip:I:A"
}
cfmakeraw :: !Pointer !*w -> !*w
cfmakeraw p w = code {
ccall cfmakeraw "p:V:A"
}
tcsetattr :: !Int !Int !Pointer !*w -> (!Int, !*w)
tcsetattr fp strategy p w = code {
ccall tcsetattr "IIp:I:A"
}
dup2 :: !Int !Int !*w -> (!Int, !*w)
dup2 old new world = code {
ccall dup2 "II:I:A"
}
close :: !Int !*w -> (!Int, !*w)
close fd world = code {
ccall close "I:I:A"
......@@ -147,7 +158,7 @@ timegm tm = code {
malloc :: !Int -> Pointer
malloc num = code {
ccall malloc "p:p"
ccall malloc "I:p"
}
free :: !Pointer -> Int
free ptr = code {
......
......@@ -31,6 +31,8 @@ FD_CLOEXEC :== 1
O_RDWR :== 02
O_NOCTTY :== 0400
TCSANOW :== 0
//Posix API calls
errno :: !*w -> (!Int,!*w)
strerr :: !Int -> Pointer
......@@ -54,6 +56,9 @@ grantpt :: !Int !*w -> (!Int, !*w)
unlockpt :: !Int !*w -> (!Int, !*w)
ptsname :: !Int !*w -> (!Pointer, !*w)
open :: !Pointer !Int !*w -> (!Int, !*w)
tcgetattr :: !Int !Pointer !*w -> (!Int, !*w)
cfmakeraw :: !Pointer !*w -> !*w
tcsetattr :: !Int !Int !Pointer !*w -> (!Int, !*w)
dup2 :: !Int !Int !*w -> (!Int, !*w)
close :: !Int !*w -> (!Int, !*w)
ioctl :: !Int !Int !Pointer !*w -> (!Int, !*w)
......
......@@ -84,15 +84,15 @@ posix_openpt :: !Int !*w -> (!Int, !*w)
posix_openpt flags w = code {
ccall posix_openpt "I:I:A"
}
grantpt :: !Int *w -> (!Int, !*w)
grantpt :: !Int !*w -> (!Int, !*w)
grantpt fp w = code {
ccall grantpt "I:I:A"
}
unlockpt :: !Int *w -> (!Int, !*w)
unlockpt :: !Int !*w -> (!Int, !*w)
unlockpt fp w = code {
ccall unlockpt "I:I:A"
}
ptsname :: !Int *w -> (!Pointer, !*w)
ptsname :: !Int !*w -> (!Pointer, !*w)
ptsname fp w = code {
ccall ptsname "I:p:A"
}
......@@ -100,6 +100,18 @@ open :: !Pointer !Int !*w -> (!Int, !*w)
open p flags w = code {
ccall open "pI:I:A"
}
tcgetattr :: !Int !Pointer !*w -> (!Int, !*w)
tcgetattr fp f w = code {
ccall tcgetattr "Ip:I:A"
}
cfmakeraw :: !Pointer !*w -> !*w
cfmakeraw p w = code {
ccall cfmakeraw "p:V:A"
}
tcsetattr :: !Int !Int !Pointer !*w -> (!Int, !*w)
tcsetattr fp strategy p = code {
ccall tcsetattr "IIp:I:A"
}
dup2 :: !Int !Int !*w -> (!Int, !*w)
dup2 old new world = code {
ccall dup2 "II:I:A"
......@@ -147,7 +159,7 @@ timegm tm = code {
malloc :: !Int -> Pointer
malloc num = code {
ccall malloc "p:p"
ccall malloc "I:p"
}
free :: !Pointer -> Int
free ptr = code {
......
......@@ -98,47 +98,64 @@ runProcessPty path args mCurrentDirectory world
| slavePty == -1 = getLastOSError world
# (slavePty, world) = ptsname masterPty world
| slavePty == 0 = getLastOSError world
// StdErr
# (pipeStdErr, world) = openPipe world
| isError pipeStdErr = (liftError pipeStdErr, world)
# (pipeStdErrOut, pipeStdErrIn) = fromOk pipeStdErr
= runProcessFork (childProcess slavePty pipeStdErrOut pipeStdErrIn)
(parentProcess masterPty pipeStdErrOut pipeStdErrIn)
# (slavePty, world) = open slavePty (O_RDWR bitor O_NOCTTY) world
| slavePty == -1 = getLastOSError world
= runProcessFork (childProcess slavePty masterPty)
(parentProcess slavePty masterPty)
world
where
childProcess :: !Pointer !Int !Int !Int !Int !*World -> (!MaybeOSError (!ProcessHandle, !ProcessIO), !*World)
childProcess pipePty pipeStdErrOut pipeStdErrIn pipeExecErrorOut pipeExecErrorIn world
//redirect stdin/out/err to pipes
# (pty, world) = open pipePty (O_RDWR bitor O_NOCTTY) world
| pty == -1 = getLastOSError world
# (res, world) = dup2 pty STDIN_FILENO world
childProcess :: !Int !Int !Int !Int !*World -> (!MaybeOSError (!ProcessHandle, !ProcessIO), !*World)
childProcess slavePty masterPty pipeExecErrorOut pipeExecErrorIn world
//Disable echo
# termios = malloc 88
| termios == 0 = abort "malloc failed"
# (res, world) = tcgetattr slavePty termios world
| res == -1 = getLastOSError world
# world = cfmakeraw termios world
# (res, world) = tcsetattr slavePty TCSANOW termios world
| res == -1 = getLastOSError world
# world = freeSt termios world
# (res, world) = dup2 pty STDOUT_FILENO world
//Close the master side
# (res, world) = close masterPty world
| res == -1 = getLastOSError world
# (res, world) = dup2 pipeStdErrIn STDERR_FILENO world
//Connect the pty to the stdio
# (res, world) = dup2 slavePty STDIN_FILENO world
| res == -1 = getLastOSError world
# (res, world) = close pipeStdErrOut world
# (res, world) = dup2 slavePty STDOUT_FILENO world
| res == -1 = getLastOSError world
# (res, world) = dup2 slavePty STDERR_FILENO world
| res == -1 = getLastOSError world
//Start
# (_, world) = runProcessChildProcessExec path args mCurrentDirectory pipeExecErrorOut pipeExecErrorIn world
// this is never executed as 'childProcessExec' never returns
= (undef, world)
parentProcess :: !Int !Int !Int !Int !Int !Int !*World -> (!MaybeOSError (!ProcessHandle, !ProcessIO), !*World)
parentProcess pipePty pipeStdErrOut pipeStdErrIn pid pipeExecErrorOut pipeExecErrorIn world
# (res, world) = close pipeStdErrIn world
parentProcess :: !Int !Int !Int !Int !Int !*World -> (!MaybeOSError (!ProcessHandle, !ProcessIO), !*World)
parentProcess slavePty masterPty pid pipeExecErrorOut pipeExecErrorIn world
//Disable echo
# termios = malloc 88
| termios == 0 = abort "malloc failed"
# (res, world) = tcgetattr masterPty termios world
| res == -1 = getLastOSError world
# world = cfmakeraw termios world
# (res, world) = tcsetattr masterPty TCSANOW termios world
| res == -1 = getLastOSError world
//Close the slave side
# (res, world) = close slavePty world
| res == -1 = getLastOSError world
# world = freeSt termios world
//Start
# (mbPHandle, world) = runProcessParentProcessCheckError pid pipeExecErrorOut pipeExecErrorIn world
| isError mbPHandle = (liftError mbPHandle, world)
= ( Ok ( fromOk mbPHandle
, { stdIn = WritePipe pipePty
, stdOut = ReadPipe pipePty
, stdErr = ReadPipe pipeStdErrOut
, { stdIn = WritePipe masterPty
, stdOut = ReadPipe masterPty
, stdErr = ReadPipe masterPty
}
)
, world
)
, world)
runProcessFork :: !( Int Int *World -> (!MaybeOSError a, !*World))
!(Int Int Int *World -> (!MaybeOSError a, !*World))
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment