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