{-# LANGUAGE DeriveGeneric #-} ----------------------------------------------------------------------------- -- | -- Module : Distribution.Client.Config -- Copyright : (c) David Himmelstrup 2005 -- License : BSD-like -- -- Maintainer : lemmih@gmail.com -- Stability : provisional -- Portability : portable -- -- Utilities for handling saved state such as known packages, known servers and -- downloaded packages. ----------------------------------------------------------------------------- module Distribution.Client.Config ( SavedConfig(..), loadConfig, getConfigFilePath, showConfig, showConfigWithComments, parseConfig, getCabalDir, defaultConfigFile, defaultCacheDir, defaultCompiler, defaultInstallPath, defaultLogsDir, defaultUserInstall, baseSavedConfig, commentSavedConfig, initialSavedConfig, configFieldDescriptions, haddockFlagsFields, installDirsFields, withProgramsFields, withProgramOptionsFields, userConfigDiff, userConfigUpdate, createDefaultConfigFile, remoteRepoFields, postProcessRepo, ) where import Distribution.Client.Compat.Prelude import Prelude () import Language.Haskell.Extension ( Language(Haskell2010) ) import Distribution.Deprecated.ViewAsFieldDescr ( viewAsFieldDescr ) import Distribution.Client.Types ( RemoteRepo(..), LocalRepo (..), emptyRemoteRepo , AllowOlder(..), AllowNewer(..), RelaxDeps(..), isRelaxDeps , RepoName (..), unRepoName ) import Distribution.Client.Types.Credentials (Username (..), Password (..)) import Distribution.Client.BuildReports.Types ( ReportLevel(..) ) import qualified Distribution.Client.Init.Types as IT ( InitFlags(..) ) import qualified Distribution.Client.Init.Defaults as IT import Distribution.Client.Setup ( GlobalFlags(..), globalCommand, defaultGlobalFlags , ConfigExFlags(..), configureExOptions, defaultConfigExFlags , initOptions , InstallFlags(..), installOptions, defaultInstallFlags , UploadFlags(..), uploadCommand , ReportFlags(..), reportCommand ) import Distribution.Client.CmdInstall.ClientInstallFlags ( ClientInstallFlags(..), defaultClientInstallFlags , clientInstallOptions ) import Distribution.Utils.NubList ( NubList, fromNubList, toNubList, overNubList ) import Distribution.Simple.Compiler ( DebugInfoLevel(..), OptimisationLevel(..) ) import Distribution.Simple.Setup ( ConfigFlags(..), configureOptions, defaultConfigFlags , HaddockFlags(..), haddockOptions, defaultHaddockFlags , TestFlags(..), defaultTestFlags , BenchmarkFlags(..), defaultBenchmarkFlags , installDirsOptions, optionDistPref , programDbPaths', programDbOptions , Flag(..), toFlag, flagToMaybe, fromFlagOrDefault ) import Distribution.Simple.InstallDirs ( InstallDirs(..), defaultInstallDirs , PathTemplate, toPathTemplate ) import Distribution.Deprecated.ParseUtils ( FieldDescr(..), liftField, runP , ParseResult(..), PError(..), PWarning(..) , locatedErrorMsg, showPWarning , readFields, warning, lineNo , simpleField, listField, spaceListField , parseFilePathQ, parseOptCommaList, parseTokenQ, syntaxError , simpleFieldParsec, listFieldParsec ) import Distribution.Client.ParseUtils ( parseFields, ppFields, ppSection ) import Distribution.Client.HttpUtils ( isOldHackageURI ) import qualified Distribution.Deprecated.ParseUtils as ParseUtils ( Field(..) ) import Distribution.Simple.Command ( CommandUI(commandOptions), commandDefaultFlags, ShowOrParseArgs(..) ) import Distribution.Simple.Program ( defaultProgramDb ) import Distribution.Simple.Utils ( die', notice, warn, lowercase, cabalVersion ) import Distribution.Client.Utils ( cabalInstallVersion ) import Distribution.Compiler ( CompilerFlavor(..), defaultCompilerFlavor ) import Distribution.Verbosity ( normal ) import qualified Distribution.Compat.CharParsing as P import Distribution.Client.ProjectFlags (ProjectFlags (..)) import Distribution.Solver.Types.ConstraintSource import qualified Distribution.Deprecated.ReadP as Parse ( (<++), option ) import qualified Text.PrettyPrint as Disp ( render, text, empty ) import Distribution.Parsec (parsecOptCommaList) import Text.PrettyPrint ( ($+$) ) import Text.PrettyPrint.HughesPJ ( text, Doc ) import System.Directory ( createDirectoryIfMissing, getAppUserDataDirectory, renameFile ) import Network.URI ( URI(..), URIAuth(..), parseURI ) import System.FilePath ( (<.>), (), takeDirectory ) import System.IO.Error ( isDoesNotExistError ) import Distribution.Compat.Environment ( getEnvironment, lookupEnv ) import qualified Data.Map as M -- -- * Configuration saved in the config file -- data SavedConfig = SavedConfig { savedGlobalFlags :: GlobalFlags , savedInitFlags :: IT.InitFlags , savedInstallFlags :: InstallFlags , savedClientInstallFlags :: ClientInstallFlags , savedConfigureFlags :: ConfigFlags , savedConfigureExFlags :: ConfigExFlags , savedUserInstallDirs :: InstallDirs (Flag PathTemplate) , savedGlobalInstallDirs :: InstallDirs (Flag PathTemplate) , savedUploadFlags :: UploadFlags , savedReportFlags :: ReportFlags , savedHaddockFlags :: HaddockFlags , savedTestFlags :: TestFlags , savedBenchmarkFlags :: BenchmarkFlags , savedProjectFlags :: ProjectFlags } deriving Generic instance Monoid SavedConfig where mempty = gmempty mappend = (<>) instance Semigroup SavedConfig where a <> b = SavedConfig { savedGlobalFlags = combinedSavedGlobalFlags, savedInitFlags = combinedSavedInitFlags, savedInstallFlags = combinedSavedInstallFlags, savedClientInstallFlags = combinedSavedClientInstallFlags, savedConfigureFlags = combinedSavedConfigureFlags, savedConfigureExFlags = combinedSavedConfigureExFlags, savedUserInstallDirs = combinedSavedUserInstallDirs, savedGlobalInstallDirs = combinedSavedGlobalInstallDirs, savedUploadFlags = combinedSavedUploadFlags, savedReportFlags = combinedSavedReportFlags, savedHaddockFlags = combinedSavedHaddockFlags, savedTestFlags = combinedSavedTestFlags, savedBenchmarkFlags = combinedSavedBenchmarkFlags, savedProjectFlags = combinedSavedProjectFlags } where -- This is ugly, but necessary. If we're mappending two config files, we -- want the values of the *non-empty* list fields from the second one to -- *override* the corresponding values from the first one. Default -- behaviour (concatenation) is confusing and makes some use cases (see -- #1884) impossible. -- -- However, we also want to allow specifying multiple values for a list -- field in a *single* config file. For example, we want the following to -- continue to work: -- -- remote-repo: hackage.haskell.org:http://hackage.haskell.org/ -- remote-repo: private-collection:http://hackage.local/ -- -- So we can't just wrap the list fields inside Flags; we have to do some -- special-casing just for SavedConfig. -- NB: the signature prevents us from using 'combine' on lists. combine' :: (SavedConfig -> flags) -> (flags -> Flag a) -> Flag a combine' field subfield = (subfield . field $ a) `mappend` (subfield . field $ b) combineMonoid :: Monoid mon => (SavedConfig -> flags) -> (flags -> mon) -> mon combineMonoid field subfield = (subfield . field $ a) `mappend` (subfield . field $ b) lastNonEmpty' :: (SavedConfig -> flags) -> (flags -> [a]) -> [a] lastNonEmpty' field subfield = let a' = subfield . field $ a b' = subfield . field $ b in case b' of [] -> a' _ -> b' lastNonMempty' :: (Eq a, Monoid a) => (SavedConfig -> flags) -> (flags -> a) -> a lastNonMempty' field subfield = let a' = subfield . field $ a b' = subfield . field $ b in if b' == mempty then a' else b' lastNonEmptyNL' :: (SavedConfig -> flags) -> (flags -> NubList a) -> NubList a lastNonEmptyNL' field subfield = let a' = subfield . field $ a b' = subfield . field $ b in case fromNubList b' of [] -> a' _ -> b' combinedSavedGlobalFlags = GlobalFlags { globalVersion = combine globalVersion, globalNumericVersion = combine globalNumericVersion, globalConfigFile = combine globalConfigFile, globalConstraintsFile = combine globalConstraintsFile, globalRemoteRepos = lastNonEmptyNL globalRemoteRepos, globalCacheDir = combine globalCacheDir, globalLocalNoIndexRepos = lastNonEmptyNL globalLocalNoIndexRepos, globalActiveRepos = combine globalActiveRepos, globalLogsDir = combine globalLogsDir, globalWorldFile = combine globalWorldFile, globalIgnoreExpiry = combine globalIgnoreExpiry, globalHttpTransport = combine globalHttpTransport, globalNix = combine globalNix, globalStoreDir = combine globalStoreDir, globalProgPathExtra = lastNonEmptyNL globalProgPathExtra } where combine = combine' savedGlobalFlags lastNonEmptyNL = lastNonEmptyNL' savedGlobalFlags combinedSavedInitFlags = IT.InitFlags { IT.applicationDirs = combineMonoid savedInitFlags IT.applicationDirs, IT.author = combine IT.author, IT.buildTools = combineMonoid savedInitFlags IT.buildTools, IT.cabalVersion = combine IT.cabalVersion, IT.category = combine IT.category, IT.dependencies = combineMonoid savedInitFlags IT.dependencies, IT.email = combine IT.email, IT.exposedModules = combineMonoid savedInitFlags IT.exposedModules, IT.extraSrc = combineMonoid savedInitFlags IT.extraSrc, IT.homepage = combine IT.homepage, IT.initHcPath = combine IT.initHcPath, IT.initVerbosity = combine IT.initVerbosity, IT.initializeTestSuite = combine IT.initializeTestSuite, IT.interactive = combine IT.interactive, IT.language = combine IT.language, IT.license = combine IT.license, IT.mainIs = combine IT.mainIs, IT.minimal = combine IT.minimal, IT.noComments = combine IT.noComments, IT.otherExts = combineMonoid savedInitFlags IT.otherExts, IT.otherModules = combineMonoid savedInitFlags IT.otherModules, IT.overwrite = combine IT.overwrite, IT.packageDir = combine IT.packageDir, IT.packageName = combine IT.packageName, IT.packageType = combine IT.packageType, IT.quiet = combine IT.quiet, IT.simpleProject = combine IT.simpleProject, IT.sourceDirs = combineMonoid savedInitFlags IT.sourceDirs, IT.synopsis = combine IT.synopsis, IT.testDirs = combineMonoid savedInitFlags IT.testDirs, IT.version = combine IT.version } where combine = combine' savedInitFlags combinedSavedInstallFlags = InstallFlags { installDocumentation = combine installDocumentation, installHaddockIndex = combine installHaddockIndex, installDryRun = combine installDryRun, installDest = combine installDest, installMaxBackjumps = combine installMaxBackjumps, installReorderGoals = combine installReorderGoals, installCountConflicts = combine installCountConflicts, installFineGrainedConflicts = combine installFineGrainedConflicts, installMinimizeConflictSet = combine installMinimizeConflictSet, installIndependentGoals = combine installIndependentGoals, installShadowPkgs = combine installShadowPkgs, installStrongFlags = combine installStrongFlags, installAllowBootLibInstalls = combine installAllowBootLibInstalls, installOnlyConstrained = combine installOnlyConstrained, installReinstall = combine installReinstall, installAvoidReinstalls = combine installAvoidReinstalls, installOverrideReinstall = combine installOverrideReinstall, installUpgradeDeps = combine installUpgradeDeps, installOnly = combine installOnly, installOnlyDeps = combine installOnlyDeps, installIndexState = combine installIndexState, installRootCmd = combine installRootCmd, installSummaryFile = lastNonEmptyNL installSummaryFile, installLogFile = combine installLogFile, installBuildReports = combine installBuildReports, installReportPlanningFailure = combine installReportPlanningFailure, installSymlinkBinDir = combine installSymlinkBinDir, installPerComponent = combine installPerComponent, installOneShot = combine installOneShot, installNumJobs = combine installNumJobs, installKeepGoing = combine installKeepGoing, installRunTests = combine installRunTests, installOfflineMode = combine installOfflineMode } where combine = combine' savedInstallFlags lastNonEmptyNL = lastNonEmptyNL' savedInstallFlags combinedSavedClientInstallFlags = ClientInstallFlags { cinstInstallLibs = combine cinstInstallLibs , cinstEnvironmentPath = combine cinstEnvironmentPath , cinstOverwritePolicy = combine cinstOverwritePolicy , cinstInstallMethod = combine cinstInstallMethod , cinstInstalldir = combine cinstInstalldir } where combine = combine' savedClientInstallFlags combinedSavedConfigureFlags = ConfigFlags { configArgs = lastNonEmpty configArgs, configPrograms_ = configPrograms_ . savedConfigureFlags $ b, -- TODO: NubListify configProgramPaths = lastNonEmpty configProgramPaths, -- TODO: NubListify configProgramArgs = lastNonEmpty configProgramArgs, configProgramPathExtra = lastNonEmptyNL configProgramPathExtra, configInstantiateWith = lastNonEmpty configInstantiateWith, configHcFlavor = combine configHcFlavor, configHcPath = combine configHcPath, configHcPkg = combine configHcPkg, configVanillaLib = combine configVanillaLib, configProfLib = combine configProfLib, configProf = combine configProf, configSharedLib = combine configSharedLib, configStaticLib = combine configStaticLib, configDynExe = combine configDynExe, configFullyStaticExe = combine configFullyStaticExe, configProfExe = combine configProfExe, configProfDetail = combine configProfDetail, configProfLibDetail = combine configProfLibDetail, -- TODO: NubListify configConfigureArgs = lastNonEmpty configConfigureArgs, configOptimization = combine configOptimization, configDebugInfo = combine configDebugInfo, configProgPrefix = combine configProgPrefix, configProgSuffix = combine configProgSuffix, -- Parametrised by (Flag PathTemplate), so safe to use 'mappend'. configInstallDirs = (configInstallDirs . savedConfigureFlags $ a) `mappend` (configInstallDirs . savedConfigureFlags $ b), configScratchDir = combine configScratchDir, -- TODO: NubListify configExtraLibDirs = lastNonEmpty configExtraLibDirs, -- TODO: NubListify configExtraFrameworkDirs = lastNonEmpty configExtraFrameworkDirs, -- TODO: NubListify configExtraIncludeDirs = lastNonEmpty configExtraIncludeDirs, configDeterministic = combine configDeterministic, configIPID = combine configIPID, configCID = combine configCID, configDistPref = combine configDistPref, configCabalFilePath = combine configCabalFilePath, configVerbosity = combine configVerbosity, configUserInstall = combine configUserInstall, -- TODO: NubListify configPackageDBs = lastNonEmpty configPackageDBs, configGHCiLib = combine configGHCiLib, configSplitSections = combine configSplitSections, configSplitObjs = combine configSplitObjs, configStripExes = combine configStripExes, configStripLibs = combine configStripLibs, -- TODO: NubListify configConstraints = lastNonEmpty configConstraints, -- TODO: NubListify configDependencies = lastNonEmpty configDependencies, -- TODO: NubListify configConfigurationsFlags = lastNonMempty configConfigurationsFlags, configTests = combine configTests, configBenchmarks = combine configBenchmarks, configCoverage = combine configCoverage, configLibCoverage = combine configLibCoverage, configExactConfiguration = combine configExactConfiguration, configFlagError = combine configFlagError, configRelocatable = combine configRelocatable, configUseResponseFiles = combine configUseResponseFiles, configAllowDependingOnPrivateLibs = combine configAllowDependingOnPrivateLibs } where combine = combine' savedConfigureFlags lastNonEmpty = lastNonEmpty' savedConfigureFlags lastNonEmptyNL = lastNonEmptyNL' savedConfigureFlags lastNonMempty = lastNonMempty' savedConfigureFlags combinedSavedConfigureExFlags = ConfigExFlags { configCabalVersion = combine configCabalVersion, -- TODO: NubListify configExConstraints = lastNonEmpty configExConstraints, -- TODO: NubListify configPreferences = lastNonEmpty configPreferences, configSolver = combine configSolver, configAllowNewer = combineMonoid savedConfigureExFlags configAllowNewer, configAllowOlder = combineMonoid savedConfigureExFlags configAllowOlder, configWriteGhcEnvironmentFilesPolicy = combine configWriteGhcEnvironmentFilesPolicy } where combine = combine' savedConfigureExFlags lastNonEmpty = lastNonEmpty' savedConfigureExFlags -- Parametrised by (Flag PathTemplate), so safe to use 'mappend'. combinedSavedUserInstallDirs = savedUserInstallDirs a `mappend` savedUserInstallDirs b -- Parametrised by (Flag PathTemplate), so safe to use 'mappend'. combinedSavedGlobalInstallDirs = savedGlobalInstallDirs a `mappend` savedGlobalInstallDirs b combinedSavedUploadFlags = UploadFlags { uploadCandidate = combine uploadCandidate, uploadDoc = combine uploadDoc, uploadUsername = combine uploadUsername, uploadPassword = combine uploadPassword, uploadPasswordCmd = combine uploadPasswordCmd, uploadVerbosity = combine uploadVerbosity } where combine = combine' savedUploadFlags combinedSavedReportFlags = ReportFlags { reportUsername = combine reportUsername, reportPassword = combine reportPassword, reportVerbosity = combine reportVerbosity } where combine = combine' savedReportFlags combinedSavedHaddockFlags = HaddockFlags { -- TODO: NubListify haddockProgramPaths = lastNonEmpty haddockProgramPaths, -- TODO: NubListify haddockProgramArgs = lastNonEmpty haddockProgramArgs, haddockHoogle = combine haddockHoogle, haddockHtml = combine haddockHtml, haddockHtmlLocation = combine haddockHtmlLocation, haddockForHackage = combine haddockForHackage, haddockExecutables = combine haddockExecutables, haddockTestSuites = combine haddockTestSuites, haddockBenchmarks = combine haddockBenchmarks, haddockForeignLibs = combine haddockForeignLibs, haddockInternal = combine haddockInternal, haddockCss = combine haddockCss, haddockLinkedSource = combine haddockLinkedSource, haddockQuickJump = combine haddockQuickJump, haddockHscolourCss = combine haddockHscolourCss, haddockContents = combine haddockContents, haddockDistPref = combine haddockDistPref, haddockKeepTempFiles = combine haddockKeepTempFiles, haddockVerbosity = combine haddockVerbosity, haddockCabalFilePath = combine haddockCabalFilePath, haddockArgs = lastNonEmpty haddockArgs } where combine = combine' savedHaddockFlags lastNonEmpty = lastNonEmpty' savedHaddockFlags combinedSavedTestFlags = TestFlags { testDistPref = combine testDistPref, testVerbosity = combine testVerbosity, testHumanLog = combine testHumanLog, testMachineLog = combine testMachineLog, testShowDetails = combine testShowDetails, testKeepTix = combine testKeepTix, testWrapper = combine testWrapper, testFailWhenNoTestSuites = combine testFailWhenNoTestSuites, testOptions = lastNonEmpty testOptions } where combine = combine' savedTestFlags lastNonEmpty = lastNonEmpty' savedTestFlags combinedSavedBenchmarkFlags = BenchmarkFlags { benchmarkDistPref = combine benchmarkDistPref, benchmarkVerbosity = combine benchmarkVerbosity, benchmarkOptions = lastNonEmpty benchmarkOptions } where combine = combine' savedBenchmarkFlags lastNonEmpty = lastNonEmpty' savedBenchmarkFlags combinedSavedProjectFlags = ProjectFlags { flagProjectFileName = combine flagProjectFileName , flagIgnoreProject = combine flagIgnoreProject } where combine = combine' savedProjectFlags -- -- * Default config -- -- | These are the absolute basic defaults. The fields that must be -- initialised. When we load the config from the file we layer the loaded -- values over these ones, so any missing fields in the file take their values -- from here. -- baseSavedConfig :: IO SavedConfig baseSavedConfig = do userPrefix <- getCabalDir cacheDir <- defaultCacheDir logsDir <- defaultLogsDir worldFile <- defaultWorldFile return mempty { savedConfigureFlags = mempty { configHcFlavor = toFlag defaultCompiler, configUserInstall = toFlag defaultUserInstall, configVerbosity = toFlag normal }, savedUserInstallDirs = mempty { prefix = toFlag (toPathTemplate userPrefix) }, savedGlobalFlags = mempty { globalCacheDir = toFlag cacheDir, globalLogsDir = toFlag logsDir, globalWorldFile = toFlag worldFile } } -- | This is the initial configuration that we write out to the config file -- if the file does not exist (or the config we use if the file cannot be read -- for some other reason). When the config gets loaded it gets layered on top -- of 'baseSavedConfig' so we do not need to include it into the initial -- values we save into the config file. -- initialSavedConfig :: IO SavedConfig initialSavedConfig = do cacheDir <- defaultCacheDir logsDir <- defaultLogsDir worldFile <- defaultWorldFile extraPath <- defaultExtraPath installPath <- defaultInstallPath return mempty { savedGlobalFlags = mempty { globalCacheDir = toFlag cacheDir, globalRemoteRepos = toNubList [defaultRemoteRepo], globalWorldFile = toFlag worldFile }, savedConfigureFlags = mempty { configProgramPathExtra = toNubList extraPath }, savedInstallFlags = mempty { installSummaryFile = toNubList [toPathTemplate (logsDir "build.log")], installBuildReports= toFlag NoReports, installNumJobs = toFlag Nothing }, savedClientInstallFlags = mempty { cinstInstalldir = toFlag installPath } } defaultCabalDir :: IO FilePath defaultCabalDir = getAppUserDataDirectory "cabal" getCabalDir :: IO FilePath getCabalDir = do mDir <- lookupEnv "CABAL_DIR" case mDir of Nothing -> defaultCabalDir Just dir -> return dir defaultConfigFile :: IO FilePath defaultConfigFile = do dir <- getCabalDir return $ dir "config" defaultCacheDir :: IO FilePath defaultCacheDir = do dir <- getCabalDir return $ dir "packages" defaultLogsDir :: IO FilePath defaultLogsDir = do dir <- getCabalDir return $ dir "logs" -- | Default position of the world file defaultWorldFile :: IO FilePath defaultWorldFile = do dir <- getCabalDir return $ dir "world" defaultExtraPath :: IO [FilePath] defaultExtraPath = do dir <- getCabalDir return [dir "bin"] defaultInstallPath :: IO FilePath defaultInstallPath = do dir <- getCabalDir return (dir "bin") defaultCompiler :: CompilerFlavor defaultCompiler = fromMaybe GHC defaultCompilerFlavor defaultUserInstall :: Bool defaultUserInstall = True -- We do per-user installs by default on all platforms. We used to default to -- global installs on Windows but that no longer works on Windows Vista or 7. defaultRemoteRepo :: RemoteRepo defaultRemoteRepo = RemoteRepo name uri Nothing [] 0 False where str = "hackage.haskell.org" name = RepoName str uri = URI "http:" (Just (URIAuth "" str "")) "/" "" "" -- Note that lots of old ~/.cabal/config files will have the old url -- http://hackage.haskell.org/packages/archive -- but new config files can use the new url (without the /packages/archive) -- and avoid having to do a http redirect -- For the default repo we know extra information, fill this in. -- -- We need this because the 'defaultRemoteRepo' above is only used for the -- first time when a config file is made. So for users with older config files -- we might have only have older info. This lets us fill that in even for old -- config files. -- addInfoForKnownRepos :: RemoteRepo -> RemoteRepo addInfoForKnownRepos repo | remoteRepoName repo == remoteRepoName defaultRemoteRepo = useSecure . tryHttps . fixOldURI $ repo where fixOldURI r | isOldHackageURI (remoteRepoURI r) = r { remoteRepoURI = remoteRepoURI defaultRemoteRepo } | otherwise = r tryHttps r = r { remoteRepoShouldTryHttps = True } useSecure r@RemoteRepo{ remoteRepoSecure = secure, remoteRepoRootKeys = [], remoteRepoKeyThreshold = 0 } | secure /= Just False = r { -- Use hackage-security by default unless you opt-out with -- secure: False remoteRepoSecure = Just True, remoteRepoRootKeys = defaultHackageRemoteRepoKeys, remoteRepoKeyThreshold = defaultHackageRemoteRepoKeyThreshold } useSecure r = r addInfoForKnownRepos other = other -- | The current hackage.haskell.org repo root keys that we ship with cabal. --- -- This lets us bootstrap trust in this repo without user intervention. -- These keys need to be periodically updated when new root keys are added. -- See the root key procedures for details. -- defaultHackageRemoteRepoKeys :: [String] defaultHackageRemoteRepoKeys = [ "fe331502606802feac15e514d9b9ea83fee8b6ffef71335479a2e68d84adc6b0", "1ea9ba32c526d1cc91ab5e5bd364ec5e9e8cb67179a471872f6e26f0ae773d42", "2c6c3627bd6c982990239487f1abd02e08a02e6cf16edb105a8012d444d870c3", "0a5c7ea47cd1b15f01f5f51a33adda7e655bc0f0b0615baa8e271f4c3351e21d", "51f0161b906011b52c6613376b1ae937670da69322113a246a09f807c62f6921" ] -- | The required threshold of root key signatures for hackage.haskell.org -- defaultHackageRemoteRepoKeyThreshold :: Int defaultHackageRemoteRepoKeyThreshold = 3 -- -- * Config file reading -- -- | Loads the main configuration, and applies additional defaults to give the -- effective configuration. To loads just what is actually in the config file, -- use 'loadRawConfig'. -- loadConfig :: Verbosity -> Flag FilePath -> IO SavedConfig loadConfig verbosity configFileFlag = do config <- loadRawConfig verbosity configFileFlag extendToEffectiveConfig config extendToEffectiveConfig :: SavedConfig -> IO SavedConfig extendToEffectiveConfig config = do base <- baseSavedConfig let effective0 = base `mappend` config globalFlags0 = savedGlobalFlags effective0 effective = effective0 { savedGlobalFlags = globalFlags0 { globalRemoteRepos = overNubList (map addInfoForKnownRepos) (globalRemoteRepos globalFlags0) } } return effective -- | Like 'loadConfig' but does not apply any additional defaults, it just -- loads what is actually in the config file. This is thus suitable for -- comparing or editing a config file, but not suitable for using as the -- effective configuration. -- loadRawConfig :: Verbosity -> Flag FilePath -> IO SavedConfig loadRawConfig verbosity configFileFlag = do (source, configFile) <- getConfigFilePathAndSource configFileFlag minp <- readConfigFile mempty configFile case minp of Nothing -> do notice verbosity $ "Config file path source is " ++ sourceMsg source ++ "." notice verbosity $ "Config file " ++ configFile ++ " not found." createDefaultConfigFile verbosity [] configFile Just (ParseOk ws conf) -> do unless (null ws) $ warn verbosity $ unlines (map (showPWarning configFile) ws) return conf Just (ParseFailed err) -> do let (line, msg) = locatedErrorMsg err die' verbosity $ "Error parsing config file " ++ configFile ++ maybe "" (\n -> ':' : show n) line ++ ":\n" ++ msg where sourceMsg CommandlineOption = "commandline option" sourceMsg EnvironmentVariable = "env var CABAL_CONFIG" sourceMsg Default = "default config file" data ConfigFileSource = CommandlineOption | EnvironmentVariable | Default -- | Returns the config file path, without checking that the file exists. -- The order of precedence is: input flag, CABAL_CONFIG, default location. getConfigFilePath :: Flag FilePath -> IO FilePath getConfigFilePath = fmap snd . getConfigFilePathAndSource getConfigFilePathAndSource :: Flag FilePath -> IO (ConfigFileSource, FilePath) getConfigFilePathAndSource configFileFlag = getSource sources where sources = [ (CommandlineOption, return . flagToMaybe $ configFileFlag) , (EnvironmentVariable, lookup "CABAL_CONFIG" `liftM` getEnvironment) , (Default, Just `liftM` defaultConfigFile) ] getSource [] = error "no config file path candidate found." getSource ((source,action): xs) = action >>= maybe (getSource xs) (return . (,) source) readConfigFile :: SavedConfig -> FilePath -> IO (Maybe (ParseResult SavedConfig)) readConfigFile initial file = handleNotExists $ fmap (Just . parseConfig (ConstraintSourceMainConfig file) initial) (readFile file) where handleNotExists action = catchIO action $ \ioe -> if isDoesNotExistError ioe then return Nothing else ioError ioe createDefaultConfigFile :: Verbosity -> [String] -> FilePath -> IO SavedConfig createDefaultConfigFile verbosity extraLines filePath = do commentConf <- commentSavedConfig initialConf <- initialSavedConfig extraConf <- parseExtraLines verbosity extraLines notice verbosity $ "Writing default configuration to " ++ filePath writeConfigFile filePath commentConf (initialConf `mappend` extraConf) return initialConf writeConfigFile :: FilePath -> SavedConfig -> SavedConfig -> IO () writeConfigFile file comments vals = do let tmpFile = file <.> "tmp" createDirectoryIfMissing True (takeDirectory file) writeFile tmpFile $ explanation ++ showConfigWithComments comments vals ++ "\n" renameFile tmpFile file where explanation = unlines ["-- This is the configuration file for the 'cabal' command line tool." ,"--" ,"-- The available configuration options are listed below." ,"-- Some of them have default values listed." ,"--" ,"-- Lines (like this one) beginning with '--' are comments." ,"-- Be careful with spaces and indentation because they are" ,"-- used to indicate layout for nested sections." ,"--" ,"-- This config file was generated using the following versions" ,"-- of Cabal and cabal-install:" ,"-- Cabal library version: " ++ prettyShow cabalVersion ,"-- cabal-install version: " ++ prettyShow cabalInstallVersion ,"","" ] -- | These are the default values that get used in Cabal if a no value is -- given. We use these here to include in comments when we write out the -- initial config file so that the user can see what default value they are -- overriding. -- commentSavedConfig :: IO SavedConfig commentSavedConfig = do userInstallDirs <- defaultInstallDirs defaultCompiler True True globalInstallDirs <- defaultInstallDirs defaultCompiler False True let conf0 = mempty { savedGlobalFlags = defaultGlobalFlags { globalRemoteRepos = toNubList [defaultRemoteRepo] }, savedInitFlags = mempty { IT.interactive = toFlag False, IT.cabalVersion = toFlag IT.defaultCabalVersion, IT.language = toFlag Haskell2010, IT.license = NoFlag, IT.sourceDirs = Just [IT.defaultSourceDir], IT.applicationDirs = Just [IT.defaultApplicationDir] }, savedInstallFlags = defaultInstallFlags, savedClientInstallFlags= defaultClientInstallFlags, savedConfigureExFlags = defaultConfigExFlags { configAllowNewer = Just (AllowNewer mempty), configAllowOlder = Just (AllowOlder mempty) }, savedConfigureFlags = (defaultConfigFlags defaultProgramDb) { configUserInstall = toFlag defaultUserInstall }, savedUserInstallDirs = fmap toFlag userInstallDirs, savedGlobalInstallDirs = fmap toFlag globalInstallDirs, savedUploadFlags = commandDefaultFlags uploadCommand, savedReportFlags = commandDefaultFlags reportCommand, savedHaddockFlags = defaultHaddockFlags, savedTestFlags = defaultTestFlags, savedBenchmarkFlags = defaultBenchmarkFlags } conf1 <- extendToEffectiveConfig conf0 let globalFlagsConf1 = savedGlobalFlags conf1 conf2 = conf1 { savedGlobalFlags = globalFlagsConf1 { globalRemoteRepos = overNubList (map removeRootKeys) (globalRemoteRepos globalFlagsConf1) } } return conf2 where -- Most people don't want to see default root keys, so don't print them. removeRootKeys :: RemoteRepo -> RemoteRepo removeRootKeys r = r { remoteRepoRootKeys = [] } -- | All config file fields. -- configFieldDescriptions :: ConstraintSource -> [FieldDescr SavedConfig] configFieldDescriptions src = toSavedConfig liftGlobalFlag (commandOptions (globalCommand []) ParseArgs) ["version", "numeric-version", "config-file"] [] ++ toSavedConfig liftConfigFlag (configureOptions ParseArgs) (["builddir", "constraint", "dependency", "ipid"] ++ map fieldName installDirsFields) -- This is only here because viewAsFieldDescr gives us a parser -- that only recognises 'ghc' etc, the case-sensitive flag names, not -- what the normal case-insensitive parser gives us. [simpleFieldParsec "compiler" (fromFlagOrDefault Disp.empty . fmap pretty) (Flag <$> parsec <|> pure NoFlag) configHcFlavor (\v flags -> flags { configHcFlavor = v }) -- TODO: The following is a temporary fix. The "optimization" -- and "debug-info" fields are OptArg, and viewAsFieldDescr -- fails on that. Instead of a hand-written hackaged parser -- and printer, we should handle this case properly in the -- library. ,liftField configOptimization (\v flags -> flags { configOptimization = v }) $ let name = "optimization" in FieldDescr name (\f -> case f of Flag NoOptimisation -> Disp.text "False" Flag NormalOptimisation -> Disp.text "True" Flag MaximumOptimisation -> Disp.text "2" _ -> Disp.empty) (\line str _ -> case () of _ | str == "False" -> ParseOk [] (Flag NoOptimisation) | str == "True" -> ParseOk [] (Flag NormalOptimisation) | str == "0" -> ParseOk [] (Flag NoOptimisation) | str == "1" -> ParseOk [] (Flag NormalOptimisation) | str == "2" -> ParseOk [] (Flag MaximumOptimisation) | lstr == "false" -> ParseOk [caseWarning] (Flag NoOptimisation) | lstr == "true" -> ParseOk [caseWarning] (Flag NormalOptimisation) | otherwise -> ParseFailed (NoParse name line) where lstr = lowercase str caseWarning = PWarning $ "The '" ++ name ++ "' field is case sensitive, use 'True' or 'False'.") ,liftField configDebugInfo (\v flags -> flags { configDebugInfo = v }) $ let name = "debug-info" in FieldDescr name (\f -> case f of Flag NoDebugInfo -> Disp.text "False" Flag MinimalDebugInfo -> Disp.text "1" Flag NormalDebugInfo -> Disp.text "True" Flag MaximalDebugInfo -> Disp.text "3" _ -> Disp.empty) (\line str _ -> case () of _ | str == "False" -> ParseOk [] (Flag NoDebugInfo) | str == "True" -> ParseOk [] (Flag NormalDebugInfo) | str == "0" -> ParseOk [] (Flag NoDebugInfo) | str == "1" -> ParseOk [] (Flag MinimalDebugInfo) | str == "2" -> ParseOk [] (Flag NormalDebugInfo) | str == "3" -> ParseOk [] (Flag MaximalDebugInfo) | lstr == "false" -> ParseOk [caseWarning] (Flag NoDebugInfo) | lstr == "true" -> ParseOk [caseWarning] (Flag NormalDebugInfo) | otherwise -> ParseFailed (NoParse name line) where lstr = lowercase str caseWarning = PWarning $ "The '" ++ name ++ "' field is case sensitive, use 'True' or 'False'.") ] ++ toSavedConfig liftConfigExFlag (configureExOptions ParseArgs src) [] [let pkgs = (Just . AllowOlder . RelaxDepsSome) `fmap` parsecOptCommaList parsec parseAllowOlder = ((Just . AllowOlder . toRelaxDeps) `fmap` parsec) Parse.<++ pkgs in simpleField "allow-older" (showRelaxDeps . fmap unAllowOlder) parseAllowOlder configAllowOlder (\v flags -> flags { configAllowOlder = v }) ,let pkgs = (Just . AllowNewer . RelaxDepsSome) `fmap` parsecOptCommaList parsec parseAllowNewer = ((Just . AllowNewer . toRelaxDeps) `fmap` parsec) Parse.<++ pkgs in simpleField "allow-newer" (showRelaxDeps . fmap unAllowNewer) parseAllowNewer configAllowNewer (\v flags -> flags { configAllowNewer = v }) ] ++ toSavedConfig liftInstallFlag (installOptions ParseArgs) ["dry-run", "only", "only-dependencies", "dependencies-only"] [] ++ toSavedConfig liftClientInstallFlag (clientInstallOptions ParseArgs) [] [] ++ toSavedConfig liftUploadFlag (commandOptions uploadCommand ParseArgs) ["verbose", "check", "documentation", "publish"] [] ++ toSavedConfig liftReportFlag (commandOptions reportCommand ParseArgs) ["verbose", "username", "password"] [] --FIXME: this is a hack, hiding the user name and password. -- But otherwise it masks the upload ones. Either need to -- share the options or make then distinct. In any case -- they should probably be per-server. ++ [ viewAsFieldDescr $ optionDistPref (configDistPref . savedConfigureFlags) (\distPref config -> config { savedConfigureFlags = (savedConfigureFlags config) { configDistPref = distPref } , savedHaddockFlags = (savedHaddockFlags config) { haddockDistPref = distPref } } ) ParseArgs ] where toSavedConfig lift options exclusions replacements = [ lift (fromMaybe field replacement) | opt <- options , let field = viewAsFieldDescr opt name = fieldName field replacement = find ((== name) . fieldName) replacements , name `notElem` exclusions ] showRelaxDeps Nothing = mempty showRelaxDeps (Just rd) | isRelaxDeps rd = Disp.text "True" | otherwise = Disp.text "False" toRelaxDeps True = RelaxDepsAll toRelaxDeps False = mempty -- TODO: next step, make the deprecated fields elicit a warning. -- deprecatedFieldDescriptions :: [FieldDescr SavedConfig] deprecatedFieldDescriptions = [ liftGlobalFlag $ listFieldParsec "repos" pretty parsec (fromNubList . globalRemoteRepos) (\rs cfg -> cfg { globalRemoteRepos = toNubList rs }) , liftGlobalFlag $ simpleField "cachedir" (Disp.text . fromFlagOrDefault "") (optional parseFilePathQ) globalCacheDir (\d cfg -> cfg { globalCacheDir = d }) , liftUploadFlag $ simpleField "hackage-username" (Disp.text . fromFlagOrDefault "" . fmap unUsername) (optional (fmap Username parseTokenQ)) uploadUsername (\d cfg -> cfg { uploadUsername = d }) , liftUploadFlag $ simpleField "hackage-password" (Disp.text . fromFlagOrDefault "" . fmap unPassword) (optional (fmap Password parseTokenQ)) uploadPassword (\d cfg -> cfg { uploadPassword = d }) , liftUploadFlag $ spaceListField "hackage-password-command" Disp.text parseTokenQ (fromFlagOrDefault [] . uploadPasswordCmd) (\d cfg -> cfg { uploadPasswordCmd = Flag d }) ] ++ map (modifyFieldName ("user-"++) . liftUserInstallDirs) installDirsFields ++ map (modifyFieldName ("global-"++) . liftGlobalInstallDirs) installDirsFields where optional = Parse.option mempty . fmap toFlag modifyFieldName :: (String -> String) -> FieldDescr a -> FieldDescr a modifyFieldName f d = d { fieldName = f (fieldName d) } liftUserInstallDirs :: FieldDescr (InstallDirs (Flag PathTemplate)) -> FieldDescr SavedConfig liftUserInstallDirs = liftField savedUserInstallDirs (\flags conf -> conf { savedUserInstallDirs = flags }) liftGlobalInstallDirs :: FieldDescr (InstallDirs (Flag PathTemplate)) -> FieldDescr SavedConfig liftGlobalInstallDirs = liftField savedGlobalInstallDirs (\flags conf -> conf { savedGlobalInstallDirs = flags }) liftGlobalFlag :: FieldDescr GlobalFlags -> FieldDescr SavedConfig liftGlobalFlag = liftField savedGlobalFlags (\flags conf -> conf { savedGlobalFlags = flags }) liftConfigFlag :: FieldDescr ConfigFlags -> FieldDescr SavedConfig liftConfigFlag = liftField savedConfigureFlags (\flags conf -> conf { savedConfigureFlags = flags }) liftConfigExFlag :: FieldDescr ConfigExFlags -> FieldDescr SavedConfig liftConfigExFlag = liftField savedConfigureExFlags (\flags conf -> conf { savedConfigureExFlags = flags }) liftInstallFlag :: FieldDescr InstallFlags -> FieldDescr SavedConfig liftInstallFlag = liftField savedInstallFlags (\flags conf -> conf { savedInstallFlags = flags }) liftClientInstallFlag :: FieldDescr ClientInstallFlags -> FieldDescr SavedConfig liftClientInstallFlag = liftField savedClientInstallFlags (\flags conf -> conf { savedClientInstallFlags = flags }) liftUploadFlag :: FieldDescr UploadFlags -> FieldDescr SavedConfig liftUploadFlag = liftField savedUploadFlags (\flags conf -> conf { savedUploadFlags = flags }) liftReportFlag :: FieldDescr ReportFlags -> FieldDescr SavedConfig liftReportFlag = liftField savedReportFlags (\flags conf -> conf { savedReportFlags = flags }) parseConfig :: ConstraintSource -> SavedConfig -> String -> ParseResult SavedConfig parseConfig src initial = \str -> do fields <- readFields str let (knownSections, others) = partition isKnownSection fields config <- parse others let init0 = savedInitFlags config user0 = savedUserInstallDirs config global0 = savedGlobalInstallDirs config (remoteRepoSections0, localRepoSections0, haddockFlags, initFlags, user, global, paths, args) <- foldM parseSections ([], [], savedHaddockFlags config, init0, user0, global0, [], []) knownSections let remoteRepoSections = reverse . nubBy ((==) `on` remoteRepoName) $ remoteRepoSections0 let localRepoSections = reverse . nubBy ((==) `on` localRepoName) $ localRepoSections0 return . fixConfigMultilines $ config { savedGlobalFlags = (savedGlobalFlags config) { globalRemoteRepos = toNubList remoteRepoSections, globalLocalNoIndexRepos = toNubList localRepoSections, -- the global extra prog path comes from the configure flag prog path globalProgPathExtra = configProgramPathExtra (savedConfigureFlags config) }, savedConfigureFlags = (savedConfigureFlags config) { configProgramPaths = paths, configProgramArgs = args }, savedHaddockFlags = haddockFlags, savedInitFlags = initFlags, savedUserInstallDirs = user, savedGlobalInstallDirs = global } where isKnownSection (ParseUtils.Section _ "repository" _ _) = True isKnownSection (ParseUtils.F _ "remote-repo" _) = True isKnownSection (ParseUtils.Section _ "haddock" _ _) = True isKnownSection (ParseUtils.Section _ "init" _ _) = True isKnownSection (ParseUtils.Section _ "install-dirs" _ _) = True isKnownSection (ParseUtils.Section _ "program-locations" _ _) = True isKnownSection (ParseUtils.Section _ "program-default-options" _ _) = True isKnownSection _ = False -- Attempt to split fields that can represent lists of paths into -- actual lists on failure, leave the field untouched. splitMultiPath :: [String] -> [String] splitMultiPath [s] = case runP 0 "" (parseOptCommaList parseTokenQ) s of ParseOk _ res -> res _ -> [s] splitMultiPath xs = xs -- This is a fixup, pending a full config parser rewrite, to -- ensure that config fields which can be comma-separated lists -- actually parse as comma-separated lists. fixConfigMultilines conf = conf { savedConfigureFlags = let scf = savedConfigureFlags conf in scf { configProgramPathExtra = toNubList $ splitMultiPath (fromNubList $ configProgramPathExtra scf) , configExtraLibDirs = splitMultiPath (configExtraLibDirs scf) , configExtraFrameworkDirs = splitMultiPath (configExtraFrameworkDirs scf) , configExtraIncludeDirs = splitMultiPath (configExtraIncludeDirs scf) , configConfigureArgs = splitMultiPath (configConfigureArgs scf) } } parse = parseFields (configFieldDescriptions src ++ deprecatedFieldDescriptions) initial parseSections (rs, ls, h, i, u, g, p, a) (ParseUtils.Section lineno "repository" name fs) = do name' <- maybe (ParseFailed $ NoParse "repository name" lineno) return $ simpleParsec name r' <- parseFields remoteRepoFields (emptyRemoteRepo name') fs r'' <- postProcessRepo lineno name r' case r'' of Left local -> return (rs, local:ls, h, i, u, g, p, a) Right remote -> return (remote:rs, ls, h, i, u, g, p, a) parseSections (rs, ls, h, i, u, g, p, a) (ParseUtils.F lno "remote-repo" raw) = do let mr' = simpleParsec raw r' <- maybe (ParseFailed $ NoParse "remote-repo" lno) return mr' return (r':rs, ls, h, i, u, g, p, a) parseSections accum@(rs, ls, h, i, u, g, p, a) (ParseUtils.Section _ "haddock" name fs) | name == "" = do h' <- parseFields haddockFlagsFields h fs return (rs, ls, h', i, u, g, p, a) | otherwise = do warning "The 'haddock' section should be unnamed" return accum parseSections accum@(rs, ls, h, i, u, g, p, a) (ParseUtils.Section _ "init" name fs) | name == "" = do i' <- parseFields initFlagsFields i fs return (rs, ls, h, i', u, g, p, a) | otherwise = do warning "The 'init' section should be unnamed" return accum parseSections accum@(rs, ls, h, i, u, g, p, a) (ParseUtils.Section _ "install-dirs" name fs) | name' == "user" = do u' <- parseFields installDirsFields u fs return (rs, ls, h, i, u', g, p, a) | name' == "global" = do g' <- parseFields installDirsFields g fs return (rs, ls, h, i, u, g', p, a) | otherwise = do warning "The 'install-paths' section should be for 'user' or 'global'" return accum where name' = lowercase name parseSections accum@(rs, ls, h, i, u, g, p, a) (ParseUtils.Section _ "program-locations" name fs) | name == "" = do p' <- parseFields withProgramsFields p fs return (rs, ls, h, i, u, g, p', a) | otherwise = do warning "The 'program-locations' section should be unnamed" return accum parseSections accum@(rs, ls, h, i, u, g, p, a) (ParseUtils.Section _ "program-default-options" name fs) | name == "" = do a' <- parseFields withProgramOptionsFields a fs return (rs, ls, h, i, u, g, p, a') | otherwise = do warning "The 'program-default-options' section should be unnamed" return accum parseSections accum f = do warning $ "Unrecognized stanza on line " ++ show (lineNo f) return accum postProcessRepo :: Int -> String -> RemoteRepo -> ParseResult (Either LocalRepo RemoteRepo) postProcessRepo lineno reponameStr repo0 = do when (null reponameStr) $ syntaxError lineno $ "a 'repository' section requires the " ++ "repository name as an argument" reponame <- maybe (fail $ "Invalid repository name " ++ reponameStr) return $ simpleParsec reponameStr case uriScheme (remoteRepoURI repo0) of -- TODO: check that there are no authority, query or fragment -- Note: the trailing colon is important "file+noindex:" -> do let uri = remoteRepoURI repo0 return $ Left $ LocalRepo reponame (uriPath uri) (uriFragment uri == "#shared-cache") _ -> do let repo = repo0 { remoteRepoName = reponame } when (remoteRepoKeyThreshold repo > length (remoteRepoRootKeys repo)) $ warning $ "'key-threshold' for repository " ++ show (remoteRepoName repo) ++ " higher than number of keys" when (not (null (remoteRepoRootKeys repo)) && remoteRepoSecure repo /= Just True) $ warning $ "'root-keys' for repository " ++ show (remoteRepoName repo) ++ " non-empty, but 'secure' not set to True." return $ Right repo showConfig :: SavedConfig -> String showConfig = showConfigWithComments mempty showConfigWithComments :: SavedConfig -> SavedConfig -> String showConfigWithComments comment vals = Disp.render $ case fmap (uncurry ppRemoteRepoSection) (zip (getRemoteRepos comment) (getRemoteRepos vals)) of [] -> Disp.text "" (x:xs) -> foldl' (\ r r' -> r $+$ Disp.text "" $+$ r') x xs $+$ Disp.text "" $+$ ppFields (skipSomeFields (configFieldDescriptions ConstraintSourceUnknown)) mcomment vals $+$ Disp.text "" $+$ ppSection "haddock" "" haddockFlagsFields (fmap savedHaddockFlags mcomment) (savedHaddockFlags vals) $+$ Disp.text "" $+$ ppSection "init" "" initFlagsFields (fmap savedInitFlags mcomment) (savedInitFlags vals) $+$ Disp.text "" $+$ installDirsSection "user" savedUserInstallDirs $+$ Disp.text "" $+$ installDirsSection "global" savedGlobalInstallDirs $+$ Disp.text "" $+$ configFlagsSection "program-locations" withProgramsFields configProgramPaths $+$ Disp.text "" $+$ configFlagsSection "program-default-options" withProgramOptionsFields configProgramArgs where getRemoteRepos = fromNubList . globalRemoteRepos . savedGlobalFlags mcomment = Just comment installDirsSection name field = ppSection "install-dirs" name installDirsFields (fmap field mcomment) (field vals) configFlagsSection name fields field = ppSection name "" fields (fmap (field . savedConfigureFlags) mcomment) ((field . savedConfigureFlags) vals) -- skip fields based on field name. currently only skips "remote-repo", -- because that is rendered as a section. (see 'ppRemoteRepoSection'.) skipSomeFields = filter ((/= "remote-repo") . fieldName) -- | Fields for the 'install-dirs' sections. installDirsFields :: [FieldDescr (InstallDirs (Flag PathTemplate))] installDirsFields = map viewAsFieldDescr installDirsOptions ppRemoteRepoSection :: RemoteRepo -> RemoteRepo -> Doc ppRemoteRepoSection def vals = ppSection "repository" (unRepoName (remoteRepoName vals)) remoteRepoFields (Just def) vals remoteRepoFields :: [FieldDescr RemoteRepo] remoteRepoFields = [ simpleField "url" (text . show) (parseTokenQ >>= parseURI') remoteRepoURI (\x repo -> repo { remoteRepoURI = x }) , simpleFieldParsec "secure" showSecure (Just `fmap` parsec) remoteRepoSecure (\x repo -> repo { remoteRepoSecure = x }) , listField "root-keys" text parseTokenQ remoteRepoRootKeys (\x repo -> repo { remoteRepoRootKeys = x }) , simpleFieldParsec "key-threshold" showThreshold P.integral remoteRepoKeyThreshold (\x repo -> repo { remoteRepoKeyThreshold = x }) ] where parseURI' uriString = case parseURI uriString of Nothing -> fail $ "remote-repo: no parse on " ++ show uriString Just uri -> return uri showSecure Nothing = mempty -- default 'secure' setting showSecure (Just True) = text "True" -- user explicitly enabled it showSecure (Just False) = text "False" -- user explicitly disabled it -- If the key-threshold is set to 0, we omit it as this is the default -- and it looks odd to have a value for key-threshold but not for 'secure' -- (note that an empty list of keys is already omitted by default, since -- that is what we do for all list fields) showThreshold 0 = mempty showThreshold t = text (show t) -- | Fields for the 'haddock' section. haddockFlagsFields :: [FieldDescr HaddockFlags] haddockFlagsFields = [ field | opt <- haddockOptions ParseArgs , let field = viewAsFieldDescr opt name = fieldName field , name `notElem` exclusions ] where exclusions = ["verbose", "builddir", "for-hackage"] -- | Fields for the 'init' section. initFlagsFields :: [FieldDescr IT.InitFlags] initFlagsFields = [ field | opt <- initOptions ParseArgs , let field = viewAsFieldDescr opt name = fieldName field , name `notElem` exclusions ] where exclusions = [ "author", "email", "quiet", "no-comments", "minimal", "overwrite" , "package-dir", "packagedir", "package-name", "version", "homepage" , "synopsis", "category", "extra-source-file", "lib", "exe", "libandexe" , "simple", "main-is", "expose-module", "exposed-modules", "extension" , "dependency", "build-tool", "with-compiler" , "verbose" ] -- | Fields for the 'program-locations' section. withProgramsFields :: [FieldDescr [(String, FilePath)]] withProgramsFields = map viewAsFieldDescr $ programDbPaths' (++ "-location") defaultProgramDb ParseArgs id (++) -- | Fields for the 'program-default-options' section. withProgramOptionsFields :: [FieldDescr [(String, [String])]] withProgramOptionsFields = map viewAsFieldDescr $ programDbOptions defaultProgramDb ParseArgs id (++) parseExtraLines :: Verbosity -> [String] -> IO SavedConfig parseExtraLines verbosity extraLines = case parseConfig (ConstraintSourceMainConfig "additional lines") mempty (unlines extraLines) of ParseFailed err -> let (line, msg) = locatedErrorMsg err in die' verbosity $ "Error parsing additional config lines\n" ++ maybe "" (\n -> ':' : show n) line ++ ":\n" ++ msg ParseOk [] r -> return r ParseOk ws _ -> die' verbosity $ unlines (map (showPWarning "Error parsing additional config lines") ws) -- | Get the differences (as a pseudo code diff) between the user's -- '~/.cabal/config' and the one that cabal would generate if it didn't exist. userConfigDiff :: Verbosity -> GlobalFlags -> [String] -> IO [String] userConfigDiff verbosity globalFlags extraLines = do userConfig <- loadRawConfig normal (globalConfigFile globalFlags) extraConfig <- parseExtraLines verbosity extraLines testConfig <- initialSavedConfig return $ reverse . foldl' createDiff [] . M.toList $ M.unionWith combine (M.fromList . map justFst $ filterShow testConfig) (M.fromList . map justSnd $ filterShow (userConfig `mappend` extraConfig)) where justFst (a, b) = (a, (Just b, Nothing)) justSnd (a, b) = (a, (Nothing, Just b)) combine (Nothing, Just b) (Just a, Nothing) = (Just a, Just b) combine (Just a, Nothing) (Nothing, Just b) = (Just a, Just b) combine x y = error $ "Can't happen : userConfigDiff " ++ show x ++ " " ++ show y createDiff :: [String] -> (String, (Maybe String, Maybe String)) -> [String] createDiff acc (key, (Just a, Just b)) | a == b = acc | otherwise = ("+ " ++ key ++ ": " ++ b) : ("- " ++ key ++ ": " ++ a) : acc createDiff acc (key, (Nothing, Just b)) = ("+ " ++ key ++ ": " ++ b) : acc createDiff acc (key, (Just a, Nothing)) = ("- " ++ key ++ ": " ++ a) : acc createDiff acc (_, (Nothing, Nothing)) = acc filterShow :: SavedConfig -> [(String, String)] filterShow cfg = map keyValueSplit . filter (\s -> not (null s) && ':' `elem` s) . map nonComment . lines $ showConfig cfg nonComment [] = [] nonComment ('-':'-':_) = [] nonComment (x:xs) = x : nonComment xs topAndTail = reverse . dropWhile isSpace . reverse . dropWhile isSpace keyValueSplit s = let (left, right) = break (== ':') s in (topAndTail left, topAndTail (drop 1 right)) -- | Update the user's ~/.cabal/config' keeping the user's customizations. userConfigUpdate :: Verbosity -> GlobalFlags -> [String] -> IO () userConfigUpdate verbosity globalFlags extraLines = do userConfig <- loadRawConfig normal (globalConfigFile globalFlags) extraConfig <- parseExtraLines verbosity extraLines newConfig <- initialSavedConfig commentConf <- commentSavedConfig cabalFile <- getConfigFilePath $ globalConfigFile globalFlags let backup = cabalFile ++ ".backup" notice verbosity $ "Renaming " ++ cabalFile ++ " to " ++ backup ++ "." renameFile cabalFile backup notice verbosity $ "Writing merged config to " ++ cabalFile ++ "." writeConfigFile cabalFile commentConf (newConfig `mappend` userConfig `mappend` extraConfig)