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