ghc/lib/std/PrelPosix.hs

   1 {-# OPTIONS -fno-implicit-prelude -#include "PrelIOUtils.h" #-}
   2
   3 -- ---------------------------------------------------------------------------
   4 --
   5 -- POSIX support layer for the standard libraries
   6 --
   7 -- Non-posix compliant in order to support the following features:
   8 --      * S_ISSOCK (no sockets in POSIX)
   9
  10 module PrelPosix where
  11
  12 -- See above comment for non-Posixness reasons.
  13 -- #include "PosixSource.h"
  14
  15 #include "config.h"
  16
  17 import PrelBase
  18 import PrelNum
  19 import PrelReal
  20 import PrelMaybe
  21 import PrelCString
  22 import PrelPtr
  23 import PrelWord
  24 import PrelInt
  25 import PrelCTypesISO
  26 import PrelCTypes
  27 import PrelCError
  28 import PrelStorable
  29 import PrelMarshalAlloc
  30 import PrelMarshalUtils
  31 import PrelBits
  32 import PrelIOBase
  33 import Monad
  34
  35
  36 -- ---------------------------------------------------------------------------
  37 -- Types
  38
  39 data CDir    = CDir
  40 type CSigset = ()
  41
  42 type CDev    = HTYPE_DEV_T
  43 type CIno    = HTYPE_INO_T
  44 type CMode   = HTYPE_MODE_T
  45 type COff    = HTYPE_OFF_T
  46 type CPid    = HTYPE_PID_T
  47
  48 #ifdef mingw32_TARGET_OS
  49 type CSsize  = HTYPE_SIZE_T
  50 #else
  51 type CGid    = HTYPE_GID_T
  52 type CNlink  = HTYPE_NLINK_T
  53 type CSsize  = HTYPE_SSIZE_T
  54 type CUid    = HTYPE_UID_T
  55 type CCc     = HTYPE_CC_T
  56 type CSpeed  = HTYPE_SPEED_T
  57 type CTcflag = HTYPE_TCFLAG_T
  58 #endif
  59
  60 -- ---------------------------------------------------------------------------
  61 -- stat()-related stuff
  62
  63 type CStat = ()
  64
  65 fdFileSize :: Int -> IO Integer
  66 fdFileSize fd =
  67   allocaBytes sizeof_stat $ \ p_stat -> do
  68     throwErrnoIfMinus1Retry "fileSize" $
  69         c_fstat (fromIntegral fd) p_stat
  70     c_mode <- st_mode p_stat :: IO CMode
  71     if not (s_isreg c_mode)
  72         then return (-1)
  73         else do
  74     c_size <- st_size p_stat :: IO COff
  75     return (fromIntegral c_size)
  76
  77 data FDType  = Directory | Stream | RegularFile
  78                deriving (Eq)
  79
  80 -- NOTE: On Win32 platforms, this will only work with file descriptors
  81 -- referring to file handles. i.e., it'll fail for socket FDs.
  82 fdType :: Int -> IO FDType
  83 fdType fd =
  84   allocaBytes sizeof_stat $ \ p_stat -> do
  85     throwErrnoIfMinus1Retry "fdType" $
  86         c_fstat (fromIntegral fd) p_stat
  87     c_mode <- st_mode p_stat :: IO CMode
  88     case () of
  89       _ |  s_isdir  c_mode  -> return Directory
  90         |  s_isfifo c_mode  -> return Stream
  91         |  s_issock c_mode  -> return Stream
  92         |  s_ischr  c_mode  -> return Stream
  93         |  s_isreg  c_mode  -> return RegularFile
  94         |  s_isblk  c_mode  -> return RegularFile
  95         | otherwise         -> ioException ioe_unknownfiletype
  96     -- we consider character devices to be streams (eg. ttys),
  97     -- whereas block devices are more like regular files because they
  98     -- are seekable.
  99
 100 ioe_unknownfiletype = IOError Nothing UnsupportedOperation "fdType"
 101                         "unknown file type" Nothing
 102
 103 foreign import "s_isreg_PrelPosix_wrap" unsafe s_isreg :: CMode -> Bool
 104 foreign import "s_isdir_PrelPosix_wrap" unsafe s_isdir :: CMode -> Bool
 105 foreign import "s_isfifo_PrelPosix_wrap" unsafe s_isfifo :: CMode -> Bool
 106 foreign import "s_ischr_PrelPosix_wrap" unsafe s_ischr :: CMode -> Bool
 107 foreign import "s_isblk_PrelPosix_wrap" unsafe s_isblk :: CMode -> Bool
 108
 109 #ifndef mingw32_TARGET_OS
 110 foreign import "s_issock_PrelPosix_wrap" unsafe s_issock :: CMode -> Bool
 111
 112 #else
 113 s_issock :: CMode -> Bool
 114 s_issock cmode = False
 115 #endif
 116
 117 -- It isn't clear whether ftruncate is POSIX or not (I've read several
 118 -- manpages and they seem to conflict), so we truncate using open/2.
 119 fileTruncate :: FilePath -> IO ()
 120 fileTruncate file = do
 121   let flags = o_WRONLY .|. o_TRUNC
 122   withCString file $ \file_cstr -> do
 123     fd <- fromIntegral `liftM`
 124             throwErrnoIfMinus1Retry "fileTruncate"
 125                 (c_open file_cstr (fromIntegral flags) 0o666)
 126     c_close fd
 127   return ()
 128
 129 -- ---------------------------------------------------------------------------
 130 -- Terminal-related stuff
 131
 132 fdIsTTY :: Int -> IO Bool
 133 fdIsTTY fd = c_isatty (fromIntegral fd) >>= return.toBool
 134
 135 #ifndef mingw32_TARGET_OS
 136
 137 type Termios = ()
 138
 139 setEcho :: Int -> Bool -> IO ()
 140 setEcho fd on = do
 141   allocaBytes sizeof_termios  $ \p_tios -> do
 142     throwErrnoIfMinus1Retry "setEcho"
 143         (c_tcgetattr (fromIntegral fd) p_tios)
 144     c_lflag <- c_lflag p_tios :: IO CTcflag
 145     let new_c_lflag | on        = c_lflag .|. fromIntegral prel_echo
 146                     | otherwise = c_lflag .&. complement (fromIntegral prel_echo)
 147     poke_c_lflag p_tios (new_c_lflag :: CTcflag)
 148     tcSetAttr fd prel_tcsanow p_tios
 149
 150 getEcho :: Int -> IO Bool
 151 getEcho fd = 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     return ((c_lflag .&. fromIntegral prel_echo) /= 0)
 157
 158 setCooked :: Int -> Bool -> IO ()
 159 setCooked fd cooked =
 160   allocaBytes sizeof_termios  $ \p_tios -> do
 161     throwErrnoIfMinus1Retry "setCooked"
 162         (c_tcgetattr (fromIntegral fd) p_tios)
 163
 164     -- turn on/off ICANON
 165     c_lflag <- c_lflag p_tios :: IO CTcflag
 166     let new_c_lflag | cooked    = c_lflag .|. (fromIntegral prel_icanon)
 167                     | otherwise = c_lflag .&. complement (fromIntegral prel_icanon)
 168     poke_c_lflag p_tios (new_c_lflag :: CTcflag)
 169
 170     -- set VMIN & VTIME to 1/0 respectively
 171     when cooked $ do
 172             c_cc <- ptr_c_cc p_tios
 173             let vmin  = (c_cc `plusPtr` (fromIntegral prel_vmin))  :: Ptr Word8
 174                 vtime = (c_cc `plusPtr` (fromIntegral prel_vtime)) :: Ptr Word8
 175             poke vmin  1
 176             poke vtime 0
 177
 178     tcSetAttr fd prel_tcsanow p_tios
 179
 180 -- tcsetattr() when invoked by a background process causes the process
 181 -- to be sent SIGTTOU regardless of whether the process has TOSTOP set
 182 -- in its terminal flags (try it...).  This function provides a
 183 -- wrapper which temporarily blocks SIGTTOU around the call, making it
 184 -- transparent.
 185
 186 tcSetAttr :: FD -> CInt -> Ptr Termios -> IO ()
 187 tcSetAttr fd options p_tios = do
 188   allocaBytes sizeof_sigset_t $ \ p_sigset -> do
 189   allocaBytes sizeof_sigset_t $ \ p_old_sigset -> do
 190      c_sigemptyset p_sigset
 191      c_sigaddset   p_sigset prel_sigttou
 192      c_sigprocmask prel_sig_block p_sigset p_old_sigset
 193      throwErrnoIfMinus1Retry_ "tcSetAttr" $
 194          c_tcsetattr (fromIntegral fd) options p_tios
 195      c_sigprocmask prel_sig_setmask p_old_sigset nullPtr
 196
 197 foreign import ccall "prel_lflag" c_lflag :: Ptr Termios -> IO CTcflag
 198 foreign import ccall "prel_poke_lflag" poke_c_lflag :: Ptr Termios -> CTcflag -> IO ()
 199 foreign import ccall "prel_ptr_c_cc" ptr_c_cc  :: Ptr Termios -> IO (Ptr Word8)
 200
 201 foreign import ccall "prel_echo"      unsafe prel_echo :: CInt
 202 foreign import ccall "prel_tcsanow"   unsafe prel_tcsanow :: CInt
 203 foreign import ccall "prel_icanon"    unsafe prel_icanon :: CInt
 204 foreign import ccall "prel_vmin"      unsafe prel_vmin   :: CInt
 205 foreign import ccall "prel_vtime"     unsafe prel_vtime  :: CInt
 206 foreign import ccall "prel_sigttou"   unsafe prel_sigttou :: CInt
 207 foreign import ccall "prel_sig_block" unsafe prel_sig_block :: CInt
 208 foreign import ccall "prel_sig_setmask" unsafe prel_sig_setmask :: CInt
 209 foreign import ccall "prel_f_getfl"     unsafe prel_f_getfl :: CInt
 210 foreign import ccall "prel_f_setfl"     unsafe prel_f_setfl :: CInt
 211 #else
 212
 213 -- bogus defns for win32
 214 setCooked :: Int -> Bool -> IO ()
 215 setCooked fd cooked = return ()
 216
 217 setEcho :: Int -> Bool -> IO ()
 218 setEcho fd on = return ()
 219
 220 getEcho :: Int -> IO Bool
 221 getEcho fd = return False
 222
 223 #endif
 224
 225 -- ---------------------------------------------------------------------------
 226 -- Turning on non-blocking for a file descriptor
 227
 228 #ifndef mingw32_TARGET_OS
 229
 230 setNonBlockingFD fd = do
 231   flags <- throwErrnoIfMinus1Retry "setNonBlockingFD"
 232                  (fcntl_read (fromIntegral fd) prel_f_getfl)
 233   -- An error when setting O_NONBLOCK isn't fatal: on some systems
 234   -- there are certain file handles on which this will fail (eg. /dev/null
 235   -- on FreeBSD) so we throw away the return code from fcntl_write.
 236   fcntl_write (fromIntegral fd) prel_f_setfl (flags .|. o_NONBLOCK)
 237 #else
 238
 239 -- bogus defns for win32
 240 setNonBlockingFD fd = return ()
 241
 242 #endif
 243
 244 -- -----------------------------------------------------------------------------
 245 -- foreign imports
 246
 247 foreign import "stat" unsafe
 248    c_stat :: CString -> Ptr CStat -> IO CInt
 249
 250 foreign import "fstat" unsafe
 251    c_fstat :: CInt -> Ptr CStat -> IO CInt
 252
 253 foreign import "open" unsafe
 254    c_open :: CString -> CInt -> CMode -> IO CInt
 255
 256 foreign import ccall "prel_sizeof_stat" unsafe sizeof_stat :: Int
 257 foreign import ccall "prel_st_mtime" unsafe st_mtime :: Ptr CStat -> IO CTime
 258 foreign import ccall "prel_st_size" unsafe st_size :: Ptr CStat -> IO COff
 259 foreign import ccall "prel_st_mode" unsafe st_mode :: Ptr CStat -> IO CMode
 260
 261 #ifndef mingw32_TARGET_OS
 262 foreign import ccall "prel_sizeof_termios" unsafe sizeof_termios :: Int
 263 foreign import ccall "prel_sizeof_sigset_t" unsafe sizeof_sigset_t :: Int
 264 #endif
 265
 266 -- POSIX flags only:
 267 foreign import ccall "prel_o_rdonly" unsafe o_RDONLY :: CInt
 268 foreign import ccall "prel_o_wronly" unsafe o_WRONLY :: CInt
 269 foreign import ccall "prel_o_rdwr"   unsafe o_RDWR   :: CInt
 270 foreign import ccall "prel_o_append" unsafe o_APPEND :: CInt
 271 foreign import ccall "prel_o_creat"  unsafe o_CREAT  :: CInt
 272 foreign import ccall "prel_o_excl"   unsafe o_EXCL   :: CInt
 273 foreign import ccall "prel_o_trunc"  unsafe o_TRUNC  :: CInt
 274
 275
 276 -- non-POSIX flags.
 277 foreign import ccall "prel_o_noctty"   unsafe o_NOCTTY   :: CInt
 278 foreign import ccall "prel_o_nonblock" unsafe o_NONBLOCK :: CInt
 279 foreign import ccall "prel_o_binary" unsafe o_BINARY :: CInt
 280
 281
 282 foreign import "isatty" unsafe
 283    c_isatty :: CInt -> IO CInt
 284
 285 foreign import "close" unsafe
 286    c_close :: CInt -> IO CInt
 287
 288 #ifdef mingw32_TARGET_OS
 289 closeFd :: Bool -> CInt -> IO CInt
 290 closeFd isStream fd
 291   | isStream  = c_closesocket fd
 292   | otherwise = c_close fd
 293
 294 foreign import "closesocket" unsafe
 295    c_closesocket :: CInt -> IO CInt
 296 #endif
 297
 298 foreign import "lseek" unsafe
 299    c_lseek :: CInt -> COff -> CInt -> IO COff
 300
 301 #ifndef mingw32_TARGET_OS
 302 foreign import "fcntl" unsafe
 303    fcntl_read  :: CInt -> CInt -> IO CInt
 304
 305 foreign import "fcntl" unsafe
 306    fcntl_write :: CInt -> CInt -> CInt -> IO CInt
 307
 308 foreign import "fork" unsafe
 309    fork :: IO CPid
 310
 311 foreign import "sigemptyset_PrelPosix_wrap" unsafe
 312    c_sigemptyset :: Ptr CSigset -> IO ()
 313
 314 foreign import "sigaddset" unsafe
 315    c_sigaddset :: Ptr CSigset -> CInt -> IO ()
 316
 317 foreign import "sigprocmask" unsafe
 318    c_sigprocmask :: CInt -> Ptr CSigset -> Ptr CSigset -> IO ()
 319
 320 foreign import "tcgetattr" unsafe
 321    c_tcgetattr :: CInt -> Ptr Termios -> IO CInt
 322
 323 foreign import "tcsetattr" unsafe
 324    c_tcsetattr :: CInt -> CInt -> Ptr Termios -> IO CInt
 325
 326 foreign import "unlink" unsafe
 327    c_unlink :: CString -> IO CInt
 328
 329 foreign import "waitpid" unsafe
 330    c_waitpid :: CPid -> Ptr CInt -> CInt -> IO CPid
 331 #endif