fa40cefe7dfbb4203b65a0ceea81cb2ee54c366c
[packages/random.git] / GHC / Posix.hs
1 {-# OPTIONS -fno-implicit-prelude #-}
2
3 -----------------------------------------------------------------------------
4 -- |
5 -- Module : GHC.Posix
6 -- Copyright : (c) The University of Glasgow, 1992-2002
7 -- License : see libraries/base/LICENSE
8 --
9 -- Maintainer : cvs-ghc@haskell.org
10 -- Stability : internal
11 -- Portability : non-portable
12 --
13 -- POSIX support layer for the standard libraries.
14 -- This library is built on *every* platform, including Win32.
15 --
16 -- Non-posix compliant in order to support the following features:
17 -- * S_ISSOCK (no sockets in POSIX)
18 --
19 -----------------------------------------------------------------------------
20
21 module GHC.Posix where
22
23 #include "config.h"
24
25 import Control.Monad
26
27 import Foreign
28 import Foreign.C
29
30 import Data.Bits
31 import Data.Maybe
32
33 import GHC.Base
34 import GHC.Num
35 import GHC.Real
36 import GHC.IOBase
37
38 -- ---------------------------------------------------------------------------
39 -- Types
40
41 type CDir = ()
42 type CDirent = ()
43 type CFLock = ()
44 type CGroup = ()
45 type CLconv = ()
46 type CPasswd = ()
47 type CSigaction = ()
48 type CSigset = ()
49 type CStat = ()
50 type CTermios = ()
51 type CTm = ()
52 type CTms = ()
53 type CUtimbuf = ()
54 type CUtsname = ()
55
56 type CDev = HTYPE_DEV_T
57 type CIno = HTYPE_INO_T
58 type CMode = HTYPE_MODE_T
59 type COff = HTYPE_OFF_T
60 type CPid = HTYPE_PID_T
61
62 #ifdef mingw32_TARGET_OS
63 type CSsize = HTYPE_SIZE_T
64 #else
65 type CGid = HTYPE_GID_T
66 type CNlink = HTYPE_NLINK_T
67 type CSsize = HTYPE_SSIZE_T
68 type CUid = HTYPE_UID_T
69 type CCc = HTYPE_CC_T
70 type CSpeed = HTYPE_SPEED_T
71 type CTcflag = HTYPE_TCFLAG_T
72 #endif
73
74 -- ---------------------------------------------------------------------------
75 -- stat()-related stuff
76
77 fdFileSize :: Int -> IO Integer
78 fdFileSize fd =
79 allocaBytes sizeof_stat $ \ p_stat -> do
80 throwErrnoIfMinus1Retry "fileSize" $
81 c_fstat (fromIntegral fd) p_stat
82 c_mode <- st_mode p_stat :: IO CMode
83 if not (s_isreg c_mode)
84 then return (-1)
85 else do
86 c_size <- st_size p_stat :: IO COff
87 return (fromIntegral c_size)
88
89 data FDType = Directory | Stream | RegularFile
90 deriving (Eq)
91
92 fileType :: FilePath -> IO FDType
93 fileType file =
94 allocaBytes sizeof_stat $ \ p_stat -> do
95 withCString file $ \p_file -> do
96 throwErrnoIfMinus1Retry "fileType" $
97 c_stat p_file p_stat
98 statGetType p_stat
99
100 -- NOTE: On Win32 platforms, this will only work with file descriptors
101 -- referring to file handles. i.e., it'll fail for socket FDs.
102 fdType :: Int -> IO FDType
103 fdType fd =
104 allocaBytes sizeof_stat $ \ p_stat -> do
105 throwErrnoIfMinus1Retry "fdType" $
106 c_fstat (fromIntegral fd) p_stat
107 statGetType p_stat
108
109 statGetType p_stat = do
110 c_mode <- st_mode p_stat :: IO CMode
111 case () of
112 _ | s_isdir c_mode -> return Directory
113 | s_isfifo c_mode || s_issock c_mode -> return Stream
114 | s_isreg c_mode -> return RegularFile
115 | otherwise -> ioException ioe_unknownfiletype
116
117
118 ioe_unknownfiletype = IOError Nothing UnsupportedOperation "fdType"
119 "unknown file type" Nothing
120
121 -- It isn't clear whether ftruncate is POSIX or not (I've read several
122 -- manpages and they seem to conflict), so we truncate using open/2.
123 fileTruncate :: FilePath -> IO ()
124 fileTruncate file = do
125 let flags = o_WRONLY .|. o_TRUNC
126 withCString file $ \file_cstr -> do
127 fd <- fromIntegral `liftM`
128 throwErrnoIfMinus1Retry "fileTruncate"
129 (c_open file_cstr (fromIntegral flags) 0o666)
130 c_close fd
131 return ()
132
133 #ifdef mingw32_TARGET_OS
134 closeFd :: Bool -> CInt -> IO CInt
135 closeFd isStream fd
136 | isStream = c_closesocket fd
137 | otherwise = c_close fd
138
139 foreign import stdcall unsafe "closesocket"
140 c_closesocket :: CInt -> IO CInt
141 #endif
142
143 fdGetMode :: Int -> IO IOMode
144 fdGetMode fd = do
145 #ifdef mingw32_TARGET_OS
146 flags1 <- throwErrnoIfMinus1Retry "fdGetMode"
147 (c__setmode (fromIntegral fd) (fromIntegral o_WRONLY))
148 flags <- throwErrnoIfMinus1Retry "fdGetMode"
149 (c__setmode (fromIntegral fd) (fromIntegral flags1))
150 #else
151 flags <- throwErrnoIfMinus1Retry "fdGetMode"
152 (c_fcntl_read (fromIntegral fd) const_f_getfl)
153 #endif
154 let
155 wH = (flags .&. o_WRONLY) /= 0
156 aH = (flags .&. o_APPEND) /= 0
157 rwH = (flags .&. o_RDWR) /= 0
158
159 mode
160 | wH && aH = AppendMode
161 | wH = WriteMode
162 | rwH = ReadWriteMode
163 | otherwise = ReadMode
164
165 return mode
166
167 -- ---------------------------------------------------------------------------
168 -- Terminal-related stuff
169
170 fdIsTTY :: Int -> IO Bool
171 fdIsTTY fd = c_isatty (fromIntegral fd) >>= return.toBool
172
173 #ifndef mingw32_TARGET_OS
174
175 setEcho :: Int -> Bool -> IO ()
176 setEcho fd on = do
177 allocaBytes sizeof_termios $ \p_tios -> do
178 throwErrnoIfMinus1Retry "setEcho"
179 (c_tcgetattr (fromIntegral fd) p_tios)
180 c_lflag <- c_lflag p_tios :: IO CTcflag
181 let new_c_lflag
182 | on = c_lflag .|. fromIntegral const_echo
183 | otherwise = c_lflag .&. complement (fromIntegral const_echo)
184 poke_c_lflag p_tios (new_c_lflag :: CTcflag)
185 tcSetAttr fd const_tcsanow p_tios
186
187 getEcho :: Int -> IO Bool
188 getEcho fd = do
189 allocaBytes sizeof_termios $ \p_tios -> do
190 throwErrnoIfMinus1Retry "setEcho"
191 (c_tcgetattr (fromIntegral fd) p_tios)
192 c_lflag <- c_lflag p_tios :: IO CTcflag
193 return ((c_lflag .&. fromIntegral const_echo) /= 0)
194
195 setCooked :: Int -> Bool -> IO ()
196 setCooked fd cooked =
197 allocaBytes sizeof_termios $ \p_tios -> do
198 throwErrnoIfMinus1Retry "setCooked"
199 (c_tcgetattr (fromIntegral fd) p_tios)
200
201 -- turn on/off ICANON
202 c_lflag <- c_lflag p_tios :: IO CTcflag
203 let new_c_lflag | cooked = c_lflag .|. (fromIntegral const_icanon)
204 | otherwise = c_lflag .&. complement (fromIntegral const_icanon)
205 poke_c_lflag p_tios (new_c_lflag :: CTcflag)
206
207 -- set VMIN & VTIME to 1/0 respectively
208 when cooked $ do
209 c_cc <- ptr_c_cc p_tios
210 let vmin = (c_cc `plusPtr` (fromIntegral const_vmin)) :: Ptr Word8
211 vtime = (c_cc `plusPtr` (fromIntegral const_vtime)) :: Ptr Word8
212 poke vmin 1
213 poke vtime 0
214
215 tcSetAttr fd const_tcsanow p_tios
216
217 -- tcsetattr() when invoked by a background process causes the process
218 -- to be sent SIGTTOU regardless of whether the process has TOSTOP set
219 -- in its terminal flags (try it...). This function provides a
220 -- wrapper which temporarily blocks SIGTTOU around the call, making it
221 -- transparent.
222
223 tcSetAttr :: FD -> CInt -> Ptr CTermios -> IO ()
224 tcSetAttr fd options p_tios = do
225 allocaBytes sizeof_sigset_t $ \ p_sigset -> do
226 allocaBytes sizeof_sigset_t $ \ p_old_sigset -> do
227 c_sigemptyset p_sigset
228 c_sigaddset p_sigset const_sigttou
229 c_sigprocmask const_sig_block p_sigset p_old_sigset
230 throwErrnoIfMinus1Retry_ "tcSetAttr" $
231 c_tcsetattr (fromIntegral fd) options p_tios
232 c_sigprocmask const_sig_setmask p_old_sigset nullPtr
233
234 #else
235
236 -- bogus defns for win32
237 setCooked :: Int -> Bool -> IO ()
238 setCooked fd cooked = do
239 x <- set_console_buffering (fromIntegral fd) (if cooked then 1 else 0)
240 if (x /= 0)
241 then ioException (ioe_unk_error "setCooked" "failed to set buffering")
242 else return ()
243
244 ioe_unk_error loc msg
245 = IOError Nothing OtherError loc msg Nothing
246
247 setEcho :: Int -> Bool -> IO ()
248 setEcho fd on = do
249 x <- set_console_echo (fromIntegral fd) (if on then 1 else 0)
250 if (x /= 0)
251 then ioException (ioe_unk_error "setEcho" "failed to set echoing")
252 else return ()
253
254 getEcho :: Int -> IO Bool
255 getEcho fd = do
256 r <- get_console_echo (fromIntegral fd)
257 if (r == (-1))
258 then ioException (ioe_unk_error "getEcho" "failed to get echoing")
259 else return (r == 1)
260
261 foreign import ccall unsafe "consUtils.h set_console_buffering__"
262 set_console_buffering :: CInt -> CInt -> IO CInt
263
264 foreign import ccall unsafe "consUtils.h set_console_echo__"
265 set_console_echo :: CInt -> CInt -> IO CInt
266
267 foreign import ccall unsafe "consUtils.h get_console_echo__"
268 get_console_echo :: CInt -> IO CInt
269
270 #endif
271
272 -- ---------------------------------------------------------------------------
273 -- Turning on non-blocking for a file descriptor
274
275 #ifndef mingw32_TARGET_OS
276
277 setNonBlockingFD fd = do
278 flags <- throwErrnoIfMinus1Retry "setNonBlockingFD"
279 (c_fcntl_read (fromIntegral fd) const_f_getfl)
280 -- An error when setting O_NONBLOCK isn't fatal: on some systems
281 -- there are certain file handles on which this will fail (eg. /dev/null
282 -- on FreeBSD) so we throw away the return code from fcntl_write.
283 c_fcntl_write (fromIntegral fd) const_f_setfl (flags .|. o_NONBLOCK)
284 #else
285
286 -- bogus defns for win32
287 setNonBlockingFD fd = return ()
288
289 #endif
290
291 -- -----------------------------------------------------------------------------
292 -- foreign imports
293
294 foreign import ccall unsafe "access"
295 c_access :: CString -> CMode -> IO CInt
296
297 foreign import ccall unsafe "chmod"
298 c_chmod :: CString -> CMode -> IO CInt
299
300 foreign import ccall unsafe "chdir"
301 c_chdir :: CString -> IO CInt
302
303 foreign import ccall unsafe "close"
304 c_close :: CInt -> IO CInt
305
306 foreign import ccall unsafe "closedir"
307 c_closedir :: Ptr CDir -> IO CInt
308
309 foreign import ccall unsafe "creat"
310 c_creat :: CString -> CMode -> IO CInt
311
312 foreign import ccall unsafe "dup"
313 c_dup :: CInt -> IO CInt
314
315 foreign import ccall unsafe "dup2"
316 c_dup2 :: CInt -> CInt -> IO CInt
317
318 foreign import ccall unsafe "fstat"
319 c_fstat :: CInt -> Ptr CStat -> IO CInt
320
321 foreign import ccall unsafe "getcwd"
322 c_getcwd :: Ptr CChar -> CInt -> IO (Ptr CChar)
323
324 foreign import ccall unsafe "isatty"
325 c_isatty :: CInt -> IO CInt
326
327 foreign import ccall unsafe "lseek"
328 c_lseek :: CInt -> COff -> CInt -> IO COff
329
330 foreign import ccall unsafe "__hscore_lstat"
331 lstat :: CString -> Ptr CStat -> IO CInt
332
333 foreign import ccall unsafe "open"
334 c_open :: CString -> CInt -> CMode -> IO CInt
335
336 foreign import ccall unsafe "opendir"
337 c_opendir :: CString -> IO (Ptr CDir)
338
339 foreign import ccall unsafe "__hscore_mkdir"
340 mkdir :: CString -> CInt -> IO CInt
341
342 foreign import ccall unsafe "read"
343 c_read :: CInt -> Ptr CChar -> CSize -> IO CSsize
344
345 foreign import ccall unsafe "readdir"
346 c_readdir :: Ptr CDir -> IO (Ptr CDirent)
347
348 foreign import ccall unsafe "rename"
349 c_rename :: CString -> CString -> IO CInt
350
351 foreign import ccall unsafe "rewinddir"
352 c_rewinddir :: Ptr CDir -> IO ()
353
354 foreign import ccall unsafe "rmdir"
355 c_rmdir :: CString -> IO CInt
356
357 foreign import ccall unsafe "stat"
358 c_stat :: CString -> Ptr CStat -> IO CInt
359
360 foreign import ccall unsafe "umask"
361 c_umask :: CMode -> IO CMode
362
363 foreign import ccall unsafe "write"
364 c_write :: CInt -> Ptr CChar -> CSize -> IO CSsize
365
366 foreign import ccall unsafe "unlink"
367 c_unlink :: CString -> IO CInt
368
369 #ifndef mingw32_TARGET_OS
370 foreign import ccall unsafe "fcntl"
371 c_fcntl_read :: CInt -> CInt -> IO CInt
372
373 foreign import ccall unsafe "fcntl"
374 c_fcntl_write :: CInt -> CInt -> CInt -> IO CInt
375
376 foreign import ccall unsafe "fcntl"
377 c_fcntl_lock :: CInt -> CInt -> Ptr CFLock -> IO CInt
378
379 foreign import ccall unsafe "fork"
380 c_fork :: IO CPid
381
382 foreign import ccall unsafe "fpathconf"
383 c_fpathconf :: CInt -> CInt -> IO CLong
384
385 foreign import ccall unsafe "__hscore_sigemptyset"
386 c_sigemptyset :: Ptr CSigset -> IO ()
387
388 foreign import ccall unsafe "link"
389 c_link :: CString -> CString -> IO CInt
390
391 foreign import ccall unsafe "mkfifo"
392 c_mkfifo :: CString -> CMode -> IO CInt
393
394 foreign import ccall unsafe "pathconf"
395 c_pathconf :: CString -> CInt -> IO CLong
396
397 foreign import ccall unsafe "pipe"
398 c_pipe :: Ptr CInt -> IO CInt
399
400 foreign import ccall unsafe "__hscore_sigaddset"
401 c_sigaddset :: Ptr CSigset -> CInt -> IO CInt
402
403 foreign import ccall unsafe "sigprocmask"
404 c_sigprocmask :: CInt -> Ptr CSigset -> Ptr CSigset -> IO ()
405
406 foreign import ccall unsafe "tcgetattr"
407 c_tcgetattr :: CInt -> Ptr CTermios -> IO CInt
408
409 foreign import ccall unsafe "tcsetattr"
410 c_tcsetattr :: CInt -> CInt -> Ptr CTermios -> IO CInt
411
412 foreign import ccall unsafe "uname"
413 c_uname :: Ptr CUtsname -> IO CInt
414
415 foreign import ccall unsafe "utime"
416 c_utime :: CString -> Ptr CUtimbuf -> IO CMode
417
418 foreign import ccall unsafe "waitpid"
419 c_waitpid :: CPid -> Ptr CInt -> CInt -> IO CPid
420 #else
421 foreign import ccall unsafe "_setmode"
422 c__setmode :: CInt -> CInt -> IO CInt
423
424 -- /* Set "stdin" to have binary mode: */
425 -- result = _setmode( _fileno( stdin ), _O_BINARY );
426 -- if( result == -1 )
427 -- perror( "Cannot set mode" );
428 -- else
429 -- printf( "'stdin' successfully changed to binary mode\n" );
430 #endif
431
432 -- POSIX flags only:
433 foreign import ccall unsafe "__hscore_o_rdonly" o_RDONLY :: CInt
434 foreign import ccall unsafe "__hscore_o_wronly" o_WRONLY :: CInt
435 foreign import ccall unsafe "__hscore_o_rdwr" o_RDWR :: CInt
436 foreign import ccall unsafe "__hscore_o_append" o_APPEND :: CInt
437 foreign import ccall unsafe "__hscore_o_creat" o_CREAT :: CInt
438 foreign import ccall unsafe "__hscore_o_excl" o_EXCL :: CInt
439 foreign import ccall unsafe "__hscore_o_trunc" o_TRUNC :: CInt
440
441 -- non-POSIX flags.
442 foreign import ccall unsafe "__hscore_o_noctty" o_NOCTTY :: CInt
443 foreign import ccall unsafe "__hscore_o_nonblock" o_NONBLOCK :: CInt
444 foreign import ccall unsafe "__hscore_o_binary" o_BINARY :: CInt
445
446 foreign import ccall unsafe "__hscore_s_isreg" s_isreg :: CMode -> Bool
447 foreign import ccall unsafe "__hscore_s_ischr" s_ischr :: CMode -> Bool
448 foreign import ccall unsafe "__hscore_s_isblk" s_isblk :: CMode -> Bool
449 foreign import ccall unsafe "__hscore_s_isdir" s_isdir :: CMode -> Bool
450 foreign import ccall unsafe "__hscore_s_isfifo" s_isfifo :: CMode -> Bool
451
452 foreign import ccall unsafe "__hscore_sizeof_stat" sizeof_stat :: Int
453 foreign import ccall unsafe "__hscore_st_mtime" st_mtime :: Ptr CStat -> IO CTime
454 foreign import ccall unsafe "__hscore_st_size" st_size :: Ptr CStat -> IO COff
455 foreign import ccall unsafe "__hscore_st_mode" st_mode :: Ptr CStat -> IO CMode
456
457 foreign import ccall unsafe "__hscore_echo" const_echo :: CInt
458 foreign import ccall unsafe "__hscore_tcsanow" const_tcsanow :: CInt
459 foreign import ccall unsafe "__hscore_icanon" const_icanon :: CInt
460 foreign import ccall unsafe "__hscore_vmin" const_vmin :: CInt
461 foreign import ccall unsafe "__hscore_vtime" const_vtime :: CInt
462 foreign import ccall unsafe "__hscore_sigttou" const_sigttou :: CInt
463 foreign import ccall unsafe "__hscore_sig_block" const_sig_block :: CInt
464 foreign import ccall unsafe "__hscore_sig_setmask" const_sig_setmask :: CInt
465 foreign import ccall unsafe "__hscore_f_getfl" const_f_getfl :: CInt
466 foreign import ccall unsafe "__hscore_f_setfl" const_f_setfl :: CInt
467
468 #ifndef mingw32_TARGET_OS
469 foreign import ccall unsafe "__hscore_sizeof_termios" sizeof_termios :: Int
470 foreign import ccall unsafe "__hscore_sizeof_sigset_t" sizeof_sigset_t :: Int
471
472 foreign import ccall unsafe "__hscore_lflag" c_lflag :: Ptr CTermios -> IO CTcflag
473 foreign import ccall unsafe "__hscore_poke_lflag" poke_c_lflag :: Ptr CTermios -> CTcflag -> IO ()
474 foreign import ccall unsafe "__hscore_ptr_c_cc" ptr_c_cc :: Ptr CTermios -> IO (Ptr Word8)
475 #endif
476
477 #ifndef mingw32_TARGET_OS
478 foreign import ccall unsafe "__hscore_s_issock" s_issock :: CMode -> Bool
479 #else
480 s_issock :: CMode -> Bool
481 s_issock cmode = False
482 #endif