testsuite/timeout: Ensure that processes are cleaned up on Windows
[ghc.git] / testsuite / timeout / WinCBindings.hsc
1 {-# LANGUAGE CPP, ForeignFunctionInterface #-}
2 module WinCBindings where
3
4 #if defined(mingw32_HOST_OS)
5
6 import Foreign
7 import System.Win32.File
8 import System.Win32.Types
9
10 #include <windows.h>
11
12 type LPPROCESS_INFORMATION = Ptr PROCESS_INFORMATION
13 data PROCESS_INFORMATION = PROCESS_INFORMATION
14     { piProcess :: HANDLE
15     , piThread :: HANDLE
16     , piProcessId :: DWORD
17     , piThreadId :: DWORD
18     } deriving Show
19
20 instance Storable PROCESS_INFORMATION where
21     sizeOf = const #size PROCESS_INFORMATION
22     alignment = sizeOf
23     poke buf pi = do
24         (#poke PROCESS_INFORMATION, hProcess)    buf (piProcess   pi)
25         (#poke PROCESS_INFORMATION, hThread)     buf (piThread    pi)
26         (#poke PROCESS_INFORMATION, dwProcessId) buf (piProcessId pi)
27         (#poke PROCESS_INFORMATION, dwThreadId)  buf (piThreadId  pi)
28
29     peek buf = do
30         vhProcess    <- (#peek PROCESS_INFORMATION, hProcess)    buf
31         vhThread     <- (#peek PROCESS_INFORMATION, hThread)     buf
32         vdwProcessId <- (#peek PROCESS_INFORMATION, dwProcessId) buf
33         vdwThreadId  <- (#peek PROCESS_INFORMATION, dwThreadId)  buf
34         return $ PROCESS_INFORMATION {
35             piProcess   = vhProcess,
36             piThread    = vhThread,
37             piProcessId = vdwProcessId,
38             piThreadId  = vdwThreadId}
39
40 type LPSTARTUPINFO = Ptr STARTUPINFO
41 data STARTUPINFO = STARTUPINFO
42     { siCb :: DWORD
43     , siDesktop :: LPTSTR
44     , siTitle :: LPTSTR
45     , siX :: DWORD
46     , siY :: DWORD
47     , siXSize :: DWORD
48     , siYSize :: DWORD
49     , siXCountChars :: DWORD
50     , siYCountChars :: DWORD
51     , siFillAttribute :: DWORD
52     , siFlags :: DWORD
53     , siShowWindow :: WORD
54     , siStdInput :: HANDLE
55     , siStdOutput :: HANDLE
56     , siStdError :: HANDLE
57     } deriving Show
58
59 instance Storable STARTUPINFO where
60     sizeOf = const #size STARTUPINFO
61     alignment = sizeOf
62     poke buf si = do
63         (#poke STARTUPINFO, cb)              buf (siCb si)
64         (#poke STARTUPINFO, lpDesktop)       buf (siDesktop si)
65         (#poke STARTUPINFO, lpTitle)         buf (siTitle si)
66         (#poke STARTUPINFO, dwX)             buf (siX si)
67         (#poke STARTUPINFO, dwY)             buf (siY si)
68         (#poke STARTUPINFO, dwXSize)         buf (siXSize si)
69         (#poke STARTUPINFO, dwYSize)         buf (siYSize si)
70         (#poke STARTUPINFO, dwXCountChars)   buf (siXCountChars si)
71         (#poke STARTUPINFO, dwYCountChars)   buf (siYCountChars si)
72         (#poke STARTUPINFO, dwFillAttribute) buf (siFillAttribute si)
73         (#poke STARTUPINFO, dwFlags)         buf (siFlags si)
74         (#poke STARTUPINFO, wShowWindow)     buf (siShowWindow si)
75         (#poke STARTUPINFO, hStdInput)       buf (siStdInput si)
76         (#poke STARTUPINFO, hStdOutput)      buf (siStdOutput si)
77         (#poke STARTUPINFO, hStdError)       buf (siStdError si)
78
79     peek buf = do
80         vcb              <- (#peek STARTUPINFO, cb)              buf
81         vlpDesktop       <- (#peek STARTUPINFO, lpDesktop)       buf
82         vlpTitle         <- (#peek STARTUPINFO, lpTitle)         buf
83         vdwX             <- (#peek STARTUPINFO, dwX)             buf
84         vdwY             <- (#peek STARTUPINFO, dwY)             buf
85         vdwXSize         <- (#peek STARTUPINFO, dwXSize)         buf
86         vdwYSize         <- (#peek STARTUPINFO, dwYSize)         buf
87         vdwXCountChars   <- (#peek STARTUPINFO, dwXCountChars)   buf
88         vdwYCountChars   <- (#peek STARTUPINFO, dwYCountChars)   buf
89         vdwFillAttribute <- (#peek STARTUPINFO, dwFillAttribute) buf
90         vdwFlags         <- (#peek STARTUPINFO, dwFlags)         buf
91         vwShowWindow     <- (#peek STARTUPINFO, wShowWindow)     buf
92         vhStdInput       <- (#peek STARTUPINFO, hStdInput)       buf
93         vhStdOutput      <- (#peek STARTUPINFO, hStdOutput)      buf
94         vhStdError       <- (#peek STARTUPINFO, hStdError)       buf
95         return $ STARTUPINFO {
96             siCb            =  vcb,
97             siDesktop       =  vlpDesktop,
98             siTitle         =  vlpTitle,
99             siX             =  vdwX,
100             siY             =  vdwY,
101             siXSize         =  vdwXSize,
102             siYSize         =  vdwYSize,
103             siXCountChars   =  vdwXCountChars,
104             siYCountChars   =  vdwYCountChars,
105             siFillAttribute =  vdwFillAttribute,
106             siFlags         =  vdwFlags,
107             siShowWindow    =  vwShowWindow,
108             siStdInput      =  vhStdInput,
109             siStdOutput     =  vhStdOutput,
110             siStdError      =  vhStdError}
111
112 foreign import stdcall unsafe "windows.h WaitForSingleObject"
113     waitForSingleObject :: HANDLE -> DWORD -> IO DWORD
114
115 cWAIT_ABANDONED :: DWORD
116 cWAIT_ABANDONED = #const WAIT_ABANDONED
117
118 cWAIT_OBJECT_0 :: DWORD
119 cWAIT_OBJECT_0 = #const WAIT_OBJECT_0
120
121 cWAIT_TIMEOUT :: DWORD
122 cWAIT_TIMEOUT = #const WAIT_TIMEOUT
123
124 foreign import stdcall unsafe "windows.h GetExitCodeProcess"
125     getExitCodeProcess :: HANDLE -> LPDWORD -> IO BOOL
126
127 foreign import stdcall unsafe "windows.h TerminateJobObject"
128     terminateJobObject :: HANDLE -> UINT -> IO BOOL
129
130 foreign import stdcall unsafe "windows.h AssignProcessToJobObject"
131     assignProcessToJobObject :: HANDLE -> HANDLE -> IO BOOL
132
133 foreign import stdcall unsafe "windows.h CreateJobObjectW"
134     createJobObjectW :: LPSECURITY_ATTRIBUTES -> LPCTSTR -> IO HANDLE
135
136 foreign import stdcall unsafe "windows.h CreateProcessW"
137     createProcessW :: LPCTSTR -> LPTSTR
138                    -> LPSECURITY_ATTRIBUTES -> LPSECURITY_ATTRIBUTES
139                    -> BOOL -> DWORD -> LPVOID -> LPCTSTR -> LPSTARTUPINFO
140                    -> LPPROCESS_INFORMATION -> IO BOOL
141
142 #endif
143