diff --git a/System/FilePath/Internal.hs b/System/FilePath/Internal.hs index e55840a1..7befd6f3 100644 --- a/System/FilePath/Internal.hs +++ b/System/FilePath/Internal.hs @@ -130,9 +130,10 @@ import Data.List(stripPrefix, isSuffixOf, uncons, dropWhileEnd) #define FILEPATH FilePath #else 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 System.OsPath.Encoding.Internal (trySafe) import qualified Data.Char as C #ifdef WINDOWS import GHC.IO.Encoding.Failure ( CodingFailureMode(..) ) @@ -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.hs b/System/OsPath/Encoding/Internal.hs index 1ae1c85a..7a8c0207 100644 --- a/System/OsPath/Encoding/Internal.hs +++ b/System/OsPath/Encoding/Internal.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, SomeAsyncException(..), Exception (displayException), evaluate, catch, throwIO, toException, fromException) 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,25 @@ 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 80eb69b5..55eca92c 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 @@ -73,6 +73,7 @@ import Language.Haskell.TH.Syntax import GHC.IO.Encoding.Failure ( CodingFailureMode(..) ) +import System.OsPath.Encoding.Internal (trySafe) #ifdef WINDOWS import System.OsPath.Encoding import System.IO @@ -116,10 +117,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 +177,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 +187,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 15d4359f..466e0787 100644 --- a/changelog.md +++ b/changelog.md @@ -2,7 +2,11 @@ _Note: below all `FilePath` values are unquoted, so `\\` really means two backslashes._ -## 1.4.101.0. *Jan 2024* +## 1.4.102.0 *Nov 2024* + +* Don't catch async exceptions in internal functions wrt https://github.com/haskell/os-string/issues/22 + +## 1.4.101.0 *Jan 2024* * Backport bugfix for [`splitFileName`](https://github.com/haskell/filepath/issues/219) on windows diff --git a/filepath.cabal b/filepath.cabal index 6794957f..3e05e165 100644 --- a/filepath.cabal +++ b/filepath.cabal @@ -1,6 +1,6 @@ cabal-version: 2.2 name: filepath -version: 1.4.101.0 +version: 1.4.102.0 -- NOTE: Don't forget to update ./changelog.md license: BSD-3-Clause