module System.Posix.IO.Common (
stdInput, stdOutput, stdError,
OpenMode(..),
OpenFileFlags(..), defaultFileFlags,
open_,
closeFd,
fdRead, fdWrite,
fdReadBuf, fdWriteBuf,
fdSeek,
FdOption(..),
queryFdOption,
setFdOption,
FileLock,
LockRequest(..),
getLock, setLock,
waitToSetLock,
createPipe,
dup, dupTo,
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)
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
dup :: Fd -> IO Fd
dup (Fd fd) = do r <- throwErrnoIfMinus1 "dup" (c_dup fd); return (Fd r)
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
stdInput, stdOutput, stdError :: Fd
stdInput = Fd (0)
stdOutput = Fd (1)
stdError = Fd (2)
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
}
open_ :: CString
-> OpenMode
-> Maybe FileMode
-> OpenFileFlags
-> IO Fd
open_ str how maybe_mode (OpenFileFlags appendFlag exclusiveFlag nocttyFlag
nonBlockFlag truncateFlag) = do
fd <- c_open str all_flags mode_w
return (Fd fd)
where
all_flags = creat .|. flags .|. open_mode
flags =
(if appendFlag then (1024) else 0) .|.
(if exclusiveFlag then (128) else 0) .|.
(if nocttyFlag then (256) else 0) .|.
(if nonBlockFlag then (2048) else 0) .|.
(if truncateFlag then (512) else 0)
(creat, mode_w) = case maybe_mode of
Nothing -> (0,0)
Just x -> ((64), x)
open_mode = case how of
ReadOnly -> (0)
WriteOnly -> (1)
ReadWrite -> (2)
foreign import capi unsafe "HsUnix.h open"
c_open :: CString -> CInt -> CMode -> IO CInt
closeFd :: Fd -> IO ()
closeFd (Fd fd) = throwErrnoIfMinus1_ "closeFd" (c_close fd)
foreign import ccall unsafe "HsUnix.h close"
c_close :: CInt -> IO CInt
handleToFd :: Handle -> IO Fd
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
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
flushWriteBuffer h_
FD.release fd
return (Handle__{haType=ClosedHandle,..}, Fd (FD.fdFD fd))
data FdOption = AppendOnWrite
| CloseOnExec
| NonBlockingRead
| SynchronousWrites
fdOption2Int :: FdOption -> CInt
fdOption2Int CloseOnExec = (1)
fdOption2Int AppendOnWrite = (1024)
fdOption2Int NonBlockingRead = (2048)
fdOption2Int SynchronousWrites = (1052672)
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 -> (1)
_ -> (3)
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 -> ((1),(2))
_ -> ((3),(4))
opt_val = fdOption2Int opt
mode2Int :: SeekMode -> CInt
mode2Int AbsoluteSeek = (0)
mode2Int RelativeSeek = (1)
mode2Int SeekFromEnd = (2)
fdSeek :: Fd -> SeekMode -> FileOffset -> IO FileOffset
fdSeek (Fd fd) mode off =
throwErrnoIfMinus1 "fdSeek" (Base.c_lseek fd off (mode2Int mode))
data LockRequest = ReadLock
| WriteLock
| Unlock
type FileLock = (LockRequest, SeekMode, FileOffset, FileOffset)
getLock :: Fd -> FileLock -> IO (Maybe (ProcessID, FileLock))
getLock (Fd fd) lock =
allocaLock lock $ \p_flock -> do
throwErrnoIfMinus1_ "getLock" (Base.c_fcntl_lock fd (5) 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 (32) $ \p -> do
((\hsc_ptr -> pokeByteOff hsc_ptr 0)) p (lockReq2Int lockreq :: CShort)
((\hsc_ptr -> pokeByteOff hsc_ptr 2)) p (fromIntegral (mode2Int mode) :: CShort)
((\hsc_ptr -> pokeByteOff hsc_ptr 8)) p start
((\hsc_ptr -> pokeByteOff hsc_ptr 16)) p len
io p
lockReq2Int :: LockRequest -> CShort
lockReq2Int ReadLock = (0)
lockReq2Int WriteLock = (1)
lockReq2Int Unlock = (2)
bytes2ProcessIDAndLock :: Ptr Base.CFLock -> IO (ProcessID, FileLock)
bytes2ProcessIDAndLock p = do
req <- ((\hsc_ptr -> peekByteOff hsc_ptr 0)) p
mode <- ((\hsc_ptr -> peekByteOff hsc_ptr 2)) p
start <- ((\hsc_ptr -> peekByteOff hsc_ptr 8)) p
len <- ((\hsc_ptr -> peekByteOff hsc_ptr 16)) p
pid <- ((\hsc_ptr -> peekByteOff hsc_ptr 24)) p
return (pid, (int2req req, int2mode mode, start, len))
where
int2req :: CShort -> LockRequest
int2req (0) = ReadLock
int2req (1) = WriteLock
int2req (2) = Unlock
int2req _ = error $ "int2req: bad argument"
int2mode :: CShort -> SeekMode
int2mode (0) = AbsoluteSeek
int2mode (1) = RelativeSeek
int2mode (2) = SeekFromEnd
int2mode _ = error $ "int2mode: bad argument"
setLock :: Fd -> FileLock -> IO ()
setLock (Fd fd) lock = do
allocaLock lock $ \p_flock ->
throwErrnoIfMinus1_ "setLock" (Base.c_fcntl_lock fd (6) p_flock)
waitToSetLock :: Fd -> FileLock -> IO ()
waitToSetLock (Fd fd) lock = do
allocaLock lock $ \p_flock ->
throwErrnoIfMinus1_ "waitToSetLock"
(Base.c_fcntl_lock fd (7) p_flock)
fdRead :: Fd
-> ByteCount
-> IO (String, ByteCount)
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)
fdReadBuf :: Fd
-> Ptr Word8
-> ByteCount
-> IO ByteCount
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
fdWrite :: Fd -> String -> IO ByteCount
fdWrite fd str =
withCStringLen str $ \ (buf,len) ->
fdWriteBuf fd (castPtr buf) (fromIntegral len)
fdWriteBuf :: Fd
-> Ptr Word8
-> ByteCount
-> IO ByteCount
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