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

   1 {-# LANGUAGE CPP #-}
   2 {-# LANGUAGE DeriveDataTypeable #-}
   3 {-# LANGUAGE LambdaCase #-}
   4 {-# LANGUAGE NamedFieldPuns #-}
   5 {-# LANGUAGE RecordWildCards #-}
   6
   7 -- | Handling project configuration.
   8 module Distribution.Client.ProjectConfig
   9   ( -- * Types for project config
  10     ProjectConfig (..)
  11   , ProjectConfigBuildOnly (..)
  12   , ProjectConfigShared (..)
  13   , ProjectConfigProvenance (..)
  14   , PackageConfig (..)
  15   , MapLast (..)
  16   , MapMappend (..)
  17
  18     -- * Project root
  19   , findProjectRoot
  20   , ProjectRoot (..)
  21   , BadProjectRoot
  22
  23     -- * Project config files
  24   , readProjectConfig
  25   , readGlobalConfig
  26   , readProjectLocalExtraConfig
  27   , readProjectLocalFreezeConfig
  28   , reportParseResult
  29   , showProjectConfig
  30   , withGlobalConfig
  31   , withProjectOrGlobalConfig
  32   , writeProjectLocalExtraConfig
  33   , writeProjectLocalFreezeConfig
  34   , writeProjectConfigFile
  35   , commandLineFlagsToProjectConfig
  36
  37     -- * Packages within projects
  38   , ProjectPackageLocation (..)
  39   , BadPackageLocations (..)
  40   , BadPackageLocation (..)
  41   , BadPackageLocationMatch (..)
  42   , findProjectPackages
  43   , fetchAndReadSourcePackages
  44
  45     -- * Resolving configuration
  46   , lookupLocalPackageConfig
  47   , projectConfigWithBuilderRepoContext
  48   , projectConfigWithSolverRepoContext
  49   , SolverSettings (..)
  50   , resolveSolverSettings
  51   , BuildTimeSettings (..)
  52   , resolveBuildTimeSettings
  53
  54     -- * Checking configuration
  55   , checkBadPerPackageCompilerPaths
  56   , BadPerPackageCompilerPaths (..)
  57   ) where
  58
  59 import Distribution.Client.Compat.Prelude
  60 import Prelude ()
  61
  62 import Distribution.Client.Glob
  63   ( isTrivialFilePathGlob
  64   )
  65 import Distribution.Client.ProjectConfig.Legacy
  66 import Distribution.Client.ProjectConfig.Types
  67 import Distribution.Client.RebuildMonad
  68 import Distribution.Client.VCS
  69   ( SourceRepoProblem (..)
  70   , VCS (..)
  71   , configureVCS
  72   , knownVCSs
  73   , syncSourceRepos
  74   , validateSourceRepos
  75   )
  76
  77 import Distribution.Client.BuildReports.Types
  78   ( ReportLevel (..)
  79   )
  80 import Distribution.Client.Config
  81   ( getConfigFilePath
  82   , loadConfig
  83   )
  84 import Distribution.Client.DistDirLayout
  85   ( CabalDirLayout (..)
  86   , DistDirLayout (..)
  87   , ProjectRoot (..)
  88   , defaultProjectFile
  89   )
  90 import Distribution.Client.GlobalFlags
  91   ( RepoContext (..)
  92   , withRepoContext'
  93   )
  94 import Distribution.Client.HttpUtils
  95   ( HttpTransport
  96   , configureTransport
  97   , downloadURI
  98   , transportCheckHttps
  99   )
 100 import Distribution.Client.Types
 101 import Distribution.Client.Utils.Parsec (renderParseError)
 102
 103 import Distribution.Solver.Types.PackageConstraint
 104   ( PackageProperty (..)
 105   )
 106 import Distribution.Solver.Types.Settings
 107 import Distribution.Solver.Types.SourcePackage
 108
 109 import Distribution.Client.Setup
 110   ( defaultMaxBackjumps
 111   , defaultSolver
 112   )
 113 import Distribution.Client.SrcDist
 114   ( packageDirToSdist
 115   )
 116 import Distribution.Client.Types.SourceRepo
 117   ( SourceRepoList
 118   , SourceRepositoryPackage (..)
 119   , srpFanOut
 120   )
 121 import Distribution.Client.Utils
 122   ( determineNumJobs
 123   )
 124 import qualified Distribution.Deprecated.ParseUtils as OldParser
 125   ( ParseResult (..)
 126   , locatedErrorMsg
 127   , showPWarning
 128   )
 129 import Distribution.Fields
 130   ( PError
 131   , PWarning
 132   , runParseResult
 133   , showPWarning
 134   )
 135 import Distribution.Package
 136   ( PackageId
 137   , PackageName
 138   , UnitId
 139   , packageId
 140   )
 141 import Distribution.PackageDescription.Parsec
 142   ( parseGenericPackageDescription
 143   )
 144 import Distribution.Simple.Compiler
 145   ( Compiler
 146   , compilerInfo
 147   )
 148 import Distribution.Simple.InstallDirs
 149   ( PathTemplate
 150   , fromPathTemplate
 151   , initialPathTemplateEnv
 152   , substPathTemplate
 153   , toPathTemplate
 154   )
 155 import Distribution.Simple.Program
 156   ( ConfiguredProgram (..)
 157   )
 158 import Distribution.Simple.Setup
 159   ( Flag (Flag)
 160   , flagToList
 161   , flagToMaybe
 162   , fromFlag
 163   , fromFlagOrDefault
 164   , toFlag
 165   )
 166 import Distribution.Simple.Utils
 167   ( createDirectoryIfMissingVerbose
 168   , dieWithException
 169   , info
 170   , maybeExit
 171   , notice
 172   , rawSystemIOWithEnv
 173   , warn
 174   )
 175 import Distribution.System
 176   ( Platform
 177   )
 178 import Distribution.Types.GenericPackageDescription
 179   ( GenericPackageDescription
 180   )
 181 import Distribution.Types.PackageVersionConstraint
 182   ( PackageVersionConstraint (..)
 183   )
 184 import Distribution.Types.SourceRepo
 185   ( RepoType (..)
 186   )
 187 import Distribution.Utils.NubList
 188   ( fromNubList
 189   )
 190 import Distribution.Verbosity
 191   ( modifyVerbosity
 192   , verbose
 193   )
 194 import Distribution.Version
 195   ( Version
 196   )
 197
 198 import qualified Codec.Archive.Tar as Tar
 199 import qualified Codec.Archive.Tar.Entry as Tar
 200 import qualified Distribution.Client.GZipUtils as GZipUtils
 201 import qualified Distribution.Client.Tar as Tar
 202
 203 import Control.Monad.Trans (liftIO)
 204 import qualified Data.ByteString as BS
 205 import qualified Data.ByteString.Lazy as LBS
 206 import qualified Data.Hashable as Hashable
 207 import qualified Data.List.NonEmpty as NE
 208 import qualified Data.Map as Map
 209 import qualified Data.Set as Set
 210 import Numeric (showHex)
 211
 212 import Distribution.Client.Errors
 213 import Network.URI
 214   ( URI (..)
 215   , URIAuth (..)
 216   , parseAbsoluteURI
 217   , uriToString
 218   )
 219 import System.Directory
 220 import System.FilePath hiding (combine)
 221 import System.IO
 222   ( IOMode (ReadMode)
 223   , withBinaryFile
 224   )
 225
 226 ----------------------------------------
 227 -- Resolving configuration to settings
 228 --
 229
 230 -- | Look up a 'PackageConfig' field in the 'ProjectConfig' for a specific
 231 -- 'PackageName'. This returns the configuration that applies to all local
 232 -- packages plus any package-specific configuration for this package.
 233 lookupLocalPackageConfig
 234   :: (Semigroup a, Monoid a)
 235   => (PackageConfig -> a)
 236   -> ProjectConfig
 237   -> PackageName
 238   -> a
 239 lookupLocalPackageConfig
 240   field
 241   ProjectConfig
 242     { projectConfigLocalPackages
 243     , projectConfigSpecificPackage
 244     }
 245   pkgname =
 246     field projectConfigLocalPackages
 247       <> maybe
 248         mempty
 249         field
 250         (Map.lookup pkgname (getMapMappend projectConfigSpecificPackage))
 251
 252 -- | Use a 'RepoContext' based on the 'BuildTimeSettings'.
 253 projectConfigWithBuilderRepoContext
 254   :: Verbosity
 255   -> BuildTimeSettings
 256   -> (RepoContext -> IO a)
 257   -> IO a
 258 projectConfigWithBuilderRepoContext verbosity BuildTimeSettings{..} =
 259   withRepoContext'
 260     verbosity
 261     buildSettingRemoteRepos
 262     buildSettingLocalNoIndexRepos
 263     buildSettingCacheDir
 264     buildSettingHttpTransport
 265     (Just buildSettingIgnoreExpiry)
 266     buildSettingProgPathExtra
 267
 268 -- | Use a 'RepoContext', but only for the solver. The solver does not use the
 269 -- full facilities of the 'RepoContext' so we can get away with making one
 270 -- that doesn't have an http transport. And that avoids having to have access
 271 -- to the 'BuildTimeSettings'
 272 projectConfigWithSolverRepoContext
 273   :: Verbosity
 274   -> ProjectConfigShared
 275   -> ProjectConfigBuildOnly
 276   -> (RepoContext -> IO a)
 277   -> IO a
 278 projectConfigWithSolverRepoContext
 279   verbosity
 280   ProjectConfigShared{..}
 281   ProjectConfigBuildOnly{..} =
 282     withRepoContext'
 283       verbosity
 284       (fromNubList projectConfigRemoteRepos)
 285       (fromNubList projectConfigLocalNoIndexRepos)
 286       ( fromFlagOrDefault
 287           ( error
 288               "projectConfigWithSolverRepoContext: projectConfigCacheDir"
 289           )
 290           projectConfigCacheDir
 291       )
 292       (flagToMaybe projectConfigHttpTransport)
 293       (flagToMaybe projectConfigIgnoreExpiry)
 294       (fromNubList projectConfigProgPathExtra)
 295
 296 -- | Resolve the project configuration, with all its optional fields, into
 297 -- 'SolverSettings' with no optional fields (by applying defaults).
 298 resolveSolverSettings :: ProjectConfig -> SolverSettings
 299 resolveSolverSettings
 300   ProjectConfig
 301     { projectConfigShared
 302     , projectConfigLocalPackages
 303     , projectConfigSpecificPackage
 304     } =
 305     SolverSettings{..}
 306     where
 307       -- TODO: [required eventually] some of these settings need validation, e.g.
 308       -- the flag assignments need checking.
 309       solverSettingRemoteRepos = fromNubList projectConfigRemoteRepos
 310       solverSettingLocalNoIndexRepos = fromNubList projectConfigLocalNoIndexRepos
 311       solverSettingConstraints = projectConfigConstraints
 312       solverSettingPreferences = projectConfigPreferences
 313       solverSettingFlagAssignment = packageConfigFlagAssignment projectConfigLocalPackages
 314       solverSettingFlagAssignments =
 315         fmap
 316           packageConfigFlagAssignment
 317           (getMapMappend projectConfigSpecificPackage)
 318       solverSettingCabalVersion = flagToMaybe projectConfigCabalVersion
 319       solverSettingSolver = fromFlag projectConfigSolver
 320       solverSettingAllowOlder = fromMaybe mempty projectConfigAllowOlder
 321       solverSettingAllowNewer = fromMaybe mempty projectConfigAllowNewer
 322       solverSettingMaxBackjumps = case fromFlag projectConfigMaxBackjumps of
 323         n
 324           | n < 0 -> Nothing
 325           | otherwise -> Just n
 326       solverSettingReorderGoals = fromFlag projectConfigReorderGoals
 327       solverSettingCountConflicts = fromFlag projectConfigCountConflicts
 328       solverSettingFineGrainedConflicts = fromFlag projectConfigFineGrainedConflicts
 329       solverSettingMinimizeConflictSet = fromFlag projectConfigMinimizeConflictSet
 330       solverSettingStrongFlags = fromFlag projectConfigStrongFlags
 331       solverSettingAllowBootLibInstalls = fromFlag projectConfigAllowBootLibInstalls
 332       solverSettingOnlyConstrained = fromFlag projectConfigOnlyConstrained
 333       solverSettingIndexState = flagToMaybe projectConfigIndexState
 334       solverSettingActiveRepos = flagToMaybe projectConfigActiveRepos
 335       solverSettingIndependentGoals = fromFlag projectConfigIndependentGoals
 336       solverSettingPreferOldest = fromFlag projectConfigPreferOldest
 337       -- solverSettingShadowPkgs        = fromFlag projectConfigShadowPkgs
 338       -- solverSettingReinstall         = fromFlag projectConfigReinstall
 339       -- solverSettingAvoidReinstalls   = fromFlag projectConfigAvoidReinstalls
 340       -- solverSettingOverrideReinstall = fromFlag projectConfigOverrideReinstall
 341       -- solverSettingUpgradeDeps       = fromFlag projectConfigUpgradeDeps
 342
 343       ProjectConfigShared{..} = defaults <> projectConfigShared
 344
 345       defaults =
 346         mempty
 347           { projectConfigSolver = Flag defaultSolver
 348           , projectConfigAllowOlder = Just (AllowOlder mempty)
 349           , projectConfigAllowNewer = Just (AllowNewer mempty)
 350           , projectConfigMaxBackjumps = Flag defaultMaxBackjumps
 351           , projectConfigReorderGoals = Flag (ReorderGoals False)
 352           , projectConfigCountConflicts = Flag (CountConflicts True)
 353           , projectConfigFineGrainedConflicts = Flag (FineGrainedConflicts True)
 354           , projectConfigMinimizeConflictSet = Flag (MinimizeConflictSet False)
 355           , projectConfigStrongFlags = Flag (StrongFlags False)
 356           , projectConfigAllowBootLibInstalls = Flag (AllowBootLibInstalls False)
 357           , projectConfigOnlyConstrained = Flag OnlyConstrainedNone
 358           , projectConfigIndependentGoals = Flag (IndependentGoals False)
 359           , projectConfigPreferOldest = Flag (PreferOldest False)
 360           -- projectConfigShadowPkgs        = Flag False,
 361           -- projectConfigReinstall         = Flag False,
 362           -- projectConfigAvoidReinstalls   = Flag False,
 363           -- projectConfigOverrideReinstall = Flag False,
 364           -- projectConfigUpgradeDeps       = Flag False
 365           }
 366
 367 -- | Resolve the project configuration, with all its optional fields, into
 368 -- 'BuildTimeSettings' with no optional fields (by applying defaults).
 369 resolveBuildTimeSettings
 370   :: Verbosity
 371   -> CabalDirLayout
 372   -> ProjectConfig
 373   -> BuildTimeSettings
 374 resolveBuildTimeSettings
 375   verbosity
 376   CabalDirLayout
 377     { cabalLogsDirectory
 378     }
 379   ProjectConfig
 380     { projectConfigShared =
 381       ProjectConfigShared
 382         { projectConfigRemoteRepos
 383         , projectConfigLocalNoIndexRepos
 384         , projectConfigProgPathExtra
 385         }
 386     , projectConfigBuildOnly
 387     } =
 388     BuildTimeSettings{..}
 389     where
 390       buildSettingDryRun = fromFlag projectConfigDryRun
 391       buildSettingOnlyDeps = fromFlag projectConfigOnlyDeps
 392       buildSettingOnlyDownload = fromFlag projectConfigOnlyDownload
 393       buildSettingSummaryFile = fromNubList projectConfigSummaryFile
 394       -- buildSettingLogFile       -- defined below, more complicated
 395       -- buildSettingLogVerbosity  -- defined below, more complicated
 396       buildSettingBuildReports = fromFlag projectConfigBuildReports
 397       buildSettingSymlinkBinDir = flagToList projectConfigSymlinkBinDir
 398       buildSettingNumJobs =
 399         if fromFlag projectConfigUseSemaphore
 400           then UseSem (determineNumJobs projectConfigNumJobs)
 401           else case (determineNumJobs projectConfigNumJobs) of
 402             1 -> Serial
 403             n -> NumJobs (Just n)
 404       buildSettingKeepGoing = fromFlag projectConfigKeepGoing
 405       buildSettingOfflineMode = fromFlag projectConfigOfflineMode
 406       buildSettingKeepTempFiles = fromFlag projectConfigKeepTempFiles
 407       buildSettingRemoteRepos = fromNubList projectConfigRemoteRepos
 408       buildSettingLocalNoIndexRepos = fromNubList projectConfigLocalNoIndexRepos
 409       buildSettingCacheDir = fromFlag projectConfigCacheDir
 410       buildSettingHttpTransport = flagToMaybe projectConfigHttpTransport
 411       buildSettingIgnoreExpiry = fromFlag projectConfigIgnoreExpiry
 412       buildSettingReportPlanningFailure =
 413         fromFlag projectConfigReportPlanningFailure
 414       buildSettingProgPathExtra = fromNubList projectConfigProgPathExtra
 415       buildSettingHaddockOpen = False
 416
 417       ProjectConfigBuildOnly{..} =
 418         defaults
 419           <> projectConfigBuildOnly
 420
 421       defaults =
 422         mempty
 423           { projectConfigDryRun = toFlag False
 424           , projectConfigOnlyDeps = toFlag False
 425           , projectConfigOnlyDownload = toFlag False
 426           , projectConfigBuildReports = toFlag NoReports
 427           , projectConfigReportPlanningFailure = toFlag False
 428           , projectConfigKeepGoing = toFlag False
 429           , projectConfigOfflineMode = toFlag False
 430           , projectConfigKeepTempFiles = toFlag False
 431           , projectConfigIgnoreExpiry = toFlag False
 432           }
 433
 434       -- The logging logic: what log file to use and what verbosity.
 435       --
 436       -- If the user has specified --remote-build-reporting=detailed, use the
 437       -- default log file location. If the --build-log option is set, use the
 438       -- provided location. Otherwise don't use logging, unless building in
 439       -- parallel (in which case the default location is used).
 440       --
 441       buildSettingLogFile
 442         :: Maybe
 443             ( Compiler
 444               -> Platform
 445               -> PackageId
 446               -> UnitId
 447               -> FilePath
 448             )
 449       buildSettingLogFile
 450         | useDefaultTemplate = Just (substLogFileName defaultTemplate)
 451         | otherwise = fmap substLogFileName givenTemplate
 452
 453       defaultTemplate =
 454         toPathTemplate $
 455           cabalLogsDirectory
 456             </> "$compiler"
 457             </> "$libname"
 458             <.> "log"
 459       givenTemplate = flagToMaybe projectConfigLogFile
 460
 461       useDefaultTemplate
 462         | buildSettingBuildReports == DetailedReports = True
 463         | isJust givenTemplate = False
 464         | isParallelBuild buildSettingNumJobs = True
 465         | otherwise = False
 466
 467       substLogFileName
 468         :: PathTemplate
 469         -> Compiler
 470         -> Platform
 471         -> PackageId
 472         -> UnitId
 473         -> FilePath
 474       substLogFileName template compiler platform pkgid uid =
 475         fromPathTemplate (substPathTemplate env template)
 476         where
 477           env =
 478             initialPathTemplateEnv
 479               pkgid
 480               uid
 481               (compilerInfo compiler)
 482               platform
 483
 484       -- If the user has specified --remote-build-reporting=detailed or
 485       -- --build-log, use more verbose logging.
 486       --
 487       buildSettingLogVerbosity :: Verbosity
 488       buildSettingLogVerbosity
 489         | overrideVerbosity = modifyVerbosity (max verbose) verbosity
 490         | otherwise = verbosity
 491
 492       overrideVerbosity :: Bool
 493       overrideVerbosity
 494         | buildSettingBuildReports == DetailedReports = True
 495         | isJust givenTemplate = True
 496         | isParallelBuild buildSettingNumJobs = False
 497         | otherwise = False
 498
 499 ---------------------------------------------
 500 -- Reading and writing project config files
 501 --
 502
 503 -- | Find the root of this project.
 504 --
 505 -- The project directory will be one of the following:
 506 --   1. @mprojectDir@ when present
 507 --   2. The first directory containing @mprojectFile@/@cabal.project@, starting from the current directory
 508 --      and recursively checking parent directories
 509 --   3. The current directory
 510 findProjectRoot
 511   :: Verbosity
 512   -> Maybe FilePath
 513   -- ^ Explicit project directory
 514   -> Maybe FilePath
 515   -- ^ Explicit project file
 516   -> IO (Either BadProjectRoot ProjectRoot)
 517 findProjectRoot verbosity mprojectDir mprojectFile = do
 518   case mprojectDir of
 519     Nothing
 520       | Just file <- mprojectFile
 521       , isAbsolute file -> do
 522           warn verbosity $
 523             "Specifying an absolute path to the project file is deprecated."
 524               <> " Use --project-dir to set the project's directory."
 525
 526           doesFileExist file >>= \case
 527             False -> left (BadProjectRootExplicitFile file)
 528             True -> uncurry projectRoot =<< first dropTrailingPathSeparator . splitFileName <$> canonicalizePath file
 529       | otherwise -> probeProjectRoot mprojectFile
 530     Just dir ->
 531       doesDirectoryExist dir >>= \case
 532         False -> left (BadProjectRootDir dir)
 533         True -> do
 534           projectDir <- canonicalizePath dir
 535
 536           case mprojectFile of
 537             Nothing -> pure $ Right (ProjectRootExplicit projectDir defaultProjectFile)
 538             Just projectFile
 539               | isAbsolute projectFile ->
 540                   doesFileExist projectFile >>= \case
 541                     False -> left (BadProjectRootAbsoluteFile projectFile)
 542                     True -> Right . ProjectRootExplicitAbsolute dir <$> canonicalizePath projectFile
 543               | otherwise ->
 544                   doesFileExist (projectDir </> projectFile) >>= \case
 545                     False -> left (BadProjectRootDirFile dir projectFile)
 546                     True -> projectRoot projectDir projectFile
 547   where
 548     left = pure . Left
 549
 550     projectRoot projectDir projectFile =
 551       pure $ Right (ProjectRootExplicit projectDir projectFile)
 552
 553 probeProjectRoot :: Maybe FilePath -> IO (Either BadProjectRoot ProjectRoot)
 554 probeProjectRoot mprojectFile = do
 555   startdir <- getCurrentDirectory
 556   homedir <- getHomeDirectory
 557   probe startdir homedir
 558   where
 559     projectFileName :: String
 560     projectFileName = fromMaybe defaultProjectFile mprojectFile
 561
 562     -- Search upwards. If we get to the users home dir or the filesystem root,
 563     -- then use the current dir
 564     probe :: FilePath -> String -> IO (Either BadProjectRoot ProjectRoot)
 565     probe startdir homedir = go startdir
 566       where
 567         go :: FilePath -> IO (Either BadProjectRoot ProjectRoot)
 568         go dir | isDrive dir || dir == homedir =
 569           case mprojectFile of
 570             Nothing -> return (Right (ProjectRootImplicit startdir))
 571             Just file -> return (Left (BadProjectRootExplicitFile file))
 572         go dir = do
 573           exists <- doesFileExist (dir </> projectFileName)
 574           if exists
 575             then return (Right (ProjectRootExplicit dir projectFileName))
 576             else go (takeDirectory dir)
 577
 578 -- | Errors returned by 'findProjectRoot'.
 579 data BadProjectRoot
 580   = BadProjectRootExplicitFile FilePath
 581   | BadProjectRootDir FilePath
 582   | BadProjectRootAbsoluteFile FilePath
 583   | BadProjectRootDirFile FilePath FilePath
 584 #if MIN_VERSION_base(4,8,0)
 585   deriving (Show, Typeable)
 586 #else
 587   deriving (Typeable)
 588
 589 instance Show BadProjectRoot where
 590   show = renderBadProjectRoot
 591 #endif
 592
 593 #if MIN_VERSION_base(4,8,0)
 594 instance Exception BadProjectRoot where
 595   displayException = renderBadProjectRoot
 596 #else
 597 instance Exception BadProjectRoot
 598 #endif
 599
 600 renderBadProjectRoot :: BadProjectRoot -> String
 601 renderBadProjectRoot = \case
 602   BadProjectRootExplicitFile projectFile ->
 603     "The given project file '" ++ projectFile ++ "' does not exist."
 604   BadProjectRootDir dir ->
 605     "The given project directory '" <> dir <> "' does not exist."
 606   BadProjectRootAbsoluteFile file ->
 607     "The given project file '" <> file <> "' does not exist."
 608   BadProjectRootDirFile dir file ->
 609     "The given project directory/file combination '" <> dir </> file <> "' does not exist."
 610
 611 withGlobalConfig
 612   :: Verbosity
 613   -- ^ verbosity
 614   -> Flag FilePath
 615   -- ^ @--cabal-config@
 616   -> (ProjectConfig -> IO a)
 617   -- ^ with global
 618   -> IO a
 619 withGlobalConfig verbosity gcf with = do
 620   globalConfig <- runRebuild "" $ readGlobalConfig verbosity gcf
 621   with globalConfig
 622
 623 withProjectOrGlobalConfig
 624   :: Verbosity
 625   -- ^ verbosity
 626   -> Flag Bool
 627   -- ^ whether to ignore local project (--ignore-project flag)
 628   -> Flag FilePath
 629   -- ^ @--cabal-config@
 630   -> IO a
 631   -- ^ with project
 632   -> (ProjectConfig -> IO a)
 633   -- ^ without project
 634   -> IO a
 635 withProjectOrGlobalConfig verbosity (Flag True) gcf _with without = do
 636   globalConfig <- runRebuild "" $ readGlobalConfig verbosity gcf
 637   without globalConfig
 638 withProjectOrGlobalConfig verbosity _ignorePrj gcf with without =
 639   withProjectOrGlobalConfig' verbosity gcf with without
 640
 641 withProjectOrGlobalConfig'
 642   :: Verbosity
 643   -> Flag FilePath
 644   -> IO a
 645   -> (ProjectConfig -> IO a)
 646   -> IO a
 647 withProjectOrGlobalConfig' verbosity globalConfigFlag with without = do
 648   globalConfig <- runRebuild "" $ readGlobalConfig verbosity globalConfigFlag
 649
 650   catch with $
 651     \case
 652       (BadPackageLocations prov locs)
 653         | prov == Set.singleton Implicit
 654         , let
 655             isGlobErr (BadLocGlobEmptyMatch _) = True
 656             isGlobErr _ = False
 657         , any isGlobErr locs ->
 658             without globalConfig
 659       err -> throwIO err
 660
 661 -- | Read all the config relevant for a project. This includes the project
 662 -- file if any, plus other global config.
 663 readProjectConfig
 664   :: Verbosity
 665   -> HttpTransport
 666   -> Flag Bool
 667   -- ^ @--ignore-project@
 668   -> Flag FilePath
 669   -> DistDirLayout
 670   -> Rebuild ProjectConfigSkeleton
 671 readProjectConfig verbosity _ (Flag True) configFileFlag _ = do
 672   global <- singletonProjectConfigSkeleton <$> readGlobalConfig verbosity configFileFlag
 673   return (global <> singletonProjectConfigSkeleton defaultImplicitProjectConfig)
 674 readProjectConfig verbosity httpTransport _ configFileFlag distDirLayout = do
 675   global <- singletonProjectConfigSkeleton <$> readGlobalConfig verbosity configFileFlag
 676   local <- readProjectLocalConfigOrDefault verbosity httpTransport distDirLayout
 677   freeze <- readProjectLocalFreezeConfig verbosity httpTransport distDirLayout
 678   extra <- readProjectLocalExtraConfig verbosity httpTransport distDirLayout
 679   return (global <> local <> freeze <> extra)
 680
 681 -- | Reads an explicit @cabal.project@ file in the given project root dir,
 682 -- or returns the default project config for an implicitly defined project.
 683 readProjectLocalConfigOrDefault
 684   :: Verbosity
 685   -> HttpTransport
 686   -> DistDirLayout
 687   -> Rebuild ProjectConfigSkeleton
 688 readProjectLocalConfigOrDefault verbosity httpTransport distDirLayout = do
 689   let projectFile = distProjectFile distDirLayout ""
 690   usesExplicitProjectRoot <- liftIO $ doesFileExist projectFile
 691   if usesExplicitProjectRoot
 692     then do
 693       readProjectFileSkeleton verbosity httpTransport distDirLayout "" "project file"
 694     else do
 695       monitorFiles [monitorNonExistentFile projectFile]
 696       return (singletonProjectConfigSkeleton defaultImplicitProjectConfig)
 697
 698 defaultImplicitProjectConfig :: ProjectConfig
 699 defaultImplicitProjectConfig =
 700   mempty
 701     { -- We expect a package in the current directory.
 702       projectPackages = ["./*.cabal"]
 703     , projectConfigProvenance = Set.singleton Implicit
 704     }
 705
 706 -- | Reads a @cabal.project.local@ file in the given project root dir,
 707 -- or returns empty. This file gets written by @cabal configure@, or in
 708 -- principle can be edited manually or by other tools.
 709 readProjectLocalExtraConfig
 710   :: Verbosity
 711   -> HttpTransport
 712   -> DistDirLayout
 713   -> Rebuild ProjectConfigSkeleton
 714 readProjectLocalExtraConfig verbosity httpTransport distDirLayout =
 715   readProjectFileSkeleton
 716     verbosity
 717     httpTransport
 718     distDirLayout
 719     "local"
 720     "project local configuration file"
 721
 722 -- | Reads a @cabal.project.freeze@ file in the given project root dir,
 723 -- or returns empty. This file gets written by @cabal freeze@, or in
 724 -- principle can be edited manually or by other tools.
 725 readProjectLocalFreezeConfig
 726   :: Verbosity
 727   -> HttpTransport
 728   -> DistDirLayout
 729   -> Rebuild ProjectConfigSkeleton
 730 readProjectLocalFreezeConfig verbosity httpTransport distDirLayout =
 731   readProjectFileSkeleton
 732     verbosity
 733     httpTransport
 734     distDirLayout
 735     "freeze"
 736     "project freeze file"
 737
 738 -- | Reads a named extended (with imports and conditionals) config file in the given project root dir, or returns empty.
 739 readProjectFileSkeleton :: Verbosity -> HttpTransport -> DistDirLayout -> String -> String -> Rebuild ProjectConfigSkeleton
 740 readProjectFileSkeleton
 741   verbosity
 742   httpTransport
 743   DistDirLayout{distProjectFile, distDownloadSrcDirectory}
 744   extensionName
 745   extensionDescription = do
 746     exists <- liftIO $ doesFileExist extensionFile
 747     if exists
 748       then do
 749         monitorFiles [monitorFileHashed extensionFile]
 750         pcs <- liftIO readExtensionFile
 751         monitorFiles $ map monitorFileHashed (projectSkeletonImports pcs)
 752         pure pcs
 753       else do
 754         monitorFiles [monitorNonExistentFile extensionFile]
 755         return mempty
 756     where
 757       extensionFile = distProjectFile extensionName
 758
 759       readExtensionFile =
 760         reportParseResult verbosity extensionDescription extensionFile
 761           =<< parseProjectSkeleton distDownloadSrcDirectory httpTransport verbosity [] extensionFile
 762           =<< BS.readFile extensionFile
 763
 764 -- | Render the 'ProjectConfig' format.
 765 --
 766 -- For the moment this is implemented in terms of a pretty printer for the
 767 -- legacy configuration types, plus a conversion.
 768 showProjectConfig :: ProjectConfig -> String
 769 showProjectConfig =
 770   showLegacyProjectConfig . convertToLegacyProjectConfig
 771
 772 -- | Write a @cabal.project.local@ file in the given project root dir.
 773 writeProjectLocalExtraConfig :: DistDirLayout -> ProjectConfig -> IO ()
 774 writeProjectLocalExtraConfig DistDirLayout{distProjectFile} =
 775   writeProjectConfigFile (distProjectFile "local")
 776
 777 -- | Write a @cabal.project.freeze@ file in the given project root dir.
 778 writeProjectLocalFreezeConfig :: DistDirLayout -> ProjectConfig -> IO ()
 779 writeProjectLocalFreezeConfig DistDirLayout{distProjectFile} =
 780   writeProjectConfigFile (distProjectFile "freeze")
 781
 782 -- | Write in the @cabal.project@ format to the given file.
 783 writeProjectConfigFile :: FilePath -> ProjectConfig -> IO ()
 784 writeProjectConfigFile file =
 785   writeFile file . showProjectConfig
 786
 787 -- | Read the user's cabal-install config file.
 788 readGlobalConfig :: Verbosity -> Flag FilePath -> Rebuild ProjectConfig
 789 readGlobalConfig verbosity configFileFlag = do
 790   config <- liftIO (loadConfig verbosity configFileFlag)
 791   configFile <- liftIO (getConfigFilePath configFileFlag)
 792   monitorFiles [monitorFileHashed configFile]
 793   return (convertLegacyGlobalConfig config)
 794
 795 reportParseResult :: Verbosity -> String -> FilePath -> OldParser.ParseResult ProjectConfigSkeleton -> IO ProjectConfigSkeleton
 796 reportParseResult verbosity _filetype filename (OldParser.ParseOk warnings x) = do
 797   unless (null warnings) $
 798     let msg = unlines (map (OldParser.showPWarning (intercalate ", " $ filename : projectSkeletonImports x)) warnings)
 799      in warn verbosity msg
 800   return x
 801 reportParseResult verbosity filetype filename (OldParser.ParseFailed err) =
 802   let (line, msg) = OldParser.locatedErrorMsg err
 803       errLineNo = maybe "" (\n -> ':' : show n) line
 804    in dieWithException verbosity $ ReportParseResult filetype filename errLineNo msg
 805
 806 ---------------------------------------------
 807 -- Finding packages in the project
 808 --
 809
 810 -- | The location of a package as part of a project. Local file paths are
 811 -- either absolute (if the user specified it as such) or they are relative
 812 -- to the project root.
 813 data ProjectPackageLocation
 814   = ProjectPackageLocalCabalFile FilePath
 815   | ProjectPackageLocalDirectory FilePath FilePath -- dir and .cabal file
 816   | ProjectPackageLocalTarball FilePath
 817   | ProjectPackageRemoteTarball URI
 818   | ProjectPackageRemoteRepo SourceRepoList
 819   | ProjectPackageNamed PackageVersionConstraint
 820   deriving (Show)
 821
 822 -- | Exception thrown by 'findProjectPackages'.
 823 data BadPackageLocations
 824   = BadPackageLocations (Set ProjectConfigProvenance) [BadPackageLocation]
 825 #if MIN_VERSION_base(4,8,0)
 826   deriving (Show, Typeable)
 827 #else
 828   deriving (Typeable)
 829
 830 instance Show BadPackageLocations where
 831   show = renderBadPackageLocations
 832 #endif
 833
 834 #if MIN_VERSION_base(4,8,0)
 835 instance Exception BadPackageLocations where
 836   displayException = renderBadPackageLocations
 837 #else
 838 instance Exception BadPackageLocations
 839 #endif
 840 -- TODO: [nice to have] custom exception subclass for Doc rendering, colour etc
 841
 842 data BadPackageLocation
 843   = BadPackageLocationFile BadPackageLocationMatch
 844   | BadLocGlobEmptyMatch String
 845   | BadLocGlobBadMatches String [BadPackageLocationMatch]
 846   | BadLocUnexpectedUriScheme String
 847   | BadLocUnrecognisedUri String
 848   | BadLocUnrecognised String
 849   deriving (Show)
 850
 851 data BadPackageLocationMatch
 852   = BadLocUnexpectedFile String
 853   | BadLocNonexistantFile String
 854   | BadLocDirNoCabalFile String
 855   | BadLocDirManyCabalFiles String
 856   deriving (Show)
 857
 858 renderBadPackageLocations :: BadPackageLocations -> String
 859 renderBadPackageLocations (BadPackageLocations provenance bpls)
 860   -- There is no provenance information,
 861   -- render standard bad package error information.
 862   | Set.null provenance = renderErrors renderBadPackageLocation
 863   -- The configuration is implicit, render bad package locations
 864   -- using possibly specialized error messages.
 865   | Set.singleton Implicit == provenance =
 866       renderErrors renderImplicitBadPackageLocation
 867   -- The configuration contains both implicit and explicit provenance.
 868   -- This should not occur, and a message is output to assist debugging.
 869   | Implicit `Set.member` provenance =
 870       "Warning: both implicit and explicit configuration is present."
 871         ++ renderExplicit
 872   -- The configuration was read from one or more explicit path(s),
 873   -- list the locations and render the bad package error information.
 874   -- The intent is to supersede this with the relevant location information
 875   -- per package error.
 876   | otherwise = renderExplicit
 877   where
 878     renderErrors f = unlines (map f bpls)
 879
 880     renderExplicit =
 881       "When using configuration(s) from "
 882         ++ intercalate ", " (mapMaybe getExplicit (Set.toList provenance))
 883         ++ ", the following errors occurred:\n"
 884         ++ renderErrors renderBadPackageLocation
 885
 886     getExplicit (Explicit path) = Just path
 887     getExplicit Implicit = Nothing
 888
 889 -- TODO: [nice to have] keep track of the config file (and src loc) packages
 890 -- were listed, to use in error messages
 891
 892 -- | Render bad package location error information for the implicit
 893 -- @cabal.project@ configuration.
 894 --
 895 -- TODO: This is currently not fully realized, with only one of the implicit
 896 -- cases handled. More cases should be added with informative help text
 897 -- about the issues related specifically when having no project configuration
 898 -- is present.
 899 renderImplicitBadPackageLocation :: BadPackageLocation -> String
 900 renderImplicitBadPackageLocation bpl = case bpl of
 901   BadLocGlobEmptyMatch pkglocstr ->
 902     "No cabal.project file or cabal file matching the default glob '"
 903       ++ pkglocstr
 904       ++ "' was found.\n"
 905       ++ "Please create a package description file <pkgname>.cabal "
 906       ++ "or a cabal.project file referencing the packages you "
 907       ++ "want to build."
 908   _ -> renderBadPackageLocation bpl
 909
 910 renderBadPackageLocation :: BadPackageLocation -> String
 911 renderBadPackageLocation bpl = case bpl of
 912   BadPackageLocationFile badmatch ->
 913     renderBadPackageLocationMatch badmatch
 914   BadLocGlobEmptyMatch pkglocstr ->
 915     "The package location glob '"
 916       ++ pkglocstr
 917       ++ "' does not match any files or directories."
 918   BadLocGlobBadMatches pkglocstr failures ->
 919     "The package location glob '"
 920       ++ pkglocstr
 921       ++ "' does not match any "
 922       ++ "recognised forms of package. "
 923       ++ concatMap ((' ' :) . renderBadPackageLocationMatch) failures
 924   BadLocUnexpectedUriScheme pkglocstr ->
 925     "The package location URI '"
 926       ++ pkglocstr
 927       ++ "' does not use a "
 928       ++ "supported URI scheme. The supported URI schemes are http, https and "
 929       ++ "file."
 930   BadLocUnrecognisedUri pkglocstr ->
 931     "The package location URI '"
 932       ++ pkglocstr
 933       ++ "' does not appear to "
 934       ++ "be a valid absolute URI."
 935   BadLocUnrecognised pkglocstr ->
 936     "The package location syntax '" ++ pkglocstr ++ "' is not recognised."
 937
 938 renderBadPackageLocationMatch :: BadPackageLocationMatch -> String
 939 renderBadPackageLocationMatch bplm = case bplm of
 940   BadLocUnexpectedFile pkglocstr ->
 941     "The package location '"
 942       ++ pkglocstr
 943       ++ "' is not recognised. The "
 944       ++ "supported file targets are .cabal files, .tar.gz tarballs or package "
 945       ++ "directories (i.e. directories containing a .cabal file)."
 946   BadLocNonexistantFile pkglocstr ->
 947     "The package location '" ++ pkglocstr ++ "' does not exist."
 948   BadLocDirNoCabalFile pkglocstr ->
 949     "The package directory '"
 950       ++ pkglocstr
 951       ++ "' does not contain any "
 952       ++ ".cabal file."
 953   BadLocDirManyCabalFiles pkglocstr ->
 954     "The package directory '"
 955       ++ pkglocstr
 956       ++ "' contains multiple "
 957       ++ ".cabal files (which is not currently supported)."
 958
 959 -- | Given the project config,
 960 --
 961 -- Throws 'BadPackageLocations'.
 962 findProjectPackages
 963   :: DistDirLayout
 964   -> ProjectConfig
 965   -> Rebuild [ProjectPackageLocation]
 966 findProjectPackages
 967   DistDirLayout{distProjectRootDirectory}
 968   ProjectConfig{..} = do
 969     requiredPkgs <- findPackageLocations True projectPackages
 970     optionalPkgs <- findPackageLocations False projectPackagesOptional
 971     let repoPkgs = map ProjectPackageRemoteRepo projectPackagesRepo
 972         namedPkgs = map ProjectPackageNamed projectPackagesNamed
 973
 974     return (concat [requiredPkgs, optionalPkgs, repoPkgs, namedPkgs])
 975     where
 976       findPackageLocations :: Bool -> [String] -> Rebuild [ProjectPackageLocation]
 977       findPackageLocations required pkglocstr = do
 978         (problems, pkglocs) <-
 979           partitionEithers <$> traverse (findPackageLocation required) pkglocstr
 980         unless (null problems) $
 981           liftIO $
 982             throwIO $
 983               BadPackageLocations projectConfigProvenance problems
 984         return (concat pkglocs)
 985
 986       findPackageLocation
 987         :: Bool
 988         -> String
 989         -> Rebuild
 990             ( Either
 991                 BadPackageLocation
 992                 [ProjectPackageLocation]
 993             )
 994       findPackageLocation _required@True pkglocstr =
 995         -- strategy: try first as a file:// or http(s):// URL.
 996         -- then as a file glob (usually encompassing single file)
 997         -- finally as a single file, for files that fail to parse as globs
 998         checkIsUriPackage pkglocstr
 999           `mplusMaybeT` checkIsFileGlobPackage pkglocstr
1000           `mplusMaybeT` checkIsSingleFilePackage pkglocstr
1001           >>= maybe (return (Left (BadLocUnrecognised pkglocstr))) return
1002       findPackageLocation _required@False pkglocstr = do
1003         -- just globs for optional case
1004         res <- checkIsFileGlobPackage pkglocstr
1005         case res of
1006           Nothing -> return (Left (BadLocUnrecognised pkglocstr))
1007           Just (Left _) -> return (Right []) -- it's optional
1008           Just (Right pkglocs) -> return (Right pkglocs)
1009
1010       checkIsUriPackage
1011         , checkIsFileGlobPackage
1012         , checkIsSingleFilePackage
1013           :: String
1014           -> Rebuild
1015               ( Maybe
1016                   ( Either
1017                       BadPackageLocation
1018                       [ProjectPackageLocation]
1019                   )
1020               )
1021       checkIsUriPackage pkglocstr =
1022         case parseAbsoluteURI pkglocstr of
1023           Just
1024             uri@URI
1025               { uriScheme = scheme
1026               , uriAuthority = Just URIAuth{uriRegName = host}
1027               , uriPath = path
1028               , uriQuery = query
1029               , uriFragment = frag
1030               }
1031               | recognisedScheme && not (null host) ->
1032                   return (Just (Right [ProjectPackageRemoteTarball uri]))
1033               | scheme == "file:" && null host && null query && null frag ->
1034                   checkIsSingleFilePackage path
1035               | not recognisedScheme && not (null host) ->
1036                   return (Just (Left (BadLocUnexpectedUriScheme pkglocstr)))
1037               | recognisedScheme && null host ->
1038                   return (Just (Left (BadLocUnrecognisedUri pkglocstr)))
1039               where
1040                 recognisedScheme =
1041                   scheme == "http:"
1042                     || scheme == "https:"
1043                     || scheme == "file:"
1044           _ -> return Nothing
1045
1046       checkIsFileGlobPackage pkglocstr =
1047         case simpleParsec pkglocstr of
1048           Nothing -> return Nothing
1049           Just glob -> liftM Just $ do
1050             matches <- matchFileGlob glob
1051             case matches of
1052               []
1053                 | isJust (isTrivialFilePathGlob glob) ->
1054                     return
1055                       ( Left
1056                           ( BadPackageLocationFile
1057                               (BadLocNonexistantFile pkglocstr)
1058                           )
1059                       )
1060               [] -> return (Left (BadLocGlobEmptyMatch pkglocstr))
1061               _ -> do
1062                 (failures, pkglocs) <-
1063                   partitionEithers
1064                     <$> traverse checkFilePackageMatch matches
1065                 return $! case (failures, pkglocs) of
1066                   ([failure], [])
1067                     | isJust (isTrivialFilePathGlob glob) ->
1068                         Left (BadPackageLocationFile failure)
1069                   (_, []) -> Left (BadLocGlobBadMatches pkglocstr failures)
1070                   _ -> Right pkglocs
1071
1072       checkIsSingleFilePackage pkglocstr = do
1073         let filename = distProjectRootDirectory </> pkglocstr
1074         isFile <- liftIO $ doesFileExist filename
1075         isDir <- liftIO $ doesDirectoryExist filename
1076         if isFile || isDir
1077           then
1078             checkFilePackageMatch pkglocstr
1079               >>= either
1080                 (return . Just . Left . BadPackageLocationFile)
1081                 (return . Just . Right . (\x -> [x]))
1082           else return Nothing
1083
1084       checkFilePackageMatch
1085         :: String
1086         -> Rebuild
1087             ( Either
1088                 BadPackageLocationMatch
1089                 ProjectPackageLocation
1090             )
1091       checkFilePackageMatch pkglocstr = do
1092         -- The pkglocstr may be absolute or may be relative to the project root.
1093         -- Either way, </> does the right thing here. We return relative paths if
1094         -- they were relative in the first place.
1095         let abspath = distProjectRootDirectory </> pkglocstr
1096         isFile <- liftIO $ doesFileExist abspath
1097         isDir <- liftIO $ doesDirectoryExist abspath
1098         parentDirExists <- case takeDirectory abspath of
1099           [] -> return False
1100           dir -> liftIO $ doesDirectoryExist dir
1101         case () of
1102           _
1103             | isDir ->
1104                 do
1105                   matches <- matchFileGlob (globStarDotCabal pkglocstr)
1106                   case matches of
1107                     [cabalFile] ->
1108                       return
1109                         ( Right
1110                             ( ProjectPackageLocalDirectory
1111                                 pkglocstr
1112                                 cabalFile
1113                             )
1114                         )
1115                     [] -> return (Left (BadLocDirNoCabalFile pkglocstr))
1116                     _ -> return (Left (BadLocDirManyCabalFiles pkglocstr))
1117             | extensionIsTarGz pkglocstr ->
1118                 return (Right (ProjectPackageLocalTarball pkglocstr))
1119             | takeExtension pkglocstr == ".cabal" ->
1120                 return (Right (ProjectPackageLocalCabalFile pkglocstr))
1121             | isFile ->
1122                 return (Left (BadLocUnexpectedFile pkglocstr))
1123             | parentDirExists ->
1124                 return (Left (BadLocNonexistantFile pkglocstr))
1125             | otherwise ->
1126                 return (Left (BadLocUnexpectedFile pkglocstr))
1127
1128       extensionIsTarGz f =
1129         takeExtension f == ".gz"
1130           && takeExtension (dropExtension f) == ".tar"
1131
1132 -- | A glob to find all the cabal files in a directory.
1133 --
1134 -- For a directory @some/dir/@, this is a glob of the form @some/dir/\*.cabal@.
1135 -- The directory part can be either absolute or relative.
1136 globStarDotCabal :: FilePath -> FilePathGlob
1137 globStarDotCabal dir =
1138   FilePathGlob
1139     (if isAbsolute dir then FilePathRoot root else FilePathRelative)
1140     ( foldr
1141         (\d -> GlobDir [Literal d])
1142         (GlobFile [WildCard, Literal ".cabal"])
1143         dirComponents
1144     )
1145   where
1146     (root, dirComponents) = fmap splitDirectories (splitDrive dir)
1147
1148 -- TODO: [code cleanup] use sufficiently recent transformers package
1149 mplusMaybeT :: Monad m => m (Maybe a) -> m (Maybe a) -> m (Maybe a)
1150 mplusMaybeT ma mb = do
1151   mx <- ma
1152   case mx of
1153     Nothing -> mb
1154     Just x -> return (Just x)
1155
1156 -------------------------------------------------
1157 -- Fetching and reading packages in the project
1158 --
1159
1160 -- | Read the @.cabal@ files for a set of packages. For remote tarballs and
1161 -- VCS source repos this also fetches them if needed.
1162 --
1163 -- Note here is where we convert from project-root relative paths to absolute
1164 -- paths.
1165 fetchAndReadSourcePackages
1166   :: Verbosity
1167   -> DistDirLayout
1168   -> ProjectConfigShared
1169   -> ProjectConfigBuildOnly
1170   -> [ProjectPackageLocation]
1171   -> Rebuild [PackageSpecifier (SourcePackage UnresolvedPkgLoc)]
1172 fetchAndReadSourcePackages
1173   verbosity
1174   distDirLayout
1175   projectConfigShared
1176   projectConfigBuildOnly
1177   pkgLocations = do
1178     pkgsLocalDirectory <-
1179       sequenceA
1180         [ readSourcePackageLocalDirectory verbosity dir cabalFile
1181         | location <- pkgLocations
1182         , (dir, cabalFile) <- projectPackageLocal location
1183         ]
1184
1185     pkgsLocalTarball <-
1186       sequenceA
1187         [ readSourcePackageLocalTarball verbosity path
1188         | ProjectPackageLocalTarball path <- pkgLocations
1189         ]
1190
1191     pkgsRemoteTarball <- do
1192       getTransport <-
1193         delayInitSharedResource $
1194           configureTransport
1195             verbosity
1196             progPathExtra
1197             preferredHttpTransport
1198       sequenceA
1199         [ fetchAndReadSourcePackageRemoteTarball
1200           verbosity
1201           distDirLayout
1202           getTransport
1203           uri
1204         | ProjectPackageRemoteTarball uri <- pkgLocations
1205         ]
1206
1207     pkgsRemoteRepo <-
1208       syncAndReadSourcePackagesRemoteRepos
1209         verbosity
1210         distDirLayout
1211         projectConfigShared
1212         [repo | ProjectPackageRemoteRepo repo <- pkgLocations]
1213
1214     let pkgsNamed =
1215           [ NamedPackage pkgname [PackagePropertyVersion verrange]
1216           | ProjectPackageNamed (PackageVersionConstraint pkgname verrange) <- pkgLocations
1217           ]
1218
1219     return $
1220       concat
1221         [ pkgsLocalDirectory
1222         , pkgsLocalTarball
1223         , pkgsRemoteTarball
1224         , pkgsRemoteRepo
1225         , pkgsNamed
1226         ]
1227     where
1228       projectPackageLocal (ProjectPackageLocalDirectory dir file) = [(dir, file)]
1229       projectPackageLocal (ProjectPackageLocalCabalFile file) = [(dir, file)]
1230         where
1231           dir = takeDirectory file
1232       projectPackageLocal _ = []
1233
1234       progPathExtra = fromNubList (projectConfigProgPathExtra projectConfigShared)
1235       preferredHttpTransport =
1236         flagToMaybe (projectConfigHttpTransport projectConfigBuildOnly)
1237
1238 -- | A helper for 'fetchAndReadSourcePackages' to handle the case of
1239 -- 'ProjectPackageLocalDirectory' and 'ProjectPackageLocalCabalFile'.
1240 -- We simply read the @.cabal@ file.
1241 readSourcePackageLocalDirectory
1242   :: Verbosity
1243   -> FilePath
1244   -- ^ The package directory
1245   -> FilePath
1246   -- ^ The package @.cabal@ file
1247   -> Rebuild (PackageSpecifier (SourcePackage UnresolvedPkgLoc))
1248 readSourcePackageLocalDirectory verbosity dir cabalFile = do
1249   monitorFiles [monitorFileHashed cabalFile]
1250   root <- askRoot
1251   let location = LocalUnpackedPackage (root </> dir)
1252   liftIO $
1253     fmap (mkSpecificSourcePackage location)
1254       . readSourcePackageCabalFile verbosity cabalFile
1255       =<< BS.readFile (root </> cabalFile)
1256
1257 -- | A helper for 'fetchAndReadSourcePackages' to handle the case of
1258 -- 'ProjectPackageLocalTarball'. We scan through the @.tar.gz@ file to find
1259 -- the @.cabal@ file and read that.
1260 readSourcePackageLocalTarball
1261   :: Verbosity
1262   -> FilePath
1263   -> Rebuild (PackageSpecifier (SourcePackage UnresolvedPkgLoc))
1264 readSourcePackageLocalTarball verbosity tarballFile = do
1265   monitorFiles [monitorFile tarballFile]
1266   root <- askRoot
1267   let location = LocalTarballPackage (root </> tarballFile)
1268   liftIO $
1269     fmap (mkSpecificSourcePackage location)
1270       . uncurry (readSourcePackageCabalFile verbosity)
1271       =<< extractTarballPackageCabalFile (root </> tarballFile)
1272
1273 -- | A helper for 'fetchAndReadSourcePackages' to handle the case of
1274 -- 'ProjectPackageRemoteTarball'. We download the tarball to the dist src dir
1275 -- and after that handle it like the local tarball case.
1276 fetchAndReadSourcePackageRemoteTarball
1277   :: Verbosity
1278   -> DistDirLayout
1279   -> Rebuild HttpTransport
1280   -> URI
1281   -> Rebuild (PackageSpecifier (SourcePackage UnresolvedPkgLoc))
1282 fetchAndReadSourcePackageRemoteTarball
1283   verbosity
1284   DistDirLayout
1285     { distDownloadSrcDirectory
1286     }
1287   getTransport
1288   tarballUri =
1289     -- The tarball download is expensive so we use another layer of file
1290     -- monitor to avoid it whenever possible.
1291     rerunIfChanged verbosity monitor tarballUri $ do
1292       -- Download
1293       transport <- getTransport
1294       liftIO $ do
1295         transportCheckHttps verbosity transport tarballUri
1296         notice verbosity ("Downloading " ++ show tarballUri)
1297         createDirectoryIfMissingVerbose
1298           verbosity
1299           True
1300           distDownloadSrcDirectory
1301         _ <- downloadURI transport verbosity tarballUri tarballFile
1302         return ()
1303
1304       -- Read
1305       monitorFiles [monitorFile tarballFile]
1306       let location = RemoteTarballPackage tarballUri tarballFile
1307       liftIO $
1308         fmap (mkSpecificSourcePackage location)
1309           . uncurry (readSourcePackageCabalFile verbosity)
1310           =<< extractTarballPackageCabalFile tarballFile
1311     where
1312       tarballStem :: FilePath
1313       tarballStem =
1314         distDownloadSrcDirectory
1315           </> localFileNameForRemoteTarball tarballUri
1316       tarballFile :: FilePath
1317       tarballFile = tarballStem <.> "tar.gz"
1318
1319       monitor :: FileMonitor URI (PackageSpecifier (SourcePackage UnresolvedPkgLoc))
1320       monitor = newFileMonitor (tarballStem <.> "cache")
1321
1322 -- | A helper for 'fetchAndReadSourcePackages' to handle all the cases of
1323 -- 'ProjectPackageRemoteRepo'.
1324 syncAndReadSourcePackagesRemoteRepos
1325   :: Verbosity
1326   -> DistDirLayout
1327   -> ProjectConfigShared
1328   -> [SourceRepoList]
1329   -> Rebuild [PackageSpecifier (SourcePackage UnresolvedPkgLoc)]
1330 syncAndReadSourcePackagesRemoteRepos
1331   verbosity
1332   DistDirLayout{distDownloadSrcDirectory}
1333   ProjectConfigShared
1334     { projectConfigProgPathExtra
1335     }
1336   repos = do
1337     repos' <-
1338       either reportSourceRepoProblems return $
1339         validateSourceRepos repos
1340
1341     -- All 'SourceRepo's grouped by referring to the "same" remote repo
1342     -- instance. So same location but can differ in commit/tag/branch/subdir.
1343     let reposByLocation
1344           :: Map
1345               (RepoType, String)
1346               [(SourceRepoList, RepoType)]
1347         reposByLocation =
1348           Map.fromListWith
1349             (++)
1350             [ ((rtype, rloc), [(repo, vcsRepoType vcs)])
1351             | (repo, rloc, rtype, vcs) <- repos'
1352             ]
1353
1354     -- TODO: pass progPathExtra on to 'configureVCS'
1355     let _progPathExtra = fromNubList projectConfigProgPathExtra
1356     getConfiguredVCS <- delayInitSharedResources $ \repoType ->
1357       let vcs = Map.findWithDefault (error $ "Unknown VCS: " ++ prettyShow repoType) repoType knownVCSs
1358        in configureVCS verbosity {-progPathExtra-} vcs
1359
1360     concat
1361       <$> sequenceA
1362         [ rerunIfChanged verbosity monitor repoGroup' $ do
1363           vcs' <- getConfiguredVCS repoType
1364           syncRepoGroupAndReadSourcePackages vcs' pathStem repoGroup'
1365         | repoGroup@((primaryRepo, repoType) : _) <- Map.elems reposByLocation
1366         , let repoGroup' = map fst repoGroup
1367               pathStem =
1368                 distDownloadSrcDirectory
1369                   </> localFileNameForRemoteRepo primaryRepo
1370               monitor
1371                 :: FileMonitor
1372                     [SourceRepoList]
1373                     [PackageSpecifier (SourcePackage UnresolvedPkgLoc)]
1374               monitor = newFileMonitor (pathStem <.> "cache")
1375         ]
1376     where
1377       syncRepoGroupAndReadSourcePackages
1378         :: VCS ConfiguredProgram
1379         -> FilePath
1380         -> [SourceRepoList]
1381         -> Rebuild [PackageSpecifier (SourcePackage UnresolvedPkgLoc)]
1382       syncRepoGroupAndReadSourcePackages vcs pathStem repoGroup = do
1383         liftIO $
1384           createDirectoryIfMissingVerbose
1385             verbosity
1386             False
1387             distDownloadSrcDirectory
1388
1389         -- For syncing we don't care about different 'SourceRepo' values that
1390         -- are just different subdirs in the same repo.
1391         syncSourceRepos
1392           verbosity
1393           vcs
1394           [ (repo, repoPath)
1395           | (repo, _, repoPath) <- repoGroupWithPaths
1396           ]
1397
1398         -- Run post-checkout-command if it is specified
1399         for_ repoGroupWithPaths $ \(repo, _, repoPath) ->
1400           for_ (nonEmpty (srpCommand repo)) $ \(cmd :| args) -> liftIO $ do
1401             maybeExit $ rawSystemIOWithEnv verbosity cmd args (Just repoPath) Nothing Nothing Nothing Nothing
1402
1403         -- But for reading we go through each 'SourceRepo' including its subdir
1404         -- value and have to know which path each one ended up in.
1405         sequenceA
1406           [ readPackageFromSourceRepo repoWithSubdir repoPath
1407           | (_, reposWithSubdir, repoPath) <- repoGroupWithPaths
1408           , repoWithSubdir <- NE.toList reposWithSubdir
1409           ]
1410         where
1411           -- So to do both things above, we pair them up here.
1412           repoGroupWithPaths
1413             :: [(SourceRepositoryPackage Proxy, NonEmpty (SourceRepositoryPackage Maybe), FilePath)]
1414           repoGroupWithPaths =
1415             zipWith
1416               (\(x, y) z -> (x, y, z))
1417               ( mapGroup
1418                   [ (repo{srpSubdir = Proxy}, repo)
1419                   | repo <- foldMap (NE.toList . srpFanOut) repoGroup
1420                   ]
1421               )
1422               repoPaths
1423
1424           mapGroup :: Ord k => [(k, v)] -> [(k, NonEmpty v)]
1425           mapGroup = Map.toList . Map.fromListWith (<>) . map (\(k, v) -> (k, pure v))
1426
1427           -- The repos in a group are given distinct names by simple enumeration
1428           -- foo, foo-2, foo-3 etc
1429           repoPaths :: [FilePath]
1430           repoPaths =
1431             pathStem
1432               : [pathStem ++ "-" ++ show (i :: Int) | i <- [2 ..]]
1433
1434       readPackageFromSourceRepo
1435         :: SourceRepositoryPackage Maybe
1436         -> FilePath
1437         -> Rebuild (PackageSpecifier (SourcePackage UnresolvedPkgLoc))
1438       readPackageFromSourceRepo repo repoPath = do
1439         let packageDir :: FilePath
1440             packageDir = maybe repoPath (repoPath </>) (srpSubdir repo)
1441
1442         entries <- liftIO $ getDirectoryContents packageDir
1443         -- TODO: dcoutts 2018-06-23: wrap exceptions
1444         case filter (\e -> takeExtension e == ".cabal") entries of
1445           [] -> liftIO $ throwIO $ NoCabalFileFound packageDir
1446           (_ : _ : _) -> liftIO $ throwIO $ MultipleCabalFilesFound packageDir
1447           [cabalFileName] -> do
1448             let cabalFilePath = packageDir </> cabalFileName
1449             monitorFiles [monitorFileHashed cabalFilePath]
1450             gpd <- liftIO $ readSourcePackageCabalFile verbosity cabalFilePath =<< BS.readFile cabalFilePath
1451
1452             -- write sdist tarball, to repoPath-pgkid
1453             tarball <- liftIO $ packageDirToSdist verbosity gpd packageDir
1454             let tarballPath = repoPath ++ "-" ++ prettyShow (packageId gpd) ++ ".tar.gz"
1455             liftIO $ LBS.writeFile tarballPath tarball
1456
1457             let location = RemoteSourceRepoPackage repo tarballPath
1458             return $ mkSpecificSourcePackage location gpd
1459
1460       reportSourceRepoProblems :: [(SourceRepoList, SourceRepoProblem)] -> Rebuild a
1461       reportSourceRepoProblems = liftIO . dieWithException verbosity . ReportSourceRepoProblems . renderSourceRepoProblems
1462
1463       renderSourceRepoProblems :: [(SourceRepoList, SourceRepoProblem)] -> String
1464       renderSourceRepoProblems = unlines . map show -- "TODO: the repo problems"
1465
1466 -- | Utility used by all the helpers of 'fetchAndReadSourcePackages' to make an
1467 -- appropriate @'PackageSpecifier' ('SourcePackage' (..))@ for a given package
1468 -- from a given location.
1469 mkSpecificSourcePackage
1470   :: PackageLocation FilePath
1471   -> GenericPackageDescription
1472   -> PackageSpecifier (SourcePackage UnresolvedPkgLoc)
1473 mkSpecificSourcePackage location pkg =
1474   SpecificSourcePackage
1475     SourcePackage
1476       { srcpkgPackageId = packageId pkg
1477       , srcpkgDescription = pkg
1478       , srcpkgSource = fmap Just location
1479       , srcpkgDescrOverride = Nothing
1480       }
1481
1482 -- | Errors reported upon failing to parse a @.cabal@ file.
1483 data CabalFileParseError
1484   = CabalFileParseError
1485       FilePath
1486       -- ^ @.cabal@ file path
1487       BS.ByteString
1488       -- ^ @.cabal@ file contents
1489       (NonEmpty PError)
1490       -- ^ errors
1491       (Maybe Version)
1492       -- ^ We might discover the spec version the package needs
1493       [PWarning]
1494       -- ^ warnings
1495   deriving (Typeable)
1496
1497 -- | Manual instance which skips file contents
1498 instance Show CabalFileParseError where
1499   showsPrec d (CabalFileParseError fp _ es mv ws) =
1500     showParen (d > 10) $
1501       showString "CabalFileParseError"
1502         . showChar ' '
1503         . showsPrec 11 fp
1504         . showChar ' '
1505         . showsPrec 11 ("" :: String)
1506         . showChar ' '
1507         . showsPrec 11 es
1508         . showChar ' '
1509         . showsPrec 11 mv
1510         . showChar ' '
1511         . showsPrec 11 ws
1512
1513 instance Exception CabalFileParseError
1514 #if MIN_VERSION_base(4,8,0)
1515   where
1516   displayException = renderCabalFileParseError
1517 #endif
1518
1519 renderCabalFileParseError :: CabalFileParseError -> String
1520 renderCabalFileParseError (CabalFileParseError filePath contents errors _ warnings) =
1521   renderParseError filePath contents errors warnings
1522
1523 -- | Wrapper for the @.cabal@ file parser. It reports warnings on higher
1524 -- verbosity levels and throws 'CabalFileParseError' on failure.
1525 readSourcePackageCabalFile
1526   :: Verbosity
1527   -> FilePath
1528   -> BS.ByteString
1529   -> IO GenericPackageDescription
1530 readSourcePackageCabalFile verbosity pkgfilename content =
1531   case runParseResult (parseGenericPackageDescription content) of
1532     (warnings, Right pkg) -> do
1533       unless (null warnings) $
1534         info verbosity (formatWarnings warnings)
1535       return pkg
1536     (warnings, Left (mspecVersion, errors)) ->
1537       throwIO $ CabalFileParseError pkgfilename content errors mspecVersion warnings
1538   where
1539     formatWarnings warnings =
1540       "The package description file "
1541         ++ pkgfilename
1542         ++ " has warnings: "
1543         ++ unlines (map (showPWarning pkgfilename) warnings)
1544
1545 -- | When looking for a package's @.cabal@ file we can find none, or several,
1546 -- both of which are failures.
1547 data CabalFileSearchFailure
1548   = NoCabalFileFound FilePath
1549   | MultipleCabalFilesFound FilePath
1550   deriving (Show, Typeable)
1551
1552 instance Exception CabalFileSearchFailure
1553
1554 -- | Find the @.cabal@ file within a tarball file and return it by value.
1555 --
1556 -- Can fail with a 'Tar.FormatError' or 'CabalFileSearchFailure' exception.
1557 extractTarballPackageCabalFile :: FilePath -> IO (FilePath, BS.ByteString)
1558 extractTarballPackageCabalFile tarballFile =
1559   withBinaryFile tarballFile ReadMode $ \hnd -> do
1560     content <- LBS.hGetContents hnd
1561     case extractTarballPackageCabalFilePure tarballFile content of
1562       Left (Left e) -> throwIO e
1563       Left (Right e) -> throwIO e
1564       Right (fileName, fileContent) ->
1565         (,) fileName <$> evaluate (LBS.toStrict fileContent)
1566
1567 -- | Scan through a tar file stream and collect the @.cabal@ file, or fail.
1568 extractTarballPackageCabalFilePure
1569   :: FilePath
1570   -> LBS.ByteString
1571   -> Either
1572       ( Either
1573           Tar.FormatError
1574           CabalFileSearchFailure
1575       )
1576       (FilePath, LBS.ByteString)
1577 extractTarballPackageCabalFilePure tarballFile =
1578   check
1579     . accumEntryMap
1580     . Tar.filterEntries isCabalFile
1581     . Tar.read
1582     . GZipUtils.maybeDecompress
1583   where
1584     accumEntryMap =
1585       Tar.foldlEntries
1586         (\m e -> Map.insert (Tar.entryTarPath e) e m)
1587         Map.empty
1588
1589     check (Left (e, _m)) = Left (Left e)
1590     check (Right m) = case Map.elems m of
1591       [] -> Left (Right $ NoCabalFileFound tarballFile)
1592       [file] -> case Tar.entryContent file of
1593         Tar.NormalFile content _ -> Right (Tar.entryPath file, content)
1594         _ -> Left (Right $ NoCabalFileFound tarballFile)
1595       _files -> Left (Right $ MultipleCabalFilesFound tarballFile)
1596
1597     isCabalFile e = case splitPath (Tar.entryPath e) of
1598       [_dir, file] -> takeExtension file == ".cabal"
1599       [".", _dir, file] -> takeExtension file == ".cabal"
1600       _ -> False
1601
1602 -- | The name to use for a local file for a remote tarball 'SourceRepo'.
1603 -- This is deterministic based on the remote tarball URI, and is intended
1604 -- to produce non-clashing file names for different tarballs.
1605 localFileNameForRemoteTarball :: URI -> FilePath
1606 localFileNameForRemoteTarball uri =
1607   mangleName uri
1608     ++ "-"
1609     ++ showHex locationHash ""
1610   where
1611     mangleName =
1612       truncateString 10
1613         . dropExtension
1614         . dropExtension
1615         . takeFileName
1616         . dropTrailingPathSeparator
1617         . uriPath
1618
1619     locationHash :: Word
1620     locationHash = fromIntegral (Hashable.hash (uriToString id uri ""))
1621
1622 -- | The name to use for a local file or dir for a remote 'SourceRepo'.
1623 -- This is deterministic based on the source repo identity details, and
1624 -- intended to produce non-clashing file names for different repos.
1625 localFileNameForRemoteRepo :: SourceRepoList -> FilePath
1626 localFileNameForRemoteRepo SourceRepositoryPackage{srpType, srpLocation} =
1627   mangleName srpLocation ++ "-" ++ showHex locationHash ""
1628   where
1629     mangleName =
1630       truncateString 10
1631         . dropExtension
1632         . takeFileName
1633         . dropTrailingPathSeparator
1634
1635     -- just the parts that make up the "identity" of the repo
1636     locationHash :: Word
1637     locationHash =
1638       fromIntegral (Hashable.hash (show srpType, srpLocation))
1639
1640 -- | Truncate a string, with a visual indication that it is truncated.
1641 truncateString :: Int -> String -> String
1642 truncateString n s
1643   | length s <= n = s
1644   | otherwise = take (n - 1) s ++ "_"
1645
1646 -- TODO: add something like this, here or in the project planning
1647 -- Based on the package location, which packages will be built inplace in the
1648 -- build tree vs placed in the store. This has various implications on what we
1649 -- can do with the package, e.g. can we run tests, ghci etc.
1650 --
1651 -- packageIsLocalToProject :: ProjectPackageLocation -> Bool
1652
1653 ---------------------------------------------
1654 -- Checking configuration sanity
1655 --
1656
1657 data BadPerPackageCompilerPaths
1658   = BadPerPackageCompilerPaths [(PackageName, String)]
1659 #if MIN_VERSION_base(4,8,0)
1660   deriving (Show, Typeable)
1661 #else
1662   deriving (Typeable)
1663
1664 instance Show BadPerPackageCompilerPaths where
1665   show = renderBadPerPackageCompilerPaths
1666 #endif
1667
1668 #if MIN_VERSION_base(4,8,0)
1669 instance Exception BadPerPackageCompilerPaths where
1670   displayException = renderBadPerPackageCompilerPaths
1671 #else
1672 instance Exception BadPerPackageCompilerPaths
1673 #endif
1674 -- TODO: [nice to have] custom exception subclass for Doc rendering, colour etc
1675
1676 renderBadPerPackageCompilerPaths :: BadPerPackageCompilerPaths -> String
1677 renderBadPerPackageCompilerPaths
1678   (BadPerPackageCompilerPaths ((pkgname, progname) : _)) =
1679     "The path to the compiler program (or programs used by the compiler) "
1680       ++ "cannot be specified on a per-package basis in the cabal.project file "
1681       ++ "(i.e. setting the '"
1682       ++ progname
1683       ++ "-location' for package '"
1684       ++ prettyShow pkgname
1685       ++ "'). All packages have to use the same compiler, so "
1686       ++ "specify the path in a global 'program-locations' section."
1687 -- TODO: [nice to have] better format control so we can pretty-print the
1688 -- offending part of the project file. Currently the line wrapping breaks any
1689 -- formatting.
1690 renderBadPerPackageCompilerPaths _ = error "renderBadPerPackageCompilerPaths"
1691
1692 -- | The project configuration is not allowed to specify program locations for
1693 -- programs used by the compiler as these have to be the same for each set of
1694 -- packages.
1695 --
1696 -- We cannot check this until we know which programs the compiler uses, which
1697 -- in principle is not until we've configured the compiler.
1698 --
1699 -- Throws 'BadPerPackageCompilerPaths'
1700 checkBadPerPackageCompilerPaths
1701   :: [ConfiguredProgram]
1702   -> Map PackageName PackageConfig
1703   -> IO ()
1704 checkBadPerPackageCompilerPaths compilerPrograms packagesConfig =
1705   case [ (pkgname, progname)
1706        | let compProgNames = Set.fromList (map programId compilerPrograms)
1707        , (pkgname, pkgconf) <- Map.toList packagesConfig
1708        , progname <- Map.keys (getMapLast (packageConfigProgramPaths pkgconf))
1709        , progname `Set.member` compProgNames
1710        ] of
1711     [] -> return ()
1712     ps -> throwIO (BadPerPackageCompilerPaths ps)