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