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