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