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
...@@ -4,7 +4,7 @@ from System._Pointer import :: Pointer ...@@ -4,7 +4,7 @@ from System._Pointer import :: Pointer
from StdInt import IF_INT_64_OR_32 from StdInt import IF_INT_64_OR_32
from System.Time import :: Tm from System.Time import :: Tm
WNOHANG :== 0x00000001 WNOHANG :== 0x00000001
WUNTRACED :== 0x00000002 WUNTRACED :== 0x00000002
MAXPATHLEN :== 1024 MAXPATHLEN :== 1024
...@@ -32,6 +32,8 @@ FD_CLOEXEC :== 1 ...@@ -32,6 +32,8 @@ FD_CLOEXEC :== 1
O_RDWR :== 02 O_RDWR :== 02
O_NOCTTY :== 0400 O_NOCTTY :== 0400
TCSANOW :== 0
//Posix API calls //Posix API calls
errno :: !*w -> (!Int,!*w) errno :: !*w -> (!Int,!*w)
strerr :: !Int -> Pointer strerr :: !Int -> Pointer
...@@ -55,6 +57,9 @@ grantpt :: !Int !*w -> (!Int, !*w) ...@@ -55,6 +57,9 @@ grantpt :: !Int !*w -> (!Int, !*w)
unlockpt :: !Int !*w -> (!Int, !*w) unlockpt :: !Int !*w -> (!Int, !*w)
ptsname :: !Int !*w -> (!Pointer, !*w) ptsname :: !Int !*w -> (!Pointer, !*w)
open :: !Pointer !Int !*w -> (!Int, !*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) dup2 :: !Int !Int !*w -> (!Int, !*w)
close :: !Int !*w -> (!Int, !*w) close :: !Int !*w -> (!Int, !*w)
ioctl :: !Int !Int !Pointer !*w -> (!Int, !*w) ioctl :: !Int !Int !Pointer !*w -> (!Int, !*w)
......
...@@ -100,11 +100,22 @@ open :: !Pointer !Int !*w -> (!Int, !*w) ...@@ -100,11 +100,22 @@ open :: !Pointer !Int !*w -> (!Int, !*w)
open p flags w = code { open p flags w = code {
ccall open "pI:I:A" 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 :: !Int !Int !*w -> (!Int, !*w)
dup2 old new world = code { dup2 old new world = code {
ccall dup2 "II:I:A" ccall dup2 "II:I:A"
} }
close :: !Int !*w -> (!Int, !*w) close :: !Int !*w -> (!Int, !*w)
close fd world = code { close fd world = code {
ccall close "I:I:A" ccall close "I:I:A"
...@@ -147,7 +158,7 @@ timegm tm = code { ...@@ -147,7 +158,7 @@ timegm tm = code {
malloc :: !Int -> Pointer malloc :: !Int -> Pointer
malloc num = code { malloc num = code {
ccall malloc "p:p" ccall malloc "I:p"
} }
free :: !Pointer -> Int free :: !Pointer -> Int
free ptr = code { free ptr = code {
......
...@@ -31,6 +31,8 @@ FD_CLOEXEC :== 1 ...@@ -31,6 +31,8 @@ FD_CLOEXEC :== 1
O_RDWR :== 02 O_RDWR :== 02
O_NOCTTY :== 0400 O_NOCTTY :== 0400
TCSANOW :== 0
//Posix API calls //Posix API calls
errno :: !*w -> (!Int,!*w) errno :: !*w -> (!Int,!*w)
strerr :: !Int -> Pointer strerr :: !Int -> Pointer
...@@ -54,6 +56,9 @@ grantpt :: !Int !*w -> (!Int, !*w) ...@@ -54,6 +56,9 @@ grantpt :: !Int !*w -> (!Int, !*w)
unlockpt :: !Int !*w -> (!Int, !*w) unlockpt :: !Int !*w -> (!Int, !*w)
ptsname :: !Int !*w -> (!Pointer, !*w) ptsname :: !Int !*w -> (!Pointer, !*w)
open :: !Pointer !Int !*w -> (!Int, !*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) dup2 :: !Int !Int !*w -> (!Int, !*w)
close :: !Int !*w -> (!Int, !*w) close :: !Int !*w -> (!Int, !*w)
ioctl :: !Int !Int !Pointer !*w -> (!Int, !*w) ioctl :: !Int !Int !Pointer !*w -> (!Int, !*w)
......
...@@ -84,15 +84,15 @@ posix_openpt :: !Int !*w -> (!Int, !*w) ...@@ -84,15 +84,15 @@ posix_openpt :: !Int !*w -> (!Int, !*w)
posix_openpt flags w = code { posix_openpt flags w = code {
ccall posix_openpt "I:I:A" ccall posix_openpt "I:I:A"
} }
grantpt :: !Int *w -> (!Int, !*w) grantpt :: !Int !*w -> (!Int, !*w)
grantpt fp w = code { grantpt fp w = code {
ccall grantpt "I:I:A" ccall grantpt "I:I:A"
} }
unlockpt :: !Int *w -> (!Int, !*w) unlockpt :: !Int !*w -> (!Int, !*w)
unlockpt fp w = code { unlockpt fp w = code {
ccall unlockpt "I:I:A" ccall unlockpt "I:I:A"
} }
ptsname :: !Int *w -> (!Pointer, !*w) ptsname :: !Int !*w -> (!Pointer, !*w)
ptsname fp w = code { ptsname fp w = code {
ccall ptsname "I:p:A" ccall ptsname "I:p:A"
} }
...@@ -100,6 +100,18 @@ open :: !Pointer !Int !*w -> (!Int, !*w) ...@@ -100,6 +100,18 @@ open :: !Pointer !Int !*w -> (!Int, !*w)
open p flags w = code { open p flags w = code {
ccall open "pI:I:A" 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 :: !Int !Int !*w -> (!Int, !*w)
dup2 old new world = code { dup2 old new world = code {
ccall dup2 "II:I:A" ccall dup2 "II:I:A"
...@@ -147,7 +159,7 @@ timegm tm = code { ...@@ -147,7 +159,7 @@ timegm tm = code {
malloc :: !Int -> Pointer malloc :: !Int -> Pointer
malloc num = code { malloc num = code {
ccall malloc "p:p" ccall malloc "I:p"
} }
free :: !Pointer -> Int free :: !Pointer -> Int
free ptr = code { free ptr = code {
......
...@@ -98,47 +98,64 @@ runProcessPty path args mCurrentDirectory world ...@@ -98,47 +98,64 @@ runProcessPty path args mCurrentDirectory world
| slavePty == -1 = getLastOSError world | slavePty == -1 = getLastOSError world
# (slavePty, world) = ptsname masterPty world # (slavePty, world) = ptsname masterPty world
| slavePty == 0 = getLastOSError world | slavePty == 0 = getLastOSError world
// StdErr # (slavePty, world) = open slavePty (O_RDWR bitor O_NOCTTY) world
# (pipeStdErr, world) = openPipe world | slavePty == -1 = getLastOSError world
| isError pipeStdErr = (liftError pipeStdErr, world) = runProcessFork (childProcess slavePty masterPty)
# (pipeStdErrOut, pipeStdErrIn) = fromOk pipeStdErr (parentProcess slavePty masterPty)
= runProcessFork (childProcess slavePty pipeStdErrOut pipeStdErrIn) world
(parentProcess masterPty pipeStdErrOut pipeStdErrIn)
world
where where
childProcess :: !Pointer !Int !Int !Int !Int !*World -> (!MaybeOSError (!ProcessHandle, !ProcessIO), !*World) childProcess :: !Int !Int !Int !Int !*World -> (!MaybeOSError (!ProcessHandle, !ProcessIO), !*World)
childProcess pipePty pipeStdErrOut pipeStdErrIn pipeExecErrorOut pipeExecErrorIn world childProcess slavePty masterPty pipeExecErrorOut pipeExecErrorIn world
//redirect stdin/out/err to pipes //Disable echo
# (pty, world) = open pipePty (O_RDWR bitor O_NOCTTY) world # termios = malloc 88
| pty == -1 = getLastOSError world | termios == 0 = abort "malloc failed"
# (res, world) = dup2 pty STDIN_FILENO world # (res, world) = tcgetattr slavePty termios world
| res == -1 = getLastOSError world | res == -1 = getLastOSError world
# world = cfmakeraw termios world
# (res, world) = dup2 pty STDOUT_FILENO world # (res, world) = tcsetattr slavePty TCSANOW termios world
| res == -1 = getLastOSError world | res == -1 = getLastOSError world
# world = freeSt termios world
# (res, world) = dup2 pipeStdErrIn STDERR_FILENO world
| res == -1 = getLastOSError world //Close the master side
# (res, world) = close pipeStdErrOut world # (res, world) = close masterPty world
| res == -1 = getLastOSError world | res == -1 = getLastOSError world
//Connect the pty to the stdio
# (res, world) = dup2 slavePty STDIN_FILENO world
| res == -1 = getLastOSError 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 # (_, world) = runProcessChildProcessExec path args mCurrentDirectory pipeExecErrorOut pipeExecErrorIn world
// this is never executed as 'childProcessExec' never returns // this is never executed as 'childProcessExec' never returns
= (undef, world) = (undef, world)
parentProcess :: !Int !Int !Int !Int !Int !Int !*World -> (!MaybeOSError (!ProcessHandle, !ProcessIO), !*World) parentProcess :: !Int !Int !Int !Int !Int !*World -> (!MaybeOSError (!ProcessHandle, !ProcessIO), !*World)
parentProcess pipePty pipeStdErrOut pipeStdErrIn pid pipeExecErrorOut pipeExecErrorIn world parentProcess slavePty masterPty pid pipeExecErrorOut pipeExecErrorIn world
# (res, world) = close pipeStdErrIn world //Disable echo
| res == -1 = getLastOSError world # termios = malloc 88
# (mbPHandle, world) = runProcessParentProcessCheckError pid pipeExecErrorOut pipeExecErrorIn world | termios == 0 = abort "malloc failed"
| isError mbPHandle = (liftError mbPHandle, world) # (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 = ( Ok ( fromOk mbPHandle
, { stdIn = WritePipe pipePty , { stdIn = WritePipe masterPty
, stdOut = ReadPipe pipePty , stdOut = ReadPipe masterPty
, stdErr = ReadPipe pipeStdErrOut , stdErr = ReadPipe masterPty
} }
) )
, world , world)
)
runProcessFork :: !( Int Int *World -> (!MaybeOSError a, !*World)) runProcessFork :: !( Int Int *World -> (!MaybeOSError a, !*World))
!(Int 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