Skip to content

Commit 00a4e5f

Browse files
hasufellhasufell
committed
Be stricter about URI imports
This behavior is documented, but not enforced. We redesign the 'ProjectConfigPath' type to better express the properties we expect.
1 parent 504ccd5 commit 00a4e5f

12 files changed

Lines changed: 248 additions & 187 deletions

File tree

‎Cabal-syntax/Cabal-syntax.cabal‎

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -37,6 +37,7 @@ library
3737
, directory >= 1.2 && < 1.4
3838
, filepath >= 1.3.0.1 && < 1.6
3939
, mtl >= 2.1 && < 2.4
40+
, network-uri >= 2.6.0.2 && < 2.7
4041
, parsec >= 3.1.13.0 && < 3.2
4142
, pretty >= 1.1.1 && < 1.2
4243
, text >= 2.0.2 && < 2.2
@@ -72,6 +73,7 @@ library
7273
Distribution.Compat.Lens
7374
Distribution.Compat.Newtype
7475
Distribution.Compat.NonEmptySet
76+
Distribution.Compat.Orphans
7577
Distribution.Compat.Parsing
7678
Distribution.Compat.Prelude
7779
Distribution.Compat.Semigroup

‎Cabal-syntax/src/Distribution/Compat/Orphans.hs‎

