[Git][ghc/ghc][wip/T13660] 2 commits: base: Add test for #13660

[Ben Gamari (@bgamari)]

Ben Gamari pushed to branch wip/T13660 at Glasgow Haskell Compiler / GHC


Commits:
3ebaff02 by Ben Gamari at 2023-03-25T23:39:39-04:00
base: Add test for #13660

- - - - -
a6d1b763 by Ben Gamari at 2023-03-31T18:46:08-04:00
base: Ensure that FilePaths don't contain NULs

POSIX filepaths may not contain the NUL octet but previously we did not
reject such paths. This could be exploited by untrusted input to cause
discrepancies between various `FilePath` queries and the opened
filename. For instance, `readFile "hello.so\x00.txt"` would open the
file `"hello.so"` yet `takeFileExtension` would return `".txt"`.

The same argument applies to Windows FilePaths

Fixes #13660.

- - - - -


3 changed files:

- libraries/base/System/Posix/Internals.hs
- + libraries/base/tests/T13660.hs
- libraries/base/tests/all.T


Changes:

=====================================
libraries/base/System/Posix/Internals.hs
=====================================
@@ -43,6 +43,8 @@ import System.IO.Error
 
 import GHC.Base
 import GHC.Num
+import GHC.OldList (elem)
+import GHC.Ptr
 import GHC.Real
 import GHC.IO
 import GHC.IO.IOMode
@@ -164,13 +166,22 @@ fdGetMode fd = do
 
 #if defined(mingw32_HOST_OS)
 withFilePath :: FilePath -> (CWString -> IO a) -> IO a
-withFilePath = withCWString
+withFilePath fp f = do
+    checkForInteriorNuls fp
+    withCWString fp f
 
 newFilePath :: FilePath -> IO CWString
-newFilePath = newCWString
+newFilePath fp = do
+    checkForInteriorNuls fp
+    newCWString fp
 
 peekFilePath :: CWString -> IO FilePath
 peekFilePath = peekCWString
+
+-- | Check a 'FilePath' for internal NUL codepoints as these are
+-- disallowed in Windows filepaths. See #13660.
+checkForInteriorNuls :: FilePath -> IO ()
+checkForInteriorNuls fp = when ('\0' `elem` fp) (throwInternalNulError fp)
 #else
 
 withFilePath :: FilePath -> (CString -> IO a) -> IO a
@@ -178,13 +189,43 @@ newFilePath :: FilePath -> IO CString
 peekFilePath :: CString -> IO FilePath
 peekFilePathLen :: CStringLen -> IO FilePath
 
-withFilePath fp f = getFileSystemEncoding >>= \enc -> GHC.withCString enc fp f
-newFilePath fp = getFileSystemEncoding >>= \enc -> GHC.newCString enc fp
+withFilePath fp f = do
+    enc <- getFileSystemEncoding
+    GHC.withCStringLen enc fp $ \(str, len) -> do
+        checkForInteriorNuls fp (str, len)
+        f str
+newFilePath fp = do
+    enc <- getFileSystemEncoding
+    (str, len) <- GHC.newCStringLen enc fp
+    checkForInteriorNuls fp (str, len)
+    return str
 peekFilePath fp = getFileSystemEncoding >>= \enc -> GHC.peekCString enc fp
 peekFilePathLen fp = getFileSystemEncoding >>= \enc -> GHC.peekCStringLen enc fp
 
+-- | Check an encoded 'FilePath' for internal NUL octets as these are
+-- disallowed in POSIX filepaths. See #13660.
+checkForInteriorNuls :: FilePath -> CStringLen -> IO ()
+checkForInteriorNuls fp (str, len) =
+    when (len' /= len) (throwInternalNulError fp)
+    -- N.B. If the string contains internal NUL codeunits then the strlen will
+    -- indicate a size smaller than that returned by withCStringLen.
+  where
+    len' = case str of Ptr ptr -> I# (cstringLength# ptr)
 #endif
 
+throwInternalNulError :: FilePath -> IO a
+throwInternalNulError fp = ioError err
+  where
+    err =
+      IOError
+        { ioe_handle = Nothing
+        , ioe_type = InvalidArgument
+        , ioe_location = "checkForInteriorNuls"
+        , ioe_description = "FilePaths must not contain internal NUL code units."
+        , ioe_errno = Nothing
+        , ioe_filename = Just fp
+        }
+
 -- ---------------------------------------------------------------------------
 -- Terminal-related stuff
 


=====================================
libraries/base/tests/T13660.hs
=====================================
@@ -0,0 +1,9 @@
+-- | This should print an InvalidArgument error complaining that
+-- the file path contains a NUL octet.
+module Main where
+
+main :: IO ()
+main = do
+    catchIOError
+      (writeFile "hello\x00world" "hello")
+      print


=====================================
libraries/base/tests/all.T
=====================================
@@ -256,6 +256,7 @@ test('T13191',
       ['-O'])
 test('T13525', [when(opsys('mingw32'), skip), js_broken(22374)], compile_and_run, [''])
 test('T13097', normal, compile_and_run, [''])
+test('T13660', when(opsys('mingw32'), skip), compile_and_run, [''])
 test('functorOperators', normal, compile_and_run, [''])
 test('T3474',
      [collect_stats('max_bytes_used',5),



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/6625b5fc91b4771971826b4bc245a24e7fc2b245...a6d1b763cba5049c3448eabc3703fec4a1a3f08b

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/6625b5fc91b4771971826b4bc245a24e7fc2b245...a6d1b763cba5049c3448eabc3703fec4a1a3f08b
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/20230331/3644bb57/attachment-0001.html>