Skip to content

Commit fa57c3b

Browse files
hasufellhasufell
committed
Ensure that FilePaths don't contain interior NULs
Follow: * https://gitlab.haskell.org/ghc/ghc/-/merge_requests/10110 * haskell/core-libraries-committee#144
1 parent b7a5c22 commit fa57c3b

File tree

4 files changed

+129
-8
lines changed

4 files changed

+129
-8
lines changed

‎System/Posix/ByteString/FilePath.hsc

Lines changed: 32 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -1,4 +1,4 @@
1-
{-# LANGUAGE Safe #-}
1+
{-# LANGUAGE Trustworthy #-}
22

33
-----------------------------------------------------------------------------
44
-- |
@@ -40,8 +40,14 @@ import Foreign.C hiding (
4040

4141
import Control.Monad
4242
import Data.ByteString
43-
import Data.ByteString.Char8 as BC
44-
import Prelude hiding (FilePath)
43+
import qualified Data.ByteString.Char8 as BC
44+
import qualified System.OsPath.Data.ByteString.Short as SBS
45+
import GHC.IO.Exception
46+
import System.OsPath.Posix
47+
import GHC.IO.Encoding.UTF8 ( mkUTF8 )
48+
import GHC.IO.Encoding.Failure ( CodingFailureMode(..) )
49+
import System.OsString.Internal.Types
50+
import Prelude hiding (FilePath, elem)
4551
#if !MIN_VERSION_base(4, 11, 0)
4652
import Data.Monoid ((<>))
4753
#endif
@@ -50,7 +56,9 @@ import Data.Monoid ((<>))
5056
type RawFilePath = ByteString
5157

5258
withFilePath :: RawFilePath -> (CString -> IO a) -> IO a
53-
withFilePath = useAsCString
59+
withFilePath path f = do
60+
checkForInteriorNuls path
61+
useAsCString path f
5462

5563
peekFilePath :: CString -> IO RawFilePath
5664
peekFilePath = packCString
@@ -131,3 +139,23 @@ throwErrnoPathIfMinus1_ = throwErrnoPathIf_ (== -1)
131139
throwErrnoTwoPathsIfMinus1_ :: (Eq a, Num a) => String -> RawFilePath -> RawFilePath -> IO a -> IO ()
132140
throwErrnoTwoPathsIfMinus1_ loc path1 path2 =
133141
throwErrnoIfMinus1_ (loc <> " '" <> BC.unpack path1 <> "' to '" <> BC.unpack path2 <> "'")
142+
143+
-- | Check an encoded 'FilePath' for internal NUL octets as these are
144+
-- disallowed in POSIX filepaths. See https://gitlab.haskell.org/ghc/ghc/-/issues/13660
145+
checkForInteriorNuls :: RawFilePath -> IO ()
146+
checkForInteriorNuls path = when (0x00 `elem` path) (ioError err)
147+
where
148+
err =
149+
IOError
150+
{ ioe_handle = Nothing
151+
, ioe_type = InvalidArgument
152+
, ioe_location = "checkForInteriorNuls"
153+
, ioe_description = "POSIX filepaths must not contain internal NUL octets."
154+
, ioe_errno = Nothing
155+
, ioe_filename = Just (either (error . show) id
156+
. decodeWith (mkUTF8 TransliterateCodingFailure)
157+
. PosixString
158+
. SBS.toShort
159+
$ path)
160+
}
161+

‎System/Posix/PosixPath/FilePath.hsc

Lines changed: 22 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -1,4 +1,5 @@
11
{-# LANGUAGE CPP #-}
2+
{-# LANGUAGE PatternSynonyms #-}
23

34
-----------------------------------------------------------------------------
45
-- |
@@ -42,17 +43,20 @@ import System.OsPath.Types
4243
import Control.Monad
4344
import GHC.IO.Encoding.UTF8 ( mkUTF8 )
4445
import GHC.IO.Encoding.Failure ( CodingFailureMode(..) )
45-
import System.OsPath.Posix
46-
import System.OsPath.Data.ByteString.Short
46+
import System.OsPath.Posix as Posix
47+
import System.OsPath.Data.ByteString.Short as SBS
4748
import Prelude hiding (FilePath)
48-
import System.OsString.Internal.Types (PosixString(..))
49+
import System.OsString.Internal.Types (PosixString(..), pattern PW)
50+
import GHC.IO.Exception
4951
#if !MIN_VERSION_base(4, 11, 0)
5052
import Data.Monoid ((<>))
5153
#endif
5254

5355

5456
withFilePath :: PosixPath -> (CString -> IO a) -> IO a
55-
withFilePath = useAsCString . getPosixString
57+
withFilePath path f = do
58+
checkForInteriorNuls path
59+
useAsCString (getPosixString path) f
5660

5761
peekFilePath :: CString -> IO PosixPath
5862
peekFilePath = fmap PosixString . packCString
@@ -138,3 +142,17 @@ throwErrnoTwoPathsIfMinus1_ loc path1 path2 =
138142
_toStr :: PosixPath -> String
139143
_toStr fp = either (error . show) id $ decodeWith (mkUTF8 TransliterateCodingFailure) fp
140144

145+
-- | Check an encoded 'FilePath' for internal NUL octets as these are
146+
-- disallowed in POSIX filepaths. See https://gitlab.haskell.org/ghc/ghc/-/issues/13660
147+
checkForInteriorNuls :: PosixPath -> IO ()
148+
checkForInteriorNuls path = when ((PW 0x00) `Prelude.elem` Posix.unpack path) (ioError err)
149+
where
150+
err =
151+
IOError
152+
{ ioe_handle = Nothing
153+
, ioe_type = InvalidArgument
154+
, ioe_location = "checkForInteriorNuls"
155+
, ioe_description = "POSIX filepaths must not contain internal NUL octets."
156+
, ioe_errno = Nothing
157+
, ioe_filename = Just (_toStr path)
158+
}

‎tests/T13660.hs

Lines changed: 67 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,67 @@
1+
{-# LANGUAGE CPP #-}
2+
{-# LANGUAGE OverloadedStrings #-}
3+
4+
module Main where
5+
6+
import Data.Maybe
7+
#if !MIN_VERSION_base(4, 11, 0)
8+
import Data.Monoid ((<>))
9+
#endif
10+
import GHC.IO.Exception
11+
import System.IO.Error
12+
import System.OsPath.Posix
13+
import System.OsString.Internal.Types (PosixString(..))
14+
import System.Posix.IO (defaultFileFlags, OpenFileFlags(..), OpenMode(..))
15+
import System.Posix.ByteString.FilePath
16+
17+
import qualified Data.ByteString.Char8 as C
18+
import qualified System.OsPath.Data.ByteString.Short as SBS
19+
import qualified System.Posix.Env.PosixString as PS
20+
import qualified System.Posix.IO.PosixString as PS
21+
import qualified System.Posix.IO.ByteString as BS
22+
import qualified System.Posix.Env.ByteString as BS
23+
24+
25+
main :: IO ()
26+
main = do
27+
tmp <- getTemporaryDirectory
28+
let fp = tmp <> fromStr' "/hello\0world"
29+
res <- tryIOError $ PS.openFd fp WriteOnly df
30+
31+
tmp' <- getTemporaryDirectory'
32+
let fp' = tmp' <> "/hello\0world"
33+
res' <- tryIOError $ BS.openFd fp' WriteOnly df
34+
35+
case (res, res') of
36+
(Left e, Left e')
37+
| e == fileError (_toStr fp)
38+
, e' == fileError (C.unpack fp') -> pure ()
39+
| otherwise -> fail $ "Unexpected errors: " <> show e <> "\n\t" <> show e'
40+
(Right _, Left _) -> fail "System.Posix.IO.PosixString.openFd should not accept filepaths with NUL bytes"
41+
(Left _, Right _) -> fail "System.Posix.IO.ByteString.openFd should not accept filepaths with NUL bytes"
42+
(Right _, Right _) -> fail $ "System.Posix.IO.PosixString.openFd and System.Posix.IO.ByteString.openFd" <>
43+
" should not accept filepaths with NUL bytes"
44+
45+
where
46+
df :: OpenFileFlags
47+
df = defaultFileFlags{ trunc = True, creat = Just 0o666, noctty = True, nonBlock = True }
48+
49+
getTemporaryDirectory :: IO PosixPath
50+
getTemporaryDirectory = fromMaybe (fromStr' "/tmp") <$> PS.getEnv (fromStr' "TMPDIR")
51+
52+
getTemporaryDirectory' :: IO RawFilePath
53+
getTemporaryDirectory' = fromMaybe "/tmp" <$> BS.getEnv "TMPDIR"
54+
55+
fromStr' = pack . fmap unsafeFromChar
56+
57+
_toStr (PosixString sbs) = C.unpack $ SBS.fromShort sbs
58+
59+
fileError fp = IOError
60+
{ ioe_handle = Nothing
61+
, ioe_type = InvalidArgument
62+
, ioe_location = "checkForInteriorNuls"
63+
, ioe_description = "POSIX filepaths must not contain internal NUL octets."
64+
, ioe_errno = Nothing
65+
, ioe_filename = Just fp
66+
}
67+

‎unix.cabal

Lines changed: 8 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -279,3 +279,11 @@ test-suite SemaphoreInterrupt
279279
default-language: Haskell2010
280280
build-depends: base, unix
281281
ghc-options: -Wall -threaded
282+
283+
test-suite T13660
284+
hs-source-dirs: tests
285+
main-is: T13660.hs
286+
type: exitcode-stdio-1.0
287+
default-language: Haskell2010
288+
build-depends: base, unix, filepath >= 1.4.100.0 && < 1.5, bytestring
289+
ghc-options: -Wall

0 commit comments

Comments
 (0)