GHC/Posix.hs

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