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