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