Ensure that FilePaths don't contain interior NULs

Follow:

* https://gitlab.haskell.org/ghc/ghc/-/merge_requests/10110
* haskell/core-libraries-committee#144

Author: hasufell

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'
+          }

System/Posix/PosixPath/FilePath.hsc

@@ -1,5 +1,6 @@
 {-# LANGUAGE CPP #-}
 {-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE PatternSynonyms #-}
 
 -----------------------------------------------------------------------------
 -- |
@@ -40,20 +41,22 @@ 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 ((<>))
 #endif
 
 
 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'
+          }

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
+          }
+

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