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