Commit b10e7d1c authored by judah's avatar judah
Browse files

Refactor terminal unit tests.

Previously we used the "script" command-line utility to capture output from
programs that expected to be run in a terminal.  
Now, we use openpty and other C function (as wrapped by the unix library) to
run them directly from Haskell.  

As a related change, we now return the individual chunks of bytes that were
output from the process that we're testing.  This lets us test its behavior
more specifically, in particular in the "file style" tests with an incomplete
byte sequence at EOF.
parent 9afc1d2d
{-# LANGUAGE ForeignFunctionInterface #-}
-- This module is a quick-and-dirty way to run an executable
-- within a pseudoterminal and obtain its output.
--
-- It is not intended for general use. In particular:
-- - It expects the output to be available quickly (<0.2s)
-- after each chunk of input.
-- - It expects each output chunk be no more than 4096 bytes.
module Pty (runCommandInPty) where
import System.Posix.Types
import System.Posix.Terminal
import System.Posix.Process
import System.Posix.Signals
import qualified Data.ByteString as B
import System.Posix.IO.ByteString
import Foreign.Marshal.Alloc
import Foreign.C.Error
import Foreign.C.Types
import Foreign.Ptr
import Control.Exception
import Control.Concurrent
import Control.Monad (liftM2)
-- Run the given command in a pseudoterminal, and return its output chunks.
-- Read the initial output, then feed the given input to it
-- one block at a time.
-- After each input, pause for 0.2s and then read as much output as possible.
runCommandInPty :: String -> [String] -> Maybe [(String,String)]
-> [B.ByteString] -> IO [B.ByteString]
runCommandInPty prog args env inputs = do
(fd,pid) <- forkCommandInPty prog args env
-- Block until the initial output from the program.
-- After that, only use non-blocking reads. Otherwise,
-- we would hang the program in cases where the program has no output
-- in between inputs.
firstOutput <- getOutput fd
setFdOption fd NonBlockingRead True
outputs <- mapM (inputOutput fd) inputs
signalProcess killProcess pid
status <- getProcessStatus True False pid
closeFd fd
return (firstOutput : outputs)
inputOutput :: Fd -> B.ByteString -> IO B.ByteString
inputOutput fd input = do
putInput fd input
getOutput fd
putInput :: Fd -> B.ByteString -> IO ()
putInput fd input =
B.useAsCStringLen input $ \(cstr,len) -> do
written <- fdWriteBuf fd (castPtr cstr) (fromIntegral len)
if written == 0
then threadDelay 1000 >> putInput fd input
else return ()
getOutput :: Fd -> IO B.ByteString
getOutput fd = do
threadDelay 20000
allocaBytes (fromIntegral numBytes) $ \buf -> do
num <- fdReadNonBlocking fd buf numBytes
B.packCStringLen (castPtr buf, fromIntegral num)
where
numBytes = 4096
-- Unlike fdReadBuf, don't throw an error if nothing's immediately available.
-- Instead, just return empty output.
fdReadNonBlocking :: Fd -> Ptr CChar -> CSize -> IO CSsize
fdReadNonBlocking fd buf n = do
num_read <- c_read fd buf n
if num_read >= 0
then return num_read
else do
e <- getErrno
if e == eAGAIN
then return 0
else throwErrno "fdReadNonBlocking"
foreign import ccall "read" c_read :: Fd -> Ptr CChar -> CSize -> IO CSsize
-- returns the master Fd, and the pid for the subprocess.
forkCommandInPty :: String -> [String] -> Maybe [(String,String)]
-> IO (Fd,ProcessID)
forkCommandInPty prog args env = do
(master,slave) <- openPseudoTerminal
pid <- forkProcess $ do
closeFd master
loginTTY slave
executeFile prog False args env
return (master,pid)
loginTTY :: Fd -> IO ()
loginTTY = throwErrnoIfMinus1_ "loginTTY" . login_tty
foreign import ccall login_tty :: Fd -> IO CInt
{-# LANGUAGE RecordWildCards #-}
-- This module provides an interface for running terminal-using programs
-- without the presence of a terminal.
-- It uses the "script" command to run a program and capture its output.
-- This module provides an interface for testing the output
-- of programs that expect to be run in a terminal.
module RunTTY (Invocation(..),
runInvocation,
assertInvocation,
......@@ -16,13 +15,12 @@ import Data.ByteString as B
import qualified Data.ByteString.Char8 as BC
import System.Posix.Env.ByteString hiding (setEnv)
import System.Process
import System.Directory
import System.Timeout
import Control.Concurrent.Async
import Control.Concurrent
import System.IO
import Test.HUnit
import Control.Monad (unless)
import Control.Monad (unless, liftM2, zipWithM_)
import Pty
data Invocation = Invocation {
......@@ -50,69 +48,60 @@ runInvocation :: Invocation
-> [B.ByteString] -- Input chunks. (We pause after each chunk to
-- simulate real user input and prevent Haskeline
-- from coalescing the changes.)
-> IO B.ByteString
runInvocation Invocation {..} input = do
tempDir <- getTemporaryDirectory
(fTemp,hTemp) <- openTempFile tempDir "input.txt"
hClose hTemp
let p
| not runInTTY = proc prog progArgs
| otherwise = proc "script" $
[ "-q" -- no start/stop status
, "-k" -- include user input
, "-t", "0" -- flush after every character I/O
, fTemp
, prog
] ++ progArgs
-> IO [B.ByteString]
runInvocation Invocation {..} inputs
| runInTTY = runCommandInPty prog progArgs (Just environment) inputs
| otherwise = do
(Just inH, Just outH, Nothing, ph)
<- createProcess p
<- createProcess (proc prog progArgs)
{ env = Just environment
, std_in = CreatePipe
, std_out = CreatePipe
, std_err = Inherit
}
readOut <- async $ B.hGetContents outH
mapM_ (\i -> B.hPutStr inH i >> hFlush inH >> threadDelay 20000) input
hSetBuffering inH NoBuffering
firstOutput <- getOutput outH
outputs <- mapM (inputOutput inH outH) inputs
hClose inH
-- if the process is paused, wait 1/5 of a second before forcing it
-- to close.
race (waitForProcess ph)
(threadDelay 100000
>> terminateProcess ph >> waitForProcess ph)
output <- wait readOut
tempContents <- B.readFile fTemp
removeFile fTemp
return $ if runInTTY then tempContents else output
lastOutput <- getOutput outH -- output triggered by EOF, if any
terminateProcess ph
waitForProcess ph
return $ firstOutput : outputs
++ if B.null lastOutput then [] else [lastOutput]
inputOutput :: Handle -> Handle -> B.ByteString -> IO B.ByteString
inputOutput inH outH input = do
B.hPut inH input
getOutput outH
getOutput :: Handle -> IO B.ByteString
getOutput h = do
threadDelay 20000
B.hGetNonBlocking h 4096
assertInvocation :: Invocation -> [B.ByteString] -> [B.ByteString]
-> Assertion
assertInvocation i input output = do
let expectedOutput = if runInTTY i
then interleave input output
else B.concat output
assertInvocation i input expectedOutput = do
actualOutput <- runInvocation i input
assertSame ((if runInTTY i then fixInput else id) expectedOutput)
(fixOutput actualOutput)
assertSameList expectedOutput $ fmap fixOutput actualOutput
interleave (x:xs) (y:ys) = x `B.append` y `B.append` interleave xs ys
interleave xs [] = B.concat xs
interleave [] ys = B.concat ys
-- script expands LF -> CRLF (like a normal terminal would)
-- so we'll do the same for our inputs/outputs
fixInput = B.concatMap
$ \c -> if c == 10 then B.pack [13,10] else B.singleton c
-- script turns "\ESC" from input into "^["
-- so we'll normalize any "^[" into "\ESC"
-- Remove CRLFs from output, since tty translates all LFs into CRLF.
-- (TODO: I'd like to just unset ONLCR in the slave tty, but
-- System.Posix.Terminal doesn't support that flag.)
fixOutput = BC.pack . loop . BC.unpack
where
loop ('^':'[':rest) = '\ESC':loop rest
loop ('\r':'\n':rest) = '\n' : loop rest
loop (c:cs) = c : loop cs
loop [] = []
assertSameList :: (Show a, Eq a) => [a] -> [a] -> Assertion
assertSameList [] [] = return ()
assertSameList (x:xs) (y:ys)
| x == y = assertSameList xs ys
assertSameList xs ys = xs @=? ys -- cause error to be thrown
assertSame :: B.ByteString -> B.ByteString -> Assertion
assertSame expected actual = do
let (same,expected',actual') = commonPrefix expected actual
......
......@@ -58,32 +58,39 @@ interactionTests i = "interaction" ~: test
unicodeEncoding i = "Unicode encoding (valid)" ~:
[ utf8Test i [utf8 "xαβγy"]
[prompt 0 <> utf8 "xαβγy"]
, utf8Test i [utf8 "xαβyψ안기q영\nquit\n"]
[ prompt 0 <> utf8 "xαβyψ안기q영" <> end
<> output 0 (utf8 "xαβyψ안기q영")
, prompt 1 <> utf8 "quit" <> end
[prompt 0, utf8 "xαβγy"]
, utf8Test i [utf8 "a\n", "quit\n"]
[ prompt 0
, utf8 "a" <> end
<> output 0 (utf8 "a") <> prompt 1
, utf8 "quit" <> end
]
, utf8Test i [utf8 "xαβyψ안기q영\n", "quit\n"]
[ prompt 0
, utf8 "xαβyψ안기q영" <> end
<> output 0 (utf8 "xαβyψ안기q영") <> prompt 1
, utf8 "quit" <> end
]
-- test buffering: 32 bytes is in middle of a char encoding,
-- also test long paste
, "multipleLines" ~: utf8Test i [l1 <> "\n" <> l1]
[prompt 0 <> l1 <> end <> output 0 l1
<> prompt 1 <> l1]
[ prompt 0
, l1 <> end <> output 0 l1 <> prompt 1 <> l1]
]
where
l1 = utf8 $ T.replicate 30 "안" -- three bytes, width 60
unicodeMovement i = "Unicode movement" ~:
[ "separate" ~: utf8Test i [utf8 "α", utf8 "\ESC[Dx"]
[prompt 0 <> utf8 "α", utf8 "\b\b"]
[prompt 0, utf8 "α", utf8 "\b\b"]
, "coalesced" ~: utf8Test i [utf8 \ESC[Dx"]
[prompt 0 <> utf8 "xα\b"]
[prompt 0, utf8 "xα\b"]
, "lineWrap" ~: utf8Test i
[ utf8 longWideChar
, raw [1]
, raw [5]
]
[prompt 0 <> utf8 lwc1 <> wrap <> utf8 lwc2 <> wrap <> utf8 lwc3
[prompt 0, utf8 lwc1 <> wrap <> utf8 lwc2 <> wrap <> utf8 lwc3
, cr <> "\ESC[2A\ESC[2C"
, cr <> nl <> nl <> "\ESC[22C"
]
......@@ -99,8 +106,8 @@ unicodeMovement i = "Unicode movement" ~:
tabCompletion i = "tab completion" ~:
[ utf8Test i [ utf8 "dummy-μ\t\t" ]
[ prompt 0 <> utf8 "dummy-μασ/"
, nl <> utf8 "bar ςερτ" <> nl
[ prompt 0, utf8 "dummy-μασ/"
<> nl <> utf8 "bar ςερτ" <> nl
<> prompt' 0 <> utf8 "dummy-μασ/"
]
]
......@@ -109,25 +116,25 @@ incorrectInput i = "incorrect input" ~:
[ utf8Test i [ utf8 "x" <> raw [206] ] -- needs one more byte
-- non-legacy encoder ignores the "206" since it's still waiting
-- for more input.
[ prompt 0 <> utf8 "x" <> whenLegacy err ]
[ prompt 0, utf8 "x" <> whenLegacy err ]
, utf8Test i [ raw [206] <> utf8 "x" ]
-- 'x' is not valid after '\206', so both the legacy and
-- non-legacy encoders should handle the "x" correctly.
[ prompt 0 <> err <> utf8 "x"]
[ prompt 0, err <> utf8 "x"]
, utf8Test i [ raw [236,149] <> utf8 "x" ] -- needs one more byte
[prompt 0 <> err <> err <> utf8 "x"]
[prompt 0, err <> err <> utf8 "x"]
]
historyTests i = "history encoding" ~:
[ utf8TestValidHist i [ "\ESC[A" ]
[prompt 0 <> utf8 "abcα" ]
[prompt 0, utf8 "abcα" ]
, utf8TestInvalidHist i [ "\ESC[A" ]
-- NB: this is decoded by either utf8-string or base;
-- either way they produce \65533 instead of '?'.
[prompt 0 <> utf8 "abcα\65533x\65533x\65533" ]
[prompt 0, utf8 "abcα\65533x\65533x\65533" ]
-- In latin-1: read errors as utf-8 '\65533', display as '?'
, latin1TestInvalidHist i [ "\ESC[A" ]
[prompt 0 <> utf8 "abc??x?x?" ]
[prompt 0, utf8 "abc??x?x?" ]
]
invalidHist = utf8 "abcα"
......@@ -142,21 +149,28 @@ validHist = utf8 "abcα"
inputChar i = "getInputChar" ~:
[ utf8Test i [utf8 "xαβ"]
[ prompt 0 <> utf8 "x" <> end <> output 0 (utf8 "x")
[ prompt 0, utf8 "x" <> end <> output 0 (utf8 "x")
<> prompt 1 <> utf8 "α" <> end <> output 1 (utf8 "α")
<> prompt 2 <> utf8 "β" <> end <> output 2 (utf8 "β")
<> prompt 3
]
, utf8Test i [utf8 "α" <> raw [149] <> utf8 "x" <> raw [206]]
[ prompt 0 <> utf8 "α" <> end <> output 0 (utf8 "α")
, prompt 1 <> err <> end <> output 1 err
, prompt 2 <> utf8 "x" <> end <> output 2 (utf8 "x")
, prompt 3 <> whenLegacy (err <> end <> output 3 err)
, whenLegacy (prompt 4)
, "bad encoding (separate)" ~:
utf8Test i [utf8 "α", raw [149], utf8 "x", raw [206]]
[ prompt 0, utf8 "α" <> end <> output 0 (utf8 "α") <> prompt 1
, err <> end <> output 1 err <> prompt 2
, utf8 "x" <> end <> output 2 (utf8 "x") <> prompt 3
, whenLegacy (err <> end <> output 3 err <> prompt 4)
]
, "bad encoding (together)" ~:
utf8Test i [utf8 "α" <> raw [149] <> utf8 "x" <> raw [206]]
[ prompt 0, utf8 "α" <> end <> output 0 (utf8 "α")
<> prompt 1 <> err <> end <> output 1 err
<> prompt 2 <> utf8 "x" <> end <> output 2 (utf8 "x")
<> prompt 3 <> whenLegacy (err <> end <> output 3 err <> prompt 4)
]
, utf8Test i [raw [206]] -- incomplete
[ prompt 0 <> whenLegacy (utf8 "?" <> end <> output 0 (utf8 "?"))
, whenLegacy (prompt 1)
[ prompt 0, whenLegacy (utf8 "?" <> end <> output 0 (utf8 "?"))
<> whenLegacy (prompt 1)
]
]
......@@ -169,7 +183,8 @@ fileStyleTests i = "file style" ~:
[ prompt' 0, output 0 (utf8 "xαβyψ안기q영") <> prompt' 1]
, "char input" ~: utf8Test iFileChar
[utf8 "xαβt"]
[prompt' 0 <> output 0 (utf8 "x")
[ prompt' 0
, output 0 (utf8 "x")
<> prompt' 1 <> output 1 (utf8 "α")
<> prompt' 2 <> output 2 (utf8 "β")
<> prompt' 3 <> output 3 (utf8 "t")
......@@ -182,25 +197,32 @@ fileStyleTests i = "file style" ~:
-- Also recall GHC bug #5436 which caused a crash
-- if the last byte started an incomplete sequence.
[ utf8 "a" <> raw [149] <> utf8 "x" <> raw [206] ]
[prompt' 0 <> output 0 (utf8 "a" <> err <> utf8 "x" <> err)
<> prompt' 1]
, "invalid char input" ~: utf8Test iFileChar
[ prompt' 0
, B.empty
-- It only prompts after the EOF.
, output 0 (utf8 "a" <> err <> utf8 "x" <> err) <> prompt' 1
]
, "invalid char input (following a newline)" ~: utf8Test iFileChar
[ utf8 "a\n" <> raw [149] <> utf8 "x\n" <> raw [206] ]
[prompt' 0 <> output 0 (utf8 "a")
<> prompt' 1 <> output 1 err
<> prompt' 2 <> output 2 (utf8 "x")
<> prompt' 3 <> output 3 err
<> prompt' 4]
, "invalid char file input" ~: utf8Test iFileChar
$ [ prompt' 0
, output 0 (utf8 "a")
<> prompt' 1 <> output 1 err
<> prompt' 2 <> output 2 (utf8 "x")
<> prompt' 3
<> whenLegacy (output 3 err <> prompt' 4)
] ++ if legacyEncoding then [] else [ output 3 err <> prompt' 4 ]
, "invalid char file input (no preceding newline)" ~: utf8Test iFileChar
[ utf8 "a" <> raw [149] <> utf8 "x" <> raw [206] ]
-- make sure it tries to read a newline
-- and instead gets the incomplete 206.
-- This should *not* cause it to crash or block.
[prompt' 0 <> output 0 (utf8 "a")
<> prompt' 1 <> output 1 err
<> prompt' 2 <> output 2 (utf8 "x")
<> prompt' 3 <> output 3 err
<> prompt' 4]
$ [ prompt' 0
, output 0 (utf8 "a")
<> prompt' 1 <> output 1 err
<> prompt' 2 <> output 2 (utf8 "x")
<> prompt' 3
<> whenLegacy (output 3 err <> prompt' 4)
] ++ if legacyEncoding then [] else [ output 3 err <> prompt' 4 ]
]
-- also single char and buffer break and other stuff
where
......@@ -214,16 +236,16 @@ fileStyleTests i = "file style" ~:
dumbTests i = "dumb term" ~:
[ "line input" ~: utf8Test i
[ utf8 "xαβγy" ]
[ prompt' 0 <> utf8 "xαβγy" ]
[ prompt' 0, utf8 "xαβγy" ]
, "line input wide movement" ~: utf8Test i
[ utf8 wideChar, raw [1], raw [5] ]
[ prompt' 0 <> utf8 wideChar
[ prompt' 0, utf8 wideChar
, utf8 (T.replicate 60 "\b")
, utf8 wideChar
]
, "line char input" ~: utf8Test (setCharInput i)
[utf8 "xαβ"]
[ prompt' 0 <> utf8 "x" <> nl <> output 0 (utf8 "x")
[ prompt' 0, utf8 "x" <> nl <> output 0 (utf8 "x")
<> prompt' 1 <> utf8 "α" <> nl <> output 1 (utf8 "α")
<> prompt' 2 <> utf8 "β" <> nl <> output 2 (utf8 "β")
<> prompt' 3
......
Supports Markdown
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