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