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 module PosixIO (
   8     FdOption(..),
   9     FileLock,
  10     LockRequest(..),
  11
  12     fdClose,
  13     createPipe,
  14     dup,
  15     dupTo,
  16
  17     fdRead,
  18     fdWrite,
  19     fdSeek,
  20
  21     queryFdOption,
  22     setFdOption,
  23
  24     getLock,  setLock,
  25     waitToSetLock,
  26
  27     -- Handle <-> Fd
  28     handleToFd, fdToHandle,
  29     ) where
  30
  31 import GlaExts
  32 import ST
  33 import PrelIOBase
  34 import PrelHandle (filePtr, readHandle, writeHandle, newHandle)
  35 import IO
  36 import PackedString ( unpackPS, unsafeByteArrayToPS, psToByteArrayST )
  37 import Addr
  38 import Foreign
  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  h_ <- readHandle h
  73  case h_ of
  74    ErrorHandle ioError ->  writeHandle h h_  >> fail ioError
  75    ClosedHandle        ->  writeHandle h h_  >>
  76                            fail (IOError Nothing IllegalOperation
  77                                          "handle is closed")
  78    SemiClosedHandle _ _ -> writeHandle h h_  >>
  79                            fail (IOError Nothing IllegalOperation
  80                                          "handle is semi-closed")
  81    other ->
  82     let file = filePtr h_ in
  83     _casm_ `` %r=fileno((FILE *)%0); '' file   >>= \ fd@(FD# fd#) ->
  84     writeHandle h h_  >>
  85     if fd# /=# (negateInt# 1#) then
  86        return fd
  87     else
  88        syserr "handleToFd"
  89
  90 -- default is no buffering.
  91 fdToHandle :: Fd -> IO Handle
  92 fdToHandle fd@(FD# fd#) =
  93     _ccall_ fcntl fd (``F_GETFL''::Int) 0          >>= \ flags@(I# flags#) ->
  94     if flags /= -1 then
  95       let
  96        wH  = (int2Word# flags# `and#` (case ``O_WRONLY'' of { W# x -> x}))
  97                         `neWord#` int2Word# 0#
  98        aH  = (int2Word# flags# `and#` (case ``O_APPEND'' of { W# x -> x}))
  99                         `neWord#` int2Word# 0#
 100        rwH = (int2Word# flags# `and#` (case ``O_RDWR'' of { W# x -> x }))
 101                         `neWord#` int2Word# 0#
 102        (ft,handle_t) =
 103         if wH then
 104           if aH
 105           then ("a",AppendHandle)
 106           else ("w",WriteHandle)
 107         else if rwH then
 108           ("r+",ReadWriteHandle)
 109         else
 110           ("r",ReadHandle)
 111       in
 112       _ccall_ fdopen fd ft >>= \ file_struct@(A# ptr#) ->
 113       if file_struct /= (``NULL''::Addr) then
 114          {-
 115            A distinction is made here between std{Input,Output,Error} Fds
 116            and all others. The standard descriptors have a finaliser
 117            that will not close the underlying fd, the others have one
 118            that will. Or rather, the closing of the standard descriptors is
 119            delayed until the process exits.
 120          -}
 121 #ifndef __PARALLEL_HASKELL__
 122          (if fd == stdInput || fd == stdOutput || fd == stdError then
 123              makeForeignObj file_struct (``&freeStdFile''::Addr)
 124           else
 125              makeForeignObj file_struct (``&freeFile''::Addr)) >>= \ fp ->
 126           newHandle (handle_t fp Nothing False)
 127 #else
 128           newHandle (handle_t file_struct Nothing False)
 129 #endif
 130       else
 131          syserr "fdToHandle"
 132    else
 133       syserr "fdToHandle"
 134
 135 fdRead :: Fd -> ByteCount -> IO (String, ByteCount)
 136 fdRead fd 0 = return ("", 0)
 137 fdRead fd nbytes = do
 138     bytes <-  allocChars nbytes
 139     rc    <-  _ccall_ read fd bytes nbytes
 140     case rc of
 141       -1 -> syserr "fdRead"
 142       0  -> fail (IOError Nothing EOF "EOF")
 143       n | n == nbytes -> do
 144             buf <- freeze bytes
 145             return (unpackPS (unsafeByteArrayToPS buf n), n)
 146         | otherwise -> do
 147             -- Let go of the excessively long ByteArray# by copying to a
 148             -- shorter one.  Maybe we need a new primitive, shrinkCharArray#?
 149             bytes' <- allocChars n
 150             _casm_ ``do {I_ i; for(i = 0; i < %2; i++) ((B_)%0)[i] = ((B_)%1)[i];
 151                       } while(0);'' bytes' bytes n
 152             buf <- freeze bytes'
 153             return (unpackPS (unsafeByteArrayToPS buf n), n)
 154
 155 fdWrite :: Fd -> String -> IO ByteCount
 156 fdWrite fd str = do
 157     buf <- stToIO (psToByteArrayST str)
 158     rc  <- _ccall_ write fd buf (length str)
 159     if rc /= -1
 160        then return rc
 161        else syserr "fdWrite"
 162
 163 data FdOption = AppendOnWrite
 164               | CloseOnExec
 165               | NonBlockingRead
 166
 167 queryFdOption :: Fd -> FdOption -> IO Bool
 168 queryFdOption fd CloseOnExec =
 169     _ccall_ fcntl fd (``F_GETFD''::Int) 0           >>= \ (I# flags#) ->
 170     if flags# /=# -1# then
 171         return ((int2Word# flags# `and#` fd_cloexec#) `neWord#` int2Word# 0#)
 172     else
 173         syserr "queryFdOption"
 174   where
 175     fd_cloexec# = case (``FD_CLOEXEC'') of { W# x -> x }
 176 queryFdOption fd other =
 177     _ccall_ fcntl fd (``F_GETFL''::Int) 0           >>= \ (I# flags#) ->
 178     if flags# >=# 0# then
 179         return ((int2Word# flags# `and#` opt#) `neWord#` int2Word# 0#)
 180     else
 181         syserr "queryFdOption"
 182   where
 183     opt# = case (
 184         case other of
 185           AppendOnWrite   -> ``O_APPEND''
 186           NonBlockingRead -> ``O_NONBLOCK'' ) of { W# x -> x }
 187
 188 setFdOption :: Fd -> FdOption -> Bool -> IO ()
 189 setFdOption fd CloseOnExec val = do
 190     flags <- _ccall_ fcntl fd (``F_GETFD''::Int) 0
 191     if flags /= -1 then do
 192         rc <- (if val then
 193                  _casm_ ``%r = fcntl(%0, F_SETFD, %1 | FD_CLOEXEC);'' fd flags
 194                else do
 195                  _casm_ ``%r = fcntl(%0, F_SETFD, %1 & ~FD_CLOEXEC);'' fd flags)
 196         if rc /= -1
 197            then return ()
 198            else fail
 199      else fail
 200   where
 201     fail = syserr "setFdOption"
 202
 203 setFdOption fd other val = do
 204     flags <- _ccall_ fcntl fd (``F_GETFL''::Int) 0
 205     if flags >= 0 then do
 206         rc <- (if val then
 207                  _casm_ ``%r = fcntl(%0, F_SETFL, %1 | %2);'' fd flags opt
 208                else do
 209                  _casm_ ``%r = fcntl(%0, F_SETFL, %1 & ~(%2));'' fd flags opt)
 210         if rc /= -1
 211            then return ()
 212            else fail
 213      else fail
 214   where
 215     fail = syserr "setFdOption"
 216     opt =
 217         case other of
 218           AppendOnWrite -> (``O_APPEND''::Word)
 219           NonBlockingRead -> (``O_NONBLOCK''::Word)
 220
 221 data LockRequest = ReadLock
 222                  | WriteLock
 223                  | Unlock
 224
 225 type FileLock = (LockRequest, SeekMode, FileOffset, FileOffset)
 226
 227 getLock :: Fd -> FileLock -> IO (Maybe (ProcessID, FileLock))
 228 getLock fd lock = do
 229     flock <- lock2Bytes lock
 230     rc    <- _ccall_ fcntl fd (``F_GETLK''::Int) flock
 231     if rc /= -1
 232        then do
 233             result <- bytes2ProcessIDAndLock flock
 234             return (maybeResult result)
 235        else syserr "getLock"
 236   where
 237     maybeResult (_, (Unlock, _, _, _)) = Nothing
 238     maybeResult x = Just x
 239
 240 setLock :: Fd -> FileLock -> IO ()
 241 setLock fd lock = do
 242     flock <- lock2Bytes lock
 243     minusone_error (_ccall_ fcntl fd (``F_SETLK''::Int) flock) "setLock"
 244
 245 waitToSetLock :: Fd -> FileLock -> IO ()
 246 waitToSetLock fd lock = do
 247     flock <- lock2Bytes lock
 248     minusone_error (_ccall_ fcntl fd (``F_SETLKW''::Int) flock) "waitToSetLock"
 249
 250 fdSeek :: Fd -> SeekMode -> FileOffset -> IO FileOffset
 251 fdSeek fd mode offset = do
 252     rc <- _ccall_ lseek fd offset (mode2Int mode)
 253     if rc /= -1
 254        then return rc
 255        else syserr "fdSeek"
 256
 257 \end{code}
 258
 259 Local utility functions
 260
 261 \begin{code}
 262
 263 -- Convert a Haskell SeekMode to an int
 264
 265 mode2Int :: SeekMode -> Int
 266 mode2Int AbsoluteSeek = ``SEEK_SET''
 267 mode2Int RelativeSeek = ``SEEK_CUR''
 268 mode2Int SeekFromEnd  = ``SEEK_END''
 269
 270 -- Convert a Haskell FileLock to an flock structure
 271 lockRequest2Int :: LockRequest -> Int
 272 lockRequest2Int kind =
 273  case kind of
 274   ReadLock  -> ``F_RDLCK''
 275   WriteLock -> ``F_WRLCK''
 276   Unlock    -> ``F_UNLCK''
 277
 278 lock2Bytes :: FileLock -> IO (MutableByteArray RealWorld ())
 279 lock2Bytes (kind, mode, start, len) = do
 280     bytes <- allocChars ``sizeof(struct flock)''
 281     _casm_ ``do { struct flock *fl = (struct flock *)%0;
 282                   fl->l_type = %1;
 283                   fl->l_whence = %2;
 284                   fl->l_start = %3;
 285                   fl->l_len = %4;
 286              } while(0);''
 287              bytes (lockRequest2Int kind) (mode2Int mode) start len
 288     return bytes
 289 --  where
 290
 291 bytes2ProcessIDAndLock :: MutableByteArray s () -> IO (ProcessID, FileLock)
 292 bytes2ProcessIDAndLock bytes = do
 293     ltype   <- _casm_ ``%r = ((struct flock *)%0)->l_type;'' bytes
 294     lwhence <- _casm_ ``%r = ((struct flock *)%0)->l_whence;'' bytes
 295     lstart  <- _casm_ ``%r = ((struct flock *)%0)->l_start;'' bytes
 296     llen    <- _casm_ ``%r = ((struct flock *)%0)->l_len;'' bytes
 297     lpid    <- _casm_ ``%r = ((struct flock *)%0)->l_pid;'' bytes
 298     return (lpid, (kind ltype, mode lwhence, lstart, llen))
 299 --  where
 300 kind :: Int -> LockRequest
 301 kind x
 302  | x == ``F_RDLCK'' = ReadLock
 303  | x == ``F_WRLCK'' = WriteLock
 304  | x == ``F_UNLCK'' = Unlock
 305 mode :: Int -> SeekMode
 306 mode x
 307  | x == ``SEEK_SET'' = AbsoluteSeek
 308  | x == ``SEEK_CUR'' = RelativeSeek
 309  | x == ``SEEK_END'' = SeekFromEnd
 310
 311 \end{code}