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
22module 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
67import System.IO
68import System.IO.Error
69import System.Posix.Types
70import qualified System.Posix.Internals as Base
71
72import Foreign
73import Foreign.C
74
75import GHC.IO.Handle.Internals
76import GHC.IO.Handle.Types
77import qualified GHC.IO.FD as FD
78import qualified GHC.IO.Handle.FD as FD
79import GHC.IO.Exception
80import 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
93createPipe :: IO (Fd, Fd)
94createPipe =
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
101foreign 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.
108dup :: Fd -> IO Fd
109dup (Fd fd) = do r <- throwErrnoIfMinus1 "dup" (c_dup fd); return (Fd r)
110
111-- | May throw an exception if this is an invalid descriptor.
112dupTo :: Fd -> Fd -> IO Fd
113dupTo (Fd fd1) (Fd fd2) = do
114  r <- throwErrnoIfMinus1 "dupTo" (c_dup2 fd1 fd2)
115  return (Fd r)
116
117foreign import ccall unsafe "dup"
118   c_dup :: CInt -> IO CInt
119
120foreign import ccall unsafe "dup2"
121   c_dup2 :: CInt -> CInt -> IO CInt
122
123-- -----------------------------------------------------------------------------
124-- Opening and closing files
125
126stdInput, stdOutput, stdError :: Fd
127stdInput   = Fd (#const STDIN_FILENO)
128stdOutput  = Fd (#const STDOUT_FILENO)
129stdError   = Fd (#const STDERR_FILENO)
130
131data OpenMode = ReadOnly | WriteOnly | ReadWrite
132
133-- |Correspond to some of the int flags from C's fcntl.h.
134data OpenFileFlags =
135 OpenFileFlags {
136    append    :: Bool, -- ^ O_APPEND
137    exclusive :: Bool, -- ^ O_EXCL
138    noctty    :: Bool, -- ^ O_NOCTTY
139    nonBlock  :: Bool, -- ^ O_NONBLOCK
140    trunc     :: Bool  -- ^ O_TRUNC
141 }
142
143
144-- |Default values for the 'OpenFileFlags' type. False for each of
145-- append, exclusive, noctty, nonBlock, and trunc.
146defaultFileFlags :: OpenFileFlags
147defaultFileFlags =
148 OpenFileFlags {
149    append    = False,
150    exclusive = False,
151    noctty    = False,
152    nonBlock  = False,
153    trunc     = False
154  }
155
156
157-- |Open and optionally create this file.  See 'System.Posix.Files'
158-- for information on how to use the 'FileMode' type.
159open_  :: CString
160       -> OpenMode
161       -> Maybe FileMode -- ^Just x => creates the file with the given modes, Nothing => the file must exist.
162       -> OpenFileFlags
163       -> IO Fd
164open_ str how maybe_mode (OpenFileFlags appendFlag exclusiveFlag nocttyFlag
165                                nonBlockFlag truncateFlag) = do
166    fd <- c_open str all_flags mode_w
167    return (Fd fd)
168  where
169    all_flags  = creat .|. flags .|. open_mode
170
171    flags =
172       (if appendFlag    then (#const O_APPEND)   else 0) .|.
173       (if exclusiveFlag then (#const O_EXCL)     else 0) .|.
174       (if nocttyFlag    then (#const O_NOCTTY)   else 0) .|.
175       (if nonBlockFlag  then (#const O_NONBLOCK) else 0) .|.
176       (if truncateFlag  then (#const O_TRUNC)    else 0)
177
178    (creat, mode_w) = case maybe_mode of
179                        Nothing -> (0,0)
180                        Just x  -> ((#const O_CREAT), x)
181
182    open_mode = case how of
183                   ReadOnly  -> (#const O_RDONLY)
184                   WriteOnly -> (#const O_WRONLY)
185                   ReadWrite -> (#const O_RDWR)
186
187foreign import capi unsafe "HsUnix.h open"
188   c_open :: CString -> CInt -> CMode -> IO CInt
189
190-- |Close this file descriptor.  May throw an exception if this is an
191-- invalid descriptor.
192
193closeFd :: Fd -> IO ()
194closeFd (Fd fd) = throwErrnoIfMinus1_ "closeFd" (c_close fd)
195
196foreign import ccall unsafe "HsUnix.h close"
197   c_close :: CInt -> IO CInt
198
199-- -----------------------------------------------------------------------------
200-- Converting file descriptors to/from Handles
201
202-- | Extracts the 'Fd' from a 'Handle'.  This function has the side effect
203-- of closing the 'Handle' and flushing its write buffer, if necessary.
204handleToFd :: Handle -> IO Fd
205
206-- | Converts an 'Fd' into a 'Handle' that can be used with the
207-- standard Haskell IO library (see "System.IO").
208fdToHandle :: Fd -> IO Handle
209fdToHandle fd = FD.fdToHandle (fromIntegral fd)
210
211handleToFd h@(FileHandle _ m) = do
212  withHandle' "handleToFd" h m $ handleToFd' h
213handleToFd h@(DuplexHandle _ r w) = do
214  _ <- withHandle' "handleToFd" h r $ handleToFd' h
215  withHandle' "handleToFd" h w $ handleToFd' h
216  -- for a DuplexHandle, make sure we mark both sides as closed,
217  -- otherwise a finalizer will come along later and close the other
218  -- side. (#3914)
219
220handleToFd' :: Handle -> Handle__ -> IO (Handle__, Fd)
221handleToFd' h h_@Handle__{haType=_,..} = do
222  case cast haDevice of
223    Nothing -> ioError (ioeSetErrorString (mkIOError IllegalOperation
224                                           "handleToFd" (Just h) Nothing)
225                        "handle is not a file descriptor")
226    Just fd -> do
227     -- converting a Handle into an Fd effectively means
228     -- letting go of the Handle; it is put into a closed
229     -- state as a result.
230     flushWriteBuffer h_
231     FD.release fd
232     return (Handle__{haType=ClosedHandle,..}, Fd (FD.fdFD fd))
233
234
235-- -----------------------------------------------------------------------------
236-- Fd options
237
238data FdOption = AppendOnWrite     -- ^O_APPEND
239              | CloseOnExec       -- ^FD_CLOEXEC
240              | NonBlockingRead   -- ^O_NONBLOCK
241              | SynchronousWrites -- ^O_SYNC
242
243fdOption2Int :: FdOption -> CInt
244fdOption2Int CloseOnExec       = (#const FD_CLOEXEC)
245fdOption2Int AppendOnWrite     = (#const O_APPEND)
246fdOption2Int NonBlockingRead   = (#const O_NONBLOCK)
247fdOption2Int SynchronousWrites = (#const O_SYNC)
248
249-- | May throw an exception if this is an invalid descriptor.
250queryFdOption :: Fd -> FdOption -> IO Bool
251queryFdOption (Fd fd) opt = do
252  r <- throwErrnoIfMinus1 "queryFdOption" (Base.c_fcntl_read fd flag)
253  return ((r .&. fdOption2Int opt) /= 0)
254 where
255  flag    = case opt of
256              CloseOnExec       -> (#const F_GETFD)
257              _                 -> (#const F_GETFL)
258
259-- | May throw an exception if this is an invalid descriptor.
260setFdOption :: Fd -> FdOption -> Bool -> IO ()
261setFdOption (Fd fd) opt val = do
262  r <- throwErrnoIfMinus1 "setFdOption" (Base.c_fcntl_read fd getflag)
263  let r' | val       = r .|. opt_val
264         | otherwise = r .&. (complement opt_val)
265  throwErrnoIfMinus1_ "setFdOption"
266                      (Base.c_fcntl_write fd setflag (fromIntegral r'))
267 where
268  (getflag,setflag)= case opt of
269              CloseOnExec       -> ((#const F_GETFD),(#const F_SETFD))
270              _                 -> ((#const F_GETFL),(#const F_SETFL))
271  opt_val = fdOption2Int opt
272
273-- -----------------------------------------------------------------------------
274-- Seeking
275
276mode2Int :: SeekMode -> CInt
277mode2Int AbsoluteSeek = (#const SEEK_SET)
278mode2Int RelativeSeek = (#const SEEK_CUR)
279mode2Int SeekFromEnd  = (#const SEEK_END)
280
281-- | May throw an exception if this is an invalid descriptor.
282fdSeek :: Fd -> SeekMode -> FileOffset -> IO FileOffset
283fdSeek (Fd fd) mode off =
284  throwErrnoIfMinus1 "fdSeek" (Base.c_lseek fd off (mode2Int mode))
285
286-- -----------------------------------------------------------------------------
287-- Locking
288
289data LockRequest = ReadLock
290                 | WriteLock
291                 | Unlock
292
293type FileLock = (LockRequest, SeekMode, FileOffset, FileOffset)
294
295-- | May throw an exception if this is an invalid descriptor.
296getLock :: Fd -> FileLock -> IO (Maybe (ProcessID, FileLock))
297getLock (Fd fd) lock =
298  allocaLock lock $ \p_flock -> do
299    throwErrnoIfMinus1_ "getLock" (Base.c_fcntl_lock fd (#const F_GETLK) p_flock)
300    result <- bytes2ProcessIDAndLock p_flock
301    return (maybeResult result)
302  where
303    maybeResult (_, (Unlock, _, _, _)) = Nothing
304    maybeResult x = Just x
305
306allocaLock :: FileLock -> (Ptr Base.CFLock -> IO a) -> IO a
307allocaLock (lockreq, mode, start, len) io =
308  allocaBytes (#const sizeof(struct flock)) $ \p -> do
309    (#poke struct flock, l_type)   p (lockReq2Int lockreq :: CShort)
310    (#poke struct flock, l_whence) p (fromIntegral (mode2Int mode) :: CShort)
311    (#poke struct flock, l_start)  p start
312    (#poke struct flock, l_len)    p len
313    io p
314
315lockReq2Int :: LockRequest -> CShort
316lockReq2Int ReadLock  = (#const F_RDLCK)
317lockReq2Int WriteLock = (#const F_WRLCK)
318lockReq2Int Unlock    = (#const F_UNLCK)
319
320bytes2ProcessIDAndLock :: Ptr Base.CFLock -> IO (ProcessID, FileLock)
321bytes2ProcessIDAndLock p = do
322  req   <- (#peek struct flock, l_type)   p
323  mode  <- (#peek struct flock, l_whence) p
324  start <- (#peek struct flock, l_start)  p
325  len   <- (#peek struct flock, l_len)    p
326  pid   <- (#peek struct flock, l_pid)    p
327  return (pid, (int2req req, int2mode mode, start, len))
328 where
329  int2req :: CShort -> LockRequest
330  int2req (#const F_RDLCK) = ReadLock
331  int2req (#const F_WRLCK) = WriteLock
332  int2req (#const F_UNLCK) = Unlock
333  int2req _ = error $ "int2req: bad argument"
334
335  int2mode :: CShort -> SeekMode
336  int2mode (#const SEEK_SET) = AbsoluteSeek
337  int2mode (#const SEEK_CUR) = RelativeSeek
338  int2mode (#const SEEK_END) = SeekFromEnd
339  int2mode _ = error $ "int2mode: bad argument"
340
341-- | May throw an exception if this is an invalid descriptor.
342setLock :: Fd -> FileLock -> IO ()
343setLock (Fd fd) lock = do
344  allocaLock lock $ \p_flock ->
345    throwErrnoIfMinus1_ "setLock" (Base.c_fcntl_lock fd (#const F_SETLK) p_flock)
346
347-- | May throw an exception if this is an invalid descriptor.
348waitToSetLock :: Fd -> FileLock -> IO ()
349waitToSetLock (Fd fd) lock = do
350  allocaLock lock $ \p_flock ->
351    throwErrnoIfMinus1_ "waitToSetLock"
352        (Base.c_fcntl_lock fd (#const F_SETLKW) p_flock)
353
354-- -----------------------------------------------------------------------------
355-- fd{Read,Write}
356
357-- | Read data from an 'Fd' and convert it to a 'String' using the locale encoding.
358-- Throws an exception if this is an invalid descriptor, or EOF has been
359-- reached.
360fdRead :: Fd
361       -> ByteCount -- ^How many bytes to read
362       -> IO (String, ByteCount) -- ^The bytes read, how many bytes were read.
363fdRead _fd 0 = return ("", 0)
364fdRead fd nbytes = do
365    allocaBytes (fromIntegral nbytes) $ \ buf -> do
366    rc <- fdReadBuf fd buf nbytes
367    case rc of
368      0 -> ioError (ioeSetErrorString (mkIOError EOF "fdRead" Nothing Nothing) "EOF")
369      n -> do
370       s <- peekCStringLen (castPtr buf, fromIntegral n)
371       return (s, n)
372
373-- | Read data from an 'Fd' into memory.  This is exactly equivalent
374-- to the POSIX @read@ function.
375fdReadBuf :: Fd
376          -> Ptr Word8 -- ^ Memory in which to put the data
377          -> ByteCount -- ^ Maximum number of bytes to read
378          -> IO ByteCount -- ^ Number of bytes read (zero for EOF)
379fdReadBuf _fd _buf 0 = return 0
380fdReadBuf fd buf nbytes =
381  fmap fromIntegral $
382    throwErrnoIfMinus1Retry "fdReadBuf" $
383      c_safe_read (fromIntegral fd) (castPtr buf) nbytes
384
385foreign import ccall safe "read"
386   c_safe_read :: CInt -> Ptr CChar -> CSize -> IO CSsize
387
388-- | Write a 'String' to an 'Fd' using the locale encoding.
389fdWrite :: Fd -> String -> IO ByteCount
390fdWrite fd str =
391  withCStringLen str $ \ (buf,len) ->
392    fdWriteBuf fd (castPtr buf) (fromIntegral len)
393
394-- | Write data from memory to an 'Fd'.  This is exactly equivalent
395-- to the POSIX @write@ function.
396fdWriteBuf :: Fd
397           -> Ptr Word8    -- ^ Memory containing the data to write
398           -> ByteCount    -- ^ Maximum number of bytes to write
399           -> IO ByteCount -- ^ Number of bytes written
400fdWriteBuf fd buf len =
401  fmap fromIntegral $
402    throwErrnoIfMinus1Retry "fdWriteBuf" $
403      c_safe_write (fromIntegral fd) (castPtr buf) len
404
405foreign import ccall safe "write"
406   c_safe_write :: CInt -> Ptr CChar -> CSize -> IO CSsize
407