Some some

unix/System/Posix/IO/ByteString.hsc

@@ -0,0 +1,92 @@
+#if __GLASGOW_HASKELL__ >= 709
+{-# LANGUAGE Safe #-}
+#else
+{-# LANGUAGE Trustworthy #-}
+#endif
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  System.Posix.IO.ByteString
+-- Copyright   :  (c) The University of Glasgow 2002
+-- License     :  BSD-style (see the file libraries/base/LICENSE)
+--
+-- Maintainer  :  libraries@haskell.org
+-- Stability   :  provisional
+-- Portability :  non-portable (requires POSIX)
+--
+-- POSIX IO support.  These types and functions correspond to the unix
+-- functions open(2), close(2), etc.  For more portable functions
+-- which are more like fopen(3) and friends from stdio.h, see
+-- "System.IO".
+--
+-----------------------------------------------------------------------------
+
+#include "HsUnix.h"
+
+module System.Posix.IO.ByteString (
+    -- * Input \/ Output
+
+    -- ** Standard file descriptors
+    stdInput, stdOutput, stdError,
+
+    -- ** Opening and closing files
+    OpenMode(..),
+    OpenFileFlags(..), defaultFileFlags,
+    openFd, createFile,
+    closeFd,
+
+    -- ** Reading\/writing data
+    -- |Programmers using the 'fdRead' and 'fdWrite' API should be aware that
+    -- EAGAIN exceptions may occur for non-blocking IO!
+
+    fdRead, fdWrite,
+    fdReadBuf, fdWriteBuf,
+
+    -- ** Seeking
+    fdSeek,
+
+    -- ** File options
+    FdOption(..),
+    queryFdOption,
+    setFdOption,
+
+    -- ** Locking
+    FileLock,
+    LockRequest(..),
+    getLock,  setLock,
+    waitToSetLock,
+
+    -- ** Pipes
+    createPipe,
+
+    -- ** Duplicating file descriptors
+    dup, dupTo,
+
+    -- ** Converting file descriptors to\/from Handles
+    handleToFd,
+    fdToHandle,
+
+  ) where
+
+import System.Posix.Types
+import System.Posix.IO.Common
+
+import System.Posix.ByteString.FilePath
+
+-- |Open and optionally create this file.  See 'System.Posix.Files'
+-- for information on how to use the 'FileMode' type.
+openFd :: RawFilePath
+       -> OpenMode
+       -> OpenFileFlags
+       -> IO Fd
+openFd name how flags =
+   withFilePath name $ \str ->
+     throwErrnoPathIfMinus1Retry "openFd" name $
+       open_ str how flags
+
+-- |Create and open this file in WriteOnly mode.  A special case of
+-- 'openFd'.  See 'System.Posix.Files' for information on how to use
+-- the 'FileMode' type.
+
+createFile :: RawFilePath -> FileMode -> IO Fd
+createFile name mode
+  = openFd name WriteOnly defaultFileFlags{ trunc=True, creat=(Just mode) }

unix/System/Posix/IO/Common.hsc

@@ -0,0 +1,443 @@
+{-# LANGUAGE CApiFFI #-}
+{-# LANGUAGE NondecreasingIndentation #-}
+{-# LANGUAGE RecordWildCards #-}
+#if __GLASGOW_HASKELL__ >= 709
+{-# LANGUAGE Safe #-}
+#else
+{-# LANGUAGE Trustworthy #-}
+#endif
+
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  System.Posix.IO.Common
+-- Copyright   :  (c) The University of Glasgow 2002
+-- License     :  BSD-style (see the file libraries/base/LICENSE)
+--
+-- Maintainer  :  libraries@haskell.org
+-- Stability   :  provisional
+-- Portability :  non-portable (requires POSIX)
+--
+-----------------------------------------------------------------------------
+
+module System.Posix.IO.Common (
+    -- * Input \/ Output
+
+    -- ** Standard file descriptors
+    stdInput, stdOutput, stdError,
+
+    -- ** Opening and closing files
+    OpenMode(..),
+    OpenFileFlags(..), defaultFileFlags,
+    open_,
+    closeFd,
+
+    -- ** Reading\/writing data
+    -- |Programmers using the 'fdRead' and 'fdWrite' API should be aware that
+    -- EAGAIN exceptions may occur for non-blocking IO!
+
+    fdRead, fdWrite,
+    fdReadBuf, fdWriteBuf,
+
+    -- ** Seeking
+    fdSeek,
+
+    -- ** File options
+    FdOption(..),
+    queryFdOption,
+    setFdOption,
+
+    -- ** Locking
+    FileLock,
+    LockRequest(..),
+    getLock,  setLock,
+    waitToSetLock,
+
+    -- ** Pipes
+    createPipe,
+
+    -- ** Duplicating file descriptors
+    dup, dupTo,
+
+    -- ** Converting file descriptors to\/from Handles
+    handleToFd,
+    fdToHandle,
+
+  ) where
+
+import System.IO
+import System.IO.Error
+import System.Posix.Types
+import qualified System.Posix.Internals as Base
+
+import Foreign
+import Foreign.C
+
+import GHC.IO.Handle.Internals
+import GHC.IO.Handle.Types
+import qualified GHC.IO.FD as FD
+import qualified GHC.IO.Handle.FD as FD
+import GHC.IO.Exception
+import Data.Typeable (cast)
+
+#include "HsUnix.h"
+
+-- -----------------------------------------------------------------------------
+-- Pipes
+-- |The 'createPipe' function creates a pair of connected file
+-- descriptors. The first component is the fd to read from, the second
+-- is the write end.  Although pipes may be bidirectional, this
+-- behaviour is not portable and programmers should use two separate
+-- pipes for this purpose.  May throw an exception if this is an
+-- invalid descriptor.
+
+createPipe :: IO (Fd, Fd)
+createPipe =
+  allocaArray 2 $ \p_fd -> do
+    throwErrnoIfMinus1_ "createPipe" (c_pipe p_fd)
+    rfd <- peekElemOff p_fd 0
+    wfd <- peekElemOff p_fd 1
+    return (Fd rfd, Fd wfd)
+
+foreign import ccall unsafe "pipe"
+   c_pipe :: Ptr CInt -> IO CInt
+
+-- -----------------------------------------------------------------------------
+-- Duplicating file descriptors
+
+-- | May throw an exception if this is an invalid descriptor.
+dup :: Fd -> IO Fd
+dup (Fd fd) = do r <- throwErrnoIfMinus1 "dup" (c_dup fd); return (Fd r)
+
+-- | May throw an exception if this is an invalid descriptor.
+dupTo :: Fd -> Fd -> IO Fd
+dupTo (Fd fd1) (Fd fd2) = do
+  r <- throwErrnoIfMinus1 "dupTo" (c_dup2 fd1 fd2)
+  return (Fd r)
+
+foreign import ccall unsafe "dup"
+   c_dup :: CInt -> IO CInt
+
+foreign import ccall unsafe "dup2"
+   c_dup2 :: CInt -> CInt -> IO CInt
+
+-- -----------------------------------------------------------------------------
+-- Opening and closing files
+
+stdInput, stdOutput, stdError :: Fd
+stdInput   = Fd (#const STDIN_FILENO)
+stdOutput  = Fd (#const STDOUT_FILENO)
+stdError   = Fd (#const STDERR_FILENO)
+
+data OpenMode = ReadOnly | WriteOnly | ReadWrite
+              deriving (Read, Show, Eq, Ord)
+
+-- |Correspond to some of the int flags from C's fcntl.h.
+data OpenFileFlags =
+ OpenFileFlags {
+    append    :: Bool,           -- ^ O_APPEND
+    exclusive :: Bool,           -- ^ O_EXCL
+                                 --
+                                 -- __NOTE__: Result is undefined if 'creat' is 'Nothing'.
+    noctty    :: Bool,           -- ^ O_NOCTTY
+    nonBlock  :: Bool,           -- ^ O_NONBLOCK
+    trunc     :: Bool,           -- ^ O_TRUNC
+    nofollow  :: Bool,           -- ^ O_NOFOLLOW
+                                 --
+                                 -- @since 2.8.0.0
+    creat     :: Maybe FileMode, -- ^ O_CREAT
+                                 --
+                                 -- @since 2.8.0.0
+    cloexec   :: Bool,           -- ^ O_CLOEXEC
+                                 --
+                                 -- @since 2.8.0.0
+    directory :: Bool,           -- ^ O_DIRECTORY
+                                 --
+                                 -- @since 2.8.0.0
+    sync      :: Bool            -- ^ O_SYNC
+                                 --
+                                 -- @since 2.8.0.0
+ }
+ deriving (Read, Show, Eq, Ord)
+
+
+-- | Default values for the 'OpenFileFlags' type.
+--
+-- Each field of 'OpenFileFlags' is either 'False' or 'Nothing'
+-- respectively.
+defaultFileFlags :: OpenFileFlags
+defaultFileFlags =
+ OpenFileFlags {
+    append    = False,
+    exclusive = False,
+    noctty    = False,
+    nonBlock  = False,
+    trunc     = False,
+    nofollow  = False,
+    creat     = Nothing,
+    cloexec   = False,
+    directory = False,
+    sync      = False
+  }
+
+
+-- |Open and optionally create this file.  See 'System.Posix.Files'
+-- for information on how to use the 'FileMode' type.
+open_  :: CString
+       -> OpenMode
+       -> OpenFileFlags
+       -> IO Fd
+open_ str how (OpenFileFlags appendFlag exclusiveFlag nocttyFlag
+                                nonBlockFlag truncateFlag nofollowFlag
+                                creatFlag cloexecFlag directoryFlag
+                                syncFlag) = do
+    fd <- c_open str all_flags mode_w
+    return (Fd fd)
+  where
+    all_flags  = creat .|. flags .|. open_mode
+
+    flags =
+       (if appendFlag       then (#const O_APPEND)    else 0) .|.
+       (if exclusiveFlag    then (#const O_EXCL)      else 0) .|.
+       (if nocttyFlag       then (#const O_NOCTTY)    else 0) .|.
+       (if nonBlockFlag     then (#const O_NONBLOCK)  else 0) .|.
+       (if truncateFlag     then (#const O_TRUNC)     else 0) .|.
+       (if nofollowFlag     then (#const O_NOFOLLOW)  else 0) .|.
+       (if cloexecFlag      then (#const O_CLOEXEC)   else 0) .|.
+       (if directoryFlag    then (#const O_DIRECTORY) else 0) .|.
+       (if syncFlag         then (#const O_SYNC)      else 0)
+
+    (creat, mode_w) = case creatFlag of
+                        Nothing -> (0,0)
+                        Just x  -> ((#const O_CREAT), x)
+
+    open_mode = case how of
+                   ReadOnly  -> (#const O_RDONLY)
+                   WriteOnly -> (#const O_WRONLY)
+                   ReadWrite -> (#const O_RDWR)
+
+foreign import capi unsafe "HsUnix.h open"
+   c_open :: CString -> CInt -> CMode -> IO CInt
+
+-- |Close this file descriptor.  May throw an exception if this is an
+-- invalid descriptor.
+
+closeFd :: Fd -> IO ()
+closeFd (Fd fd) = throwErrnoIfMinus1_ "closeFd" (c_close fd)
+-- Here we don't to retry on EINTR because according to
+--  http://pubs.opengroup.org/onlinepubs/9699919799/functions/close.html
+-- "with errno set to [EINTR] [...] the state of fildes is unspecified"
+-- and on Linux, already the first close() removes the FD from the process's
+-- FD table so closing a second time is invalid
+-- (see http://man7.org/linux/man-pages/man2/close.2.html#NOTES).
+
+foreign import ccall unsafe "HsUnix.h close"
+   c_close :: CInt -> IO CInt
+
+-- -----------------------------------------------------------------------------
+-- Converting file descriptors to/from Handles
+
+-- | Extracts the 'Fd' from a 'Handle'.  This function has the side effect
+-- of closing the 'Handle' and flushing its write buffer, if necessary.
+handleToFd :: Handle -> IO Fd
+
+-- | Converts an 'Fd' into a 'Handle' that can be used with the
+-- standard Haskell IO library (see "System.IO").
+fdToHandle :: Fd -> IO Handle
+fdToHandle fd = FD.fdToHandle (fromIntegral fd)
+
+handleToFd h@(FileHandle _ m) = do
+  withHandle' "handleToFd" h m $ handleToFd' h
+handleToFd h@(DuplexHandle _ r w) = do
+  _ <- withHandle' "handleToFd" h r $ handleToFd' h
+  withHandle' "handleToFd" h w $ handleToFd' h
+  -- for a DuplexHandle, make sure we mark both sides as closed,
+  -- otherwise a finalizer will come along later and close the other
+  -- side. (#3914)
+
+handleToFd' :: Handle -> Handle__ -> IO (Handle__, Fd)
+handleToFd' h h_@Handle__{haType=_,..} = do
+  case cast haDevice of
+    Nothing -> ioError (ioeSetErrorString (mkIOError IllegalOperation
+                                           "handleToFd" (Just h) Nothing)
+                        "handle is not a file descriptor")
+    Just fd -> do
+     -- converting a Handle into an Fd effectively means
+     -- letting go of the Handle; it is put into a closed
+     -- state as a result.
+     flushWriteBuffer h_
+     FD.release fd
+     return (Handle__{haType=ClosedHandle,..}, Fd (FD.fdFD fd))
+
+
+-- -----------------------------------------------------------------------------
+-- Fd options
+
+data FdOption = AppendOnWrite     -- ^O_APPEND
+              | CloseOnExec       -- ^FD_CLOEXEC
+              | NonBlockingRead   -- ^O_NONBLOCK
+              | SynchronousWrites -- ^O_SYNC
+
+fdOption2Int :: FdOption -> CInt
+fdOption2Int CloseOnExec       = (#const FD_CLOEXEC)
+fdOption2Int AppendOnWrite     = (#const O_APPEND)
+fdOption2Int NonBlockingRead   = (#const O_NONBLOCK)
+fdOption2Int SynchronousWrites = (#const O_SYNC)
+
+-- | May throw an exception if this is an invalid descriptor.
+queryFdOption :: Fd -> FdOption -> IO Bool
+queryFdOption (Fd fd) opt = do
+  r <- throwErrnoIfMinus1 "queryFdOption" (Base.c_fcntl_read fd flag)
+  return ((r .&. fdOption2Int opt) /= 0)
+ where
+  flag    = case opt of
+              CloseOnExec       -> (#const F_GETFD)
+              _                 -> (#const F_GETFL)
+
+-- | May throw an exception if this is an invalid descriptor.
+setFdOption :: Fd -> FdOption -> Bool -> IO ()
+setFdOption (Fd fd) opt val = do
+  r <- throwErrnoIfMinus1 "setFdOption" (Base.c_fcntl_read fd getflag)
+  let r' | val       = r .|. opt_val
+         | otherwise = r .&. (complement opt_val)
+  throwErrnoIfMinus1_ "setFdOption"
+                      (Base.c_fcntl_write fd setflag (fromIntegral r'))
+ where
+  (getflag,setflag)= case opt of
+              CloseOnExec       -> ((#const F_GETFD),(#const F_SETFD))
+              _                 -> ((#const F_GETFL),(#const F_SETFL))
+  opt_val = fdOption2Int opt
+
+-- -----------------------------------------------------------------------------
+-- Seeking
+
+mode2Int :: SeekMode -> CInt
+mode2Int AbsoluteSeek = (#const SEEK_SET)
+mode2Int RelativeSeek = (#const SEEK_CUR)
+mode2Int SeekFromEnd  = (#const SEEK_END)
+
+-- | May throw an exception if this is an invalid descriptor.
+fdSeek :: Fd -> SeekMode -> FileOffset -> IO FileOffset
+fdSeek (Fd fd) mode off =
+  throwErrnoIfMinus1 "fdSeek" (Base.c_lseek fd off (mode2Int mode))
+
+-- -----------------------------------------------------------------------------
+-- Locking
+
+data LockRequest = ReadLock
+                 | WriteLock
+                 | Unlock
+
+type FileLock = (LockRequest, SeekMode, FileOffset, FileOffset)
+
+-- | May throw an exception if this is an invalid descriptor.
+getLock :: Fd -> FileLock -> IO (Maybe (ProcessID, FileLock))
+getLock (Fd fd) lock =
+  allocaLock lock $ \p_flock -> do
+    throwErrnoIfMinus1_ "getLock" (Base.c_fcntl_lock fd (#const F_GETLK) p_flock)
+    result <- bytes2ProcessIDAndLock p_flock
+    return (maybeResult result)
+  where
+    maybeResult (_, (Unlock, _, _, _)) = Nothing
+    maybeResult x = Just x
+
+allocaLock :: FileLock -> (Ptr Base.CFLock -> IO a) -> IO a
+allocaLock (lockreq, mode, start, len) io =
+  allocaBytes (#const sizeof(struct flock)) $ \p -> do
+    (#poke struct flock, l_type)   p (lockReq2Int lockreq :: CShort)
+    (#poke struct flock, l_whence) p (fromIntegral (mode2Int mode) :: CShort)
+    (#poke struct flock, l_start)  p start
+    (#poke struct flock, l_len)    p len
+    io p
+
+lockReq2Int :: LockRequest -> CShort
+lockReq2Int ReadLock  = (#const F_RDLCK)
+lockReq2Int WriteLock = (#const F_WRLCK)
+lockReq2Int Unlock    = (#const F_UNLCK)
+
+bytes2ProcessIDAndLock :: Ptr Base.CFLock -> IO (ProcessID, FileLock)
+bytes2ProcessIDAndLock p = do
+  req   <- (#peek struct flock, l_type)   p
+  mode  <- (#peek struct flock, l_whence) p
+  start <- (#peek struct flock, l_start)  p
+  len   <- (#peek struct flock, l_len)    p
+  pid   <- (#peek struct flock, l_pid)    p
+  return (pid, (int2req req, int2mode mode, start, len))
+ where
+  int2req :: CShort -> LockRequest
+  int2req (#const F_RDLCK) = ReadLock
+  int2req (#const F_WRLCK) = WriteLock
+  int2req (#const F_UNLCK) = Unlock
+  int2req _ = error $ "int2req: bad argument"
+
+  int2mode :: CShort -> SeekMode
+  int2mode (#const SEEK_SET) = AbsoluteSeek
+  int2mode (#const SEEK_CUR) = RelativeSeek
+  int2mode (#const SEEK_END) = SeekFromEnd
+  int2mode _ = error $ "int2mode: bad argument"
+
+-- | May throw an exception if this is an invalid descriptor.
+setLock :: Fd -> FileLock -> IO ()
+setLock (Fd fd) lock = do
+  allocaLock lock $ \p_flock ->
+    throwErrnoIfMinus1_ "setLock" (Base.c_fcntl_lock fd (#const F_SETLK) p_flock)
+
+-- | May throw an exception if this is an invalid descriptor.
+waitToSetLock :: Fd -> FileLock -> IO ()
+waitToSetLock (Fd fd) lock = do
+  allocaLock lock $ \p_flock ->
+    throwErrnoIfMinus1_ "waitToSetLock"
+        (Base.c_fcntl_lock fd (#const F_SETLKW) p_flock)
+
+-- -----------------------------------------------------------------------------
+-- fd{Read,Write}
+
+-- | Read data from an 'Fd' and convert it to a 'String' using the locale encoding.
+-- Throws an exception if this is an invalid descriptor, or EOF has been
+-- reached.
+fdRead :: Fd
+       -> ByteCount -- ^How many bytes to read
+       -> IO (String, ByteCount) -- ^The bytes read, how many bytes were read.
+fdRead _fd 0 = return ("", 0)
+fdRead fd nbytes = do
+    allocaBytes (fromIntegral nbytes) $ \ buf -> do
+    rc <- fdReadBuf fd buf nbytes
+    case rc of
+      0 -> ioError (ioeSetErrorString (mkIOError EOF "fdRead" Nothing Nothing) "EOF")
+      n -> do
+       s <- peekCStringLen (castPtr buf, fromIntegral n)
+       return (s, n)
+
+-- | Read data from an 'Fd' into memory.  This is exactly equivalent
+-- to the POSIX @read@ function.
+fdReadBuf :: Fd
+          -> Ptr Word8 -- ^ Memory in which to put the data
+          -> ByteCount -- ^ Maximum number of bytes to read
+          -> IO ByteCount -- ^ Number of bytes read (zero for EOF)
+fdReadBuf _fd _buf 0 = return 0
+fdReadBuf fd buf nbytes =
+  fmap fromIntegral $
+    throwErrnoIfMinus1Retry "fdReadBuf" $
+      c_safe_read (fromIntegral fd) (castPtr buf) nbytes
+
+foreign import ccall safe "read"
+   c_safe_read :: CInt -> Ptr CChar -> CSize -> IO CSsize
+
+-- | Write a 'String' to an 'Fd' using the locale encoding.
+fdWrite :: Fd -> String -> IO ByteCount
+fdWrite fd str =
+  withCStringLen str $ \ (buf,len) ->
+    fdWriteBuf fd (castPtr buf) (fromIntegral len)
+
+-- | Write data from memory to an 'Fd'.  This is exactly equivalent
+-- to the POSIX @write@ function.
+fdWriteBuf :: Fd
+           -> Ptr Word8    -- ^ Memory containing the data to write
+           -> ByteCount    -- ^ Maximum number of bytes to write
+           -> IO ByteCount -- ^ Number of bytes written
+fdWriteBuf fd buf len =
+  fmap fromIntegral $
+    throwErrnoIfMinus1Retry "fdWriteBuf" $
+      c_safe_write (fromIntegral fd) (castPtr buf) len
+
+foreign import ccall safe "write"
+   c_safe_write :: CInt -> Ptr CChar -> CSize -> IO CSsize