[project @ 2002-09-12 16:38:21 by simonmar]

More POSIX bits... we're getting there.

1 files changed, 327 insertions, 0 deletions

diff --git a/System/Posix/IO.hsc b/System/Posix/IO.hsc
new file mode 100644
index 0000000..f324841
--- /dev/null
+++ b/System/Posix/IO.hsc
@@ -0,0 +1,327 @@
+{-# OPTIONS -fffi #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  System.Posix.IO
+-- 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
+--
+-----------------------------------------------------------------------------
+
+module System.Posix.IO (
+    -- * Input \/ Output
+
+    -- ** Standard file descriptors
+    stdInput, stdOutput, stdError,
+
+    -- ** Opening and closing files
+    OpenMode(..),
+    OpenFileFlags(..), defaultFileFlags,
+    openFd, createFile,
+    closeFd,
+
+    -- ** Reading/writing data
+{-
+    fdRead, fdWrite,
+-}
+
+    -- ** 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 Control.Exception	( throw )
+
+import Foreign
+import Foreign.C
+import Data.Bits
+
+#ifdef __GLASGOW_HASKELL__
+import GHC.IOBase
+import GHC.Handle hiding (fdToHandle, openFd)
+import qualified GHC.Handle
+#endif
+
+#include <unistd.h>
+#include <fcntl.h>
+
+-- -----------------------------------------------------------------------------
+-- Pipes
+
+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 (rfd, wfd)
+
+foreign import ccall unsafe "pipe"
+  c_pipe :: Ptr Fd -> IO CInt
+
+-- -----------------------------------------------------------------------------
+-- Duplicating file descriptors
+
+dup :: Fd -> IO Fd
+dup fd = do r <- throwErrnoIfMinus1 "dup" (c_dup fd); return (Fd r)
+
+foreign import ccall unsafe "dup"
+  c_dup :: Fd -> IO CInt
+
+dupTo :: Fd -> Fd -> IO Fd
+dupTo fd1 fd2 = throwErrnoIfMinus1 "dupTp" (c_dup2 fd1 fd2)
+
+foreign import ccall unsafe "dup2"
+  c_dup2 :: Fd -> Fd -> IO Fd
+
+-- -----------------------------------------------------------------------------
+-- 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
+
+data OpenFileFlags =
+ OpenFileFlags {
+    append    :: Bool,
+    exclusive :: Bool,
+    noctty    :: Bool,
+    nonBlock  :: Bool,
+    trunc     :: Bool
+ }
+
+defaultFileFlags :: OpenFileFlags
+defaultFileFlags =
+ OpenFileFlags {
+    append    = False,
+    exclusive = False,
+    noctty    = False,
+    nonBlock  = False,
+    trunc     = False
+  }
+
+openFd :: FilePath
+       -> OpenMode
+       -> Maybe FileMode -- Just x => O_CREAT, Nothing => must exist
+       -> OpenFileFlags
+       -> IO Fd
+openFd name how maybe_mode (OpenFileFlags append exclusive noctty
+				nonBlock truncate) = do
+   withCString name $ \s -> do
+    fd <- throwErrnoIfMinus1 "openFd" (c_open s all_flags mode_w)
+    return (Fd fd)
+  where
+    all_flags  = creat .|. flags .|. open_mode
+
+    flags =
+       (if append    then (#const O_APPEND)   else 0) .|.
+       (if exclusive then (#const O_EXCL)     else 0) .|.
+       (if noctty    then (#const O_NOCTTY)   else 0) .|.
+       (if nonBlock  then (#const O_NONBLOCK) else 0) .|.
+       (if truncate  then (#const O_TRUNC)    else 0)
+
+    (creat, mode_w) = case maybe_mode 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 ccall unsafe "open"
+   c_open :: CString -> CInt -> CMode -> IO CInt
+
+createFile :: FilePath -> FileMode -> IO Fd
+createFile name mode
+  = openFd name WriteOnly (Just mode) defaultFileFlags{ trunc=True } 
+
+closeFd :: Fd -> IO ()
+closeFd (Fd fd) = throwErrnoIfMinus1_ "closeFd" (c_close fd)
+
+foreign import ccall unsafe "close"
+   c_close :: CInt -> IO CInt
+
+-- -----------------------------------------------------------------------------
+-- Converting file descriptors to/from Handles
+
+#ifdef __GLASGOW_HASKELL__
+handleToFd :: Handle -> IO Fd
+handleToFd h = withHandle "handleToFd" h $ \ h_ -> do
+  -- converting a Handle into an Fd effectively means
+  -- letting go of the Handle; it is put into a closed
+  -- state as a result. 
+  let fd = haFD h_
+  flushWriteBufferOnly h_
+  unlockFile (fromIntegral fd)
+    -- setting the Handle's fd to (-1) as well as its 'type'
+    -- to closed, is enough to disable the finalizer that
+    -- eventually is run on the Handle.
+  return (h_{haFD= (-1),haType=ClosedHandle}, Fd (fromIntegral fd))
+
+fdToHandle :: Fd -> IO Handle
+fdToHandle fd = GHC.Handle.fdToHandle (fromIntegral fd)
+#endif
+
+-- -----------------------------------------------------------------------------
+-- Fd options
+
+data FdOption = AppendOnWrite
+	      | CloseOnExec
+	      | NonBlockingRead
+	      | SynchronousWrites
+
+queryFdOption :: Fd -> FdOption -> IO Bool
+queryFdOption fd opt = do
+  r <- throwErrnoIfMinus1 "queryFdOption" (c_fcntl_read fd flag)
+  return ((r .&. opt_val) /= 0)
+ where
+  flag    = case opt of
+	      CloseOnExec       -> (#const F_GETFD)
+	      other		-> (#const F_GETFL)
+
+  opt_val = case opt of
+	      CloseOnExec       -> (#const FD_CLOEXEC)
+	      AppendOnWrite     -> (#const O_APPEND)
+              NonBlockingRead   -> (#const O_NONBLOCK)
+	      SynchronousWrites -> (#const O_SYNC)
+
+foreign import ccall unsafe "fcntl"
+   c_fcntl_read  :: Fd -> CInt -> IO CInt
+
+setFdOption :: Fd -> FdOption -> Bool -> IO ()
+setFdOption fd opt val = do
+  r <- throwErrnoIfMinus1 "setFdOption" (c_fcntl_read fd flag)
+  let r' | val       = r .|. opt_val
+	 | otherwise = r .&. (complement opt_val) 
+  throwErrnoIfMinus1_ "setFdOption" (c_fcntl_write fd flag r')
+ where
+  flag    = case opt of
+	      CloseOnExec       -> (#const F_GETFD)
+	      other		-> (#const F_GETFL)
+  opt_val = case opt of
+	      CloseOnExec       -> (#const FD_CLOEXEC)
+	      AppendOnWrite     -> (#const O_APPEND)
+              NonBlockingRead   -> (#const O_NONBLOCK)
+	      SynchronousWrites -> (#const O_SYNC)
+
+foreign import ccall unsafe "fcntl"
+   c_fcntl_write :: Fd -> CInt -> CInt -> IO CInt
+
+-- -----------------------------------------------------------------------------
+-- Seeking 
+
+mode2Int :: SeekMode -> CInt
+mode2Int AbsoluteSeek = (#const SEEK_SET)
+mode2Int RelativeSeek = (#const SEEK_CUR)
+mode2Int SeekFromEnd  = (#const SEEK_END)
+
+fdSeek :: Fd -> SeekMode -> FileOffset -> IO FileOffset
+fdSeek fd mode off =
+  throwErrnoIfMinus1 "fdSeek" (c_lseek fd off (mode2Int mode))
+
+foreign import ccall unsafe "lseek"
+  c_lseek :: Fd -> COff -> CInt -> IO COff
+
+-- -----------------------------------------------------------------------------
+-- Locking
+
+data LockRequest = ReadLock
+                 | WriteLock
+                 | Unlock
+
+type FileLock = (LockRequest, SeekMode, FileOffset, FileOffset)
+
+type CFLock = ()
+
+getLock :: Fd -> FileLock -> IO (Maybe (ProcessID, FileLock))
+getLock fd lock =
+  allocaLock lock $ \p_flock -> do
+    throwErrnoIfMinus1_ "getLock" (c_fcntl_flock fd (#const F_GETLK) p_flock)
+    result <- bytes2ProcessIDAndLock p_flock
+    return (maybeResult result)
+  where
+    maybeResult (_, (Unlock, _, _, _)) = Nothing
+    maybeResult x = Just x
+
+foreign import ccall unsafe "fcntl"
+  c_fcntl_flock :: Fd -> CInt -> Ptr CFLock -> IO CInt
+
+allocaLock :: FileLock -> (Ptr CFLock -> IO a) -> IO a
+allocaLock (lockreq, mode, start, len) io = 
+  allocaBytes (#const sizeof(struct flock)) $ \p -> do
+    (#poke struct flock, l_type)   p (lockReqToInt 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
+
+lockReqToInt :: LockRequest -> CShort
+lockReqToInt ReadLock  = (#const F_RDLCK)
+lockReqToInt WriteLock = (#const F_WRLCK)
+lockReqToInt Unlock    = (#const F_UNLCK)
+
+bytes2ProcessIDAndLock :: Ptr 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 _ = throw (mkIOError illegalOperationErrorType "int2req"
+			     Nothing Nothing)
+
+  int2mode :: CShort -> SeekMode
+  int2mode (#const SEEK_SET) = AbsoluteSeek
+  int2mode (#const SEEK_CUR) = RelativeSeek
+  int2mode (#const SEEK_END) = SeekFromEnd
+  int2mode _ = throw (mkIOError illegalOperationErrorType "int2mode"
+			     Nothing Nothing)
+
+setLock :: Fd -> FileLock -> IO ()
+setLock fd lock = do
+  allocaLock lock $ \p_flock ->
+    throwErrnoIfMinus1_ "setLock" (c_fcntl_flock fd (#const F_SETLK) p_flock)
+
+waitToSetLock :: Fd -> FileLock -> IO ()
+waitToSetLock fd lock = do
+  allocaLock lock $ \p_flock ->
+    throwErrnoIfMinus1_ "waitToSetLock" 
+	(c_fcntl_flock fd (#const F_SETLKW) p_flock)