Ticket #2650: createprocess-race-condition.hs

File createprocess-race-condition.hs, 1.1 KB (added by Deewiant, 6 years ago)

Test case

Line 
1import Control.Concurrent
2import Control.Exception (onException)
3import Control.Monad     (forever)
4import System.IO
5import System.Process
6
7main = do
8   let s = "foo.tmp"
9
10   done <- newEmptyMVar
11
12   forkIO $
13      onException
14         (forever $ withFile s ReadWriteMode (\_ -> return ()))
15         (putMVar done ())
16
17   let
18      loop pids n = do
19         (_,_,_,pid) <- createProcess $ CreateProcess
20            -- windows doesn't have sleep so we use ping -n as a replacement
21            { cmdspec   = RawCommand "ping" ["-n", "2", "localhost"]
22            , cwd       = Nothing
23            , env       = Nothing
24            , std_in    = CreatePipe
25            , std_out   = CreatePipe
26            , std_err   = CreatePipe
27            , close_fds = True
28            }
29
30         let pids' = pid:pids
31             n'    = n+1
32
33         notDoneYet <- isEmptyMVar done
34         if notDoneYet
35            then loop pids' n'
36            else return (pids', n')
37   (pids,n) <- loop [] 0
38
39   putStrLn$ "Broke after " ++ show n ++ " processes. Cleaning up..."
40
41   mapM_ waitForProcess pids