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 -- ---------------------------------------------------------------------------
 144 -- Terminal-related stuff
 145
 146 fdIsTTY :: Int -> IO Bool
 147 fdIsTTY fd = c_isatty (fromIntegral fd) >>= return.toBool
 148
 149 #ifndef mingw32_TARGET_OS
 150
 151 setEcho :: Int -> Bool -> IO ()
 152 setEcho fd on = do
 153   allocaBytes sizeof_termios  $ \p_tios -> do
 154     throwErrnoIfMinus1Retry "setEcho"
 155         (c_tcgetattr (fromIntegral fd) p_tios)
 156     c_lflag <- c_lflag p_tios :: IO CTcflag
 157     let new_c_lflag
 158          | on        = c_lflag .|. fromIntegral const_echo
 159          | otherwise = c_lflag .&. complement (fromIntegral const_echo)
 160     poke_c_lflag p_tios (new_c_lflag :: CTcflag)
 161     tcSetAttr fd const_tcsanow p_tios
 162
 163 getEcho :: Int -> IO Bool
 164 getEcho fd = do
 165   allocaBytes sizeof_termios  $ \p_tios -> do
 166     throwErrnoIfMinus1Retry "setEcho"
 167         (c_tcgetattr (fromIntegral fd) p_tios)
 168     c_lflag <- c_lflag p_tios :: IO CTcflag
 169     return ((c_lflag .&. fromIntegral const_echo) /= 0)
 170
 171 setCooked :: Int -> Bool -> IO ()
 172 setCooked fd cooked =
 173   allocaBytes sizeof_termios  $ \p_tios -> do
 174     throwErrnoIfMinus1Retry "setCooked"
 175         (c_tcgetattr (fromIntegral fd) p_tios)
 176
 177     -- turn on/off ICANON
 178     c_lflag <- c_lflag p_tios :: IO CTcflag
 179     let new_c_lflag | cooked    = c_lflag .|. (fromIntegral const_icanon)
 180                     | otherwise = c_lflag .&. complement (fromIntegral const_icanon)
 181     poke_c_lflag p_tios (new_c_lflag :: CTcflag)
 182
 183     -- set VMIN & VTIME to 1/0 respectively
 184     when cooked $ do
 185             c_cc <- ptr_c_cc p_tios
 186             let vmin  = (c_cc `plusPtr` (fromIntegral const_vmin))  :: Ptr Word8
 187                 vtime = (c_cc `plusPtr` (fromIntegral const_vtime)) :: Ptr Word8
 188             poke vmin  1
 189             poke vtime 0
 190
 191     tcSetAttr fd const_tcsanow p_tios
 192
 193 -- tcsetattr() when invoked by a background process causes the process
 194 -- to be sent SIGTTOU regardless of whether the process has TOSTOP set
 195 -- in its terminal flags (try it...).  This function provides a
 196 -- wrapper which temporarily blocks SIGTTOU around the call, making it
 197 -- transparent.
 198
 199 tcSetAttr :: FD -> CInt -> Ptr CTermios -> IO ()
 200 tcSetAttr fd options p_tios = do
 201   allocaBytes sizeof_sigset_t $ \ p_sigset -> do
 202   allocaBytes sizeof_sigset_t $ \ p_old_sigset -> do
 203      c_sigemptyset p_sigset
 204      c_sigaddset   p_sigset const_sigttou
 205      c_sigprocmask const_sig_block p_sigset p_old_sigset
 206      throwErrnoIfMinus1Retry_ "tcSetAttr" $
 207          c_tcsetattr (fromIntegral fd) options p_tios
 208      c_sigprocmask const_sig_setmask p_old_sigset nullPtr
 209
 210 #else
 211
 212 -- bogus defns for win32
 213 setCooked :: Int -> Bool -> IO ()
 214 setCooked fd cooked = return ()
 215
 216 setEcho :: Int -> Bool -> IO ()
 217 setEcho fd on = return ()
 218
 219 getEcho :: Int -> IO Bool
 220 getEcho fd = return False
 221
 222 #endif
 223
 224 -- ---------------------------------------------------------------------------
 225 -- Turning on non-blocking for a file descriptor
 226
 227 #ifndef mingw32_TARGET_OS
 228
 229 setNonBlockingFD fd = do
 230   flags <- throwErrnoIfMinus1Retry "setNonBlockingFD"
 231                  (c_fcntl_read (fromIntegral fd) const_f_getfl)
 232   -- An error when setting O_NONBLOCK isn't fatal: on some systems
 233   -- there are certain file handles on which this will fail (eg. /dev/null
 234   -- on FreeBSD) so we throw away the return code from fcntl_write.
 235   c_fcntl_write (fromIntegral fd) const_f_setfl (flags .|. o_NONBLOCK)
 236 #else
 237
 238 -- bogus defns for win32
 239 setNonBlockingFD fd = return ()
 240
 241 #endif
 242
 243 -- -----------------------------------------------------------------------------
 244 -- foreign imports
 245
 246 foreign import ccall unsafe "access"
 247    c_access :: CString -> CMode -> IO CInt
 248
 249 foreign import ccall unsafe "chmod"
 250    c_chmod :: CString -> CMode -> IO CInt
 251
 252 foreign import ccall unsafe "chdir"
 253    c_chdir :: CString -> IO CInt
 254
 255 foreign import ccall unsafe "close"
 256    c_close :: CInt -> IO CInt
 257
 258 foreign import ccall unsafe "closedir"
 259    c_closedir :: Ptr CDir -> IO CInt
 260
 261 foreign import ccall unsafe "creat"
 262    c_creat :: CString -> CMode -> IO CInt
 263
 264 foreign import ccall unsafe "dup"
 265    c_dup :: CInt -> IO CInt
 266
 267 foreign import ccall unsafe "dup2"
 268    c_dup2 :: CInt -> CInt -> IO CInt
 269
 270 foreign import ccall unsafe "fstat"
 271    c_fstat :: CInt -> Ptr CStat -> IO CInt
 272
 273 foreign import ccall unsafe "getcwd"
 274    c_getcwd   :: Ptr CChar -> CInt -> IO (Ptr CChar)
 275
 276 foreign import ccall unsafe "isatty"
 277    c_isatty :: CInt -> IO CInt
 278
 279 foreign import ccall unsafe "lseek"
 280    c_lseek :: CInt -> COff -> CInt -> IO COff
 281
 282 foreign import ccall unsafe "__hscore_lstat"
 283    lstat :: CString -> Ptr CStat -> IO CInt
 284
 285 foreign import ccall unsafe "open"
 286    c_open :: CString -> CInt -> CMode -> IO CInt
 287
 288 foreign import ccall unsafe "opendir"
 289    c_opendir :: CString  -> IO (Ptr CDir)
 290
 291 foreign import ccall unsafe "__hscore_mkdir"
 292    mkdir :: CString -> CInt -> IO CInt
 293
 294 foreign import ccall unsafe "read"
 295    c_read :: CInt -> Ptr CChar -> CSize -> IO CSsize
 296
 297 foreign import ccall unsafe "readdir"
 298    c_readdir :: Ptr CDir -> IO (Ptr CDirent)
 299
 300 foreign import ccall unsafe "rename"
 301    c_rename :: CString -> CString -> IO CInt
 302
 303 foreign import ccall unsafe "rewinddir"
 304    c_rewinddir :: Ptr CDir -> IO ()
 305
 306 foreign import ccall unsafe "rmdir"
 307    c_rmdir :: CString -> IO CInt
 308
 309 foreign import ccall unsafe "stat"
 310    c_stat :: CString -> Ptr CStat -> IO CInt
 311
 312 foreign import ccall unsafe "umask"
 313    c_umask :: CMode -> IO CMode
 314
 315 foreign import ccall unsafe "write"
 316    c_write :: CInt -> Ptr CChar -> CSize -> IO CSsize
 317
 318 foreign import ccall unsafe "unlink"
 319    c_unlink :: CString -> IO CInt
 320
 321 #ifndef mingw32_TARGET_OS
 322 foreign import ccall unsafe "fcntl"
 323    c_fcntl_read  :: CInt -> CInt -> IO CInt
 324
 325 foreign import ccall unsafe "fcntl"
 326    c_fcntl_write :: CInt -> CInt -> CInt -> IO CInt
 327
 328 foreign import ccall unsafe "fcntl"
 329    c_fcntl_lock  :: CInt -> CInt -> Ptr CFLock -> IO CInt
 330
 331 foreign import ccall unsafe "fork"
 332    c_fork :: IO CPid
 333
 334 foreign import ccall unsafe "fpathconf"
 335    c_fpathconf :: CInt -> CInt -> IO CLong
 336
 337 foreign import ccall unsafe "__hscore_sigemptyset"
 338    c_sigemptyset :: Ptr CSigset -> IO ()
 339
 340 foreign import ccall unsafe "link"
 341    c_link :: CString -> CString -> IO CInt
 342
 343 foreign import ccall unsafe "mkfifo"
 344    c_mkfifo :: CString -> CMode -> IO CInt
 345
 346 foreign import ccall unsafe "pathconf"
 347    c_pathconf :: CString -> CInt -> IO CLong
 348
 349 foreign import ccall unsafe "pipe"
 350    c_pipe :: Ptr CInt -> IO CInt
 351
 352 foreign import ccall unsafe "__hscore_sigaddset"
 353    c_sigaddset :: Ptr CSigset -> CInt -> IO CInt
 354
 355 foreign import ccall unsafe "sigprocmask"
 356    c_sigprocmask :: CInt -> Ptr CSigset -> Ptr CSigset -> IO ()
 357
 358 foreign import ccall unsafe "tcgetattr"
 359    c_tcgetattr :: CInt -> Ptr CTermios -> IO CInt
 360
 361 foreign import ccall unsafe "tcsetattr"
 362    c_tcsetattr :: CInt -> CInt -> Ptr CTermios -> IO CInt
 363
 364 foreign import ccall unsafe "uname"
 365    c_uname :: Ptr CUtsname -> IO CInt
 366
 367 foreign import ccall unsafe "utime"
 368    c_utime :: CString -> Ptr CUtimbuf -> IO CMode
 369
 370 foreign import ccall unsafe "waitpid"
 371    c_waitpid :: CPid -> Ptr CInt -> CInt -> IO CPid
 372 #endif
 373
 374 -- POSIX flags only:
 375 foreign import ccall unsafe "__hscore_o_rdonly" o_RDONLY :: CInt
 376 foreign import ccall unsafe "__hscore_o_wronly" o_WRONLY :: CInt
 377 foreign import ccall unsafe "__hscore_o_rdwr"   o_RDWR   :: CInt
 378 foreign import ccall unsafe "__hscore_o_append" o_APPEND :: CInt
 379 foreign import ccall unsafe "__hscore_o_creat"  o_CREAT  :: CInt
 380 foreign import ccall unsafe "__hscore_o_excl"   o_EXCL   :: CInt
 381 foreign import ccall unsafe "__hscore_o_trunc"  o_TRUNC  :: CInt
 382
 383 -- non-POSIX flags.
 384 foreign import ccall unsafe "__hscore_o_noctty"   o_NOCTTY   :: CInt
 385 foreign import ccall unsafe "__hscore_o_nonblock" o_NONBLOCK :: CInt
 386 foreign import ccall unsafe "__hscore_o_binary"   o_BINARY   :: CInt
 387
 388 foreign import ccall unsafe "__hscore_s_isreg"  s_isreg  :: CMode -> Bool
 389 foreign import ccall unsafe "__hscore_s_ischr"  s_ischr  :: CMode -> Bool
 390 foreign import ccall unsafe "__hscore_s_isblk"  s_isblk  :: CMode -> Bool
 391 foreign import ccall unsafe "__hscore_s_isdir"  s_isdir  :: CMode -> Bool
 392 foreign import ccall unsafe "__hscore_s_isfifo" s_isfifo :: CMode -> Bool
 393
 394 foreign import ccall unsafe "__hscore_sizeof_stat" sizeof_stat :: Int
 395 foreign import ccall unsafe "__hscore_st_mtime" st_mtime :: Ptr CStat -> IO CTime
 396 foreign import ccall unsafe "__hscore_st_size" st_size :: Ptr CStat -> IO COff
 397 foreign import ccall unsafe "__hscore_st_mode" st_mode :: Ptr CStat -> IO CMode
 398
 399 foreign import ccall unsafe "__hscore_echo"         const_echo :: CInt
 400 foreign import ccall unsafe "__hscore_tcsanow"      const_tcsanow :: CInt
 401 foreign import ccall unsafe "__hscore_icanon"       const_icanon :: CInt
 402 foreign import ccall unsafe "__hscore_vmin"         const_vmin   :: CInt
 403 foreign import ccall unsafe "__hscore_vtime"        const_vtime  :: CInt
 404 foreign import ccall unsafe "__hscore_sigttou"      const_sigttou :: CInt
 405 foreign import ccall unsafe "__hscore_sig_block"    const_sig_block :: CInt
 406 foreign import ccall unsafe "__hscore_sig_setmask"  const_sig_setmask :: CInt
 407 foreign import ccall unsafe "__hscore_f_getfl"      const_f_getfl :: CInt
 408 foreign import ccall unsafe "__hscore_f_setfl"      const_f_setfl :: CInt
 409
 410 #ifndef mingw32_TARGET_OS
 411 foreign import ccall unsafe "__hscore_sizeof_termios"  sizeof_termios :: Int
 412 foreign import ccall unsafe "__hscore_sizeof_sigset_t" sizeof_sigset_t :: Int
 413
 414 foreign import ccall unsafe "__hscore_lflag" c_lflag :: Ptr CTermios -> IO CTcflag
 415 foreign import ccall unsafe "__hscore_poke_lflag" poke_c_lflag :: Ptr CTermios -> CTcflag -> IO ()
 416 foreign import ccall unsafe "__hscore_ptr_c_cc" ptr_c_cc  :: Ptr CTermios -> IO (Ptr Word8)
 417 #endif
 418
 419 #ifndef mingw32_TARGET_OS
 420 foreign import ccall unsafe "__hscore_s_issock" s_issock :: CMode -> Bool
 421 #else
 422 s_issock :: CMode -> Bool
 423 s_issock cmode = False
 424 #endif