Add support for more OpenFileFlags and refactor 'openFd' (PR #59)
[packages/unix.git] / System / Posix / IO / Common.hsc
1 {-# LANGUAGE CApiFFI #-}
2 {-# LANGUAGE NondecreasingIndentation #-}
3 {-# LANGUAGE RecordWildCards #-}
4 #if __GLASGOW_HASKELL__ >= 709
5 {-# LANGUAGE Safe #-}
6 #else
7 {-# LANGUAGE Trustworthy #-}
8 #endif
9
10 -----------------------------------------------------------------------------
11 -- |
12 -- Module      :  System.Posix.IO.Common
13 -- Copyright   :  (c) The University of Glasgow 2002
14 -- License     :  BSD-style (see the file libraries/base/LICENSE)
15 --
16 -- Maintainer  :  libraries@haskell.org
17 -- Stability   :  provisional
18 -- Portability :  non-portable (requires POSIX)
19 --
20 -----------------------------------------------------------------------------
21
22 module System.Posix.IO.Common (
23     -- * Input \/ Output
24
25     -- ** Standard file descriptors
26     stdInput, stdOutput, stdError,
27
28     -- ** Opening and closing files
29     OpenMode(..),
30     OpenFileFlags(..), defaultFileFlags,
31     open_,
32     closeFd,
33
34     -- ** Reading\/writing data
35     -- |Programmers using the 'fdRead' and 'fdWrite' API should be aware that
36     -- EAGAIN exceptions may occur for non-blocking IO!
37
38     fdRead, fdWrite,
39     fdReadBuf, fdWriteBuf,
40
41     -- ** Seeking
42     fdSeek,
43
44     -- ** File options
45     FdOption(..),
46     queryFdOption,
47     setFdOption,
48
49     -- ** Locking
50     FileLock,
51     LockRequest(..),
52     getLock,  setLock,
53     waitToSetLock,
54
55     -- ** Pipes
56     createPipe,
57
58     -- ** Duplicating file descriptors
59     dup, dupTo,
60
61     -- ** Converting file descriptors to\/from Handles
62     handleToFd,
63     fdToHandle,
64
65   ) where
66
67 import System.IO
68 import System.IO.Error
69 import System.Posix.Types
70 import qualified System.Posix.Internals as Base
71
72 import Foreign
73 import Foreign.C
74
75 import GHC.IO.Handle.Internals
76 import GHC.IO.Handle.Types
77 import qualified GHC.IO.FD as FD
78 import qualified GHC.IO.Handle.FD as FD
79 import GHC.IO.Exception
80 import Data.Typeable (cast)
81
82 #include "HsUnix.h"
83
84 -- -----------------------------------------------------------------------------
85 -- Pipes
86 -- |The 'createPipe' function creates a pair of connected file
87 -- descriptors. The first component is the fd to read from, the second
88 -- is the write end.  Although pipes may be bidirectional, this
89 -- behaviour is not portable and programmers should use two separate
90 -- pipes for this purpose.  May throw an exception if this is an
91 -- invalid descriptor.
92
93 createPipe :: IO (Fd, Fd)
94 createPipe =
95   allocaArray 2 $ \p_fd -> do
96     throwErrnoIfMinus1_ "createPipe" (c_pipe p_fd)
97     rfd <- peekElemOff p_fd 0
98     wfd <- peekElemOff p_fd 1
99     return (Fd rfd, Fd wfd)
100
101 foreign import ccall unsafe "pipe"
102    c_pipe :: Ptr CInt -> IO CInt
103
104 -- -----------------------------------------------------------------------------
105 -- Duplicating file descriptors
106
107 -- | May throw an exception if this is an invalid descriptor.
108 dup :: Fd -> IO Fd
109 dup (Fd fd) = do r <- throwErrnoIfMinus1 "dup" (c_dup fd); return (Fd r)
110
111 -- | May throw an exception if this is an invalid descriptor.
112 dupTo :: Fd -> Fd -> IO Fd
113 dupTo (Fd fd1) (Fd fd2) = do
114   r <- throwErrnoIfMinus1 "dupTo" (c_dup2 fd1 fd2)
115   return (Fd r)
116
117 foreign import ccall unsafe "dup"
118    c_dup :: CInt -> IO CInt
119
120 foreign import ccall unsafe "dup2"
121    c_dup2 :: CInt -> CInt -> IO CInt
122
123 -- -----------------------------------------------------------------------------
124 -- Opening and closing files
125
126 stdInput, stdOutput, stdError :: Fd
127 stdInput   = Fd (#const STDIN_FILENO)
128 stdOutput  = Fd (#const STDOUT_FILENO)
129 stdError   = Fd (#const STDERR_FILENO)
130
131 data OpenMode = ReadOnly | WriteOnly | ReadWrite
132
133 -- |Correspond to some of the int flags from C's fcntl.h.
134 data OpenFileFlags =
135  OpenFileFlags {
136     append    :: Bool,           -- ^ O_APPEND
137     exclusive :: Bool,           -- ^ O_EXCL, result is undefined if O_CREAT is Nothing
138     noctty    :: Bool,           -- ^ O_NOCTTY
139     nonBlock  :: Bool,           -- ^ O_NONBLOCK
140     trunc     :: Bool,           -- ^ O_TRUNC
141     nofollow  :: Bool,           -- ^ O_NOFOLLOW
142     creat     :: Maybe FileMode, -- ^ O_CREAT
143     cloexec   :: Bool,           -- ^ O_CLOEXEC
144     directory :: Bool,           -- ^ O_DIRECTORY
145     sync      :: Bool            -- ^ O_SYNC
146  }
147
148
149 -- |Default values for the 'OpenFileFlags' type. False for each of
150 -- append, exclusive, noctty, nonBlock, and trunc.
151 defaultFileFlags :: OpenFileFlags
152 defaultFileFlags =
153  OpenFileFlags {
154     append    = False,
155     exclusive = False,
156     noctty    = False,
157     nonBlock  = False,
158     trunc     = False,
159     nofollow  = False,
160     creat     = Nothing,
161     cloexec   = False,
162     directory = False,
163     sync      = False
164   }
165
166
167 -- |Open and optionally create this file.  See 'System.Posix.Files'
168 -- for information on how to use the 'FileMode' type.
169 open_  :: CString
170        -> OpenMode
171        -> OpenFileFlags
172        -> IO Fd
173 open_ str how (OpenFileFlags appendFlag exclusiveFlag nocttyFlag
174                                 nonBlockFlag truncateFlag nofollowFlag
175                                 creatFlag cloexecFlag directoryFlag
176                                 syncFlag) = do
177     fd <- c_open str all_flags mode_w
178     return (Fd fd)
179   where
180     all_flags  = creat .|. flags .|. open_mode
181
182     flags =
183        (if appendFlag       then (#const O_APPEND)    else 0) .|.
184        (if exclusiveFlag    then (#const O_EXCL)      else 0) .|.
185        (if nocttyFlag       then (#const O_NOCTTY)    else 0) .|.
186        (if nonBlockFlag     then (#const O_NONBLOCK)  else 0) .|.
187        (if truncateFlag     then (#const O_TRUNC)     else 0) .|.
188        (if nofollowFlag     then (#const O_NOFOLLOW)  else 0) .|.
189        (if cloexecFlag      then (#const O_CLOEXEC)   else 0) .|.
190        (if directoryFlag    then (#const O_DIRECTORY) else 0) .|.
191        (if syncFlag         then (#const O_SYNC)      else 0)
192
193     (creat, mode_w) = case creatFlag of
194                         Nothing -> (0,0)
195                         Just x  -> ((#const O_CREAT), x)
196
197     open_mode = case how of
198                    ReadOnly  -> (#const O_RDONLY)
199                    WriteOnly -> (#const O_WRONLY)
200                    ReadWrite -> (#const O_RDWR)
201
202 foreign import capi unsafe "HsUnix.h open"
203    c_open :: CString -> CInt -> CMode -> IO CInt
204
205 -- |Close this file descriptor.  May throw an exception if this is an
206 -- invalid descriptor.
207
208 closeFd :: Fd -> IO ()
209 closeFd (Fd fd) = throwErrnoIfMinus1_ "closeFd" (c_close fd)
210
211 foreign import ccall unsafe "HsUnix.h close"
212    c_close :: CInt -> IO CInt
213
214 -- -----------------------------------------------------------------------------
215 -- Converting file descriptors to/from Handles
216
217 -- | Extracts the 'Fd' from a 'Handle'.  This function has the side effect
218 -- of closing the 'Handle' and flushing its write buffer, if necessary.
219 handleToFd :: Handle -> IO Fd
220
221 -- | Converts an 'Fd' into a 'Handle' that can be used with the
222 -- standard Haskell IO library (see "System.IO").
223 fdToHandle :: Fd -> IO Handle
224 fdToHandle fd = FD.fdToHandle (fromIntegral fd)
225
226 handleToFd h@(FileHandle _ m) = do
227   withHandle' "handleToFd" h m $ handleToFd' h
228 handleToFd h@(DuplexHandle _ r w) = do
229   _ <- withHandle' "handleToFd" h r $ handleToFd' h
230   withHandle' "handleToFd" h w $ handleToFd' h
231   -- for a DuplexHandle, make sure we mark both sides as closed,
232   -- otherwise a finalizer will come along later and close the other
233   -- side. (#3914)
234
235 handleToFd' :: Handle -> Handle__ -> IO (Handle__, Fd)
236 handleToFd' h h_@Handle__{haType=_,..} = do
237   case cast haDevice of
238     Nothing -> ioError (ioeSetErrorString (mkIOError IllegalOperation
239                                            "handleToFd" (Just h) Nothing)
240                         "handle is not a file descriptor")
241     Just fd -> do
242      -- converting a Handle into an Fd effectively means
243      -- letting go of the Handle; it is put into a closed
244      -- state as a result.
245      flushWriteBuffer h_
246      FD.release fd
247      return (Handle__{haType=ClosedHandle,..}, Fd (FD.fdFD fd))
248
249
250 -- -----------------------------------------------------------------------------
251 -- Fd options
252
253 data FdOption = AppendOnWrite     -- ^O_APPEND
254               | CloseOnExec       -- ^FD_CLOEXEC
255               | NonBlockingRead   -- ^O_NONBLOCK
256               | SynchronousWrites -- ^O_SYNC
257
258 fdOption2Int :: FdOption -> CInt
259 fdOption2Int CloseOnExec       = (#const FD_CLOEXEC)
260 fdOption2Int AppendOnWrite     = (#const O_APPEND)
261 fdOption2Int NonBlockingRead   = (#const O_NONBLOCK)
262 fdOption2Int SynchronousWrites = (#const O_SYNC)
263
264 -- | May throw an exception if this is an invalid descriptor.
265 queryFdOption :: Fd -> FdOption -> IO Bool
266 queryFdOption (Fd fd) opt = do
267   r <- throwErrnoIfMinus1 "queryFdOption" (Base.c_fcntl_read fd flag)
268   return ((r .&. fdOption2Int opt) /= 0)
269  where
270   flag    = case opt of
271               CloseOnExec       -> (#const F_GETFD)
272               _                 -> (#const F_GETFL)
273
274 -- | May throw an exception if this is an invalid descriptor.
275 setFdOption :: Fd -> FdOption -> Bool -> IO ()
276 setFdOption (Fd fd) opt val = do
277   r <- throwErrnoIfMinus1 "setFdOption" (Base.c_fcntl_read fd getflag)
278   let r' | val       = r .|. opt_val
279          | otherwise = r .&. (complement opt_val)
280   throwErrnoIfMinus1_ "setFdOption"
281                       (Base.c_fcntl_write fd setflag (fromIntegral r'))
282  where
283   (getflag,setflag)= case opt of
284               CloseOnExec       -> ((#const F_GETFD),(#const F_SETFD))
285               _                 -> ((#const F_GETFL),(#const F_SETFL))
286   opt_val = fdOption2Int opt
287
288 -- -----------------------------------------------------------------------------
289 -- Seeking
290
291 mode2Int :: SeekMode -> CInt
292 mode2Int AbsoluteSeek = (#const SEEK_SET)
293 mode2Int RelativeSeek = (#const SEEK_CUR)
294 mode2Int SeekFromEnd  = (#const SEEK_END)
295
296 -- | May throw an exception if this is an invalid descriptor.
297 fdSeek :: Fd -> SeekMode -> FileOffset -> IO FileOffset
298 fdSeek (Fd fd) mode off =
299   throwErrnoIfMinus1 "fdSeek" (Base.c_lseek fd off (mode2Int mode))
300
301 -- -----------------------------------------------------------------------------
302 -- Locking
303
304 data LockRequest = ReadLock
305                  | WriteLock
306                  | Unlock
307
308 type FileLock = (LockRequest, SeekMode, FileOffset, FileOffset)
309
310 -- | May throw an exception if this is an invalid descriptor.
311 getLock :: Fd -> FileLock -> IO (Maybe (ProcessID, FileLock))
312 getLock (Fd fd) lock =
313   allocaLock lock $ \p_flock -> do
314     throwErrnoIfMinus1_ "getLock" (Base.c_fcntl_lock fd (#const F_GETLK) p_flock)
315     result <- bytes2ProcessIDAndLock p_flock
316     return (maybeResult result)
317   where
318     maybeResult (_, (Unlock, _, _, _)) = Nothing
319     maybeResult x = Just x
320
321 allocaLock :: FileLock -> (Ptr Base.CFLock -> IO a) -> IO a
322 allocaLock (lockreq, mode, start, len) io =
323   allocaBytes (#const sizeof(struct flock)) $ \p -> do
324     (#poke struct flock, l_type)   p (lockReq2Int lockreq :: CShort)
325     (#poke struct flock, l_whence) p (fromIntegral (mode2Int mode) :: CShort)
326     (#poke struct flock, l_start)  p start
327     (#poke struct flock, l_len)    p len
328     io p
329
330 lockReq2Int :: LockRequest -> CShort
331 lockReq2Int ReadLock  = (#const F_RDLCK)
332 lockReq2Int WriteLock = (#const F_WRLCK)
333 lockReq2Int Unlock    = (#const F_UNLCK)
334
335 bytes2ProcessIDAndLock :: Ptr Base.CFLock -> IO (ProcessID, FileLock)
336 bytes2ProcessIDAndLock p = do
337   req   <- (#peek struct flock, l_type)   p
338   mode  <- (#peek struct flock, l_whence) p
339   start <- (#peek struct flock, l_start)  p
340   len   <- (#peek struct flock, l_len)    p
341   pid   <- (#peek struct flock, l_pid)    p
342   return (pid, (int2req req, int2mode mode, start, len))
343  where
344   int2req :: CShort -> LockRequest
345   int2req (#const F_RDLCK) = ReadLock
346   int2req (#const F_WRLCK) = WriteLock
347   int2req (#const F_UNLCK) = Unlock
348   int2req _ = error $ "int2req: bad argument"
349
350   int2mode :: CShort -> SeekMode
351   int2mode (#const SEEK_SET) = AbsoluteSeek
352   int2mode (#const SEEK_CUR) = RelativeSeek
353   int2mode (#const SEEK_END) = SeekFromEnd
354   int2mode _ = error $ "int2mode: bad argument"
355
356 -- | May throw an exception if this is an invalid descriptor.
357 setLock :: Fd -> FileLock -> IO ()
358 setLock (Fd fd) lock = do
359   allocaLock lock $ \p_flock ->
360     throwErrnoIfMinus1_ "setLock" (Base.c_fcntl_lock fd (#const F_SETLK) p_flock)
361
362 -- | May throw an exception if this is an invalid descriptor.
363 waitToSetLock :: Fd -> FileLock -> IO ()
364 waitToSetLock (Fd fd) lock = do
365   allocaLock lock $ \p_flock ->
366     throwErrnoIfMinus1_ "waitToSetLock"
367         (Base.c_fcntl_lock fd (#const F_SETLKW) p_flock)
368
369 -- -----------------------------------------------------------------------------
370 -- fd{Read,Write}
371
372 -- | Read data from an 'Fd' and convert it to a 'String' using the locale encoding.
373 -- Throws an exception if this is an invalid descriptor, or EOF has been
374 -- reached.
375 fdRead :: Fd
376        -> ByteCount -- ^How many bytes to read
377        -> IO (String, ByteCount) -- ^The bytes read, how many bytes were read.
378 fdRead _fd 0 = return ("", 0)
379 fdRead fd nbytes = do
380     allocaBytes (fromIntegral nbytes) $ \ buf -> do
381     rc <- fdReadBuf fd buf nbytes
382     case rc of
383       0 -> ioError (ioeSetErrorString (mkIOError EOF "fdRead" Nothing Nothing) "EOF")
384       n -> do
385        s <- peekCStringLen (castPtr buf, fromIntegral n)
386        return (s, n)
387
388 -- | Read data from an 'Fd' into memory.  This is exactly equivalent
389 -- to the POSIX @read@ function.
390 fdReadBuf :: Fd
391           -> Ptr Word8 -- ^ Memory in which to put the data
392           -> ByteCount -- ^ Maximum number of bytes to read
393           -> IO ByteCount -- ^ Number of bytes read (zero for EOF)
394 fdReadBuf _fd _buf 0 = return 0
395 fdReadBuf fd buf nbytes =
396   fmap fromIntegral $
397     throwErrnoIfMinus1Retry "fdReadBuf" $
398       c_safe_read (fromIntegral fd) (castPtr buf) nbytes
399
400 foreign import ccall safe "read"
401    c_safe_read :: CInt -> Ptr CChar -> CSize -> IO CSsize
402
403 -- | Write a 'String' to an 'Fd' using the locale encoding.
404 fdWrite :: Fd -> String -> IO ByteCount
405 fdWrite fd str =
406   withCStringLen str $ \ (buf,len) ->
407     fdWriteBuf fd (castPtr buf) (fromIntegral len)
408
409 -- | Write data from memory to an 'Fd'.  This is exactly equivalent
410 -- to the POSIX @write@ function.
411 fdWriteBuf :: Fd
412            -> Ptr Word8    -- ^ Memory containing the data to write
413            -> ByteCount    -- ^ Maximum number of bytes to write
414            -> IO ByteCount -- ^ Number of bytes written
415 fdWriteBuf fd buf len =
416   fmap fromIntegral $
417     throwErrnoIfMinus1Retry "fdWriteBuf" $
418       c_safe_write (fromIntegral fd) (castPtr buf) len
419
420 foreign import ccall safe "write"
421    c_safe_write :: CInt -> Ptr CChar -> CSize -> IO CSsize