diff options
Diffstat (limited to 'libraries/base/GHC/IO/Handle')
| -rw-r--r-- | libraries/base/GHC/IO/Handle/FD.hs | 10 | ||||
| -rw-r--r-- | libraries/base/GHC/IO/Handle/Lock.hsc | 107 | ||||
| -rw-r--r-- | libraries/base/GHC/IO/Handle/Text.hs | 23 | ||||
| -rw-r--r-- | libraries/base/GHC/IO/Handle/Types.hs | 18 |
4 files changed, 137 insertions, 21 deletions
diff --git a/libraries/base/GHC/IO/Handle/FD.hs b/libraries/base/GHC/IO/Handle/FD.hs index 786fccc4f1..883bc5fe59 100644 --- a/libraries/base/GHC/IO/Handle/FD.hs +++ b/libraries/base/GHC/IO/Handle/FD.hs @@ -128,11 +128,13 @@ addFilePathToIOError fun fp ioe -- -- This operation may fail with: -- --- * 'isAlreadyInUseError' if the file is already open and cannot be reopened; +-- * 'System.IO.Error.isAlreadyInUseError' if the file is already open and +-- cannot be reopened; -- --- * 'isDoesNotExistError' if the file does not exist; or +-- * 'System.IO.Error.isDoesNotExistError' if the file does not exist; or -- --- * 'isPermissionError' if the user does not have permission to open the file. +-- * 'System.IO.Error.isPermissionError' if the user does not have permission +-- to open the file. -- -- Note: if you will be working with files containing binary data, you'll want to -- be using 'openBinaryFile'. @@ -161,7 +163,7 @@ openFileBlocking fp im = -- this is undesirable; also, as usual under Microsoft operating systems, -- text mode treats control-Z as EOF. Binary mode turns off all special -- treatment of end-of-line and end-of-file characters. --- (See also 'hSetBinaryMode'.) +-- (See also 'System.IO.hSetBinaryMode'.) openBinaryFile :: FilePath -> IOMode -> IO Handle openBinaryFile fp m = diff --git a/libraries/base/GHC/IO/Handle/Lock.hsc b/libraries/base/GHC/IO/Handle/Lock.hsc index ec62f86cc9..ec85ffd25e 100644 --- a/libraries/base/GHC/IO/Handle/Lock.hsc +++ b/libraries/base/GHC/IO/Handle/Lock.hsc @@ -8,6 +8,7 @@ module GHC.IO.Handle.Lock ( , LockMode(..) , hLock , hTryLock + , hUnlock ) where #include "HsBaseConfig.h" @@ -62,8 +63,9 @@ import GHC.Show -- | Exception thrown by 'hLock' on non-Windows platforms that don't support -- 'flock'. data FileLockingNotSupported = FileLockingNotSupported - deriving Show + deriving Show -- ^ @since 4.10.0.0 +-- ^ @since 4.10.0.0 instance Exception FileLockingNotSupported -- | Indicates a mode in which a file should be locked. @@ -97,9 +99,82 @@ hLock h mode = void $ lockImpl h "hLock" mode True hTryLock :: Handle -> LockMode -> IO Bool hTryLock h mode = lockImpl h "hTryLock" mode False +-- | Release a lock taken with 'hLock' or 'hTryLock'. +hUnlock :: Handle -> IO () +hUnlock = unlockImpl + ---------------------------------------- -#if HAVE_FLOCK +#if HAVE_OFD_LOCKING +-- Linux open file descriptor locking. +-- +-- We prefer this over BSD locking (e.g. flock) since the latter appears to +-- break in some NFS configurations. Note that we intentionally do not try to +-- use ordinary POSIX file locking due to its peculiar semantics under +-- multi-threaded environments. + +foreign import ccall interruptible "fcntl" + c_fcntl :: CInt -> CInt -> Ptr () -> IO CInt + +data FLock = FLock { l_type :: CShort + , l_whence :: CShort + , l_start :: COff + , l_len :: COff + , l_pid :: CPid + } + +instance Storable FLock where + sizeOf _ = #{size flock} + alignment _ = #{alignment flock} + poke ptr x = do + fillBytes ptr 0 (sizeOf x) + #{poke flock, l_type} ptr (l_type x) + #{poke flock, l_whence} ptr (l_whence x) + #{poke flock, l_start} ptr (l_start x) + #{poke flock, l_len} ptr (l_len x) + #{poke flock, l_pid} ptr (l_pid x) + peek ptr = do + FLock <$> #{peek flock, l_type} ptr + <*> #{peek flock, l_whence} ptr + <*> #{peek flock, l_start} ptr + <*> #{peek flock, l_len} ptr + <*> #{peek flock, l_pid} ptr + +lockImpl :: Handle -> String -> LockMode -> Bool -> IO Bool +lockImpl h ctx mode block = do + FD{fdFD = fd} <- handleToFd h + with flock $ \flock_ptr -> fix $ \retry -> do + ret <- with flock $ fcntl fd mode flock_ptr + case ret of + 0 -> return True + _ -> getErrno >>= \errno -> if + | not block && errno == eWOULDBLOCK -> return False + | errno == eINTR -> retry + | otherwise -> ioException $ errnoToIOError ctx errno (Just h) Nothing + where + flock = FLock { l_type = case mode of + SharedLock -> #{const F_RDLCK} + ExclusiveLock -> #{const F_WRLCK} + , l_whence = #{const SEEK_SET} + , l_start = 0 + , l_len = 0 + } + mode + | block = #{const F_SETLKW} + | otherwise = #{const F_SETLK} + +unlockImpl :: Handle -> IO () +unlockImpl h = do + FD{fdFD = fd} <- handleToFd h + let flock = FLock { l_type = #{const F_UNLCK} + , l_whence = #{const SEEK_SET} + , l_start = 0 + , l_len = 0 + } + throwErrnoIfMinus1_ "hUnlock" + $ with flock $ c_fcntl fd #{const F_SETLK} + +#elif HAVE_FLOCK lockImpl :: Handle -> String -> LockMode -> Bool -> IO Bool lockImpl h ctx mode block = do @@ -108,7 +183,8 @@ lockImpl h ctx mode block = do fix $ \retry -> c_flock fd flags >>= \case 0 -> return True _ -> getErrno >>= \errno -> if - | not block && errno == eWOULDBLOCK -> return False + | not block + , errno == eAGAIN || errno == eACCES -> return False | errno == eINTR -> retry | otherwise -> ioException $ errnoToIOError ctx errno (Just h) Nothing where @@ -116,6 +192,11 @@ lockImpl h ctx mode block = do SharedLock -> #{const LOCK_SH} ExclusiveLock -> #{const LOCK_EX} +unlockImpl :: Handle -> IO () +unlockImpl h = do + FD{fdFD = fd} <- handleToFd h + throwErrnoIfMinus1_ "flock" $ c_flock fd #{const LOCK_UN} + foreign import ccall interruptible "flock" c_flock :: CInt -> CInt -> IO CInt @@ -146,6 +227,18 @@ lockImpl h ctx mode block = do SharedLock -> 0 ExclusiveLock -> #{const LOCKFILE_EXCLUSIVE_LOCK} +unlockImpl :: Handle -> IO () +unlockImpl h = do + FD{fdFD = fd} <- handleToFd h + wh <- throwErrnoIf (== iNVALID_HANDLE_VALUE) "hUnlock" $ c_get_osfhandle fd + allocaBytes sizeof_OVERLAPPED $ \ovrlpd -> do + fillBytes ovrlpd 0 sizeof_OVERLAPPED + c_UnlockFileEx wh 0 0xffffffff 0xffffffff ovrlpd >>= \case + True -> return () + False -> getLastError >>= failWith "hUnlock" + where + sizeof_OVERLAPPED = #{size OVERLAPPED} + -- https://msdn.microsoft.com/en-us/library/aa297958.aspx foreign import ccall unsafe "_get_osfhandle" c_get_osfhandle :: CInt -> IO HANDLE @@ -154,10 +247,18 @@ foreign import ccall unsafe "_get_osfhandle" foreign import WINDOWS_CCONV interruptible "LockFileEx" c_LockFileEx :: HANDLE -> DWORD -> DWORD -> DWORD -> DWORD -> Ptr () -> IO BOOL +-- https://msdn.microsoft.com/en-us/library/windows/desktop/aa365716.aspx +foreign import WINDOWS_CCONV interruptible "UnlockFileEx" + c_UnlockFileEx :: HANDLE -> DWORD -> DWORD -> DWORD -> Ptr () -> IO BOOL + #else -- | No-op implementation. lockImpl :: Handle -> String -> LockMode -> Bool -> IO Bool lockImpl _ _ _ _ = throwIO FileLockingNotSupported +-- | No-op implementation. +unlockImpl :: Handle -> IO () +unlockImpl _ = throwIO FileLockingNotSupported + #endif diff --git a/libraries/base/GHC/IO/Handle/Text.hs b/libraries/base/GHC/IO/Handle/Text.hs index 57b9534976..dcf4b7c174 100644 --- a/libraries/base/GHC/IO/Handle/Text.hs +++ b/libraries/base/GHC/IO/Handle/Text.hs @@ -353,10 +353,10 @@ unpack_nl !buf !r !w acc0 -- list returned by 'hGetContents' @hdl@. -- -- Any operation that fails because a handle is closed, --- also fails if a handle is semi-closed. The only exception is 'hClose'. --- A semi-closed handle becomes closed: +-- also fails if a handle is semi-closed. The only exception is +-- 'System.IO.hClose'. A semi-closed handle becomes closed: -- --- * if 'hClose' is applied to it; +-- * if 'System.IO.hClose' is applied to it; -- -- * if an I\/O error occurs when reading an item from the handle; -- @@ -537,6 +537,7 @@ hPutStrLn handle str = hPutStr' handle str True -- overhead of a single putChar '\n', which is quite high now that we -- have to encode eagerly. +{-# NOINLINE hPutStr' #-} hPutStr' :: Handle -> String -> Bool -> IO () hPutStr' handle str add_nl = do @@ -683,7 +684,7 @@ commitBuffer' raw sz@(I# _) count@(I# _) flush release h_@Handle__{..} -- 'hPutBuf' ignores any text encoding that applies to the 'Handle', -- writing the bytes directly to the underlying file or device. -- --- 'hPutBuf' ignores the prevailing 'TextEncoding' and +-- 'hPutBuf' ignores the prevailing 'System.IO.TextEncoding' and -- 'NewlineMode' on the 'Handle', and writes bytes directly. -- -- This operation may fail with: @@ -803,11 +804,11 @@ writeChunkNonBlocking h_@Handle__{..} ptr bytes -- If the handle is a pipe or socket, and the writing end -- is closed, 'hGetBuf' will behave as if EOF was reached. -- --- 'hGetBuf' ignores the prevailing 'TextEncoding' and 'NewlineMode' +-- 'hGetBuf' ignores the prevailing 'System.IO.TextEncoding' and 'NewlineMode' -- on the 'Handle', and reads bytes directly. hGetBuf :: Handle -> Ptr a -> Int -> IO Int -hGetBuf h ptr count +hGetBuf h !ptr count | count == 0 = return 0 | count < 0 = illegalBufferSize h "hGetBuf" count | otherwise = @@ -885,11 +886,11 @@ bufReadEmpty h_@Handle__{..} -- If the handle is a pipe or socket, and the writing end -- is closed, 'hGetBufSome' will behave as if EOF was reached. -- --- 'hGetBufSome' ignores the prevailing 'TextEncoding' and 'NewlineMode' --- on the 'Handle', and reads bytes directly. +-- 'hGetBufSome' ignores the prevailing 'System.IO.TextEncoding' and +-- 'NewlineMode' on the 'Handle', and reads bytes directly. hGetBufSome :: Handle -> Ptr a -> Int -> IO Int -hGetBufSome h ptr count +hGetBufSome h !ptr count | count == 0 = return 0 | count < 0 = illegalBufferSize h "hGetBufSome" count | otherwise = @@ -927,14 +928,14 @@ haFD h_@Handle__{..} = cast haDevice -- If the handle is a pipe or socket, and the writing end -- is closed, 'hGetBufNonBlocking' will behave as if EOF was reached. -- --- 'hGetBufNonBlocking' ignores the prevailing 'TextEncoding' and +-- 'hGetBufNonBlocking' ignores the prevailing 'System.IO.TextEncoding' and -- 'NewlineMode' on the 'Handle', and reads bytes directly. -- -- NOTE: on Windows, this function does not work correctly; it -- behaves identically to 'hGetBuf'. hGetBufNonBlocking :: Handle -> Ptr a -> Int -> IO Int -hGetBufNonBlocking h ptr count +hGetBufNonBlocking h !ptr count | count == 0 = return 0 | count < 0 = illegalBufferSize h "hGetBufNonBlocking" count | otherwise = diff --git a/libraries/base/GHC/IO/Handle/Types.hs b/libraries/base/GHC/IO/Handle/Types.hs index c58a9fb1b0..d38962e77e 100644 --- a/libraries/base/GHC/IO/Handle/Types.hs +++ b/libraries/base/GHC/IO/Handle/Types.hs @@ -247,7 +247,11 @@ data BufferMode -- ^ block-buffering should be enabled if possible. -- The size of the buffer is @n@ items if the argument -- is 'Just' @n@ and is otherwise implementation-dependent. - deriving (Eq, Ord, Read, Show) + deriving ( Eq -- ^ @since 4.2.0.0 + , Ord -- ^ @since 4.2.0.0 + , Read -- ^ @since 4.2.0.0 + , Show -- ^ @since 4.2.0.0 + ) {- [note Buffering Implementation] @@ -349,7 +353,11 @@ and hence it is only possible on a seekable Handle. -- | The representation of a newline in the external file or stream. data Newline = LF -- ^ '\n' | CRLF -- ^ '\r\n' - deriving (Eq, Ord, Read, Show) + deriving ( Eq -- ^ @since 4.2.0.0 + , Ord -- ^ @since 4.3.0.0 + , Read -- ^ @since 4.3.0.0 + , Show -- ^ @since 4.3.0.0 + ) -- | Specifies the translation, if any, of newline characters between -- internal Strings and the external file or stream. Haskell Strings @@ -362,7 +370,11 @@ data NewlineMode outputNL :: Newline -- ^ the representation of newlines on output } - deriving (Eq, Ord, Read, Show) + deriving ( Eq -- ^ @since 4.2.0.0 + , Ord -- ^ @since 4.3.0.0 + , Read -- ^ @since 4.3.0.0 + , Show -- ^ @since 4.3.0.0 + ) -- | The native newline representation for the current platform: 'LF' -- on Unix systems, 'CRLF' on Windows. |