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