diff --git a/System/FilePath/Internal.hs b/System/FilePath/Internal.hs index dcb452567592c7ffd62bcd1520f625f2bd8ddb3d..d786b5c482caaf913078e7b41c08dbac6a51ab9c 100644 --- a/System/FilePath/Internal.hs +++ b/System/FilePath/Internal.hs @@ -129,8 +129,9 @@ import Data.List(stripPrefix, isSuffixOf, uncons, dropWhileEnd) #define STRING String #define FILEPATH FilePath #else +import System.OsPath.Encoding.Internal.Hidden ( trySafe ) import Prelude (fromIntegral) -import Control.Exception ( SomeException, evaluate, try, displayException ) +import Control.Exception ( SomeException, evaluate, displayException ) import Control.DeepSeq (force) import GHC.IO (unsafePerformIO) import qualified Data.Char as C @@ -1273,12 +1274,12 @@ snoc str = \c -> str <> [c] #ifdef WINDOWS fromString :: P.String -> STRING fromString str = P.either (P.error . P.show) P.id $ unsafePerformIO $ do - r <- try @SomeException $ GHC.withCStringLen (mkUTF16le ErrorOnCodingFailure) str $ \cstr -> packCStringLen cstr + r <- trySafe @SomeException $ GHC.withCStringLen (mkUTF16le ErrorOnCodingFailure) str $ \cstr -> packCStringLen cstr evaluate $ force $ first displayException r #else fromString :: P.String -> STRING fromString str = P.either (P.error . P.show) P.id $ unsafePerformIO $ do - r <- try @SomeException $ GHC.withCStringLen (mkUTF8 ErrorOnCodingFailure) str $ \cstr -> packCStringLen cstr + r <- trySafe @SomeException $ GHC.withCStringLen (mkUTF8 ErrorOnCodingFailure) str $ \cstr -> packCStringLen cstr evaluate $ force $ first displayException r #endif diff --git a/System/OsPath/Encoding/Internal/Hidden.hs b/System/OsPath/Encoding/Internal/Hidden.hs index e9aec3ba2eacd85ba6dfb88dcdeeb3a7cae77d23..04455ce9bd6b2c6352f4558e1d131c44164d7b58 100644 --- a/System/OsPath/Encoding/Internal/Hidden.hs +++ b/System/OsPath/Encoding/Internal/Hidden.hs @@ -19,7 +19,7 @@ import GHC.IO.Buffer import GHC.IO.Encoding.Failure import GHC.IO.Encoding.Types import Data.Bits -import Control.Exception (SomeException, try, Exception (displayException), evaluate) +import Control.Exception (SomeException, try, Exception (displayException), evaluate, SomeAsyncException(..), catch, fromException, toException, throwIO) import qualified GHC.Foreign as GHC import Data.Either (Either) import GHC.IO (unsafePerformIO) @@ -31,7 +31,7 @@ import Numeric (showHex) import Foreign.C (CStringLen) import Data.Char (chr) import Foreign -import Prelude (FilePath) +import Prelude (FilePath, Either(..)) import GHC.IO.Encoding (getFileSystemEncoding) -- ----------------------------------------------------------------------------- @@ -277,13 +277,13 @@ peekFilePathPosix fp = getFileSystemEncoding >>= \enc -> GHC.peekCStringLen enc -- | Decode with the given 'TextEncoding'. decodeWithTE :: TextEncoding -> BS8.ShortByteString -> Either EncodingException String decodeWithTE enc ba = unsafePerformIO $ do - r <- try @SomeException $ BS8.useAsCStringLen ba $ \fp -> GHC.peekCStringLen enc fp + r <- trySafe @SomeException $ BS8.useAsCStringLen ba $ \fp -> GHC.peekCStringLen enc fp evaluate $ force $ first (flip EncodingError Nothing . displayException) r -- | Encode with the given 'TextEncoding'. encodeWithTE :: TextEncoding -> String -> Either EncodingException BS8.ShortByteString encodeWithTE enc str = unsafePerformIO $ do - r <- try @SomeException $ GHC.withCStringLen enc str $ \cstr -> BS8.packCStringLen cstr + r <- trySafe @SomeException $ GHC.withCStringLen enc str $ \cstr -> BS8.packCStringLen cstr evaluate $ force $ first (flip EncodingError Nothing . displayException) r -- ----------------------------------------------------------------------------- @@ -347,3 +347,24 @@ instance NFData EncodingException where wNUL :: Word16 wNUL = 0x00 + +-- ----------------------------------------------------------------------------- +-- Exceptions +-- + +-- | Like 'try', but rethrows async exceptions. +trySafe :: Exception e => IO a -> IO (Either e a) +trySafe ioA = catch action eHandler + where + action = do + v <- ioA + return (Right v) + eHandler e + | isAsyncException e = throwIO e + | otherwise = return (Left e) + +isAsyncException :: Exception e => e -> Bool +isAsyncException e = + case fromException (toException e) of + Just (SomeAsyncException _) -> True + Nothing -> False diff --git a/System/OsString/Common.hs b/System/OsString/Common.hs index c4b656f0fea408155731e79bf25df000f272e8fb..368cd111ca1f47e63b5eb574911a20f7549da007 100644 --- a/System/OsString/Common.hs +++ b/System/OsString/Common.hs @@ -60,7 +60,7 @@ import Control.Monad.Catch import Data.ByteString.Internal ( ByteString ) import Control.Exception - ( SomeException, try, displayException ) + ( SomeException, displayException ) import Control.DeepSeq ( force ) import Data.Bifunctor ( first ) import GHC.IO @@ -70,7 +70,7 @@ import Language.Haskell.TH.Quote ( QuasiQuoter (..) ) import Language.Haskell.TH.Syntax ( Lift (..), lift ) - +import System.OsPath.Encoding.Internal.Hidden ( trySafe ) import GHC.IO.Encoding.Failure ( CodingFailureMode(..) ) #ifdef WINDOWS @@ -116,10 +116,10 @@ encodeWith :: TextEncoding -> Either EncodingException PLATFORM_STRING encodeWith enc str = unsafePerformIO $ do #ifdef WINDOWS - r <- try @SomeException $ GHC.withCStringLen enc str $ \cstr -> WindowsString <$> BS8.packCStringLen cstr + r <- trySafe @SomeException $ GHC.withCStringLen enc str $ \cstr -> WindowsString <$> BS8.packCStringLen cstr evaluate $ force $ first (flip EncodingError Nothing . displayException) r #else - r <- try @SomeException $ GHC.withCStringLen enc str $ \cstr -> PosixString <$> BS.packCStringLen cstr + r <- trySafe @SomeException $ GHC.withCStringLen enc str $ \cstr -> PosixString <$> BS.packCStringLen cstr evaluate $ force $ first (flip EncodingError Nothing . displayException) r #endif @@ -176,7 +176,7 @@ decodeWith :: TextEncoding -> PLATFORM_STRING -> Either EncodingException String decodeWith winEnc (WindowsString ba) = unsafePerformIO $ do - r <- try @SomeException $ BS8.useAsCStringLen ba $ \fp -> GHC.peekCStringLen winEnc fp + r <- trySafe @SomeException $ BS8.useAsCStringLen ba $ \fp -> GHC.peekCStringLen winEnc fp evaluate $ force $ first (flip EncodingError Nothing . displayException) r #else -- | Decode a 'PosixString' with the specified encoding. @@ -186,7 +186,7 @@ decodeWith :: TextEncoding -> PLATFORM_STRING -> Either EncodingException String decodeWith unixEnc (PosixString ba) = unsafePerformIO $ do - r <- try @SomeException $ BS.useAsCStringLen ba $ \fp -> GHC.peekCStringLen unixEnc fp + r <- trySafe @SomeException $ BS.useAsCStringLen ba $ \fp -> GHC.peekCStringLen unixEnc fp evaluate $ force $ first (flip EncodingError Nothing . displayException) r #endif diff --git a/changelog.md b/changelog.md index 952dd17b0c9d8664220bed295110e7e1a59a66e1..45c55d27f6f28710bc1ae97d6527a3de131423fe 100644 --- a/changelog.md +++ b/changelog.md @@ -2,6 +2,10 @@ _Note: below all `FilePath` values are unquoted, so `\\` really means two backslashes._ +## 1.4.301.0 *Nov 2024* + +* Don't catch async exceptions in internal functions wrt https://github.com/haskell/os-string/issues/22 + ## 1.4.300.2 *Apr 2024* * Fix compabitiliby with GHC 9.10 diff --git a/filepath.cabal b/filepath.cabal index 03323682ee1d47fce2609216d3550d5c631db15d..8bf0fe9421604bc85d22716ec65b3cab27437fcb 100644 --- a/filepath.cabal +++ b/filepath.cabal @@ -1,6 +1,6 @@ cabal-version: 2.2 name: filepath -version: 1.4.300.2 +version: 1.4.301.0 -- NOTE: Don't forget to update ./changelog.md license: BSD-3-Clause