Commit ebe27997 authored by Oleg Grenrus's avatar Oleg Grenrus
Browse files

Fix #7126: Stricter checks for relative paths

E.g. `foo/../../../bar` is now forbidden. That cannot work.
parent b32799f1
......@@ -48,6 +48,7 @@ checkTests = testGroup "regressions"
, checkTest "issue-6288-d.cabal"
, checkTest "issue-6288-e.cabal"
, checkTest "issue-6288-f.cabal"
, checkTest "denormalised-paths.cabal"
]
checkTest :: FilePath -> TestTree
......
cabal-version: 2.4
name: assoc
version: 1.1
license: BSD-3-Clause
license-files: LICENSE LICENSE2/ .
synopsis: swap and assoc: Symmetric and Semigroupy Bifunctors
category: Data
description:
Provides generalisations of
@swap :: (a,b) -> (b,a)@ and
@assoc :: ((a,b),c) -> (a,(b,c))@
to
@Bifunctor@s supporting similar operations (e.g. @Either@, @These@).
author: Oleg Grenrus <oleg.grenrus@iki.fi>
maintainer: Oleg Grenrus <oleg.grenrus@iki.fi>
build-type: Simple
tested-with:
GHC ==7.0.4
|| ==7.2.2
|| ==7.4.2
|| ==7.6.3
|| ==7.8.4
|| ==7.10.3
|| ==8.0.2
|| ==8.2.2
|| ==8.4.4
|| ==8.6.5
|| ==8.8.1
extra-source-files:
files/**/*.txt/
files/../foo.txt
source-repository head
type: git
location: https://github.com/phadej/assoc.git
subdir: ./.
source-repository this
type: git
location: https://github.com/phadej/assoc.git
tag: v1.1
subdir: foo/
library
default-language: Haskell2010
build-depends:
base >=4.3 && <4.13
, bifunctors >=5.5.4 && <5.6
exposed-modules:
Data.Bifunctor.Assoc
Data.Bifunctor.Swap
-- this is fine
hs-source-dirs: src/
-- collection of invalid sources
hs-source-dirs: src/.
hs-source-dirs: src/../src
hs-source-dirs: src/../../assoc/src
-- this is forbidden by a parser
-- hs-source-dirs: C:/foo/bar
hs-source-dirs: C:foo/bar
hs-source-dirs: ||s
-- this is forbidden by a parser
-- hs-source-dirs: /var/secret/source
-- this is the only case catched by Cabal-3.0.2.0
hs-source-dirs: ../../assoc/src
The 'subdir' field of a source-repository is not a good relative path: "trailing same directory segment: ."
'hs-source-dirs: ../../assoc/src' is a relative path outside of the source tree. This will not work when generating a tarball with 'sdist'.
'extra-source-files: files/**/*.txt/' is not good relative path: trailing slash
'extra-source-files: files/../foo.txt' is not good relative path: parent directory segment: ..
'license-file: LICENSE2/' is not good relative path: trailing slash
'license-file: .' is not good relative path: trailing dot segment
'hs-source-dirs: src/.' is not good relative path: trailing same directory segment: .
'hs-source-dirs: src/../src' is not good relative path: parent directory segment: ..
'hs-source-dirs: src/../../assoc/src' is not good relative path: parent directory segment: ..
'hs-source-dirs: C:foo/bar' is not good relative path: reserved character ':'
'hs-source-dirs: ||s' is not good relative path: reserved character '|'
'hs-source-dirs: ../../assoc/src' is not good relative path: parent directory segment: ..
......@@ -76,6 +76,9 @@ import qualified Distribution.Types.BuildInfo.Lens as L
import qualified Distribution.Types.GenericPackageDescription.Lens as L
import qualified Distribution.Types.PackageDescription.Lens as L
-- $setup
-- >>> import Control.Arrow ((&&&))
-- | Results of some kind of failed package check.
--
-- There are a range of severities, from merely dubious to totally insane.
......@@ -762,6 +765,16 @@ checkSourceRepos pkg =
, check (maybe False isAbsoluteOnAnyPlatform (repoSubdir repo)) $
PackageDistInexcusable
"The 'subdir' field of a source-repository must be a relative path."
, check (maybe False isAbsoluteOnAnyPlatform (repoSubdir repo)) $
PackageDistInexcusable
"The 'subdir' field of a source-repository must be a relative path."
, do
subdir <- repoSubdir repo
err <- isGoodRelativeDirectoryPath subdir
return $ PackageDistInexcusable $
"The 'subdir' field of a source-repository is not a good relative path: " ++ show err
]
| repo <- sourceRepos pkg ]
......@@ -1038,27 +1051,42 @@ checkAlternatives badField goodField flags =
where (badFlags, goodFlags) = unzip flags
data PathKind
= PathKindFile
| PathKindDirectory
| PathKindGlob
checkPaths :: PackageDescription -> [PackageCheck]
checkPaths pkg =
[ PackageBuildWarning $
quote (kind ++ ": " ++ path)
quote (field ++ ": " ++ path)
++ " is a relative path outside of the source tree. "
++ "This will not work when generating a tarball with 'sdist'."
| (path, kind) <- relPaths ++ absPaths
| (path, field, _) <- relPaths ++ absPaths
, isOutsideTree path ]
++
[ PackageDistInexcusable $
quote (kind ++ ": " ++ path) ++ " is an absolute path."
| (path, kind) <- relPaths
quote (field ++ ": " ++ path) ++ " is an absolute path."
| (path, field, _) <- relPaths
, isAbsoluteOnAnyPlatform path ]
++
[ PackageDistInexcusable $
quote (kind ++ ": " ++ path) ++ " points inside the 'dist' "
quote (field ++ ": " ++ path) ++ " is not good relative path: " ++ err
| (path, field, kind) <- relPaths
-- these are not paths, but globs...
, err <- maybeToList $ case kind of
PathKindFile -> isGoodRelativeFilePath path
PathKindGlob -> isGoodRelativeGlob path
PathKindDirectory -> isGoodRelativeDirectoryPath path
]
++
[ PackageDistInexcusable $
quote (field ++ ": " ++ path) ++ " points inside the 'dist' "
++ "directory. This is not reliable because the location of this "
++ "directory is configurable by the user (or package manager). In "
++ "addition the layout of the 'dist' directory is subject to change "
++ "in future versions of Cabal."
| (path, kind) <- relPaths ++ absPaths
| (path, field, _) <- relPaths ++ absPaths
, isInsideDist path ]
++
[ PackageDistInexcusable $
......@@ -1098,29 +1126,35 @@ checkPaths pkg =
"dist" :_ -> True
".":"dist":_ -> True
_ -> False
-- paths that must be relative
relPaths :: [(FilePath, String, PathKind)]
relPaths =
[ (path, "extra-source-files") | path <- extraSrcFiles pkg ]
++ [ (path, "extra-tmp-files") | path <- extraTmpFiles pkg ]
++ [ (path, "extra-doc-files") | path <- extraDocFiles pkg ]
++ [ (path, "data-files") | path <- dataFiles pkg ]
++ [ (path, "data-dir") | path <- [dataDir pkg]]
++ [ (path, "license-file") | path <- licenseFiles pkg ]
++ concat
[ [ (path, "asm-sources") | path <- asmSources bi ]
++ [ (path, "cmm-sources") | path <- cmmSources bi ]
++ [ (path, "c-sources") | path <- cSources bi ]
++ [ (path, "cxx-sources") | path <- cxxSources bi ]
++ [ (path, "js-sources") | path <- jsSources bi ]
++ [ (path, "install-includes") | path <- installIncludes bi ]
++ [ (getSymbolicPath path, "hs-source-dirs") | path <- hsSourceDirs bi ] -- TODO: this can be removed soon!
| bi <- allBuildInfo pkg ]
[ (path, "extra-source-files", PathKindGlob) | path <- extraSrcFiles pkg ] ++
[ (path, "extra-tmp-files", PathKindFile) | path <- extraTmpFiles pkg ] ++
[ (path, "extra-doc-files", PathKindGlob) | path <- extraDocFiles pkg ] ++
[ (path, "data-files", PathKindGlob) | path <- dataFiles pkg ] ++
[ (path, "data-dir", PathKindDirectory) | path <- [dataDir pkg]] ++
[ (path, "license-file", PathKindFile) | path <- licenseFiles pkg ] ++
concat
[ [ (path, "asm-sources", PathKindFile) | path <- asmSources bi ] ++
[ (path, "cmm-sources", PathKindFile) | path <- cmmSources bi ] ++
[ (path, "c-sources", PathKindFile) | path <- cSources bi ] ++
[ (path, "cxx-sources", PathKindFile) | path <- cxxSources bi ] ++
[ (path, "js-sources", PathKindFile) | path <- jsSources bi ] ++
[ (path, "install-includes", PathKindFile) | path <- installIncludes bi ] ++
[ (path, "hs-source-dirs", PathKindDirectory) | path <- map getSymbolicPath $ hsSourceDirs bi ]
| bi <- allBuildInfo pkg
]
-- paths that are allowed to be absolute
absPaths :: [(FilePath, String, PathKind)]
absPaths = concat
[ [ (path, "includes") | path <- includes bi ]
++ [ (path, "include-dirs") | path <- includeDirs bi ]
++ [ (path, "extra-lib-dirs") | path <- extraLibDirs bi ]
| bi <- allBuildInfo pkg ]
[ [ (path, "includes", PathKindFile) | path <- includes bi ] ++
[ (path, "include-dirs", PathKindDirectory) | path <- includeDirs bi ] ++
[ (path, "extra-lib-dirs", PathKindDirectory) | path <- extraLibDirs bi ]
| bi <- allBuildInfo pkg
]
--TODO: check sets of paths that would be interpreted differently between Unix
-- and windows, ie case-sensitive or insensitive. Things that might clash, or
......@@ -2111,3 +2145,246 @@ fileExtensionSupportedLanguage path =
extension = takeExtension path
isHaskell = extension `elem` [".hs", ".lhs"]
isC = isJust (filenameCDialect extension)
-- | Whether a path is a good relative path.
--
-- >>> let test fp = putStrLn $ show (isGoodRelativeDirectoryPath fp) ++ "; " ++ show (isGoodRelativeFilePath fp)
--
-- >>> test "foo/bar/quu"
-- Nothing; Nothing
--
-- Trailing slash is not allowed for files, for directories it is ok.
--
-- >>> test "foo/"
-- Nothing; Just "trailing slash"
--
-- Leading @./@ is fine, but @.@ and @./@ are not valid files.
--
-- >>> traverse_ test [".", "./", "./foo/bar"]
-- Nothing; Just "trailing dot segment"
-- Nothing; Just "trailing slash"
-- Nothing; Nothing
--
-- Lastly, not good file nor directory cases:
--
-- >>> traverse_ test ["", "/tmp/src", "foo//bar", "foo/.", "foo/./bar", "foo/../bar", "foo*bar"]
-- Just "empty path"; Just "empty path"
-- Just "posix absolute path"; Just "posix absolute path"
-- Just "empty path segment"; Just "empty path segment"
-- Just "trailing same directory segment: ."; Just "trailing same directory segment: ."
-- Just "same directory segment: ."; Just "same directory segment: .."
-- Just "parent directory segment: .."; Just "parent directory segment: .."
-- Just "reserved character '*'"; Just "reserved character '*'"
--
-- For the last case, 'isGoodRelativeGlob' doesn't warn:
--
-- >>> traverse_ (print . isGoodRelativeGlob) ["foo/../bar", "foo*bar"]
-- Just "parent directory segment: .."
-- Nothing
--
isGoodRelativeFilePath :: FilePath -> Maybe String
isGoodRelativeFilePath = state0
where
-- Reserved characters
-- https://docs.microsoft.com/en-us/windows/win32/fileio/naming-a-file
isReserved c = c `elem` "<>:\"\\/|?*"
-- initial state
state0 [] = Just "empty path"
state0 (c:cs) | c == '.' = state1 cs
| c == '/' = Just "posix absolute path"
| isReserved c = Just ("reserved character " ++ show c)
| otherwise = state3 cs
-- after .
state1 [] = Just "trailing dot segment"
state1 (c:cs) | c == '.' = state4 cs
| c == '/' = state2 cs
| isReserved c = Just ("reserved character " ++ show c)
| otherwise = state5 cs
-- after ./
state2 [] = Just "trailing slash"
state2 (c:cs) | c == '.' = state3 cs
| c == '/' = Just "empty path segment"
| isReserved c = Just ("reserved character " ++ show c)
| otherwise = state5 cs
-- after non-first segment's .
state3 [] = Just "trailing same directory segment: ."
state3 (c:cs) | c == '.' = state4 cs
| c == '/' = Just "same directory segment: .."
| isReserved c = Just ("reserved character " ++ show c)
| otherwise = state5 cs
-- after non-first segment's ..
state4 [] = Just "trailing parent directory segment: .."
state4 (c:cs) | c == '.' = state5 cs
| c == '/' = Just "parent directory segment: .."
| isReserved c = Just ("reserved character " ++ show c)
| otherwise = state5 cs
-- in a segment which is ok.
state5 [] = Nothing
state5 (c:cs) | c == '.' = state3 cs
| c == '/' = state2 cs
| isReserved c = Just ("reserved character " ++ show c)
| otherwise = state5 cs
-- | See 'isGoodRelativeFilePath'.
--
-- This is barebones function. We check whether the glob is a valid file
-- by replacing stars @*@ with @x@ses.
isGoodRelativeGlob :: FilePath -> Maybe String
isGoodRelativeGlob = isGoodRelativeFilePath . map f where
f '*' = 'x'
f c = c
-- | See 'isGoodRelativeFilePath'.
isGoodRelativeDirectoryPath :: FilePath -> Maybe String
isGoodRelativeDirectoryPath = state0
where
-- Reserved characters
-- https://docs.microsoft.com/en-us/windows/win32/fileio/naming-a-file
isReserved c = c `elem` "<>:\"\\/|?*"
-- initial state
state0 [] = Just "empty path"
state0 (c:cs) | c == '.' = state5 cs
| c == '/' = Just "posix absolute path"
| isReserved c = Just ("reserved character " ++ show c)
| otherwise = state4 cs
-- after ./
state1 [] = Nothing -- "./"
state1 (c:cs) | c == '.' = state2 cs
| c == '/' = Just "empty path segment"
| isReserved c = Just ("reserved character " ++ show c)
| otherwise = state4 cs
-- after non-first setgment's .
state2 [] = Just "trailing same directory segment: ."
state2 (c:cs) | c == '.' = state3 cs
| c == '/' = Just "same directory segment: ."
| isReserved c = Just ("reserved character " ++ show c)
| otherwise = state4 cs
-- after non-first segment's ..
state3 [] = Just "trailing parent directory segment: ."
state3 (c:cs) | c == '.' = state4 cs
| c == '/' = Just "parent directory segment: .."
| isReserved c = Just ("reserved character " ++ show c)
| otherwise = state4 cs
-- in a segment which is ok.
state4 [] = Nothing
state4 (c:cs) | c == '.' = state4 cs
| c == '/' = state1 cs
| isReserved c = Just ("reserved character " ++ show c)
| otherwise = state4 cs
-- after .
state5 [] = Nothing -- "."
state5 (c:cs) | c == '.' = state3 cs
| c == '/' = state1 cs
| isReserved c = Just ("reserved character " ++ show c)
| otherwise = state4 cs
-- [Note: Good relative paths]
--
-- Using @kleene@ we can define an extended regex:
--
-- @
-- import Algebra.Lattice
-- import Kleene
-- import Kleene.ERE (ERE (..), intersections)
--
-- data C = CDot | CSlash | COtherReserved | CChar
-- deriving (Eq, Ord, Enum, Bounded, Show)
--
-- reservedR :: ERE C
-- reservedR = notChar CSlash /\ notChar COtherReserved
--
-- pathPieceR :: ERE C
-- pathPieceR = intersections
-- [ plus reservedR
-- , ERENot (string [CDot])
-- , ERENot (string [CDot,CDot])
-- ]
--
-- filePathR :: ERE C
-- filePathR = optional (string [CDot, CSlash]) <> pathPieceR <> star (char CSlash <> pathPieceR)
--
-- dirPathR :: ERE C
-- dirPathR = (char CDot \/ filePathR) <> optional (char CSlash)
--
-- plus :: ERE C -> ERE C
-- plus r = r <> star r
--
-- optional :: ERE C -> ERE C
-- optional r = mempty \/ r
-- @
--
-- Results in following state machine for @filePathR@
--
-- @
-- 0 -> \x -> if
-- | x <= CDot -> 1
-- | x <= COtherReserved -> 6
-- | otherwise -> 5
-- 1 -> \x -> if
-- | x <= CDot -> 4
-- | x <= CSlash -> 2
-- | x <= COtherReserved -> 6
-- | otherwise -> 5
-- 2 -> \x -> if
-- | x <= CDot -> 3
-- | x <= COtherReserved -> 6
-- | otherwise -> 5
-- 3 -> \x -> if
-- | x <= CDot -> 4
-- | x <= COtherReserved -> 6
-- | otherwise -> 5
-- 4 -> \x -> if
-- | x <= CDot -> 5
-- | x <= COtherReserved -> 6
-- | otherwise -> 5
-- 5+ -> \x -> if
-- | x <= CDot -> 5
-- | x <= CSlash -> 2
-- | x <= COtherReserved -> 6
-- | otherwise -> 5
-- 6 -> \_ -> 6 -- black hole
-- @
--
-- and @dirPathR@:
--
-- @
-- 0 -> \x -> if
-- | x <= CDot -> 5
-- | x <= COtherReserved -> 6
-- | otherwise -> 4
-- 1+ -> \x -> if
-- | x <= CDot -> 2
-- | x <= COtherReserved -> 6
-- | otherwise -> 4
-- 2 -> \x -> if
-- | x <= CDot -> 3
-- | x <= COtherReserved -> 6
-- | otherwise -> 4
-- 3 -> \x -> if
-- | x <= CDot -> 4
-- | x <= COtherReserved -> 6
-- | otherwise -> 4
-- 4+ -> \x -> if
-- | x <= CDot -> 4
-- | x <= CSlash -> 1
-- | x <= COtherReserved -> 6
-- | otherwise -> 4
-- 5+ -> \x -> if
-- | x <= CDot -> 3
-- | x <= CSlash -> 1
-- | x <= COtherReserved -> 6
-- | otherwise -> 4
-- 6 -> \_ -> 6 -- black hole
-- @
......@@ -560,6 +560,7 @@ trdOf3 (_,_,c) = c
isAbsoluteOnAnyPlatform :: FilePath -> Bool
-- C:\\directory
isAbsoluteOnAnyPlatform (drive:':':'\\':_) = isAlpha drive
isAbsoluteOnAnyPlatform (drive:':':'/':_) = isAlpha drive
-- UNC
isAbsoluteOnAnyPlatform ('\\':'\\':_) = True
-- Posix root
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment