Skip to content

Commit 145d17b

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 145d17b

File tree

4 files changed

+135
-8
lines changed

4 files changed

+135
-8
lines changed

‎System/Posix/ByteString/FilePath.hsc

Lines changed: 35 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,15 @@ 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 Data.ByteString.Internal (c_strlen)
44+
import qualified Data.ByteString.Char8 as BC
45+
import qualified System.OsPath.Data.ByteString.Short as SBS
46+
import GHC.IO.Exception
47+
import System.OsPath.Posix
48+
import GHC.IO.Encoding.UTF8 ( mkUTF8 )
49+
import GHC.IO.Encoding.Failure ( CodingFailureMode(..) )
50+
import System.OsString.Internal.Types
51+
import Prelude hiding (FilePath, elem)
4552
#if !MIN_VERSION_base(4, 11, 0)
4653
import Data.Monoid ((<>))
4754
#endif
@@ -50,7 +57,7 @@ import Data.Monoid ((<>))
5057
type RawFilePath = ByteString
5158

5259
withFilePath :: RawFilePath -> (CString -> IO a) -> IO a
53-
withFilePath = useAsCString
60+
withFilePath path = useAsCStringSafe path
5461

5562
peekFilePath :: CString -> IO RawFilePath
5663
peekFilePath = packCString
@@ -131,3 +138,27 @@ throwErrnoPathIfMinus1_ = throwErrnoPathIf_ (== -1)
131138
throwErrnoTwoPathsIfMinus1_ :: (Eq a, Num a) => String -> RawFilePath -> RawFilePath -> IO a -> IO ()
132139
throwErrnoTwoPathsIfMinus1_ loc path1 path2 =
133140
throwErrnoIfMinus1_ (loc <> " '" <> BC.unpack path1 <> "' to '" <> BC.unpack path2 <> "'")
141+
142+
-- | Wrapper around 'useAsCString', checking the encoded 'FilePath' for internal NUL octets as these are
143+
-- disallowed in POSIX filepaths. See https://gitlab.haskell.org/ghc/ghc/-/issues/13660
144+
useAsCStringSafe :: RawFilePath -> (CString -> IO a) -> IO a
145+
useAsCStringSafe path f = useAsCStringLen path $ \(ptr, len) -> do
146+
clen <- c_strlen ptr
147+
if clen == fromIntegral len
148+
then f ptr
149+
else ioError err
150+
where
151+
err =
152+
IOError
153+
{ ioe_handle = Nothing
154+
, ioe_type = InvalidArgument
155+
, ioe_location = "checkForInteriorNuls"
156+
, ioe_description = "POSIX filepaths must not contain internal NUL octets."
157+
, ioe_errno = Nothing
158+
, ioe_filename = Just (either (error . show) id
159+
. decodeWith (mkUTF8 TransliterateCodingFailure)
160+
. PosixString
161+
. SBS.toShort
162+
$ path)
163+
}
164+

‎System/Posix/PosixPath/FilePath.hsc

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

34
-----------------------------------------------------------------------------
45
-- |
@@ -39,20 +40,22 @@ import Foreign.C hiding (
3940
throwErrnoPathIfMinus1_ )
4041

4142
import System.OsPath.Types
43+
import Data.ByteString.Internal (c_strlen)
4244
import Control.Monad
4345
import GHC.IO.Encoding.UTF8 ( mkUTF8 )
4446
import GHC.IO.Encoding.Failure ( CodingFailureMode(..) )
45-
import System.OsPath.Posix
46-
import System.OsPath.Data.ByteString.Short
47+
import System.OsPath.Posix as Posix
48+
import System.OsPath.Data.ByteString.Short as SBS
4749
import Prelude hiding (FilePath)
48-
import System.OsString.Internal.Types (PosixString(..))
50+
import System.OsString.Internal.Types (PosixString(..), pattern PS)
51+
import GHC.IO.Exception
4952
#if !MIN_VERSION_base(4, 11, 0)
5053
import Data.Monoid ((<>))
5154
#endif
5255

5356

5457
withFilePath :: PosixPath -> (CString -> IO a) -> IO a
55-
withFilePath = useAsCString . getPosixString
58+
withFilePath path = useAsCStringSafe path
5659

5760
peekFilePath :: CString -> IO PosixPath
5861
peekFilePath = fmap PosixString . packCString
@@ -138,3 +141,21 @@ throwErrnoTwoPathsIfMinus1_ loc path1 path2 =
138141
_toStr :: PosixPath -> String
139142
_toStr fp = either (error . show) id $ decodeWith (mkUTF8 TransliterateCodingFailure) fp
140143

144+
-- | Wrapper around 'useAsCString', checking the encoded 'FilePath' for internal NUL octets as these are
145+
-- disallowed in POSIX filepaths. See https://gitlab.haskell.org/ghc/ghc/-/issues/13660
146+
useAsCStringSafe :: PosixPath -> (CString -> IO a) -> IO a
147+
useAsCStringSafe pp@(PS path) f = useAsCStringLen path $ \(ptr, len) -> do
148+
clen <- c_strlen ptr
149+
if clen == fromIntegral len
150+
then f ptr
151+
else ioError err
152+
where
153+
err =
154+
IOError
155+
{ ioe_handle = Nothing
156+
, ioe_type = InvalidArgument
157+
, ioe_location = "checkForInteriorNuls"
158+
, ioe_description = "POSIX filepaths must not contain internal NUL octets."
159+
, ioe_errno = Nothing
160+
, ioe_filename = Just (_toStr pp)
161+
}

‎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)