1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
|
{-# LANGUAGE CPP #-}
import Control.Exception
import Control.Monad (guard, unless, void)
import System.Exit
import System.IO.Error
import System.Directory (getCurrentDirectory, setCurrentDirectory)
import System.Process
import Control.Concurrent
import Data.Char (isDigit)
import Data.List (isInfixOf)
import Data.Maybe (isNothing)
import System.IO (hClose, openBinaryTempFile, hGetContents)
import qualified Data.ByteString as S
import qualified Data.ByteString.Char8 as S8
import System.Directory (getTemporaryDirectory, removeFile)
ifWindows :: IO () -> IO ()
ifWindows action
| not isWindows = return ()
| otherwise = action
isWindows :: Bool
#if WINDOWS
isWindows = True
#else
isWindows = False
#endif
main :: IO ()
main = do
res <- handle (return . Left . isDoesNotExistError) $ do
(_, _, _, ph) <- createProcess (proc "definitelydoesnotexist" [])
{ close_fds = True
}
fmap Right $ waitForProcess ph
case res of
Left True -> return ()
_ -> error $ show res
let test name modifier = do
putStrLn $ "Running test: " ++ name
(_, _, _, ph) <- createProcess
$ modifier $ proc "echo" ["hello", "world"]
ec <- waitForProcess ph
if ec == ExitSuccess
then putStrLn $ "Success running: " ++ name
else error $ "echo returned: " ++ show ec
test "vanilla" id
-- FIXME need to debug this in the future on Windows
unless isWindows $ test "detach_console" $ \cp -> cp { detach_console = True }
test "create_new_console" $ \cp -> cp { create_new_console = True }
test "new_session" $ \cp -> cp { new_session = True }
putStrLn "Testing subdirectories"
ifWindows $ withCurrentDirectory "exes" $ do
res1 <- readCreateProcess (proc "./echo.bat" []) ""
unless ("parent" `isInfixOf` res1 && not ("child" `isInfixOf` res1)) $ error $
"echo.bat with cwd failed: " ++ show res1
res2 <- readCreateProcess (proc "./echo.bat" []) { cwd = Just "subdir" } ""
unless ("child" `isInfixOf` res2 && not ("parent" `isInfixOf` res2)) $ error $
"echo.bat with cwd failed: " ++ show res2
putStrLn "Binary handles"
tmpDir <- getTemporaryDirectory
bracket
(openBinaryTempFile tmpDir "process-binary-test.bin")
(\(fp, h) -> hClose h `finally` removeFile fp)
$ \(fp, h) -> do
let bs = S8.pack "hello\nthere\r\nworld\0"
S.hPut h bs
hClose h
(Nothing, Just out, Nothing, ph) <- createProcess (proc "cat" [fp])
{ std_out = CreatePipe
}
res' <- S.hGetContents out
hClose out
ec <- waitForProcess ph
unless (ec == ExitSuccess)
$ error $ "Unexpected exit code " ++ show ec
unless (bs == res')
$ error $ "Unexpected result: " ++ show res'
do -- multithreaded waitForProcess
(_, _, _, p) <- createProcess (proc "sleep" ["0.1"])
me1 <- newEmptyMVar
_ <- forkIO . void $ waitForProcess p >>= putMVar me1
-- check for race / deadlock between waitForProcess and getProcessExitCode
e3 <- getProcessExitCode p
e2 <- waitForProcess p
e1 <- readMVar me1
unless (isNothing e3)
$ error $ "unexpected exit " ++ show e3
unless (e1 == ExitSuccess && e2 == ExitSuccess)
$ error "sleep exited with non-zero exit code!"
do
putStrLn "interrupt masked waitForProcess"
(_, _, _, p) <- createProcess (proc "sleep" ["1.0"])
mec <- newEmptyMVar
tid <- mask_ . forkIO $
(waitForProcess p >>= putMVar mec . Just)
`catchThreadKilled` putMVar mec Nothing
killThread tid
eec <- takeMVar mec
case eec of
Nothing -> return ()
Just ec ->
if isWindows
then putStrLn "FIXME ignoring known failure on Windows"
else error $ "waitForProcess not interrupted: sleep exited with " ++ show ec
putStrLn "testing getPid"
do
(_, Just out, _, p) <-
if isWindows
then createProcess $ (proc "sh" ["-c", "z=$$; cat /proc/$z/winpid"]) {std_out = CreatePipe}
else createProcess $ (proc "sh" ["-c", "echo $$"]) {std_out = CreatePipe}
pid <- getPid p
line <- hGetContents out
putStrLn $ " queried PID: " ++ show pid
putStrLn $ " PID reported by stdout: " ++ show line
_ <- waitForProcess p
hClose out
let numStdoutPid = read (takeWhile isDigit line) :: Pid
unless (Just numStdoutPid == pid) $
if isWindows
then putStrLn "FIXME ignoring known failure on Windows"
else error "subprocess reported unexpected PID"
putStrLn "Tests passed successfully"
withCurrentDirectory :: FilePath -> IO a -> IO a
withCurrentDirectory new inner = do
orig <- getCurrentDirectory
bracket_
(setCurrentDirectory new)
(setCurrentDirectory orig)
inner
catchThreadKilled :: IO a -> IO a -> IO a
catchThreadKilled f g = catchJust (\e -> guard (e == ThreadKilled)) f (\() -> g)
|
