diff --git a/System/Posix/ByteString/FilePath.hsc b/System/Posix/ByteString/FilePath.hsc
index 3eecc1d3f10698f7d694e417b8abe258c7015407..6b0ac4ce0f0902fdcb2c6b456e8ec3e72abd8277 100644
--- a/System/Posix/ByteString/FilePath.hsc
+++ b/System/Posix/ByteString/FilePath.hsc
@@ -1,4 +1,4 @@
-{-# LANGUAGE Safe #-}
+{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE TypeApplications #-}
-----------------------------------------------------------------------------
@@ -41,8 +41,10 @@ import Foreign.C hiding (
import Control.Monad
import Control.Exception
+import Data.ByteString.Internal (c_strlen)
import GHC.Foreign as GHC ( peekCStringLen )
import GHC.IO.Encoding ( getFileSystemEncoding )
+import GHC.IO.Exception
import Data.ByteString as B
import Data.ByteString.Char8 as BC
import Prelude hiding (FilePath)
@@ -54,7 +56,7 @@ import Data.Monoid ((<>))
type RawFilePath = ByteString
withFilePath :: RawFilePath -> (CString -> IO a) -> IO a
-withFilePath = useAsCString
+withFilePath path = useAsCStringSafe path
peekFilePath :: CString -> IO RawFilePath
peekFilePath = packCString
@@ -147,3 +149,24 @@ decodeWithBasePosix ba = B.useAsCStringLen ba $ \fp -> peekFilePathPosix fp
where
peekFilePathPosix :: CStringLen -> IO String
peekFilePathPosix fp = getFileSystemEncoding >>= \enc -> GHC.peekCStringLen enc fp
+
+-- | Wrapper around 'useAsCString', checking the encoded 'FilePath' for internal NUL octets as these are
+-- disallowed in POSIX filepaths. See https://gitlab.haskell.org/ghc/ghc/-/issues/13660
+useAsCStringSafe :: RawFilePath -> (CString -> IO a) -> IO a
+useAsCStringSafe path f = useAsCStringLen path $ \(ptr, len) -> do
+ clen <- c_strlen ptr
+ if clen == fromIntegral len
+ then f ptr
+ else do
+ path' <- either (const (BC.unpack path)) id <$> try @IOException (decodeWithBasePosix path)
+ ioError (err path')
+ where
+ err path' =
+ IOError
+ { ioe_handle = Nothing
+ , ioe_type = InvalidArgument
+ , ioe_location = "checkForInteriorNuls"
+ , ioe_description = "POSIX filepaths must not contain internal NUL octets."
+ , ioe_errno = Nothing
+ , ioe_filename = Just path'
+ }
diff --git a/System/Posix/PosixPath/FilePath.hsc b/System/Posix/PosixPath/FilePath.hsc
index 8bba2b611d02e5452ec9794e4a7d4a9581041ed5..09d73f8be56b112143e9c2383e54fbfa3c530784 100644
--- a/System/Posix/PosixPath/FilePath.hsc
+++ b/System/Posix/PosixPath/FilePath.hsc
@@ -1,5 +1,6 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE PatternSynonyms #-}
-----------------------------------------------------------------------------
-- |
@@ -40,12 +41,14 @@ import Foreign.C hiding (
throwErrnoPathIfMinus1_ )
import System.OsPath.Types
+import Data.ByteString.Internal (c_strlen)
import Control.Monad
import Control.Exception
import System.OsPath.Posix as PS
import System.OsPath.Data.ByteString.Short
import Prelude hiding (FilePath)
-import System.OsString.Internal.Types (PosixString(..))
+import System.OsString.Internal.Types (PosixString(..), pattern PS)
+import GHC.IO.Exception
#if !MIN_VERSION_base(4, 11, 0)
import Data.Monoid ((<>))
@@ -53,7 +56,7 @@ import Data.Monoid ((<>))
withFilePath :: PosixPath -> (CString -> IO a) -> IO a
-withFilePath = useAsCString . getPosixString
+withFilePath path = useAsCStringSafe path
peekFilePath :: CString -> IO PosixPath
peekFilePath = fmap PosixString . packCString
@@ -140,3 +143,24 @@ throwErrnoTwoPathsIfMinus1_ loc path1 path2 action = do
_toStr :: PosixPath -> String
_toStr = fmap PS.toChar . PS.unpack
+
+-- | Wrapper around 'useAsCString', checking the encoded 'FilePath' for internal NUL octets as these are
+-- disallowed in POSIX filepaths. See https://gitlab.haskell.org/ghc/ghc/-/issues/13660
+useAsCStringSafe :: PosixPath -> (CString -> IO a) -> IO a
+useAsCStringSafe pp@(PS path) f = useAsCStringLen path $ \(ptr, len) -> do
+ clen <- c_strlen ptr
+ if clen == fromIntegral len
+ then f ptr
+ else do
+ path' <- either (const (_toStr pp)) id <$> try @IOException (PS.decodeFS pp)
+ ioError (err path')
+ where
+ err path' =
+ IOError
+ { ioe_handle = Nothing
+ , ioe_type = InvalidArgument
+ , ioe_location = "checkForInteriorNuls"
+ , ioe_description = "POSIX filepaths must not contain internal NUL octets."
+ , ioe_errno = Nothing
+ , ioe_filename = Just path'
+ }
diff --git a/tests/T13660.hs b/tests/T13660.hs
new file mode 100644
index 0000000000000000000000000000000000000000..d7867e994ef7f2b37580e3d2188841be59dc6d3b
--- /dev/null
+++ b/tests/T13660.hs
@@ -0,0 +1,67 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Main where
+
+import Data.Maybe
+#if !MIN_VERSION_base(4, 11, 0)
+import Data.Monoid ((<>))
+#endif
+import GHC.IO.Exception
+import System.IO.Error
+import System.OsPath.Posix
+import System.OsString.Internal.Types (PosixString(..))
+import System.Posix.IO (defaultFileFlags, OpenFileFlags(..), OpenMode(..))
+import System.Posix.ByteString.FilePath
+
+import qualified Data.ByteString.Char8 as C
+import qualified System.OsPath.Data.ByteString.Short as SBS
+import qualified System.Posix.Env.PosixString as PS
+import qualified System.Posix.IO.PosixString as PS
+import qualified System.Posix.IO.ByteString as BS
+import qualified System.Posix.Env.ByteString as BS
+
+
+main :: IO ()
+main = do
+ tmp <- getTemporaryDirectory
+ let fp = tmp <> fromStr' "/hello\0world"
+ res <- tryIOError $ PS.openFd fp WriteOnly df
+
+ tmp' <- getTemporaryDirectory'
+ let fp' = tmp' <> "/hello\0world"
+ res' <- tryIOError $ BS.openFd fp' WriteOnly df
+
+ case (res, res') of
+ (Left e, Left e')
+ | e == fileError (_toStr fp)
+ , e' == fileError (C.unpack fp') -> pure ()
+ | otherwise -> fail $ "Unexpected errors: " <> show e <> "\n\t" <> show e'
+ (Right _, Left _) -> fail "System.Posix.IO.PosixString.openFd should not accept filepaths with NUL bytes"
+ (Left _, Right _) -> fail "System.Posix.IO.ByteString.openFd should not accept filepaths with NUL bytes"
+ (Right _, Right _) -> fail $ "System.Posix.IO.PosixString.openFd and System.Posix.IO.ByteString.openFd" <>
+ " should not accept filepaths with NUL bytes"
+
+ where
+ df :: OpenFileFlags
+ df = defaultFileFlags{ trunc = True, creat = Just 0o666, noctty = True, nonBlock = True }
+
+ getTemporaryDirectory :: IO PosixPath
+ getTemporaryDirectory = fromMaybe (fromStr' "/tmp") <$> PS.getEnv (fromStr' "TMPDIR")
+
+ getTemporaryDirectory' :: IO RawFilePath
+ getTemporaryDirectory' = fromMaybe "/tmp" <$> BS.getEnv "TMPDIR"
+
+ fromStr' = pack . fmap unsafeFromChar
+
+ _toStr (PosixString sbs) = C.unpack $ SBS.fromShort sbs
+
+ fileError fp = IOError
+ { ioe_handle = Nothing
+ , ioe_type = InvalidArgument
+ , ioe_location = "checkForInteriorNuls"
+ , ioe_description = "POSIX filepaths must not contain internal NUL octets."
+ , ioe_errno = Nothing
+ , ioe_filename = Just fp
+ }
+
diff --git a/unix.cabal b/unix.cabal
index fbfa03ed04a1dc4b97be545b8877a05c28c22937..a04052c95ec7ca50ce3cbf613d511d25cad21d47 100644
--- a/unix.cabal
+++ b/unix.cabal
@@ -349,3 +349,11 @@ test-suite SemaphoreInterrupt
default-language: Haskell2010
build-depends: base, unix
ghc-options: -Wall -threaded
+
+test-suite T13660
+ hs-source-dirs: tests
+ main-is: T13660.hs
+ type: exitcode-stdio-1.0
+ default-language: Haskell2010
+ build-depends: base, unix, filepath >= 1.4.100.0 && < 1.5, bytestring
+ ghc-options: -Wall