ghc/lib/std/PrelPosix.hsc

   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 "HsStd.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    = #type dev_t
  43 type CIno    = #type ino_t
  44 type CMode   = #type mode_t
  45 type COff    = #type off_t
  46 type CPid    = #type pid_t
  47
  48 #ifdef mingw32_TARGET_OS
  49 type CSsize  = #type size_t
  50 #else
  51 type CGid    = #type gid_t
  52 type CNlink  = #type nlink_t
  53 type CSsize  = #type ssize_t
  54 type CUid    = #type uid_t
  55 type CCc     = #type cc_t
  56 type CSpeed  = #type speed_t
  57 type CTcflag = #type 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 (#const sizeof(struct stat)) $ \ p_stat -> do
  68     throwErrnoIfMinus1Retry "fileSize" $
  69         c_fstat (fromIntegral fd) p_stat
  70     c_mode <- (#peek struct stat, st_mode) p_stat :: IO CMode
  71     if not (s_isreg c_mode)
  72         then return (-1)
  73         else do
  74     c_size <- (#peek struct stat, 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 (#const sizeof(struct stat)) $ \ p_stat -> do
  85     throwErrnoIfMinus1Retry "fdType" $
  86         c_fstat (fromIntegral fd) p_stat
  87     c_mode <- (#peek struct stat, 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 #else
 112 s_issock :: CMode -> Bool
 113 s_issock cmode = False
 114 #endif
 115
 116 -- It isn't clear whether ftruncate is POSIX or not (I've read several
 117 -- manpages and they seem to conflict), so we truncate using open/2.
 118 fileTruncate :: FilePath -> IO ()
 119 fileTruncate file = do
 120   let flags = o_WRONLY .|. o_TRUNC
 121   withCString file $ \file_cstr -> do
 122     fd <- fromIntegral `liftM`
 123             throwErrnoIfMinus1Retry "fileTruncate"
 124                 (c_open file_cstr (fromIntegral flags) 0o666)
 125     c_close fd
 126   return ()
 127
 128 -- ---------------------------------------------------------------------------
 129 -- Terminal-related stuff
 130
 131 fdIsTTY :: Int -> IO Bool
 132 fdIsTTY fd = c_isatty (fromIntegral fd) >>= return.toBool
 133
 134 #ifndef mingw32_TARGET_OS
 135
 136 type Termios = ()
 137
 138 setEcho :: Int -> Bool -> IO ()
 139 setEcho fd on = do
 140   allocaBytes (#const sizeof(struct termios))  $ \p_tios -> do
 141     throwErrnoIfMinus1Retry "setEcho"
 142         (c_tcgetattr (fromIntegral fd) p_tios)
 143     c_lflag <- (#peek struct termios, c_lflag) p_tios :: IO CTcflag
 144     let new_c_lflag | on        = c_lflag .|. (#const ECHO)
 145                     | otherwise = c_lflag .&. complement (#const ECHO)
 146     (#poke struct termios, c_lflag) p_tios (new_c_lflag :: CTcflag)
 147     tcSetAttr fd (#const TCSANOW) p_tios
 148
 149 getEcho :: Int -> IO Bool
 150 getEcho fd = do
 151   allocaBytes (#const sizeof(struct termios))  $ \p_tios -> do
 152     throwErrnoIfMinus1Retry "setEcho"
 153         (c_tcgetattr (fromIntegral fd) p_tios)
 154     c_lflag <- (#peek struct termios, c_lflag) p_tios :: IO CTcflag
 155     return ((c_lflag .&. (#const ECHO)) /= 0)
 156
 157 setCooked :: Int -> Bool -> IO ()
 158 setCooked fd cooked =
 159   allocaBytes (#const sizeof(struct termios))  $ \p_tios -> do
 160     throwErrnoIfMinus1Retry "setCooked"
 161         (c_tcgetattr (fromIntegral fd) p_tios)
 162
 163     -- turn on/off ICANON
 164     c_lflag <- (#peek struct termios, c_lflag) p_tios :: IO CTcflag
 165     let new_c_lflag | cooked    = c_lflag .|. (#const ICANON)
 166                     | otherwise = c_lflag .&. complement (#const ICANON)
 167     (#poke struct termios, c_lflag) p_tios (new_c_lflag :: CTcflag)
 168
 169     -- set VMIN & VTIME to 1/0 respectively
 170     when cooked $ do
 171             let c_cc  = (#ptr struct termios, c_cc) p_tios
 172                 vmin  = c_cc `plusPtr` (#const VMIN)  :: Ptr Word8
 173                 vtime = c_cc `plusPtr` (#const VTIME) :: Ptr Word8
 174             poke vmin  1
 175             poke vtime 0
 176
 177     tcSetAttr fd (#const TCSANOW) p_tios
 178
 179 -- tcsetattr() when invoked by a background process causes the process
 180 -- to be sent SIGTTOU regardless of whether the process has TOSTOP set
 181 -- in its terminal flags (try it...).  This function provides a
 182 -- wrapper which temporarily blocks SIGTTOU around the call, making it
 183 -- transparent.
 184
 185 tcSetAttr :: FD -> CInt -> Ptr Termios -> IO ()
 186 tcSetAttr fd options p_tios = do
 187   allocaBytes (#const sizeof(sigset_t)) $ \ p_sigset -> do
 188   allocaBytes (#const sizeof(sigset_t)) $ \ p_old_sigset -> do
 189      c_sigemptyset p_sigset
 190      c_sigaddset   p_sigset (#const SIGTTOU)
 191      c_sigprocmask (#const SIG_BLOCK) p_sigset p_old_sigset
 192      throwErrnoIfMinus1Retry_ "tcSetAttr" $
 193          c_tcsetattr (fromIntegral fd) options p_tios
 194      c_sigprocmask (#const SIG_SETMASK) p_old_sigset nullPtr
 195
 196 #else
 197
 198 -- bogus defns for win32
 199 setCooked :: Int -> Bool -> IO ()
 200 setCooked fd cooked = return ()
 201
 202 setEcho :: Int -> Bool -> IO ()
 203 setEcho fd on = return ()
 204
 205 getEcho :: Int -> IO Bool
 206 getEcho fd = return False
 207
 208 #endif
 209
 210 -- ---------------------------------------------------------------------------
 211 -- Turning on non-blocking for a file descriptor
 212
 213 #ifndef mingw32_TARGET_OS
 214
 215 setNonBlockingFD fd = do
 216   flags <- throwErrnoIfMinus1Retry "setNonBlockingFD"
 217                  (fcntl_read (fromIntegral fd) (#const F_GETFL))
 218   -- An error when setting O_NONBLOCK isn't fatal: on some systems
 219   -- there are certain file handles on which this will fail (eg. /dev/null
 220   -- on FreeBSD) so we throw away the return code from fcntl_write.
 221   fcntl_write (fromIntegral fd)
 222         (#const F_SETFL) (flags .|. #const O_NONBLOCK)
 223 #else
 224
 225 -- bogus defns for win32
 226 setNonBlockingFD fd = return ()
 227
 228 #endif
 229
 230 -- -----------------------------------------------------------------------------
 231 -- foreign imports
 232
 233 foreign import "stat" unsafe
 234    c_stat :: CString -> Ptr CStat -> IO CInt
 235
 236 foreign import "fstat" unsafe
 237    c_fstat :: CInt -> Ptr CStat -> IO CInt
 238
 239 #ifdef HAVE_LSTAT
 240 foreign import "lstat" unsafe
 241    c_lstat :: CString -> Ptr CStat -> IO CInt
 242 #endif
 243
 244 foreign import "open" unsafe
 245    c_open :: CString -> CInt -> CMode -> IO CInt
 246
 247 -- POSIX flags only:
 248 o_RDONLY    = (#const O_RDONLY)    :: CInt
 249 o_WRONLY    = (#const O_WRONLY)    :: CInt
 250 o_RDWR      = (#const O_RDWR)      :: CInt
 251 o_APPEND    = (#const O_APPEND)    :: CInt
 252 o_CREAT     = (#const O_CREAT)     :: CInt
 253 o_EXCL      = (#const O_EXCL)      :: CInt
 254 o_TRUNC     = (#const O_TRUNC)     :: CInt
 255
 256 #ifdef mingw32_TARGET_OS
 257 o_NOCTTY    = 0 :: CInt
 258 o_NONBLOCK  = 0 :: CInt
 259 #else
 260 o_NOCTTY    = (#const O_NOCTTY)    :: CInt
 261 o_NONBLOCK  = (#const O_NONBLOCK)  :: CInt
 262 #endif
 263
 264 #ifdef HAVE_O_BINARY
 265 o_BINARY    = (#const O_BINARY)    :: CInt
 266 #endif
 267
 268 foreign import "isatty" unsafe
 269    c_isatty :: CInt -> IO CInt
 270
 271 foreign import "close" unsafe
 272    c_close :: CInt -> IO CInt
 273
 274 #ifdef mingw32_TARGET_OS
 275 closeFd :: Bool -> CInt -> IO CInt
 276 closeFd isStream fd
 277   | isStream  = c_closesocket fd
 278   | otherwise = c_close fd
 279
 280 foreign import "closesocket" unsafe
 281    c_closesocket :: CInt -> IO CInt
 282 #endif
 283
 284 foreign import "lseek" unsafe
 285    c_lseek :: CInt -> COff -> CInt -> IO COff
 286
 287 #ifndef mingw32_TARGET_OS
 288 foreign import "fcntl" unsafe
 289    fcntl_read  :: CInt -> CInt -> IO CInt
 290
 291 foreign import "fcntl" unsafe
 292    fcntl_write :: CInt -> CInt -> CInt -> IO CInt
 293
 294 foreign import "fork" unsafe
 295    fork :: IO CPid
 296
 297 foreign import "sigemptyset_PrelPosix_wrap" unsafe
 298    c_sigemptyset :: Ptr CSigset -> IO ()
 299
 300 foreign import "sigaddset" unsafe
 301    c_sigaddset :: Ptr CSigset -> CInt -> IO ()
 302
 303 foreign import "sigprocmask" unsafe
 304    c_sigprocmask :: CInt -> Ptr CSigset -> Ptr CSigset -> IO ()
 305
 306 foreign import "tcgetattr" unsafe
 307    c_tcgetattr :: CInt -> Ptr Termios -> IO CInt
 308
 309 foreign import "tcsetattr" unsafe
 310    c_tcsetattr :: CInt -> CInt -> Ptr Termios -> IO CInt
 311
 312 foreign import "unlink" unsafe
 313    c_unlink :: CString -> IO CInt
 314
 315 foreign import "waitpid" unsafe
 316    c_waitpid :: CPid -> Ptr CInt -> CInt -> IO CPid
 317 #endif