ghc/lib/posix/PosixIO.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1995-1996
   3 %
   4 \section[PosixIO]{Haskell 1.3 POSIX Input/Output Primitives}
   5
   6 \begin{code}
   7 {-# OPTIONS -#include "../std/cbits/stgio.h" #-}
   8 module PosixIO (
   9     FdOption(..),
  10     FileLock,
  11     LockRequest(..),
  12
  13     fdClose,
  14     createPipe,
  15     dup,
  16     dupTo,
  17
  18     fdRead,
  19     fdWrite,
  20     fdSeek,
  21
  22     queryFdOption,
  23     setFdOption,
  24
  25     getLock,  setLock,
  26     waitToSetLock,
  27
  28     -- Handle <-> Fd
  29     handleToFd, fdToHandle,
  30     ) where
  31
  32 import GlaExts
  33 import PrelIOBase
  34 import PrelHandle (newHandle, getBMode__, getHandleFd,
  35                    freeFileObject, freeStdFileObject )
  36 import IO
  37 import Addr
  38 import Foreign
  39 import Weak     ( addForeignFinaliser )
  40 import CString ( freeze, allocChars, packStringIO, unpackNBytesBAIO )
  41
  42 import PosixUtil
  43 import PosixFiles ( stdInput, stdOutput, stdError )
  44
  45
  46 createPipe :: IO (Fd, Fd)
  47 createPipe = do
  48     bytes <- allocChars ``(2*sizeof(int))''
  49     rc    <- _casm_ ``%r = pipe((int *)%0);'' bytes
  50     if rc /= -1
  51        then do
  52         rd <- _casm_ ``%r = ((int *)%0)[0];'' bytes
  53         wd <- _casm_ ``%r = ((int *)%0)[1];'' bytes
  54         return (rd, wd)
  55        else
  56         syserr "createPipe"
  57
  58 dup :: Fd -> IO Fd
  59 dup fd =
  60     _ccall_ dup fd      >>= \ fd2@(I# fd2#) ->
  61     if fd2 /= -1 then
  62         return (FD# fd2#)
  63     else
  64         syserr "dup"
  65
  66 dupTo :: Fd -> Fd -> IO ()
  67 dupTo fd1 fd2 = minusone_error (_ccall_ dup2 fd1 fd2) "dupTo"
  68
  69 fdClose :: Fd -> IO ()
  70 fdClose fd = minusone_error (_ccall_ close fd) "fdClose"
  71
  72 handleToFd :: Handle -> IO Fd
  73 handleToFd h = do
  74   fd <- getHandleFd h
  75   let (I# fd#) = fd
  76   return (FD# fd#)
  77
  78 -- default is no buffering.
  79 fdToHandle :: Fd -> IO Handle
  80 fdToHandle fd@(FD# fd#) = do
  81      -- first find out what kind of file desc. this is..
  82     flags <- _ccall_ fcntl fd (``F_GETFL''::Int) 0
  83     if flags /= -1
  84      then do
  85       let
  86        (I# flags#) = flags
  87
  88        wH  = (int2Word# flags# `and#` (case ``O_WRONLY'' of { W# x -> x}))
  89                         `neWord#` int2Word# 0#
  90        aH  = (int2Word# flags# `and#` (case ``O_APPEND'' of { W# x -> x}))
  91                         `neWord#` int2Word# 0#
  92        rwH = (int2Word# flags# `and#` (case ``O_RDWR'' of { W# x -> x }))
  93                         `neWord#` int2Word# 0#
  94
  95        (handle_t, flush_on_close)
  96          | wH && aH  = (AppendHandle, 1)
  97          | wH        = (WriteHandle, 1)
  98          | rwH       = (ReadWriteHandle, 1)
  99          | otherwise = (ReadHandle, 0)
 100
 101       fo <- _ccall_ openFd fd flags flush_on_close
 102       if fo /= nullAddr then do
 103          {-
 104            A distinction is made here between std{Input,Output,Error} Fds
 105            and all others. The standard descriptors have a finaliser
 106            that will not close the underlying fd, the others have one
 107            that will.
 108
 109            Delaying the closing of the standard descriptors until the process
 110            exits is necessary since the RTS is likely to require these after
 111            (or as a result of) program termination.
 112          -}
 113 #ifndef __PARALLEL_HASKELL__
 114          fo <- makeForeignObj fo
 115          if fd == stdInput || fd == stdOutput || fd == stdError then
 116               addForeignFinaliser fo (freeStdFileObject fo)
 117           else
 118               addForeignFinaliser fo (freeFileObject fo)
 119 #endif
 120          (bm, bf_size)  <- getBMode__ fo
 121          mkBuffer__ fo bf_size
 122          newHandle (Handle__ fo handle_t bm fd_str)
 123        else
 124          syserr "fdToHandle"
 125      else
 126        syserr "fdToHandle"
 127   where
 128    fd_str = "<file descriptor: " ++ show (I# fd#) ++ ">"
 129
 130 fdRead :: Fd -> ByteCount -> IO (String, ByteCount)
 131 fdRead fd 0 = return ("", 0)
 132 fdRead fd nbytes = do
 133     bytes <-  allocChars nbytes
 134     rc    <-  _ccall_ read fd bytes nbytes
 135     case rc of
 136       -1 -> syserr "fdRead"
 137       0  -> fail (IOError Nothing EOF "fdRead" "EOF")
 138       n | n == nbytes -> do
 139             buf <- freeze bytes
 140             s   <- unpackNBytesBAIO buf n
 141             return (s, n)
 142         | otherwise -> do
 143             -- Let go of the excessively long ByteArray# by copying to a
 144             -- shorter one.  Maybe we need a new primitive, shrinkCharArray#?
 145             bytes' <- allocChars n
 146             _casm_ ``do {I_ i; for(i = 0; i < %2; i++) ((B_)%0)[i] = ((B_)%1)[i];
 147                       } while(0);'' bytes' bytes n
 148             buf <- freeze bytes'
 149             s   <- unpackNBytesBAIO buf n
 150             return (s, n)
 151
 152 fdWrite :: Fd -> String -> IO ByteCount
 153 fdWrite fd str = do
 154     buf <- packStringIO str
 155     rc  <- _ccall_ write fd buf (length str)
 156     if rc /= -1
 157        then return rc
 158        else syserr "fdWrite"
 159
 160 data FdOption = AppendOnWrite
 161               | CloseOnExec
 162               | NonBlockingRead
 163
 164 queryFdOption :: Fd -> FdOption -> IO Bool
 165 queryFdOption fd CloseOnExec =
 166     _ccall_ fcntl fd (``F_GETFD''::Int) 0           >>= \ (I# flags#) ->
 167     if flags# /=# -1# then
 168         return ((int2Word# flags# `and#` fd_cloexec#) `neWord#` int2Word# 0#)
 169     else
 170         syserr "queryFdOption"
 171   where
 172     fd_cloexec# = case (``FD_CLOEXEC'') of { W# x -> x }
 173 queryFdOption fd other =
 174     _ccall_ fcntl fd (``F_GETFL''::Int) 0           >>= \ (I# flags#) ->
 175     if flags# >=# 0# then
 176         return ((int2Word# flags# `and#` opt#) `neWord#` int2Word# 0#)
 177     else
 178         syserr "queryFdOption"
 179   where
 180     opt# = case (
 181         case other of
 182           AppendOnWrite   -> ``O_APPEND''
 183           NonBlockingRead -> ``O_NONBLOCK'' ) of { W# x -> x }
 184
 185 setFdOption :: Fd -> FdOption -> Bool -> IO ()
 186 setFdOption fd CloseOnExec val = do
 187     flags <- _ccall_ fcntl fd (``F_GETFD''::Int) 0
 188     if flags /= -1 then do
 189         rc <- (if val then
 190                  _casm_ ``%r = fcntl(%0, F_SETFD, %1 | FD_CLOEXEC);'' fd flags
 191                else do
 192                  _casm_ ``%r = fcntl(%0, F_SETFD, %1 & ~FD_CLOEXEC);'' fd flags)
 193         if rc /= -1
 194            then return ()
 195            else fail
 196      else fail
 197   where
 198     fail = syserr "setFdOption"
 199
 200 setFdOption fd other val = do
 201     flags <- _ccall_ fcntl fd (``F_GETFL''::Int) 0
 202     if flags >= 0 then do
 203         rc <- (if val then
 204                  _casm_ ``%r = fcntl(%0, F_SETFL, %1 | %2);'' fd flags opt
 205                else do
 206                  _casm_ ``%r = fcntl(%0, F_SETFL, %1 & ~(%2));'' fd flags opt)
 207         if rc /= -1
 208            then return ()
 209            else fail
 210      else fail
 211   where
 212     fail = syserr "setFdOption"
 213     opt =
 214         case other of
 215           AppendOnWrite -> (``O_APPEND''::Word)
 216           NonBlockingRead -> (``O_NONBLOCK''::Word)
 217
 218 data LockRequest = ReadLock
 219                  | WriteLock
 220                  | Unlock
 221
 222 type FileLock = (LockRequest, SeekMode, FileOffset, FileOffset)
 223
 224 getLock :: Fd -> FileLock -> IO (Maybe (ProcessID, FileLock))
 225 getLock fd lock = do
 226     flock <- lock2Bytes lock
 227     rc    <- _ccall_ fcntl fd (``F_GETLK''::Int) flock
 228     if rc /= -1
 229        then do
 230             result <- bytes2ProcessIDAndLock flock
 231             return (maybeResult result)
 232        else syserr "getLock"
 233   where
 234     maybeResult (_, (Unlock, _, _, _)) = Nothing
 235     maybeResult x = Just x
 236
 237 setLock :: Fd -> FileLock -> IO ()
 238 setLock fd lock = do
 239     flock <- lock2Bytes lock
 240     minusone_error (_ccall_ fcntl fd (``F_SETLK''::Int) flock) "setLock"
 241
 242 waitToSetLock :: Fd -> FileLock -> IO ()
 243 waitToSetLock fd lock = do
 244     flock <- lock2Bytes lock
 245     minusone_error (_ccall_ fcntl fd (``F_SETLKW''::Int) flock) "waitToSetLock"
 246
 247 fdSeek :: Fd -> SeekMode -> FileOffset -> IO FileOffset
 248 fdSeek fd mode offset = do
 249     rc <- _ccall_ lseek fd offset (mode2Int mode)
 250     if rc /= -1
 251        then return rc
 252        else syserr "fdSeek"
 253
 254 \end{code}
 255
 256 Local utility functions
 257
 258 \begin{code}
 259
 260 -- Convert a Haskell SeekMode to an int
 261
 262 mode2Int :: SeekMode -> Int
 263 mode2Int AbsoluteSeek = ``SEEK_SET''
 264 mode2Int RelativeSeek = ``SEEK_CUR''
 265 mode2Int SeekFromEnd  = ``SEEK_END''
 266
 267 -- Convert a Haskell FileLock to an flock structure
 268 lockRequest2Int :: LockRequest -> Int
 269 lockRequest2Int kind =
 270  case kind of
 271   ReadLock  -> ``F_RDLCK''
 272   WriteLock -> ``F_WRLCK''
 273   Unlock    -> ``F_UNLCK''
 274
 275 lock2Bytes :: FileLock -> IO (MutableByteArray RealWorld Int)
 276 lock2Bytes (kind, mode, start, len) = do
 277     bytes <- allocChars ``sizeof(struct flock)''
 278     _casm_ ``do { struct flock *fl = (struct flock *)%0;
 279                   fl->l_type = %1;
 280                   fl->l_whence = %2;
 281                   fl->l_start = %3;
 282                   fl->l_len = %4;
 283              } while(0);''
 284              bytes (lockRequest2Int kind) (mode2Int mode) start len
 285     return bytes
 286 --  where
 287
 288 bytes2ProcessIDAndLock :: MutableByteArray s Int -> IO (ProcessID, FileLock)
 289 bytes2ProcessIDAndLock bytes = do
 290     ltype   <- _casm_ ``%r = ((struct flock *)%0)->l_type;'' bytes
 291     lwhence <- _casm_ ``%r = ((struct flock *)%0)->l_whence;'' bytes
 292     lstart  <- _casm_ ``%r = ((struct flock *)%0)->l_start;'' bytes
 293     llen    <- _casm_ ``%r = ((struct flock *)%0)->l_len;'' bytes
 294     lpid    <- _casm_ ``%r = ((struct flock *)%0)->l_pid;'' bytes
 295     return (lpid, (kind ltype, mode lwhence, lstart, llen))
 296
 297 kind :: Int -> LockRequest
 298 kind x
 299  | x == ``F_RDLCK'' = ReadLock
 300  | x == ``F_WRLCK'' = WriteLock
 301  | x == ``F_UNLCK'' = Unlock
 302
 303 mode :: Int -> SeekMode
 304 mode x
 305  | x == ``SEEK_SET'' = AbsoluteSeek
 306  | x == ``SEEK_CUR'' = RelativeSeek
 307  | x == ``SEEK_END'' = SeekFromEnd
 308
 309 \end{code}