GHC/Posix.hsc

   1 {-# OPTIONS -fno-implicit-prelude #-}
   2
   3 -- ---------------------------------------------------------------------------
   4 -- $Id: Posix.hsc,v 1.3 2001/08/17 12:50:34 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 fdType :: Int -> IO FDType
  94 fdType fd =
  95   allocaBytes (#const sizeof(struct stat)) $ \ p_stat -> do
  96     throwErrnoIfMinus1Retry "fdType" $
  97         c_fstat (fromIntegral fd) p_stat
  98     statGetType p_stat
  99
 100 statGetType p_stat = do
 101   c_mode <- (#peek struct stat, st_mode) p_stat :: IO CMode
 102   case () of
 103       _ | s_isdir c_mode                     -> return Directory
 104         | s_isfifo c_mode || s_issock c_mode -> return Stream
 105         | s_isreg c_mode                     -> return RegularFile
 106         | otherwise                          -> ioException ioe_unknownfiletype
 107
 108
 109 ioe_unknownfiletype = IOError Nothing UnsupportedOperation "fdType"
 110                         "unknown file type" Nothing
 111
 112 -- It isn't clear whether ftruncate is POSIX or not (I've read several
 113 -- manpages and they seem to conflict), so we truncate using open/2.
 114 fileTruncate :: FilePath -> IO ()
 115 fileTruncate file = do
 116   let flags = o_WRONLY .|. o_TRUNC
 117   withCString file $ \file_cstr -> do
 118     fd <- fromIntegral `liftM`
 119             throwErrnoIfMinus1Retry "fileTruncate"
 120                 (c_open file_cstr (fromIntegral flags) 0o666)
 121     c_close fd
 122   return ()
 123
 124 -- ---------------------------------------------------------------------------
 125 -- Terminal-related stuff
 126
 127 fdIsTTY :: Int -> IO Bool
 128 fdIsTTY fd = c_isatty (fromIntegral fd) >>= return.toBool
 129
 130 #ifndef mingw32_TARGET_OS
 131
 132 setEcho :: Int -> Bool -> IO ()
 133 setEcho fd on = do
 134   allocaBytes (#const sizeof(struct termios))  $ \p_tios -> do
 135     throwErrnoIfMinus1Retry "setEcho"
 136         (c_tcgetattr (fromIntegral fd) p_tios)
 137     c_lflag <- (#peek struct termios, c_lflag) p_tios :: IO CTcflag
 138     let new_c_lflag | on        = c_lflag .|. (#const ECHO)
 139                     | otherwise = c_lflag .&. complement (#const ECHO)
 140     (#poke struct termios, c_lflag) p_tios (new_c_lflag :: CTcflag)
 141     tcSetAttr fd (#const TCSANOW) p_tios
 142
 143 getEcho :: Int -> IO Bool
 144 getEcho fd = do
 145   allocaBytes (#const sizeof(struct termios))  $ \p_tios -> do
 146     throwErrnoIfMinus1Retry "setEcho"
 147         (c_tcgetattr (fromIntegral fd) p_tios)
 148     c_lflag <- (#peek struct termios, c_lflag) p_tios :: IO CTcflag
 149     return ((c_lflag .&. (#const ECHO)) /= 0)
 150
 151 setCooked :: Int -> Bool -> IO ()
 152 setCooked fd cooked =
 153   allocaBytes (#const sizeof(struct termios))  $ \p_tios -> do
 154     throwErrnoIfMinus1Retry "setCooked"
 155         (c_tcgetattr (fromIntegral fd) p_tios)
 156
 157     -- turn on/off ICANON
 158     c_lflag <- (#peek struct termios, c_lflag) p_tios :: IO CTcflag
 159     let new_c_lflag | cooked    = c_lflag .|. (#const ICANON)
 160                     | otherwise = c_lflag .&. complement (#const ICANON)
 161     (#poke struct termios, c_lflag) p_tios (new_c_lflag :: CTcflag)
 162
 163     -- set VMIN & VTIME to 1/0 respectively
 164     when cooked $ do
 165             let c_cc  = (#ptr struct termios, c_cc) p_tios
 166                 vmin  = c_cc `plusPtr` (#const VMIN)  :: Ptr Word8
 167                 vtime = c_cc `plusPtr` (#const VTIME) :: Ptr Word8
 168             poke vmin  1
 169             poke vtime 0
 170
 171     tcSetAttr fd (#const TCSANOW) p_tios
 172
 173 -- tcsetattr() when invoked by a background process causes the process
 174 -- to be sent SIGTTOU regardless of whether the process has TOSTOP set
 175 -- in its terminal flags (try it...).  This function provides a
 176 -- wrapper which temporarily blocks SIGTTOU around the call, making it
 177 -- transparent.
 178
 179 tcSetAttr :: FD -> CInt -> Ptr CTermios -> IO ()
 180 tcSetAttr fd options p_tios = do
 181   allocaBytes (#const sizeof(sigset_t)) $ \ p_sigset -> do
 182   allocaBytes (#const sizeof(sigset_t)) $ \ p_old_sigset -> do
 183      c_sigemptyset p_sigset
 184      c_sigaddset   p_sigset (#const SIGTTOU)
 185      c_sigprocmask (#const SIG_BLOCK) p_sigset p_old_sigset
 186      throwErrnoIfMinus1Retry_ "tcSetAttr" $
 187          c_tcsetattr (fromIntegral fd) options p_tios
 188      c_sigprocmask (#const SIG_SETMASK) p_old_sigset nullPtr
 189
 190 #else
 191
 192 -- bogus defns for win32
 193 setCooked :: Int -> Bool -> IO ()
 194 setCooked fd cooked = return ()
 195
 196 setEcho :: Int -> Bool -> IO ()
 197 setEcho fd on = return ()
 198
 199 getEcho :: Int -> IO Bool
 200 getEcho fd = return False
 201
 202 #endif
 203
 204 -- ---------------------------------------------------------------------------
 205 -- Turning on non-blocking for a file descriptor
 206
 207 #ifndef mingw32_TARGET_OS
 208
 209 setNonBlockingFD fd = do
 210   flags <- throwErrnoIfMinus1Retry "setNonBlockingFD"
 211                  (c_fcntl_read (fromIntegral fd) (#const F_GETFL))
 212   throwErrnoIfMinus1Retry "setNonBlockingFD"
 213         (c_fcntl_write (fromIntegral fd)
 214            (#const F_SETFL) (flags .|. #const O_NONBLOCK))
 215 #else
 216
 217 -- bogus defns for win32
 218 setNonBlockingFD fd = return ()
 219
 220 #endif
 221
 222 -- -----------------------------------------------------------------------------
 223 -- foreign imports
 224
 225 -- POSIX flags only:
 226 o_RDONLY    = (#const O_RDONLY)    :: CInt
 227 o_WRONLY    = (#const O_WRONLY)    :: CInt
 228 o_RDWR      = (#const O_RDWR)      :: CInt
 229 o_APPEND    = (#const O_APPEND)    :: CInt
 230 o_CREAT     = (#const O_CREAT)     :: CInt
 231 o_EXCL      = (#const O_EXCL)      :: CInt
 232 o_TRUNC     = (#const O_TRUNC)     :: CInt
 233
 234 #ifdef mingw32_TARGET_OS
 235 o_NOCTTY    = 0 :: CInt
 236 o_NONBLOCK  = 0 :: CInt
 237 #else
 238 o_NOCTTY    = (#const O_NOCTTY)    :: CInt
 239 o_NONBLOCK  = (#const O_NONBLOCK)  :: CInt
 240 #endif
 241
 242 #ifdef HAVE_O_BINARY
 243 o_BINARY    = (#const O_BINARY)    :: CInt
 244 #endif
 245
 246 foreign import ccall "access" unsafe
 247    c_access :: CString -> CMode -> IO CInt
 248
 249 foreign import ccall "chmod" unsafe
 250    c_chmod :: CString -> CMode -> IO CInt
 251
 252 foreign import ccall "chdir" unsafe
 253    c_chdir :: CString -> IO CInt
 254
 255 foreign import ccall "chown" unsafe
 256    c_chown :: CString -> CUid -> CGid -> IO CInt
 257
 258 foreign import ccall "close" unsafe
 259    c_close :: CInt -> IO CInt
 260
 261 foreign import ccall "closedir" unsafe
 262    c_closedir :: Ptr CDir -> IO CInt
 263
 264 foreign import ccall "creat" unsafe
 265    c_creat :: CString -> CMode -> IO CInt
 266
 267 foreign import ccall "dup" unsafe
 268    c_dup :: CInt -> IO CInt
 269
 270 foreign import ccall "dup2" unsafe
 271    c_dup2 :: CInt -> CInt -> IO CInt
 272
 273 foreign import ccall "fpathconf" unsafe
 274    c_fpathconf :: CInt -> CInt -> IO CLong
 275
 276 foreign import ccall "fstat" unsafe
 277    c_fstat :: CInt -> Ptr CStat -> IO CInt
 278
 279 foreign import ccall "getcwd" unsafe
 280    c_getcwd   :: Ptr CChar -> CInt -> IO (Ptr CChar)
 281
 282 foreign import ccall "isatty" unsafe
 283    c_isatty :: CInt -> IO CInt
 284
 285 foreign import ccall "link" unsafe
 286    c_link :: CString -> CString -> IO CInt
 287
 288 foreign import ccall "lseek" unsafe
 289    c_lseek :: CInt -> COff -> CInt -> IO COff
 290
 291 #ifdef HAVE_LSTAT
 292 foreign import ccall "lstat" unsafe
 293    c_lstat :: CString -> Ptr CStat -> IO CInt
 294 #endif
 295
 296 foreign import ccall "open" unsafe
 297    c_open :: CString -> CInt -> CMode -> IO CInt
 298
 299 foreign import ccall "opendir" unsafe
 300    c_opendir :: CString  -> IO (Ptr CDir)
 301
 302 foreign import ccall "mkdir" unsafe
 303 #if defined(mingw32_TARGET_OS)
 304    c_mkdir :: CString -> IO CInt
 305 #else
 306    c_mkdir :: CString -> CMode -> IO CInt
 307 #endif
 308
 309 foreign import ccall "mkfifo" unsafe
 310    c_mkfifo :: CString -> CMode -> IO CInt
 311
 312 foreign import ccall "pathconf" unsafe
 313    c_pathconf :: CString -> CInt -> IO CLong
 314
 315 foreign import ccall "pipe" unsafe
 316    c_pipe :: Ptr CInt -> IO CInt
 317
 318 foreign import ccall "read" unsafe
 319    c_read :: CInt -> Ptr CChar -> CSize -> IO CSsize
 320
 321 foreign import ccall "readdir" unsafe
 322    c_readdir :: Ptr CDir -> IO (Ptr CDirent)
 323
 324 foreign import ccall "rename" unsafe
 325    c_rename :: CString -> CString -> IO CInt
 326
 327 foreign import ccall "rewinddir" unsafe
 328    c_rewinddir :: Ptr CDir -> IO ()
 329
 330 foreign import ccall "rmdir" unsafe
 331    c_rmdir :: CString -> IO CInt
 332
 333 foreign import ccall "stat" unsafe
 334    c_stat :: CString -> Ptr CStat -> IO CInt
 335
 336 foreign import ccall "umask" unsafe
 337    c_umask :: CMode -> IO CMode
 338
 339 foreign import ccall "utime" unsafe
 340    c_utime :: CString -> Ptr CUtimbuf -> IO CMode
 341
 342 foreign import ccall "write" unsafe
 343    c_write :: CInt -> Ptr CChar -> CSize -> IO CSsize
 344
 345 #ifndef mingw32_TARGET_OS
 346 foreign import ccall "fcntl" unsafe
 347    c_fcntl_read  :: CInt -> CInt -> IO CInt
 348
 349 foreign import ccall "fcntl" unsafe
 350    c_fcntl_write :: CInt -> CInt -> CInt -> IO CInt
 351
 352 foreign import ccall "fcntl" unsafe
 353    c_fcntl_lock  :: CInt -> CInt -> Ptr CFLock -> IO CInt
 354
 355 foreign import ccall "fork" unsafe
 356    c_fork :: IO CPid
 357
 358 foreign import ccall "sigemptyset" unsafe
 359    c_sigemptyset :: Ptr CSigset -> IO ()
 360
 361 foreign import ccall "sigaddset" unsafe
 362    c_sigaddset :: Ptr CSigset -> CInt -> IO ()
 363
 364 foreign import ccall "sigprocmask" unsafe
 365    c_sigprocmask :: CInt -> Ptr CSigset -> Ptr CSigset -> IO ()
 366
 367 foreign import ccall "tcgetattr" unsafe
 368    c_tcgetattr :: CInt -> Ptr CTermios -> IO CInt
 369
 370 foreign import ccall "tcsetattr" unsafe
 371    c_tcsetattr :: CInt -> CInt -> Ptr CTermios -> IO CInt
 372
 373 foreign import ccall "uname" unsafe
 374    c_uname :: Ptr CUtsname -> IO CInt
 375
 376 foreign import ccall "unlink" unsafe
 377    c_unlink :: CString -> IO CInt
 378
 379 foreign import ccall "waitpid" unsafe
 380    c_waitpid :: CPid -> Ptr CInt -> CInt -> IO CPid
 381 #endif
 382
 383 foreign import "s_isreg_wrap"  unsafe s_isreg  :: CMode -> Bool
 384 foreign import "s_ischr_wrap"  unsafe s_ischr  :: CMode -> Bool
 385 foreign import "s_isblk_wrap"  unsafe s_isblk  :: CMode -> Bool
 386 foreign import "s_isdir_wrap"  unsafe s_isdir  :: CMode -> Bool
 387 foreign import "s_isfifo_wrap" unsafe s_isfifo :: CMode -> Bool
 388
 389 #ifndef mingw32_TARGET_OS
 390 foreign import "s_issock_wrap" s_issock :: CMode -> Bool
 391 #else
 392 s_issock :: CMode -> Bool
 393 s_issock cmode = False
 394 #endif