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