Lines changed: 47 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,47 @@
1+
{-# LANGUAGE BangPatterns #-}
2+
{-# OPTIONS_GHC -Wno-orphans #-}
3+
4+
module Distribution.Compat.Orphans () where
5+
6+
import Control.Exception (SomeException)
7+
import Data.Typeable (typeRep)
8+
import Distribution.Compat.Binary (Binary (..))
9+
import Distribution.Utils.Structured (Structure (Nominal), Structured (..))
10+
import Network.URI (URI (..), URIAuth (..))
11+
import Prelude (error, return)
12+
13+
-------------------------------------------------------------------------------
14+
-- network-uri
15+
-------------------------------------------------------------------------------
16+
17+
-- note, network-uri-2.6.0.3+ provide a Generic instance but earlier
18+
-- versions do not, so we use manual Binary instances here
19+
instance Binary URI where
20+
put (URI a b c d e) = do put a; put b; put c; put d; put e
21+
get = do
22+
!a <- get
23+
!b <- get
24+
!c <- get
25+
!d <- get
26+
!e <- get
27+
return (URI a b c d e)
28+
29+
instance Structured URI where
30+
structure p = Nominal (typeRep p) 0 "URI" []
31+
32+
instance Binary URIAuth where
33+
put (URIAuth a b c) = do put a; put b; put c
34+
get = do !a <- get; !b <- get; !c <- get; return (URIAuth a b c)
35+
36+
-------------------------------------------------------------------------------
37+
-- base
38+
-------------------------------------------------------------------------------
39+
40+
-- FIXME: Duncan Coutts: this is a total cheat
41+
-- Added in 46aa019ec85e313e257d122a3549cce01996c566
42+
instance Binary SomeException where
43+
put _ = return ()
44+
get = error "cannot serialise exceptions"
45+
46+
instance Structured SomeException where
47+
structure p = Nominal (typeRep p) 0 "SomeException" []

‎cabal-install-solver/src/Distribution/Solver/Types/ProjectConfigPath.hs‎

Lines changed: 138 additions & 87 deletions
Large diffs are not rendered by default.

‎cabal-install/parser-tests/Tests/ParserTests.hs‎

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -208,7 +208,7 @@ testProjectConfigShared = do
208208
let
209209
bar = fromRight (error "error parsing bar") $ readUserConstraint "bar == 2.1"
210210
barFlags = fromRight (error "error parsing bar flags") $ readUserConstraint "bar +foo -baz"
211-
source = ConstraintSourceProjectConfig $ ProjectConfigPath $ "cabal.project" :| []
211+
source = ConstraintSourceProjectConfig $ PCPWithoutImports $ "cabal.project"
212212
in
213213
[(bar, source), (barFlags, source)]
214214
projectConfigPreferences = [PackageVersionConstraint (mkPackageName "foo") (ThisVersion (mkVersion [0, 9])), PackageVersionConstraint (mkPackageName "baz") (LaterVersion (mkVersion [2, 0]))]
@@ -318,7 +318,7 @@ testLocalNoIndexRepos = do
318318

319319
testProjectConfigProvenance :: Assertion
320320
testProjectConfigProvenance = do
321-
let expected = Set.singleton (Explicit (ProjectConfigPath $ "cabal.project" :| []))
321+
let expected = Set.singleton (Explicit (PCPWithoutImports "cabal.project"))
322322
(config, legacy) <- readConfigDefault "empty"
323323
assertConfigEquals expected config legacy (projectConfigProvenance . condTreeData)
324324

‎cabal-install/src/Distribution/Client/Compat/Orphans.hs‎

Lines changed: 1 addition & 45 deletions
Original file line numberDiff line numberDiff line change
@@ -1,47 +1,3 @@
1-
{-# LANGUAGE BangPatterns #-}
2-
{-# OPTIONS_GHC -Wno-orphans #-}
3-
41
module Distribution.Client.Compat.Orphans () where
52

6-
import Control.Exception (SomeException)
7-
import Data.Typeable (typeRep)
8-
import Distribution.Compat.Binary (Binary (..))
9-
import Distribution.Utils.Structured (Structure (Nominal), Structured (..))
10-
import Network.URI (URI (..), URIAuth (..))
11-
import Prelude (error, return)
12-
13-
-------------------------------------------------------------------------------
14-
-- network-uri
15-
-------------------------------------------------------------------------------
16-
17-
-- note, network-uri-2.6.0.3+ provide a Generic instance but earlier
18-
-- versions do not, so we use manual Binary instances here
19-
instance Binary URI where
20-
put (URI a b c d e) = do put a; put b; put c; put d; put e
21-
get = do
22-
!a <- get
23-
!b <- get
24-
!c <- get
25-
!d <- get
26-
!e <- get
27-
return (URI a b c d e)
28-
29-
instance Structured URI where
30-
structure p = Nominal (typeRep p) 0 "URI" []
31-
32-
instance Binary URIAuth where
33-
put (URIAuth a b c) = do put a; put b; put c
34-
get = do !a <- get; !b <- get; !c <- get; return (URIAuth a b c)
35-
36-
-------------------------------------------------------------------------------
37-
-- base
38-
-------------------------------------------------------------------------------
39-
40-
-- FIXME: Duncan Coutts: this is a total cheat
41-
-- Added in 46aa019ec85e313e257d122a3549cce01996c566
42-
instance Binary SomeException where
43-
put _ = return ()
44-
get = error "cannot serialise exceptions"
45-
46-
instance Structured SomeException where
47-
structure p = Nominal (typeRep p) 0 "SomeException" []
3+
import Distribution.Compat.Orphans ()

‎cabal-install/src/Distribution/Client/Errors/Parser.hs‎

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -85,7 +85,7 @@ renderProjectConfigParseError (ProjectConfigParseError errors warnings) =
8585
renderParseError displayProjectFileSource errors warnings
8686
where
8787
displayProjectFileSource (ProjectFileSource (path, contents)) =
88-
renderParseErrorFile "project" (currentProjectConfigPath path) (if isTopLevelConfigPath path then Nothing else Just $ render (docProjectImportedBy path)) contents
88+
renderParseErrorFile "project" (prettyShow $ currentProjectConfigPath path) (if isTopLevelConfigPath path then Nothing else Just $ render (docProjectImportedBy path)) contents
8989

9090
data ProjectFileSource = ProjectFileSource (ProjectConfigPath, BS8.ByteString) deriving (Show, Generic)
9191

@@ -97,7 +97,7 @@ instance Ord ProjectFileSource where
9797

9898
renderProjectFileSource :: ProjectFileSource -> String
9999
renderProjectFileSource (ProjectFileSource (path, _contents)) =
100-
currentProjectConfigPath path
100+
prettyShow $ currentProjectConfigPath path
101101

102102
renderParseErrorCabalFile :: NonEmpty (PErrorWithSource CabalFileSource) -> [PWarningWithSource CabalFileSource] -> String
103103
renderParseErrorCabalFile errors warnings =

‎cabal-install/src/Distribution/Client/ProjectConfig.hs‎

Lines changed: 7 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -76,6 +76,7 @@ module Distribution.Client.ProjectConfig
7676
) where
7777

7878
import Data.Bifunctor (second)
79+
import Data.Either (rights)
7980
import Distribution.Client.Compat.Prelude hiding (empty)
8081
import Distribution.Parsec.Source
8182
import Distribution.Simple.Utils
@@ -844,7 +845,10 @@ readProjectFileSkeletonGen
844845
-- > ("cabal.project.foo" :| ["cabal.project"])
845846
--
846847
-- Consequently, we just take the heads of all the paths.
847-
monitorFiles $ map (monitorFileHashed . makeAbsolute) (projectConfigPathCurrent <$> projectSkeletonImports pcs)
848+
monitorFiles $
849+
map
850+
(monitorFileHashed . makeAbsolute)
851+
(rights . fmap (leafToEither . currentProjectConfigPath) . projectSkeletonImports $ pcs)
848852

849853
return pcs
850854
else do
@@ -1011,7 +1015,7 @@ readGlobalConfig verbosity configFileFlag = do
10111015
reportProjectParseWarningsLegacy :: Verbosity -> FilePath -> [ProjectParseWarning] -> IO ()
10121016
reportProjectParseWarningsLegacy verbosity projectFile warnings =
10131017
let msgs =
1014-
[ OldParser.showPWarning pFilename w
1018+
[ OldParser.showPWarning (prettyShow pFilename) w
10151019
| (p, w) <- warnings
10161020
, let pFilename = fst $ unconsProjectConfigPath p
10171021
]
@@ -1037,7 +1041,7 @@ reportParseResult verbosity filetype projectFile (OldParser.ProjectParseFailed (
10371041
maybe
10381042
(projectFile, empty)
10391043
( \p ->
1040-
( currentProjectConfigPath p
1044+
( prettyShow $ currentProjectConfigPath p
10411045
, if isTopLevelConfigPath p then empty else docProjectConfigPath p
10421046
)
10431047
)

‎cabal-install/src/Distribution/Client/ProjectConfig/Legacy.hs‎

Lines changed: 19 additions & 23 deletions
Original file line numberDiff line numberDiff line change
@@ -133,7 +133,6 @@ import Distribution.Simple.Setup
133133
import Distribution.Simple.Utils
134134
( debug
135135
, lowercase
136-
, noticeDoc
137136
)
138137
import Distribution.Types.CondTree
139138
( CondBranch (..)
@@ -149,7 +148,6 @@ import Distribution.Utils.NubList
149148
, overNubList
150149
, toNubList
151150
)
152-
import Distribution.Utils.String (trim)
153151

154152
import Distribution.Client.HttpUtils
155153
import Distribution.Client.ParseUtils
@@ -200,7 +198,7 @@ import qualified Data.ByteString.Char8 as BS
200198
import Data.Functor ((<&>))
201199
import qualified Data.Map as Map
202200
import qualified Data.Set as Set
203-
import Network.URI (URI (..), nullURIAuth, parseURI)
201+
import Network.URI (URI (..), nullURIAuth)
204202
import System.Directory (createDirectoryIfMissing, makeAbsolute)
205203
import System.FilePath (isAbsolute, isPathSeparator, makeValid, splitFileName, (</>))
206204
import Text.PrettyPrint
@@ -263,7 +261,7 @@ parseProject rootPath cacheDir httpTransport verbosity configToParse =
263261
do
264262
let (dir, projectFileName) = splitFileName rootPath
265263
projectDir <- makeAbsolute dir
266-
projectPath <- canonicalizeConfigPath projectDir (ProjectConfigPath $ projectFileName :| [])
264+
projectPath <- canonicalizeConfigPath projectDir (PCPWithoutImports projectFileName)
267265
parseProjectSkeleton cacheDir httpTransport verbosity projectDir projectPath configToParse
268266
-- NOTE: Reverse the warnings so they are in line number order.
269267
<&> \case ProjectParseOk ws x -> ProjectParseOk (reverse ws) x; x -> x
@@ -285,7 +283,7 @@ parseProjectSkeleton cacheDir httpTransport verbosity projectDir source (Project
285283
go :: [ParseUtils.Field] -> [ParseUtils.Field] -> IO (ProjectParseResult ProjectConfigSkeleton)
286284
go acc (x : xs) = case x of
287285
(ParseUtils.F _ "import" importLoc) -> do
288-
let importLocPath = importLoc `consProjectConfigPath` source
286+
importLocPath <- maybe (throwIO $ InvalidURIImport importLoc) pure $ parseLeaf importLoc `consProjectConfigPath` source
289287

290288
-- Once we canonicalize the import path, we can check for cyclical imports
291289
normSource <- canonicalizeConfigPath projectDir source
@@ -295,9 +293,6 @@ parseProjectSkeleton cacheDir httpTransport verbosity projectDir source (Project
295293
if isCyclicConfigPath normLocPath
296294
then pure . projectParseFail Nothing (Just normSource) $ ParseUtils.FromString (render $ cyclicalImportMsg normLocPath) Nothing
297295
else do
298-
when
299-
(isUntrimmedUriConfigPath importLocPath)
300-
(noticeDoc verbosity $ untrimmedUriImportMsg (Disp.text "Warning:") importLocPath)
301296
let fs = (\z -> CondNode z [normLocPath] mempty) <$> fieldsToConfig normSource (reverse acc)
302297
res <- parseProjectSkeleton cacheDir httpTransport verbosity projectDir importLocPath . ProjectConfigToParse =<< fetchImportConfig normLocPath
303298
rest <- go [] xs
@@ -367,20 +362,21 @@ parseProjectSkeleton cacheDir httpTransport verbosity projectDir source (Project
367362
liftPR p _ (ParseFailed e) = pure $ projectParseFail Nothing (Just p) e
368363

369364
fetchImportConfig :: ProjectConfigPath -> IO BS.ByteString
370-
fetchImportConfig (ProjectConfigPath (pci :| _)) = do
371-
debug verbosity $ "fetching import: " ++ pci
372-
fetch pci
373-
374-
fetch :: FilePath -> IO BS.ByteString
375-
fetch pci = case parseURI $ trim pci of
376-
Just uri -> do
377-
let fp = cacheDir </> map (\x -> if isPathSeparator x then '_' else x) (makeValid $ show uri)
378-
createDirectoryIfMissing True cacheDir
379-
_ <- downloadURI httpTransport verbosity uri fp
380-
BS.readFile fp
381-
Nothing ->
382-
BS.readFile $
383-
if isAbsolute pci then pci else coerce projectDir </> pci
365+
fetchImportConfig pcp = do
366+
let readPFile pci = BS.readFile $ if isAbsolute pci then pci else coerce projectDir </> pci
367+
case pcp of
368+
PCPWithoutImports fp -> do
369+
debug verbosity $ "reading import: " ++ fp
370+
readPFile fp
371+
PCPWithImports (PCPFilePath fp) _ -> do
372+
debug verbosity $ "reading import: " ++ fp
373+
readPFile fp
374+
PCPWithImports (PCPURI uri) _ -> do
375+
let fp = cacheDir </> map (\x -> if isPathSeparator x then '_' else x) (makeValid $ show uri)
376+
debug verbosity $ "fetching import: " ++ show uri
377+
createDirectoryIfMissing True cacheDir
378+
_ <- downloadURI httpTransport verbosity uri fp
379+
BS.readFile fp
384380

385381
modifiesCompiler :: ProjectConfig -> Bool
386382
modifiesCompiler pc = isSet projectConfigHcFlavor || isSet projectConfigHcPath || isSet projectConfigHcPkg
@@ -1290,7 +1286,7 @@ parseLegacyProjectConfigFields (ConstraintSourceProjectConfig -> constraintSrc)
12901286

12911287
parseLegacyProjectConfig :: FilePath -> BS.ByteString -> ParseResult LegacyProjectConfig
12921288
parseLegacyProjectConfig rootConfig bs =
1293-
parseLegacyProjectConfigFields (ProjectConfigPath $ rootConfig :| []) =<< ParseUtils.readFields bs
1289+
parseLegacyProjectConfigFields (PCPWithoutImports rootConfig) =<< ParseUtils.readFields bs
12941290

12951291
showLegacyProjectConfig :: LegacyProjectConfig -> String
12961292
showLegacyProjectConfig config =

‎cabal-install/src/Distribution/Client/ProjectConfig/Parsec.hs‎

Lines changed: 19 additions & 23 deletions
Original file line numberDiff line numberDiff line change
@@ -40,15 +40,14 @@ import Distribution.Parsec.Warning (PWarnType (..))
4040
import Distribution.Simple.Program.Db (ProgramDb, defaultProgramDb, knownPrograms, lookupKnownProgram)
4141
import Distribution.Simple.Program.Types (programName)
4242
import Distribution.Simple.Setup
43-
import Distribution.Simple.Utils (debug, noticeDoc)
43+
import Distribution.Simple.Utils (debug)
4444
import Distribution.Solver.Types.ProjectConfigPath
4545
import Distribution.System (buildOS)
4646
import Distribution.Types.CondTree (CondBranch (..), CondTree (..))
4747
import Distribution.Types.ConfVar (ConfVar (..))
4848
import Distribution.Types.PackageName (PackageName)
4949
import Distribution.Utils.Generic (fromUTF8BS, toUTF8BS, validateUTF8)
5050
import Distribution.Utils.NubList (toNubList)
51-
import Distribution.Utils.String (trim)
5251
import Distribution.Verbosity
5352

5453
import Control.Monad.State.Strict (StateT, execStateT, lift)
@@ -58,12 +57,11 @@ import qualified Data.Map.Strict as Map
5857
import qualified Data.Set as Set
5958
import Distribution.Client.Errors.Parser (ProjectFileSource (..))
6059
import qualified Distribution.Compat.CharParsing as P
61-
import Network.URI (parseURI, uriFragment, uriPath, uriScheme)
60+
import Network.URI (uriFragment, uriPath, uriScheme)
6261
import System.Directory (createDirectoryIfMissing, makeAbsolute)
6362
import System.FilePath (isAbsolute, isPathSeparator, makeValid, splitFileName, (</>))
6463
import qualified Text.Parsec
6564
import Text.PrettyPrint (render)
66-
import qualified Text.PrettyPrint as Disp
6765

6866
singletonProjectConfigSkeleton :: ProjectConfig -> ProjectConfigSkeleton
6967
singletonProjectConfigSkeleton x = CondNode x mempty mempty
@@ -99,7 +97,7 @@ parseProject
9997
parseProject rootPath cacheDir httpTransport verbosity configToParse = do
10098
let (dir, projectFileName) = splitFileName rootPath
10199
projectDir <- makeAbsolute dir
102-
projectPath <- canonicalizeConfigPath projectDir (ProjectConfigPath $ projectFileName :| [])
100+
projectPath <- canonicalizeConfigPath projectDir (PCPWithoutImports projectFileName)
103101
parseProjectSkeleton cacheDir httpTransport verbosity projectDir projectPath configToParse
104102

105103
parseProjectSkeleton
@@ -123,7 +121,7 @@ parseProjectSkeleton cacheDir httpTransport verbosity projectDir source (Project
123121
(Field (Name pos name) importLines) | name == "import" -> do
124122
liftParseResult
125123
( \importLoc -> do
126-
let importLocPath = importLoc `consProjectConfigPath` source
124+
importLocPath <- maybe (throwIO $ InvalidURIImport importLoc) pure $ parseLeaf importLoc `consProjectConfigPath` source
127125

128126
-- Once we canonicalize the import path, we can check for cyclical imports
129127
normSource <- canonicalizeConfigPath projectDir source
@@ -133,9 +131,6 @@ parseProjectSkeleton cacheDir httpTransport verbosity projectDir source (Project
133131
if isCyclicConfigPath normLocPath
134132
then pure $ parseFatalFailure pos (render $ cyclicalImportMsg normLocPath)
135133
else do
136-
when
137-
(isUntrimmedUriConfigPath importLocPath)
138-
(noticeDoc verbosity $ untrimmedUriImportMsg (Disp.text "Warning:") importLocPath)
139134
let fs = (\z -> CondNode z [normLocPath] mempty) <$> fieldsToConfig normSource (reverse acc)
140135
importParseResult <- parseProjectSkeleton cacheDir httpTransport verbosity projectDir importLocPath . ProjectConfigToParse =<< fetchImportConfig normLocPath
141136

@@ -192,20 +187,21 @@ parseProjectSkeleton cacheDir httpTransport verbosity projectDir source (Project
192187
return config'
193188

194189
fetchImportConfig :: ProjectConfigPath -> IO BS.ByteString
195-
fetchImportConfig (ProjectConfigPath (pci :| _)) = do
196-
debug verbosity $ "fetching import: " ++ pci
197-
fetch pci
198-
199-
fetch :: FilePath -> IO BS.ByteString
200-
fetch pci = case parseURI (trim pci) of
201-
Just uri -> do
202-
let fp = cacheDir </> map (\x -> if isPathSeparator x then '_' else x) (makeValid $ show uri)
203-
createDirectoryIfMissing True cacheDir
204-
_ <- downloadURI httpTransport verbosity uri fp
205-
BS.readFile fp
206-
Nothing ->
207-
BS.readFile $
208-
if isAbsolute pci then pci else coerce projectDir </> pci
190+
fetchImportConfig pcp = do
191+
let readPFile pci = BS.readFile $ if isAbsolute pci then pci else coerce projectDir </> pci
192+
case pcp of
193+
PCPWithoutImports fp -> do
194+
debug verbosity $ "reading import: " ++ fp
195+
readPFile fp
196+
PCPWithImports (PCPFilePath fp) _ -> do
197+
debug verbosity $ "reading import: " ++ fp
198+
readPFile fp
199+
PCPWithImports (PCPURI uri) _ -> do
200+
let fp = cacheDir </> map (\x -> if isPathSeparator x then '_' else x) (makeValid $ show uri)
201+
debug verbosity $ "fetching import: " ++ show uri
202+
createDirectoryIfMissing True cacheDir
203+
_ <- downloadURI httpTransport verbosity uri fp
204+
BS.readFile fp
209205

210206
modifiesCompiler :: ProjectConfig -> Bool
211207
modifiesCompiler pc = isSet projectConfigHcFlavor || isSet projectConfigHcPath || isSet projectConfigHcPkg

‎cabal-install/src/Distribution/Client/ProjectConfig/Types.hs‎

Lines changed: 9 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -24,6 +24,9 @@ module Distribution.Client.ProjectConfig.Types
2424
-- * Extra useful Monoids
2525
, MapLast (..)
2626
, MapMappend (..)
27+
28+
-- * Exceptions
29+
, ProjectFileParseError (..)
2730
) where
2831

2932
import Distribution.Client.Compat.Prelude
@@ -525,3 +528,9 @@ data BuildTimeSettings = BuildTimeSettings
525528
deriving (Generic)
526529

527530
instance NFData BuildTimeSettings
531+
532+
data ProjectFileParseError = InvalidURIImport String
533+
deriving (Show)
534+
535+
instance Exception ProjectFileParseError where
536+
displayException (InvalidURIImport uri) = "URI import " <> uri <> " not valid here. URI imports must be at the end of the import chain only."

0 commit comments

Comments
 (0)