[Git][ghc/ghc][wip/andreask/setNonBlockingMode] Allow unknown fd device types for setNonBlockingMode.
Andreas Klebinger (@AndreasK)
gitlab at gitlab.haskell.org
Mon Sep 9 23:46:24 UTC 2024
Andreas Klebinger pushed to branch wip/andreask/setNonBlockingMode at Glasgow Haskell Compiler / GHC
Commits:
883eb9d9 by Andreas Klebinger at 2024-09-10T01:27:22+02:00
Allow unknown fd device types for setNonBlockingMode.
This allows fds with a unknown device type to have blocking mode
set. This happens for example for fds from the inotify subsystem.
Fixes #25199.
- - - - -
7 changed files:
- libraries/base/changelog.md
- libraries/ghc-internal/src/GHC/Internal/IO/FD.hs
- libraries/ghc-internal/src/GHC/Internal/System/Posix/Internals.hs
- testsuite/tests/interface-stability/base-exports.stdout
- testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs
- testsuite/tests/interface-stability/base-exports.stdout-mingw32
- testsuite/tests/interface-stability/base-exports.stdout-ws-32
Changes:
=====================================
libraries/base/changelog.md
=====================================
@@ -16,6 +16,7 @@
* Add `firstA` and `secondA` to `Data.Bitraversable`. ([CLC proposal #172](https://github.com/haskell/core-libraries-committee/issues/172))
* Deprecate `GHC.TypeNats.Internal`, `GHC.TypeLits.Internal`, `GHC.ExecutionStack.Internal` ([CLC proposal #217](https://github.com/haskell/core-libraries-committee/issues/217))
* Define `Eq1`, `Ord1`, `Show1` and `Read1` instances for basic `Generic` representation types. ([CLC proposal #273](https://github.com/haskell/core-libraries-committee/issues/273))
+ * `setNonBlockingMode` will no longer throw an exception when called on a FD associated with a unknown device type. ([CLC proposal #282](https://github.com/haskell/core-libraries-committee/issues/282))
* Add exception type metadata to default exception handler output.
([CLC proposal #231](https://github.com/haskell/core-libraries-committee/issues/231)
and [CLC proposal #261](https://github.com/haskell/core-libraries-committee/issues/261))
=====================================
libraries/ghc-internal/src/GHC/Internal/IO/FD.hs
=====================================
@@ -57,6 +57,7 @@ import GHC.Internal.Foreign.Storable
import GHC.Internal.Foreign.C.Types
import GHC.Internal.Foreign.C.Error
import GHC.Internal.Foreign.Marshal.Utils
+import GHC.Internal.Foreign.Marshal.Alloc (allocaBytes)
import qualified GHC.Internal.System.Posix.Internals
import GHC.Internal.System.Posix.Internals hiding (FD, setEcho, getEcho)
@@ -466,10 +467,15 @@ setNonBlockingMode fd set = do
-- O_NONBLOCK has no effect on regular files and block devices;
-- utilities inspecting fdIsNonBlocking (such as readRawBufferPtr)
-- should not be tricked to think otherwise.
- is_nonblock <- if set then do
- (fd_type, _, _) <- fdStat (fdFD fd)
- pure $ fd_type /= RegularFile && fd_type /= RawDevice
- else pure False
+ is_nonblock <-
+ if set
+ then do
+ allocaBytes sizeof_stat $ \ p_stat -> do
+ throwErrnoIfMinus1Retry_ "fileSize" $
+ c_fstat (fdFD fd) p_stat
+ fd_type <- statGetType_maybe p_stat
+ pure $ fd_type /= Just RegularFile && fd_type /= Just RawDevice
+ else pure False
setNonBlockingFD (fdFD fd) is_nonblock
#if defined(mingw32_HOST_OS)
return fd
=====================================
libraries/ghc-internal/src/GHC/Internal/System/Posix/Internals.hs
=====================================
@@ -140,17 +140,30 @@ fdStat fd =
fdType :: FD -> IO IODeviceType
fdType fd = do (ty,_,_) <- fdStat fd; return ty
+-- | Return a known device type or throw an exception if the device
+-- type is unknown.
statGetType :: Ptr CStat -> IO IODeviceType
statGetType p_stat = do
+ dev_ty_m <- statGetType_maybe p_stat
+ case dev_ty_m of
+ Nothing -> ioError ioe_unknownfiletype
+ Just dev_ty -> pure dev_ty
+
+-- | Unlike @statGetType@, @statGetType_maybe@ will not throw an exception
+-- if the CStat refers to a unknown device type.
+--
+-- @since base-4.21.0.0
+statGetType_maybe :: Ptr CStat -> IO (Maybe IODeviceType)
+statGetType_maybe p_stat = do
c_mode <- st_mode p_stat :: IO CMode
case () of
- _ | s_isdir c_mode -> return Directory
+ _ | s_isdir c_mode -> return $ Just Directory
| s_isfifo c_mode || s_issock c_mode || s_ischr c_mode
- -> return Stream
- | s_isreg c_mode -> return RegularFile
+ -> return $ Just Stream
+ | s_isreg c_mode -> return $ Just RegularFile
-- Q: map char devices to RawDevice too?
- | s_isblk c_mode -> return RawDevice
- | otherwise -> ioError ioe_unknownfiletype
+ | s_isblk c_mode -> return $ Just RawDevice
+ | otherwise -> return Nothing
ioe_unknownfiletype :: IOException
ioe_unknownfiletype = IOError Nothing UnsupportedOperation "fdType"
=====================================
testsuite/tests/interface-stability/base-exports.stdout
=====================================
@@ -10549,6 +10549,7 @@ module System.Posix.Internals where
fdFileSize :: FD -> GHC.Types.IO GHC.Num.Integer.Integer
fdGetMode :: FD -> GHC.Types.IO GHC.Internal.IO.IOMode.IOMode
fdStat :: FD -> GHC.Types.IO (GHC.Internal.IO.Device.IODeviceType, GHC.Internal.System.Posix.Types.CDev, GHC.Internal.System.Posix.Types.CIno)
+ fdStat_maybe :: FD -> GHC.Types.IO (GHC.Internal.Maybe.Maybe GHC.Internal.IO.Device.IODeviceType, GHC.Internal.System.Posix.Types.CDev, GHC.Internal.System.Posix.Types.CIno)
fdType :: FD -> GHC.Types.IO GHC.Internal.IO.Device.IODeviceType
fileType :: GHC.Internal.IO.FilePath -> GHC.Types.IO GHC.Internal.IO.Device.IODeviceType
getEcho :: FD -> GHC.Types.IO GHC.Types.Bool
@@ -10596,6 +10597,7 @@ module System.Posix.Internals where
st_mtime :: GHC.Internal.Ptr.Ptr CStat -> GHC.Types.IO GHC.Internal.Foreign.C.Types.CTime
st_size :: GHC.Internal.Ptr.Ptr CStat -> GHC.Types.IO GHC.Internal.System.Posix.Types.COff
statGetType :: GHC.Internal.Ptr.Ptr CStat -> GHC.Types.IO GHC.Internal.IO.Device.IODeviceType
+ statGetType_maybe :: GHC.Internal.Ptr.Ptr CStat -> GHC.Types.IO (GHC.Internal.Maybe.Maybe GHC.Internal.IO.Device.IODeviceType)
tcSetAttr :: forall a. FD -> (GHC.Internal.Ptr.Ptr CTermios -> GHC.Types.IO a) -> GHC.Types.IO a
throwInternalNulError :: forall a. GHC.Internal.IO.FilePath -> GHC.Types.IO a
withFilePath :: forall a. GHC.Internal.IO.FilePath -> (GHC.Internal.Foreign.C.String.Encoding.CString -> GHC.Types.IO a) -> GHC.Types.IO a
=====================================
testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs
=====================================
@@ -13590,6 +13590,7 @@ module System.Posix.Internals where
fdFileSize :: FD -> GHC.Types.IO GHC.Num.Integer.Integer
fdGetMode :: FD -> GHC.Types.IO GHC.Internal.IO.IOMode.IOMode
fdStat :: FD -> GHC.Types.IO (GHC.Internal.IO.Device.IODeviceType, GHC.Internal.System.Posix.Types.CDev, GHC.Internal.System.Posix.Types.CIno)
+ fdStat_maybe :: FD -> GHC.Types.IO (GHC.Internal.Maybe.Maybe GHC.Internal.IO.Device.IODeviceType, GHC.Internal.System.Posix.Types.CDev, GHC.Internal.System.Posix.Types.CIno)
fdType :: FD -> GHC.Types.IO GHC.Internal.IO.Device.IODeviceType
fileType :: GHC.Internal.IO.FilePath -> GHC.Types.IO GHC.Internal.IO.Device.IODeviceType
getEcho :: FD -> GHC.Types.IO GHC.Types.Bool
@@ -13637,6 +13638,7 @@ module System.Posix.Internals where
st_mtime :: GHC.Internal.Ptr.Ptr CStat -> GHC.Types.IO GHC.Internal.Foreign.C.Types.CTime
st_size :: GHC.Internal.Ptr.Ptr CStat -> GHC.Types.IO GHC.Internal.Int.Int64
statGetType :: GHC.Internal.Ptr.Ptr CStat -> GHC.Types.IO GHC.Internal.IO.Device.IODeviceType
+ statGetType_maybe :: GHC.Internal.Ptr.Ptr CStat -> GHC.Types.IO (GHC.Internal.Maybe.Maybe GHC.Internal.IO.Device.IODeviceType)
tcSetAttr :: forall a. FD -> (GHC.Internal.Ptr.Ptr CTermios -> GHC.Types.IO a) -> GHC.Types.IO a
throwInternalNulError :: forall a. GHC.Internal.IO.FilePath -> GHC.Types.IO a
withFilePath :: forall a. GHC.Internal.IO.FilePath -> (GHC.Internal.Foreign.C.String.Encoding.CString -> GHC.Types.IO a) -> GHC.Types.IO a
=====================================
testsuite/tests/interface-stability/base-exports.stdout-mingw32
=====================================
@@ -10821,6 +10821,7 @@ module System.Posix.Internals where
fdFileSize :: FD -> GHC.Types.IO GHC.Num.Integer.Integer
fdGetMode :: FD -> GHC.Types.IO GHC.Internal.IO.IOMode.IOMode
fdStat :: FD -> GHC.Types.IO (GHC.Internal.IO.Device.IODeviceType, GHC.Internal.System.Posix.Types.CDev, GHC.Internal.System.Posix.Types.CIno)
+ fdStat_maybe :: FD -> GHC.Types.IO (GHC.Internal.Maybe.Maybe GHC.Internal.IO.Device.IODeviceType, GHC.Internal.System.Posix.Types.CDev, GHC.Internal.System.Posix.Types.CIno)
fdType :: FD -> GHC.Types.IO GHC.Internal.IO.Device.IODeviceType
fileType :: GHC.Internal.IO.FilePath -> GHC.Types.IO GHC.Internal.IO.Device.IODeviceType
getEcho :: FD -> GHC.Types.IO GHC.Types.Bool
@@ -10865,6 +10866,7 @@ module System.Posix.Internals where
st_mtime :: GHC.Internal.Ptr.Ptr CStat -> GHC.Types.IO GHC.Internal.Foreign.C.Types.CTime
st_size :: GHC.Internal.Ptr.Ptr CStat -> GHC.Types.IO GHC.Internal.Int.Int64
statGetType :: GHC.Internal.Ptr.Ptr CStat -> GHC.Types.IO GHC.Internal.IO.Device.IODeviceType
+ statGetType_maybe :: GHC.Internal.Ptr.Ptr CStat -> GHC.Types.IO (GHC.Internal.Maybe.Maybe GHC.Internal.IO.Device.IODeviceType)
throwInternalNulError :: forall a. GHC.Internal.IO.FilePath -> GHC.Types.IO a
withFilePath :: forall a. GHC.Internal.IO.FilePath -> (GHC.Internal.Foreign.C.String.CWString -> GHC.Types.IO a) -> GHC.Types.IO a
=====================================
testsuite/tests/interface-stability/base-exports.stdout-ws-32
=====================================
@@ -10549,6 +10549,7 @@ module System.Posix.Internals where
fdFileSize :: FD -> GHC.Types.IO GHC.Num.Integer.Integer
fdGetMode :: FD -> GHC.Types.IO GHC.Internal.IO.IOMode.IOMode
fdStat :: FD -> GHC.Types.IO (GHC.Internal.IO.Device.IODeviceType, GHC.Internal.System.Posix.Types.CDev, GHC.Internal.System.Posix.Types.CIno)
+ fdStat_maybe :: FD -> GHC.Types.IO (GHC.Internal.Maybe.Maybe GHC.Internal.IO.Device.IODeviceType, GHC.Internal.System.Posix.Types.CDev, GHC.Internal.System.Posix.Types.CIno)
fdType :: FD -> GHC.Types.IO GHC.Internal.IO.Device.IODeviceType
fileType :: GHC.Internal.IO.FilePath -> GHC.Types.IO GHC.Internal.IO.Device.IODeviceType
getEcho :: FD -> GHC.Types.IO GHC.Types.Bool
@@ -10596,6 +10597,7 @@ module System.Posix.Internals where
st_mtime :: GHC.Internal.Ptr.Ptr CStat -> GHC.Types.IO GHC.Internal.Foreign.C.Types.CTime
st_size :: GHC.Internal.Ptr.Ptr CStat -> GHC.Types.IO GHC.Internal.System.Posix.Types.COff
statGetType :: GHC.Internal.Ptr.Ptr CStat -> GHC.Types.IO GHC.Internal.IO.Device.IODeviceType
+ statGetType_maybe :: GHC.Internal.Ptr.Ptr CStat -> GHC.Types.IO (GHC.Internal.Maybe.Maybe GHC.Internal.IO.Device.IODeviceType)
tcSetAttr :: forall a. FD -> (GHC.Internal.Ptr.Ptr CTermios -> GHC.Types.IO a) -> GHC.Types.IO a
throwInternalNulError :: forall a. GHC.Internal.IO.FilePath -> GHC.Types.IO a
withFilePath :: forall a. GHC.Internal.IO.FilePath -> (GHC.Internal.Foreign.C.String.Encoding.CString -> GHC.Types.IO a) -> GHC.Types.IO a
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/883eb9d9268601b94043a9bc1a5ca9c15ff43b43
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/883eb9d9268601b94043a9bc1a5ca9c15ff43b43
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20240909/12c07be0/attachment-0001.html>
More information about the ghc-commits
mailing list