GHC/Posix.hsc

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