never executed always true always false
1 {-# LANGUAGE DeriveGeneric #-}
2
3 -----------------------------------------------------------------------------
4 -- |
5 -- Module : Distribution.Client.Config
6 -- Copyright : (c) David Himmelstrup 2005
7 -- License : BSD-like
8 --
9 -- Maintainer : lemmih@gmail.com
10 -- Stability : provisional
11 -- Portability : portable
12 --
13 -- Utilities for handling saved state such as known packages, known servers and
14 -- downloaded packages.
15 -----------------------------------------------------------------------------
16 module Distribution.Client.Config (
17 SavedConfig(..),
18 loadConfig,
19 getConfigFilePath,
20
21 showConfig,
22 showConfigWithComments,
23 parseConfig,
24
25 getCabalDir,
26 defaultConfigFile,
27 defaultCacheDir,
28 defaultCompiler,
29 defaultInstallPath,
30 defaultLogsDir,
31 defaultUserInstall,
32
33 baseSavedConfig,
34 commentSavedConfig,
35 initialSavedConfig,
36 configFieldDescriptions,
37 haddockFlagsFields,
38 installDirsFields,
39 withProgramsFields,
40 withProgramOptionsFields,
41 userConfigDiff,
42 userConfigUpdate,
43 createDefaultConfigFile,
44
45 remoteRepoFields,
46 postProcessRepo,
47 ) where
48
49 import Distribution.Client.Compat.Prelude
50 import Prelude ()
51
52 import Language.Haskell.Extension ( Language(Haskell2010) )
53
54 import Distribution.Deprecated.ViewAsFieldDescr
55 ( viewAsFieldDescr )
56
57 import Distribution.Client.Types
58 ( RemoteRepo(..), LocalRepo (..), emptyRemoteRepo
59 , AllowOlder(..), AllowNewer(..), RelaxDeps(..), isRelaxDeps
60 , RepoName (..), unRepoName
61 )
62 import Distribution.Client.Types.Credentials (Username (..), Password (..))
63 import Distribution.Client.BuildReports.Types
64 ( ReportLevel(..) )
65 import qualified Distribution.Client.Init.Types as IT
66 ( InitFlags(..) )
67 import qualified Distribution.Client.Init.Defaults as IT
68 import Distribution.Client.Setup
69 ( GlobalFlags(..), globalCommand, defaultGlobalFlags
70 , ConfigExFlags(..), configureExOptions, defaultConfigExFlags
71 , initOptions
72 , InstallFlags(..), installOptions, defaultInstallFlags
73 , UploadFlags(..), uploadCommand
74 , ReportFlags(..), reportCommand )
75 import Distribution.Client.CmdInstall.ClientInstallFlags
76 ( ClientInstallFlags(..), defaultClientInstallFlags
77 , clientInstallOptions )
78 import Distribution.Utils.NubList
79 ( NubList, fromNubList, toNubList, overNubList )
80
81 import Distribution.Simple.Compiler
82 ( DebugInfoLevel(..), OptimisationLevel(..) )
83 import Distribution.Simple.Setup
84 ( ConfigFlags(..), configureOptions, defaultConfigFlags
85 , HaddockFlags(..), haddockOptions, defaultHaddockFlags
86 , TestFlags(..), defaultTestFlags
87 , BenchmarkFlags(..), defaultBenchmarkFlags
88 , installDirsOptions, optionDistPref
89 , programDbPaths', programDbOptions
90 , Flag(..), toFlag, flagToMaybe, fromFlagOrDefault )
91 import Distribution.Simple.InstallDirs
92 ( InstallDirs(..), defaultInstallDirs
93 , PathTemplate, toPathTemplate )
94 import Distribution.Deprecated.ParseUtils
95 ( FieldDescr(..), liftField, runP
96 , ParseResult(..), PError(..), PWarning(..)
97 , locatedErrorMsg, showPWarning
98 , readFields, warning, lineNo
99 , simpleField, listField, spaceListField
100 , parseOptCommaList, parseTokenQ, syntaxError
101 , simpleFieldParsec, listFieldParsec
102 )
103 import Distribution.Client.ParseUtils
104 ( parseFields, ppFields, ppSection )
105 import Distribution.Client.HttpUtils
106 ( isOldHackageURI )
107 import qualified Distribution.Deprecated.ParseUtils as ParseUtils
108 ( Field(..) )
109 import Distribution.Simple.Command
110 ( CommandUI(commandOptions), commandDefaultFlags, ShowOrParseArgs(..) )
111 import Distribution.Simple.Program
112 ( defaultProgramDb )
113 import Distribution.Simple.Utils
114 ( die', notice, warn, lowercase, cabalVersion, toUTF8BS )
115 import Distribution.Client.Utils
116 ( cabalInstallVersion )
117 import Distribution.Compiler
118 ( CompilerFlavor(..), defaultCompilerFlavor )
119 import Distribution.Verbosity
120 ( normal )
121 import qualified Distribution.Compat.CharParsing as P
122 import Distribution.Client.ProjectFlags (ProjectFlags (..))
123 import Distribution.Solver.Types.ConstraintSource
124
125 import qualified Text.PrettyPrint as Disp
126 ( render, text, empty )
127 import Distribution.Parsec (parsecOptCommaList, ParsecParser, parsecToken, parsecFilePath)
128 import Text.PrettyPrint
129 ( ($+$) )
130 import Text.PrettyPrint.HughesPJ
131 ( text, Doc )
132 import System.Directory
133 ( createDirectoryIfMissing, getAppUserDataDirectory, renameFile )
134 import Network.URI
135 ( URI(..), URIAuth(..), parseURI )
136 import System.FilePath
137 ( (<.>), (</>), takeDirectory )
138 import System.IO.Error
139 ( isDoesNotExistError )
140 import Distribution.Compat.Environment
141 ( getEnvironment, lookupEnv )
142 import qualified Data.Map as M
143 import qualified Data.ByteString as BS
144
145 --
146 -- * Configuration saved in the config file
147 --
148
149 data SavedConfig = SavedConfig
150 { savedGlobalFlags :: GlobalFlags
151 , savedInitFlags :: IT.InitFlags
152 , savedInstallFlags :: InstallFlags
153 , savedClientInstallFlags :: ClientInstallFlags
154 , savedConfigureFlags :: ConfigFlags
155 , savedConfigureExFlags :: ConfigExFlags
156 , savedUserInstallDirs :: InstallDirs (Flag PathTemplate)
157 , savedGlobalInstallDirs :: InstallDirs (Flag PathTemplate)
158 , savedUploadFlags :: UploadFlags
159 , savedReportFlags :: ReportFlags
160 , savedHaddockFlags :: HaddockFlags
161 , savedTestFlags :: TestFlags
162 , savedBenchmarkFlags :: BenchmarkFlags
163 , savedProjectFlags :: ProjectFlags
164 } deriving Generic
165
166 instance Monoid SavedConfig where
167 mempty = gmempty
168 mappend = (<>)
169
170 instance Semigroup SavedConfig where
171 a <> b = SavedConfig {
172 savedGlobalFlags = combinedSavedGlobalFlags,
173 savedInitFlags = combinedSavedInitFlags,
174 savedInstallFlags = combinedSavedInstallFlags,
175 savedClientInstallFlags = combinedSavedClientInstallFlags,
176 savedConfigureFlags = combinedSavedConfigureFlags,
177 savedConfigureExFlags = combinedSavedConfigureExFlags,
178 savedUserInstallDirs = combinedSavedUserInstallDirs,
179 savedGlobalInstallDirs = combinedSavedGlobalInstallDirs,
180 savedUploadFlags = combinedSavedUploadFlags,
181 savedReportFlags = combinedSavedReportFlags,
182 savedHaddockFlags = combinedSavedHaddockFlags,
183 savedTestFlags = combinedSavedTestFlags,
184 savedBenchmarkFlags = combinedSavedBenchmarkFlags,
185 savedProjectFlags = combinedSavedProjectFlags
186 }
187 where
188 -- This is ugly, but necessary. If we're mappending two config files, we
189 -- want the values of the *non-empty* list fields from the second one to
190 -- *override* the corresponding values from the first one. Default
191 -- behaviour (concatenation) is confusing and makes some use cases (see
192 -- #1884) impossible.
193 --
194 -- However, we also want to allow specifying multiple values for a list
195 -- field in a *single* config file. For example, we want the following to
196 -- continue to work:
197 --
198 -- remote-repo: hackage.haskell.org:http://hackage.haskell.org/
199 -- remote-repo: private-collection:http://hackage.local/
200 --
201 -- So we can't just wrap the list fields inside Flags; we have to do some
202 -- special-casing just for SavedConfig.
203
204 -- NB: the signature prevents us from using 'combine' on lists.
205 combine' :: (SavedConfig -> flags) -> (flags -> Flag a) -> Flag a
206 combine' field subfield =
207 (subfield . field $ a) `mappend` (subfield . field $ b)
208
209 combineMonoid :: Monoid mon => (SavedConfig -> flags) -> (flags -> mon)
210 -> mon
211 combineMonoid field subfield =
212 (subfield . field $ a) `mappend` (subfield . field $ b)
213
214 lastNonEmpty' :: (SavedConfig -> flags) -> (flags -> [a]) -> [a]
215 lastNonEmpty' field subfield =
216 let a' = subfield . field $ a
217 b' = subfield . field $ b
218 in case b' of [] -> a'
219 _ -> b'
220
221 lastNonMempty'
222 :: (Eq a, Monoid a) => (SavedConfig -> flags) -> (flags -> a) -> a
223 lastNonMempty' field subfield =
224 let a' = subfield . field $ a
225 b' = subfield . field $ b
226 in if b' == mempty then a' else b'
227
228 lastNonEmptyNL' :: (SavedConfig -> flags) -> (flags -> NubList a)
229 -> NubList a
230 lastNonEmptyNL' field subfield =
231 let a' = subfield . field $ a
232 b' = subfield . field $ b
233 in case fromNubList b' of [] -> a'
234 _ -> b'
235
236 combinedSavedGlobalFlags = GlobalFlags {
237 globalVersion = combine globalVersion,
238 globalNumericVersion = combine globalNumericVersion,
239 globalConfigFile = combine globalConfigFile,
240 globalConstraintsFile = combine globalConstraintsFile,
241 globalRemoteRepos = lastNonEmptyNL globalRemoteRepos,
242 globalCacheDir = combine globalCacheDir,
243 globalLocalNoIndexRepos = lastNonEmptyNL globalLocalNoIndexRepos,
244 globalActiveRepos = combine globalActiveRepos,
245 globalLogsDir = combine globalLogsDir,
246 globalWorldFile = combine globalWorldFile,
247 globalIgnoreExpiry = combine globalIgnoreExpiry,
248 globalHttpTransport = combine globalHttpTransport,
249 globalNix = combine globalNix,
250 globalStoreDir = combine globalStoreDir,
251 globalProgPathExtra = lastNonEmptyNL globalProgPathExtra
252 }
253 where
254 combine = combine' savedGlobalFlags
255 lastNonEmptyNL = lastNonEmptyNL' savedGlobalFlags
256
257 combinedSavedInitFlags = IT.InitFlags {
258 IT.applicationDirs = combineMonoid savedInitFlags IT.applicationDirs,
259 IT.author = combine IT.author,
260 IT.buildTools = combineMonoid savedInitFlags IT.buildTools,
261 IT.cabalVersion = combine IT.cabalVersion,
262 IT.category = combine IT.category,
263 IT.dependencies = combineMonoid savedInitFlags IT.dependencies,
264 IT.email = combine IT.email,
265 IT.exposedModules = combineMonoid savedInitFlags IT.exposedModules,
266 IT.extraSrc = combineMonoid savedInitFlags IT.extraSrc,
267 IT.homepage = combine IT.homepage,
268 IT.initHcPath = combine IT.initHcPath,
269 IT.initVerbosity = combine IT.initVerbosity,
270 IT.initializeTestSuite = combine IT.initializeTestSuite,
271 IT.interactive = combine IT.interactive,
272 IT.language = combine IT.language,
273 IT.license = combine IT.license,
274 IT.mainIs = combine IT.mainIs,
275 IT.minimal = combine IT.minimal,
276 IT.noComments = combine IT.noComments,
277 IT.otherExts = combineMonoid savedInitFlags IT.otherExts,
278 IT.otherModules = combineMonoid savedInitFlags IT.otherModules,
279 IT.overwrite = combine IT.overwrite,
280 IT.packageDir = combine IT.packageDir,
281 IT.packageName = combine IT.packageName,
282 IT.packageType = combine IT.packageType,
283 IT.quiet = combine IT.quiet,
284 IT.simpleProject = combine IT.simpleProject,
285 IT.sourceDirs = combineMonoid savedInitFlags IT.sourceDirs,
286 IT.synopsis = combine IT.synopsis,
287 IT.testDirs = combineMonoid savedInitFlags IT.testDirs,
288 IT.version = combine IT.version
289 }
290 where
291 combine = combine' savedInitFlags
292
293 combinedSavedInstallFlags = InstallFlags {
294 installDocumentation = combine installDocumentation,
295 installHaddockIndex = combine installHaddockIndex,
296 installDryRun = combine installDryRun,
297 installOnlyDownload = combine installOnlyDownload,
298 installDest = combine installDest,
299 installMaxBackjumps = combine installMaxBackjumps,
300 installReorderGoals = combine installReorderGoals,
301 installCountConflicts = combine installCountConflicts,
302 installFineGrainedConflicts = combine installFineGrainedConflicts,
303 installMinimizeConflictSet = combine installMinimizeConflictSet,
304 installIndependentGoals = combine installIndependentGoals,
305 installShadowPkgs = combine installShadowPkgs,
306 installStrongFlags = combine installStrongFlags,
307 installAllowBootLibInstalls = combine installAllowBootLibInstalls,
308 installOnlyConstrained = combine installOnlyConstrained,
309 installReinstall = combine installReinstall,
310 installAvoidReinstalls = combine installAvoidReinstalls,
311 installOverrideReinstall = combine installOverrideReinstall,
312 installUpgradeDeps = combine installUpgradeDeps,
313 installOnly = combine installOnly,
314 installOnlyDeps = combine installOnlyDeps,
315 installIndexState = combine installIndexState,
316 installRootCmd = combine installRootCmd,
317 installSummaryFile = lastNonEmptyNL installSummaryFile,
318 installLogFile = combine installLogFile,
319 installBuildReports = combine installBuildReports,
320 installReportPlanningFailure = combine installReportPlanningFailure,
321 installSymlinkBinDir = combine installSymlinkBinDir,
322 installPerComponent = combine installPerComponent,
323 installOneShot = combine installOneShot,
324 installNumJobs = combine installNumJobs,
325 installKeepGoing = combine installKeepGoing,
326 installRunTests = combine installRunTests,
327 installOfflineMode = combine installOfflineMode
328 }
329 where
330 combine = combine' savedInstallFlags
331 lastNonEmptyNL = lastNonEmptyNL' savedInstallFlags
332
333 combinedSavedClientInstallFlags = ClientInstallFlags
334 { cinstInstallLibs = combine cinstInstallLibs
335 , cinstEnvironmentPath = combine cinstEnvironmentPath
336 , cinstOverwritePolicy = combine cinstOverwritePolicy
337 , cinstInstallMethod = combine cinstInstallMethod
338 , cinstInstalldir = combine cinstInstalldir
339 }
340 where
341 combine = combine' savedClientInstallFlags
342
343 combinedSavedConfigureFlags = ConfigFlags {
344 configArgs = lastNonEmpty configArgs,
345 configPrograms_ = configPrograms_ . savedConfigureFlags $ b,
346 -- TODO: NubListify
347 configProgramPaths = lastNonEmpty configProgramPaths,
348 -- TODO: NubListify
349 configProgramArgs = lastNonEmpty configProgramArgs,
350 configProgramPathExtra = lastNonEmptyNL configProgramPathExtra,
351 configInstantiateWith = lastNonEmpty configInstantiateWith,
352 configHcFlavor = combine configHcFlavor,
353 configHcPath = combine configHcPath,
354 configHcPkg = combine configHcPkg,
355 configVanillaLib = combine configVanillaLib,
356 configProfLib = combine configProfLib,
357 configProf = combine configProf,
358 configSharedLib = combine configSharedLib,
359 configStaticLib = combine configStaticLib,
360 configDynExe = combine configDynExe,
361 configFullyStaticExe = combine configFullyStaticExe,
362 configProfExe = combine configProfExe,
363 configProfDetail = combine configProfDetail,
364 configProfLibDetail = combine configProfLibDetail,
365 -- TODO: NubListify
366 configConfigureArgs = lastNonEmpty configConfigureArgs,
367 configOptimization = combine configOptimization,
368 configDebugInfo = combine configDebugInfo,
369 configProgPrefix = combine configProgPrefix,
370 configProgSuffix = combine configProgSuffix,
371 -- Parametrised by (Flag PathTemplate), so safe to use 'mappend'.
372 configInstallDirs =
373 (configInstallDirs . savedConfigureFlags $ a)
374 `mappend` (configInstallDirs . savedConfigureFlags $ b),
375 configScratchDir = combine configScratchDir,
376 -- TODO: NubListify
377 configExtraLibDirs = lastNonEmpty configExtraLibDirs,
378 -- TODO: NubListify
379 configExtraFrameworkDirs = lastNonEmpty configExtraFrameworkDirs,
380 -- TODO: NubListify
381 configExtraIncludeDirs = lastNonEmpty configExtraIncludeDirs,
382 configDeterministic = combine configDeterministic,
383 configIPID = combine configIPID,
384 configCID = combine configCID,
385 configDistPref = combine configDistPref,
386 configCabalFilePath = combine configCabalFilePath,
387 configVerbosity = combine configVerbosity,
388 configUserInstall = combine configUserInstall,
389 -- TODO: NubListify
390 configPackageDBs = lastNonEmpty configPackageDBs,
391 configGHCiLib = combine configGHCiLib,
392 configSplitSections = combine configSplitSections,
393 configSplitObjs = combine configSplitObjs,
394 configStripExes = combine configStripExes,
395 configStripLibs = combine configStripLibs,
396 -- TODO: NubListify
397 configConstraints = lastNonEmpty configConstraints,
398 -- TODO: NubListify
399 configDependencies = lastNonEmpty configDependencies,
400 -- TODO: NubListify
401 configConfigurationsFlags = lastNonMempty configConfigurationsFlags,
402 configTests = combine configTests,
403 configBenchmarks = combine configBenchmarks,
404 configCoverage = combine configCoverage,
405 configLibCoverage = combine configLibCoverage,
406 configExactConfiguration = combine configExactConfiguration,
407 configFlagError = combine configFlagError,
408 configRelocatable = combine configRelocatable,
409 configUseResponseFiles = combine configUseResponseFiles,
410 configAllowDependingOnPrivateLibs =
411 combine configAllowDependingOnPrivateLibs
412 }
413 where
414 combine = combine' savedConfigureFlags
415 lastNonEmpty = lastNonEmpty' savedConfigureFlags
416 lastNonEmptyNL = lastNonEmptyNL' savedConfigureFlags
417 lastNonMempty = lastNonMempty' savedConfigureFlags
418
419 combinedSavedConfigureExFlags = ConfigExFlags {
420 configCabalVersion = combine configCabalVersion,
421 -- TODO: NubListify
422 configExConstraints = lastNonEmpty configExConstraints,
423 -- TODO: NubListify
424 configPreferences = lastNonEmpty configPreferences,
425 configSolver = combine configSolver,
426 configAllowNewer =
427 combineMonoid savedConfigureExFlags configAllowNewer,
428 configAllowOlder =
429 combineMonoid savedConfigureExFlags configAllowOlder,
430 configWriteGhcEnvironmentFilesPolicy
431 = combine configWriteGhcEnvironmentFilesPolicy
432 }
433 where
434 combine = combine' savedConfigureExFlags
435 lastNonEmpty = lastNonEmpty' savedConfigureExFlags
436
437 -- Parametrised by (Flag PathTemplate), so safe to use 'mappend'.
438 combinedSavedUserInstallDirs = savedUserInstallDirs a
439 `mappend` savedUserInstallDirs b
440
441 -- Parametrised by (Flag PathTemplate), so safe to use 'mappend'.
442 combinedSavedGlobalInstallDirs = savedGlobalInstallDirs a
443 `mappend` savedGlobalInstallDirs b
444
445 combinedSavedUploadFlags = UploadFlags {
446 uploadCandidate = combine uploadCandidate,
447 uploadDoc = combine uploadDoc,
448 uploadUsername = combine uploadUsername,
449 uploadPassword = combine uploadPassword,
450 uploadPasswordCmd = combine uploadPasswordCmd,
451 uploadVerbosity = combine uploadVerbosity
452 }
453 where
454 combine = combine' savedUploadFlags
455
456 combinedSavedReportFlags = ReportFlags {
457 reportUsername = combine reportUsername,
458 reportPassword = combine reportPassword,
459 reportVerbosity = combine reportVerbosity
460 }
461 where
462 combine = combine' savedReportFlags
463
464 combinedSavedHaddockFlags = HaddockFlags {
465 -- TODO: NubListify
466 haddockProgramPaths = lastNonEmpty haddockProgramPaths,
467 -- TODO: NubListify
468 haddockProgramArgs = lastNonEmpty haddockProgramArgs,
469 haddockHoogle = combine haddockHoogle,
470 haddockHtml = combine haddockHtml,
471 haddockHtmlLocation = combine haddockHtmlLocation,
472 haddockForHackage = combine haddockForHackage,
473 haddockExecutables = combine haddockExecutables,
474 haddockTestSuites = combine haddockTestSuites,
475 haddockBenchmarks = combine haddockBenchmarks,
476 haddockForeignLibs = combine haddockForeignLibs,
477 haddockInternal = combine haddockInternal,
478 haddockCss = combine haddockCss,
479 haddockLinkedSource = combine haddockLinkedSource,
480 haddockQuickJump = combine haddockQuickJump,
481 haddockHscolourCss = combine haddockHscolourCss,
482 haddockContents = combine haddockContents,
483 haddockDistPref = combine haddockDistPref,
484 haddockKeepTempFiles = combine haddockKeepTempFiles,
485 haddockVerbosity = combine haddockVerbosity,
486 haddockCabalFilePath = combine haddockCabalFilePath,
487 haddockArgs = lastNonEmpty haddockArgs
488 }
489 where
490 combine = combine' savedHaddockFlags
491 lastNonEmpty = lastNonEmpty' savedHaddockFlags
492
493 combinedSavedTestFlags = TestFlags {
494 testDistPref = combine testDistPref,
495 testVerbosity = combine testVerbosity,
496 testHumanLog = combine testHumanLog,
497 testMachineLog = combine testMachineLog,
498 testShowDetails = combine testShowDetails,
499 testKeepTix = combine testKeepTix,
500 testWrapper = combine testWrapper,
501 testFailWhenNoTestSuites = combine testFailWhenNoTestSuites,
502 testOptions = lastNonEmpty testOptions
503 }
504 where
505 combine = combine' savedTestFlags
506 lastNonEmpty = lastNonEmpty' savedTestFlags
507
508 combinedSavedBenchmarkFlags = BenchmarkFlags {
509 benchmarkDistPref = combine benchmarkDistPref,
510 benchmarkVerbosity = combine benchmarkVerbosity,
511 benchmarkOptions = lastNonEmpty benchmarkOptions
512 }
513 where
514 combine = combine' savedBenchmarkFlags
515 lastNonEmpty = lastNonEmpty' savedBenchmarkFlags
516
517 combinedSavedProjectFlags = ProjectFlags
518 { flagProjectFileName = combine flagProjectFileName
519 , flagIgnoreProject = combine flagIgnoreProject
520 }
521 where
522 combine = combine' savedProjectFlags
523
524 --
525 -- * Default config
526 --
527
528 -- | These are the absolute basic defaults. The fields that must be
529 -- initialised. When we load the config from the file we layer the loaded
530 -- values over these ones, so any missing fields in the file take their values
531 -- from here.
532 --
533 baseSavedConfig :: IO SavedConfig
534 baseSavedConfig = do
535 userPrefix <- getCabalDir
536 cacheDir <- defaultCacheDir
537 logsDir <- defaultLogsDir
538 worldFile <- defaultWorldFile
539 return mempty {
540 savedConfigureFlags = mempty {
541 configHcFlavor = toFlag defaultCompiler,
542 configUserInstall = toFlag defaultUserInstall,
543 configVerbosity = toFlag normal
544 },
545 savedUserInstallDirs = mempty {
546 prefix = toFlag (toPathTemplate userPrefix)
547 },
548 savedGlobalFlags = mempty {
549 globalCacheDir = toFlag cacheDir,
550 globalLogsDir = toFlag logsDir,
551 globalWorldFile = toFlag worldFile
552 }
553 }
554
555 -- | This is the initial configuration that we write out to the config file
556 -- if the file does not exist (or the config we use if the file cannot be read
557 -- for some other reason). When the config gets loaded it gets layered on top
558 -- of 'baseSavedConfig' so we do not need to include it into the initial
559 -- values we save into the config file.
560 --
561 initialSavedConfig :: IO SavedConfig
562 initialSavedConfig = do
563 cacheDir <- defaultCacheDir
564 logsDir <- defaultLogsDir
565 worldFile <- defaultWorldFile
566 extraPath <- defaultExtraPath
567 installPath <- defaultInstallPath
568 return mempty {
569 savedGlobalFlags = mempty {
570 globalCacheDir = toFlag cacheDir,
571 globalRemoteRepos = toNubList [defaultRemoteRepo],
572 globalWorldFile = toFlag worldFile
573 },
574 savedConfigureFlags = mempty {
575 configProgramPathExtra = toNubList extraPath
576 },
577 savedInstallFlags = mempty {
578 installSummaryFile = toNubList [toPathTemplate (logsDir </> "build.log")],
579 installBuildReports= toFlag NoReports,
580 installNumJobs = toFlag Nothing
581 },
582 savedClientInstallFlags = mempty {
583 cinstInstalldir = toFlag installPath
584 }
585 }
586
587 defaultCabalDir :: IO FilePath
588 defaultCabalDir = getAppUserDataDirectory "cabal"
589
590 getCabalDir :: IO FilePath
591 getCabalDir = do
592 mDir <- lookupEnv "CABAL_DIR"
593 case mDir of
594 Nothing -> defaultCabalDir
595 Just dir -> return dir
596
597 defaultConfigFile :: IO FilePath
598 defaultConfigFile = do
599 dir <- getCabalDir
600 return $ dir </> "config"
601
602 defaultCacheDir :: IO FilePath
603 defaultCacheDir = do
604 dir <- getCabalDir
605 return $ dir </> "packages"
606
607 defaultLogsDir :: IO FilePath
608 defaultLogsDir = do
609 dir <- getCabalDir
610 return $ dir </> "logs"
611
612 -- | Default position of the world file
613 defaultWorldFile :: IO FilePath
614 defaultWorldFile = do
615 dir <- getCabalDir
616 return $ dir </> "world"
617
618 defaultExtraPath :: IO [FilePath]
619 defaultExtraPath = do
620 dir <- getCabalDir
621 return [dir </> "bin"]
622
623 defaultInstallPath :: IO FilePath
624 defaultInstallPath = do
625 dir <- getCabalDir
626 return (dir </> "bin")
627
628 defaultCompiler :: CompilerFlavor
629 defaultCompiler = fromMaybe GHC defaultCompilerFlavor
630
631 defaultUserInstall :: Bool
632 defaultUserInstall = True
633 -- We do per-user installs by default on all platforms. We used to default to
634 -- global installs on Windows but that no longer works on Windows Vista or 7.
635
636 defaultRemoteRepo :: RemoteRepo
637 defaultRemoteRepo = RemoteRepo name uri Nothing [] 0 False
638 where
639 str = "hackage.haskell.org"
640 name = RepoName str
641 uri = URI "http:" (Just (URIAuth "" str "")) "/" "" ""
642 -- Note that lots of old ~/.cabal/config files will have the old url
643 -- http://hackage.haskell.org/packages/archive
644 -- but new config files can use the new url (without the /packages/archive)
645 -- and avoid having to do a http redirect
646
647 -- For the default repo we know extra information, fill this in.
648 --
649 -- We need this because the 'defaultRemoteRepo' above is only used for the
650 -- first time when a config file is made. So for users with older config files
651 -- we might have only have older info. This lets us fill that in even for old
652 -- config files.
653 --
654 addInfoForKnownRepos :: RemoteRepo -> RemoteRepo
655 addInfoForKnownRepos repo
656 | remoteRepoName repo == remoteRepoName defaultRemoteRepo
657 = useSecure . tryHttps . fixOldURI $ repo
658 where
659 fixOldURI r
660 | isOldHackageURI (remoteRepoURI r)
661 = r { remoteRepoURI = remoteRepoURI defaultRemoteRepo }
662 | otherwise = r
663
664 tryHttps r = r { remoteRepoShouldTryHttps = True }
665
666 useSecure r@RemoteRepo{
667 remoteRepoSecure = secure,
668 remoteRepoRootKeys = [],
669 remoteRepoKeyThreshold = 0
670 } | secure /= Just False
671 = r {
672 -- Use hackage-security by default unless you opt-out with
673 -- secure: False
674 remoteRepoSecure = Just True,
675 remoteRepoRootKeys = defaultHackageRemoteRepoKeys,
676 remoteRepoKeyThreshold = defaultHackageRemoteRepoKeyThreshold
677 }
678 useSecure r = r
679 addInfoForKnownRepos other = other
680
681 -- | The current hackage.haskell.org repo root keys that we ship with cabal.
682 ---
683 -- This lets us bootstrap trust in this repo without user intervention.
684 -- These keys need to be periodically updated when new root keys are added.
685 -- See the root key procedures for details.
686 --
687 defaultHackageRemoteRepoKeys :: [String]
688 defaultHackageRemoteRepoKeys =
689 [ "fe331502606802feac15e514d9b9ea83fee8b6ffef71335479a2e68d84adc6b0",
690 "1ea9ba32c526d1cc91ab5e5bd364ec5e9e8cb67179a471872f6e26f0ae773d42",
691 "2c6c3627bd6c982990239487f1abd02e08a02e6cf16edb105a8012d444d870c3",
692 "0a5c7ea47cd1b15f01f5f51a33adda7e655bc0f0b0615baa8e271f4c3351e21d",
693 "51f0161b906011b52c6613376b1ae937670da69322113a246a09f807c62f6921"
694 ]
695
696 -- | The required threshold of root key signatures for hackage.haskell.org
697 --
698 defaultHackageRemoteRepoKeyThreshold :: Int
699 defaultHackageRemoteRepoKeyThreshold = 3
700
701 --
702 -- * Config file reading
703 --
704
705 -- | Loads the main configuration, and applies additional defaults to give the
706 -- effective configuration. To loads just what is actually in the config file,
707 -- use 'loadRawConfig'.
708 --
709 loadConfig :: Verbosity -> Flag FilePath -> IO SavedConfig
710 loadConfig verbosity configFileFlag = do
711 config <- loadRawConfig verbosity configFileFlag
712 extendToEffectiveConfig config
713
714 extendToEffectiveConfig :: SavedConfig -> IO SavedConfig
715 extendToEffectiveConfig config = do
716 base <- baseSavedConfig
717 let effective0 = base `mappend` config
718 globalFlags0 = savedGlobalFlags effective0
719 effective = effective0 {
720 savedGlobalFlags = globalFlags0 {
721 globalRemoteRepos =
722 overNubList (map addInfoForKnownRepos)
723 (globalRemoteRepos globalFlags0)
724 }
725 }
726 return effective
727
728 -- | Like 'loadConfig' but does not apply any additional defaults, it just
729 -- loads what is actually in the config file. This is thus suitable for
730 -- comparing or editing a config file, but not suitable for using as the
731 -- effective configuration.
732 --
733 loadRawConfig :: Verbosity -> Flag FilePath -> IO SavedConfig
734 loadRawConfig verbosity configFileFlag = do
735 (source, configFile) <- getConfigFilePathAndSource configFileFlag
736 minp <- readConfigFile mempty configFile
737 case minp of
738 Nothing -> do
739 notice verbosity $
740 "Config file path source is " ++ sourceMsg source ++ "."
741 notice verbosity $ "Config file " ++ configFile ++ " not found."
742 createDefaultConfigFile verbosity [] configFile
743 Just (ParseOk ws conf) -> do
744 unless (null ws) $ warn verbosity $
745 unlines (map (showPWarning configFile) ws)
746 return conf
747 Just (ParseFailed err) -> do
748 let (line, msg) = locatedErrorMsg err
749 die' verbosity $
750 "Error parsing config file " ++ configFile
751 ++ maybe "" (\n -> ':' : show n) line ++ ":\n" ++ msg
752
753 where
754 sourceMsg CommandlineOption = "commandline option"
755 sourceMsg EnvironmentVariable = "env var CABAL_CONFIG"
756 sourceMsg Default = "default config file"
757
758 data ConfigFileSource = CommandlineOption
759 | EnvironmentVariable
760 | Default
761
762 -- | Returns the config file path, without checking that the file exists.
763 -- The order of precedence is: input flag, CABAL_CONFIG, default location.
764 getConfigFilePath :: Flag FilePath -> IO FilePath
765 getConfigFilePath = fmap snd . getConfigFilePathAndSource
766
767 getConfigFilePathAndSource :: Flag FilePath -> IO (ConfigFileSource, FilePath)
768 getConfigFilePathAndSource configFileFlag =
769 getSource sources
770 where
771 sources =
772 [ (CommandlineOption, return . flagToMaybe $ configFileFlag)
773 , (EnvironmentVariable, lookup "CABAL_CONFIG" `liftM` getEnvironment)
774 , (Default, Just `liftM` defaultConfigFile) ]
775
776 getSource [] = error "no config file path candidate found."
777 getSource ((source,action): xs) =
778 action >>= maybe (getSource xs) (return . (,) source)
779
780 readConfigFile
781 :: SavedConfig -> FilePath -> IO (Maybe (ParseResult SavedConfig))
782 readConfigFile initial file = handleNotExists $
783 fmap (Just . parseConfig (ConstraintSourceMainConfig file) initial)
784 (BS.readFile file)
785
786 where
787 handleNotExists action = catchIO action $ \ioe ->
788 if isDoesNotExistError ioe
789 then return Nothing
790 else ioError ioe
791
792 createDefaultConfigFile :: Verbosity -> [String] -> FilePath -> IO SavedConfig
793 createDefaultConfigFile verbosity extraLines filePath = do
794 commentConf <- commentSavedConfig
795 initialConf <- initialSavedConfig
796 extraConf <- parseExtraLines verbosity extraLines
797 notice verbosity $ "Writing default configuration to " ++ filePath
798 writeConfigFile filePath commentConf (initialConf `mappend` extraConf)
799 return initialConf
800
801 writeConfigFile :: FilePath -> SavedConfig -> SavedConfig -> IO ()
802 writeConfigFile file comments vals = do
803 let tmpFile = file <.> "tmp"
804 createDirectoryIfMissing True (takeDirectory file)
805 writeFile tmpFile $
806 explanation ++ showConfigWithComments comments vals ++ "\n"
807 renameFile tmpFile file
808 where
809 explanation = unlines
810 ["-- This is the configuration file for the 'cabal' command line tool."
811 ,"--"
812 ,"-- The available configuration options are listed below."
813 ,"-- Some of them have default values listed."
814 ,"--"
815 ,"-- Lines (like this one) beginning with '--' are comments."
816 ,"-- Be careful with spaces and indentation because they are"
817 ,"-- used to indicate layout for nested sections."
818 ,"--"
819 ,"-- This config file was generated using the following versions"
820 ,"-- of Cabal and cabal-install:"
821 ,"-- Cabal library version: " ++ prettyShow cabalVersion
822 ,"-- cabal-install version: " ++ prettyShow cabalInstallVersion
823 ,"",""
824 ]
825
826 -- | These are the default values that get used in Cabal if a no value is
827 -- given. We use these here to include in comments when we write out the
828 -- initial config file so that the user can see what default value they are
829 -- overriding.
830 --
831 commentSavedConfig :: IO SavedConfig
832 commentSavedConfig = do
833 userInstallDirs <- defaultInstallDirs defaultCompiler True True
834 globalInstallDirs <- defaultInstallDirs defaultCompiler False True
835 let conf0 = mempty {
836 savedGlobalFlags = defaultGlobalFlags {
837 globalRemoteRepos = toNubList [defaultRemoteRepo]
838 },
839 savedInitFlags = mempty {
840 IT.interactive = toFlag False,
841 IT.cabalVersion = toFlag IT.defaultCabalVersion,
842 IT.language = toFlag Haskell2010,
843 IT.license = NoFlag,
844 IT.sourceDirs = Just [IT.defaultSourceDir],
845 IT.applicationDirs = Just [IT.defaultApplicationDir]
846 },
847 savedInstallFlags = defaultInstallFlags,
848 savedClientInstallFlags= defaultClientInstallFlags,
849 savedConfigureExFlags = defaultConfigExFlags {
850 configAllowNewer = Just (AllowNewer mempty),
851 configAllowOlder = Just (AllowOlder mempty)
852 },
853 savedConfigureFlags = (defaultConfigFlags defaultProgramDb) {
854 configUserInstall = toFlag defaultUserInstall
855 },
856 savedUserInstallDirs = fmap toFlag userInstallDirs,
857 savedGlobalInstallDirs = fmap toFlag globalInstallDirs,
858 savedUploadFlags = commandDefaultFlags uploadCommand,
859 savedReportFlags = commandDefaultFlags reportCommand,
860 savedHaddockFlags = defaultHaddockFlags,
861 savedTestFlags = defaultTestFlags,
862 savedBenchmarkFlags = defaultBenchmarkFlags
863 }
864 conf1 <- extendToEffectiveConfig conf0
865 let globalFlagsConf1 = savedGlobalFlags conf1
866 conf2 = conf1 {
867 savedGlobalFlags = globalFlagsConf1 {
868 globalRemoteRepos = overNubList (map removeRootKeys)
869 (globalRemoteRepos globalFlagsConf1)
870 }
871 }
872 return conf2
873 where
874 -- Most people don't want to see default root keys, so don't print them.
875 removeRootKeys :: RemoteRepo -> RemoteRepo
876 removeRootKeys r = r { remoteRepoRootKeys = [] }
877
878 -- | All config file fields.
879 --
880 configFieldDescriptions :: ConstraintSource -> [FieldDescr SavedConfig]
881 configFieldDescriptions src =
882
883 toSavedConfig liftGlobalFlag
884 (commandOptions (globalCommand []) ParseArgs)
885 ["version", "numeric-version", "config-file"] []
886
887 ++ toSavedConfig liftConfigFlag
888 (configureOptions ParseArgs)
889 (["builddir", "constraint", "dependency", "ipid"]
890 ++ map fieldName installDirsFields)
891
892 -- This is only here because viewAsFieldDescr gives us a parser
893 -- that only recognises 'ghc' etc, the case-sensitive flag names, not
894 -- what the normal case-insensitive parser gives us.
895 [simpleFieldParsec "compiler"
896 (fromFlagOrDefault Disp.empty . fmap pretty) (Flag <$> parsec <|> pure NoFlag)
897 configHcFlavor (\v flags -> flags { configHcFlavor = v })
898
899 -- TODO: The following is a temporary fix. The "optimization"
900 -- and "debug-info" fields are OptArg, and viewAsFieldDescr
901 -- fails on that. Instead of a hand-written hackaged parser
902 -- and printer, we should handle this case properly in the
903 -- library.
904 ,liftField configOptimization (\v flags ->
905 flags { configOptimization = v }) $
906 let name = "optimization" in
907 FieldDescr name
908 (\f -> case f of
909 Flag NoOptimisation -> Disp.text "False"
910 Flag NormalOptimisation -> Disp.text "True"
911 Flag MaximumOptimisation -> Disp.text "2"
912 _ -> Disp.empty)
913 (\line str _ -> case () of
914 _ | str == "False" -> ParseOk [] (Flag NoOptimisation)
915 | str == "True" -> ParseOk [] (Flag NormalOptimisation)
916 | str == "0" -> ParseOk [] (Flag NoOptimisation)
917 | str == "1" -> ParseOk [] (Flag NormalOptimisation)
918 | str == "2" -> ParseOk [] (Flag MaximumOptimisation)
919 | lstr == "false" -> ParseOk [caseWarning] (Flag NoOptimisation)
920 | lstr == "true" -> ParseOk [caseWarning]
921 (Flag NormalOptimisation)
922 | otherwise -> ParseFailed (NoParse name line)
923 where
924 lstr = lowercase str
925 caseWarning = PWarning $
926 "The '" ++ name
927 ++ "' field is case sensitive, use 'True' or 'False'.")
928 ,liftField configDebugInfo (\v flags -> flags { configDebugInfo = v }) $
929 let name = "debug-info" in
930 FieldDescr name
931 (\f -> case f of
932 Flag NoDebugInfo -> Disp.text "False"
933 Flag MinimalDebugInfo -> Disp.text "1"
934 Flag NormalDebugInfo -> Disp.text "True"
935 Flag MaximalDebugInfo -> Disp.text "3"
936 _ -> Disp.empty)
937 (\line str _ -> case () of
938 _ | str == "False" -> ParseOk [] (Flag NoDebugInfo)
939 | str == "True" -> ParseOk [] (Flag NormalDebugInfo)
940 | str == "0" -> ParseOk [] (Flag NoDebugInfo)
941 | str == "1" -> ParseOk [] (Flag MinimalDebugInfo)
942 | str == "2" -> ParseOk [] (Flag NormalDebugInfo)
943 | str == "3" -> ParseOk [] (Flag MaximalDebugInfo)
944 | lstr == "false" -> ParseOk [caseWarning] (Flag NoDebugInfo)
945 | lstr == "true" -> ParseOk [caseWarning] (Flag NormalDebugInfo)
946 | otherwise -> ParseFailed (NoParse name line)
947 where
948 lstr = lowercase str
949 caseWarning = PWarning $
950 "The '" ++ name
951 ++ "' field is case sensitive, use 'True' or 'False'.")
952 ]
953
954 ++ toSavedConfig liftConfigExFlag
955 (configureExOptions ParseArgs src)
956 []
957 [let pkgs = (Just . AllowOlder . RelaxDepsSome)
958 `fmap` parsecOptCommaList parsec
959 parseAllowOlder = ((Just . AllowOlder . toRelaxDeps)
960 `fmap` parsec) <|> pkgs
961 in simpleFieldParsec "allow-older"
962 (showRelaxDeps . fmap unAllowOlder) parseAllowOlder
963 configAllowOlder (\v flags -> flags { configAllowOlder = v })
964 ,let pkgs = (Just . AllowNewer . RelaxDepsSome)
965 `fmap` parsecOptCommaList parsec
966 parseAllowNewer = ((Just . AllowNewer . toRelaxDeps)
967 `fmap` parsec) <|> pkgs
968 in simpleFieldParsec "allow-newer"
969 (showRelaxDeps . fmap unAllowNewer) parseAllowNewer
970 configAllowNewer (\v flags -> flags { configAllowNewer = v })
971 ]
972
973 ++ toSavedConfig liftInstallFlag
974 (installOptions ParseArgs)
975 ["dry-run", "only", "only-dependencies", "dependencies-only"] []
976
977 ++ toSavedConfig liftClientInstallFlag
978 (clientInstallOptions ParseArgs)
979 [] []
980
981 ++ toSavedConfig liftUploadFlag
982 (commandOptions uploadCommand ParseArgs)
983 ["verbose", "check", "documentation", "publish"] []
984
985 ++ toSavedConfig liftReportFlag
986 (commandOptions reportCommand ParseArgs)
987 ["verbose", "username", "password"] []
988 --FIXME: this is a hack, hiding the user name and password.
989 -- But otherwise it masks the upload ones. Either need to
990 -- share the options or make then distinct. In any case
991 -- they should probably be per-server.
992
993 ++ [ viewAsFieldDescr
994 $ optionDistPref
995 (configDistPref . savedConfigureFlags)
996 (\distPref config ->
997 config
998 { savedConfigureFlags = (savedConfigureFlags config) {
999 configDistPref = distPref }
1000 , savedHaddockFlags = (savedHaddockFlags config) {
1001 haddockDistPref = distPref }
1002 }
1003 )
1004 ParseArgs
1005 ]
1006
1007 where
1008 toSavedConfig lift options exclusions replacements =
1009 [ lift (fromMaybe field replacement)
1010 | opt <- options
1011 , let field = viewAsFieldDescr opt
1012 name = fieldName field
1013 replacement = find ((== name) . fieldName) replacements
1014 , name `notElem` exclusions ]
1015
1016 showRelaxDeps Nothing = mempty
1017 showRelaxDeps (Just rd) | isRelaxDeps rd = Disp.text "True"
1018 | otherwise = Disp.text "False"
1019
1020 toRelaxDeps True = RelaxDepsAll
1021 toRelaxDeps False = mempty
1022
1023
1024 -- TODO: next step, make the deprecated fields elicit a warning.
1025 --
1026 deprecatedFieldDescriptions :: [FieldDescr SavedConfig]
1027 deprecatedFieldDescriptions =
1028 [ liftGlobalFlag $
1029 listFieldParsec "repos"
1030 pretty parsec
1031 (fromNubList . globalRemoteRepos)
1032 (\rs cfg -> cfg { globalRemoteRepos = toNubList rs })
1033 , liftGlobalFlag $
1034 simpleFieldParsec "cachedir"
1035 (Disp.text . fromFlagOrDefault "") (optionalFlag parsecFilePath)
1036 globalCacheDir (\d cfg -> cfg { globalCacheDir = d })
1037 , liftUploadFlag $
1038 simpleFieldParsec "hackage-username"
1039 (Disp.text . fromFlagOrDefault "" . fmap unUsername)
1040 (optionalFlag (fmap Username parsecToken))
1041 uploadUsername (\d cfg -> cfg { uploadUsername = d })
1042 , liftUploadFlag $
1043 simpleFieldParsec "hackage-password"
1044 (Disp.text . fromFlagOrDefault "" . fmap unPassword)
1045 (optionalFlag (fmap Password parsecToken))
1046 uploadPassword (\d cfg -> cfg { uploadPassword = d })
1047 , liftUploadFlag $
1048 spaceListField "hackage-password-command"
1049 Disp.text parseTokenQ
1050 (fromFlagOrDefault [] . uploadPasswordCmd)
1051 (\d cfg -> cfg { uploadPasswordCmd = Flag d })
1052 ]
1053 ++ map (modifyFieldName ("user-"++) . liftUserInstallDirs)
1054 installDirsFields
1055 ++ map (modifyFieldName ("global-"++) . liftGlobalInstallDirs)
1056 installDirsFields
1057 where
1058 optionalFlag :: ParsecParser a -> ParsecParser (Flag a)
1059 optionalFlag p = toFlag <$> p <|> pure mempty
1060
1061 modifyFieldName :: (String -> String) -> FieldDescr a -> FieldDescr a
1062 modifyFieldName f d = d { fieldName = f (fieldName d) }
1063
1064 liftUserInstallDirs :: FieldDescr (InstallDirs (Flag PathTemplate))
1065 -> FieldDescr SavedConfig
1066 liftUserInstallDirs = liftField
1067 savedUserInstallDirs (\flags conf -> conf { savedUserInstallDirs = flags })
1068
1069 liftGlobalInstallDirs :: FieldDescr (InstallDirs (Flag PathTemplate))
1070 -> FieldDescr SavedConfig
1071 liftGlobalInstallDirs =
1072 liftField savedGlobalInstallDirs
1073 (\flags conf -> conf { savedGlobalInstallDirs = flags })
1074
1075 liftGlobalFlag :: FieldDescr GlobalFlags -> FieldDescr SavedConfig
1076 liftGlobalFlag = liftField
1077 savedGlobalFlags (\flags conf -> conf { savedGlobalFlags = flags })
1078
1079 liftConfigFlag :: FieldDescr ConfigFlags -> FieldDescr SavedConfig
1080 liftConfigFlag = liftField
1081 savedConfigureFlags (\flags conf -> conf { savedConfigureFlags = flags })
1082
1083 liftConfigExFlag :: FieldDescr ConfigExFlags -> FieldDescr SavedConfig
1084 liftConfigExFlag = liftField
1085 savedConfigureExFlags (\flags conf -> conf { savedConfigureExFlags = flags })
1086
1087 liftInstallFlag :: FieldDescr InstallFlags -> FieldDescr SavedConfig
1088 liftInstallFlag = liftField
1089 savedInstallFlags (\flags conf -> conf { savedInstallFlags = flags })
1090
1091 liftClientInstallFlag :: FieldDescr ClientInstallFlags -> FieldDescr SavedConfig
1092 liftClientInstallFlag =
1093 liftField savedClientInstallFlags
1094 (\flags conf -> conf { savedClientInstallFlags = flags })
1095
1096 liftUploadFlag :: FieldDescr UploadFlags -> FieldDescr SavedConfig
1097 liftUploadFlag = liftField
1098 savedUploadFlags (\flags conf -> conf { savedUploadFlags = flags })
1099
1100 liftReportFlag :: FieldDescr ReportFlags -> FieldDescr SavedConfig
1101 liftReportFlag = liftField
1102 savedReportFlags (\flags conf -> conf { savedReportFlags = flags })
1103
1104 parseConfig :: ConstraintSource
1105 -> SavedConfig
1106 -> BS.ByteString
1107 -> ParseResult SavedConfig
1108 parseConfig src initial = \str -> do
1109 fields <- readFields str
1110 let (knownSections, others) = partition isKnownSection fields
1111 config <- parse others
1112 let init0 = savedInitFlags config
1113 user0 = savedUserInstallDirs config
1114 global0 = savedGlobalInstallDirs config
1115 (remoteRepoSections0, localRepoSections0, haddockFlags, initFlags, user, global, paths, args) <-
1116 foldM parseSections
1117 ([], [], savedHaddockFlags config, init0, user0, global0, [], [])
1118 knownSections
1119
1120 let remoteRepoSections =
1121 reverse
1122 . nubBy ((==) `on` remoteRepoName)
1123 $ remoteRepoSections0
1124
1125 let localRepoSections =
1126 reverse
1127 . nubBy ((==) `on` localRepoName)
1128 $ localRepoSections0
1129
1130 return . fixConfigMultilines $ config {
1131 savedGlobalFlags = (savedGlobalFlags config) {
1132 globalRemoteRepos = toNubList remoteRepoSections,
1133 globalLocalNoIndexRepos = toNubList localRepoSections,
1134 -- the global extra prog path comes from the configure flag prog path
1135 globalProgPathExtra = configProgramPathExtra (savedConfigureFlags config)
1136 },
1137 savedConfigureFlags = (savedConfigureFlags config) {
1138 configProgramPaths = paths,
1139 configProgramArgs = args
1140 },
1141 savedHaddockFlags = haddockFlags,
1142 savedInitFlags = initFlags,
1143 savedUserInstallDirs = user,
1144 savedGlobalInstallDirs = global
1145 }
1146
1147 where
1148 isKnownSection (ParseUtils.Section _ "repository" _ _) = True
1149 isKnownSection (ParseUtils.F _ "remote-repo" _) = True
1150 isKnownSection (ParseUtils.Section _ "haddock" _ _) = True
1151 isKnownSection (ParseUtils.Section _ "init" _ _) = True
1152 isKnownSection (ParseUtils.Section _ "install-dirs" _ _) = True
1153 isKnownSection (ParseUtils.Section _ "program-locations" _ _) = True
1154 isKnownSection (ParseUtils.Section _ "program-default-options" _ _) = True
1155 isKnownSection _ = False
1156
1157 -- Attempt to split fields that can represent lists of paths into
1158 -- actual lists on failure, leave the field untouched.
1159 splitMultiPath :: [String] -> [String]
1160 splitMultiPath [s] = case runP 0 "" (parseOptCommaList parseTokenQ) s of
1161 ParseOk _ res -> res
1162 _ -> [s]
1163 splitMultiPath xs = xs
1164
1165 -- This is a fixup, pending a full config parser rewrite, to
1166 -- ensure that config fields which can be comma-separated lists
1167 -- actually parse as comma-separated lists.
1168 fixConfigMultilines conf = conf {
1169 savedConfigureFlags =
1170 let scf = savedConfigureFlags conf
1171 in scf {
1172 configProgramPathExtra =
1173 toNubList $ splitMultiPath
1174 (fromNubList $ configProgramPathExtra scf)
1175 , configExtraLibDirs = splitMultiPath
1176 (configExtraLibDirs scf)
1177 , configExtraFrameworkDirs = splitMultiPath
1178 (configExtraFrameworkDirs scf)
1179 , configExtraIncludeDirs = splitMultiPath
1180 (configExtraIncludeDirs scf)
1181 , configConfigureArgs = splitMultiPath
1182 (configConfigureArgs scf)
1183 }
1184 }
1185
1186 parse = parseFields (configFieldDescriptions src
1187 ++ deprecatedFieldDescriptions) initial
1188
1189 parseSections (rs, ls, h, i, u, g, p, a)
1190 (ParseUtils.Section lineno "repository" name fs) = do
1191 name' <- maybe (ParseFailed $ NoParse "repository name" lineno) return $
1192 simpleParsec name
1193 r' <- parseFields remoteRepoFields (emptyRemoteRepo name') fs
1194 r'' <- postProcessRepo lineno name r'
1195 case r'' of
1196 Left local -> return (rs, local:ls, h, i, u, g, p, a)
1197 Right remote -> return (remote:rs, ls, h, i, u, g, p, a)
1198
1199 parseSections (rs, ls, h, i, u, g, p, a)
1200 (ParseUtils.F lno "remote-repo" raw) = do
1201 let mr' = simpleParsec raw
1202 r' <- maybe (ParseFailed $ NoParse "remote-repo" lno) return mr'
1203 return (r':rs, ls, h, i, u, g, p, a)
1204
1205 parseSections accum@(rs, ls, h, i, u, g, p, a)
1206 (ParseUtils.Section _ "haddock" name fs)
1207 | name == "" = do h' <- parseFields haddockFlagsFields h fs
1208 return (rs, ls, h', i, u, g, p, a)
1209 | otherwise = do
1210 warning "The 'haddock' section should be unnamed"
1211 return accum
1212
1213 parseSections accum@(rs, ls, h, i, u, g, p, a)
1214 (ParseUtils.Section _ "init" name fs)
1215 | name == "" = do i' <- parseFields initFlagsFields i fs
1216 return (rs, ls, h, i', u, g, p, a)
1217 | otherwise = do
1218 warning "The 'init' section should be unnamed"
1219 return accum
1220
1221 parseSections accum@(rs, ls, h, i, u, g, p, a)
1222 (ParseUtils.Section _ "install-dirs" name fs)
1223 | name' == "user" = do u' <- parseFields installDirsFields u fs
1224 return (rs, ls, h, i, u', g, p, a)
1225 | name' == "global" = do g' <- parseFields installDirsFields g fs
1226 return (rs, ls, h, i, u, g', p, a)
1227 | otherwise = do
1228 warning "The 'install-paths' section should be for 'user' or 'global'"
1229 return accum
1230 where name' = lowercase name
1231 parseSections accum@(rs, ls, h, i, u, g, p, a)
1232 (ParseUtils.Section _ "program-locations" name fs)
1233 | name == "" = do p' <- parseFields withProgramsFields p fs
1234 return (rs, ls, h, i, u, g, p', a)
1235 | otherwise = do
1236 warning "The 'program-locations' section should be unnamed"
1237 return accum
1238 parseSections accum@(rs, ls, h, i, u, g, p, a)
1239 (ParseUtils.Section _ "program-default-options" name fs)
1240 | name == "" = do a' <- parseFields withProgramOptionsFields a fs
1241 return (rs, ls, h, i, u, g, p, a')
1242 | otherwise = do
1243 warning "The 'program-default-options' section should be unnamed"
1244 return accum
1245 parseSections accum f = do
1246 warning $ "Unrecognized stanza on line " ++ show (lineNo f)
1247 return accum
1248
1249 postProcessRepo :: Int -> String -> RemoteRepo -> ParseResult (Either LocalRepo RemoteRepo)
1250 postProcessRepo lineno reponameStr repo0 = do
1251 when (null reponameStr) $
1252 syntaxError lineno $ "a 'repository' section requires the "
1253 ++ "repository name as an argument"
1254
1255 reponame <- maybe (fail $ "Invalid repository name " ++ reponameStr) return $
1256 simpleParsec reponameStr
1257
1258 case uriScheme (remoteRepoURI repo0) of
1259 -- TODO: check that there are no authority, query or fragment
1260 -- Note: the trailing colon is important
1261 "file+noindex:" -> do
1262 let uri = remoteRepoURI repo0
1263 return $ Left $ LocalRepo reponame (uriPath uri) (uriFragment uri == "#shared-cache")
1264
1265 _ -> do
1266 let repo = repo0 { remoteRepoName = reponame }
1267
1268 when (remoteRepoKeyThreshold repo > length (remoteRepoRootKeys repo)) $
1269 warning $ "'key-threshold' for repository "
1270 ++ show (remoteRepoName repo)
1271 ++ " higher than number of keys"
1272
1273 when (not (null (remoteRepoRootKeys repo)) && remoteRepoSecure repo /= Just True) $
1274 warning $ "'root-keys' for repository "
1275 ++ show (remoteRepoName repo)
1276 ++ " non-empty, but 'secure' not set to True."
1277
1278 return $ Right repo
1279
1280 showConfig :: SavedConfig -> String
1281 showConfig = showConfigWithComments mempty
1282
1283 showConfigWithComments :: SavedConfig -> SavedConfig -> String
1284 showConfigWithComments comment vals = Disp.render $
1285 case fmap (uncurry ppRemoteRepoSection)
1286 (zip (getRemoteRepos comment) (getRemoteRepos vals)) of
1287 [] -> Disp.text ""
1288 (x:xs) -> foldl' (\ r r' -> r $+$ Disp.text "" $+$ r') x xs
1289 $+$ Disp.text ""
1290 $+$ ppFields
1291 (skipSomeFields (configFieldDescriptions ConstraintSourceUnknown))
1292 mcomment vals
1293 $+$ Disp.text ""
1294 $+$ ppSection "haddock" "" haddockFlagsFields
1295 (fmap savedHaddockFlags mcomment) (savedHaddockFlags vals)
1296 $+$ Disp.text ""
1297 $+$ ppSection "init" "" initFlagsFields
1298 (fmap savedInitFlags mcomment) (savedInitFlags vals)
1299 $+$ Disp.text ""
1300 $+$ installDirsSection "user" savedUserInstallDirs
1301 $+$ Disp.text ""
1302 $+$ installDirsSection "global" savedGlobalInstallDirs
1303 $+$ Disp.text ""
1304 $+$ configFlagsSection "program-locations" withProgramsFields
1305 configProgramPaths
1306 $+$ Disp.text ""
1307 $+$ configFlagsSection "program-default-options" withProgramOptionsFields
1308 configProgramArgs
1309 where
1310 getRemoteRepos = fromNubList . globalRemoteRepos . savedGlobalFlags
1311 mcomment = Just comment
1312 installDirsSection name field =
1313 ppSection "install-dirs" name installDirsFields
1314 (fmap field mcomment) (field vals)
1315 configFlagsSection name fields field =
1316 ppSection name "" fields
1317 (fmap (field . savedConfigureFlags) mcomment)
1318 ((field . savedConfigureFlags) vals)
1319
1320 -- skip fields based on field name. currently only skips "remote-repo",
1321 -- because that is rendered as a section. (see 'ppRemoteRepoSection'.)
1322 skipSomeFields = filter ((/= "remote-repo") . fieldName)
1323
1324 -- | Fields for the 'install-dirs' sections.
1325 installDirsFields :: [FieldDescr (InstallDirs (Flag PathTemplate))]
1326 installDirsFields = map viewAsFieldDescr installDirsOptions
1327
1328 ppRemoteRepoSection :: RemoteRepo -> RemoteRepo -> Doc
1329 ppRemoteRepoSection def vals = ppSection "repository" (unRepoName (remoteRepoName vals))
1330 remoteRepoFields (Just def) vals
1331
1332 remoteRepoFields :: [FieldDescr RemoteRepo]
1333 remoteRepoFields =
1334 [ simpleField "url"
1335 (text . show) (parseTokenQ >>= parseURI')
1336 remoteRepoURI (\x repo -> repo { remoteRepoURI = x })
1337 , simpleFieldParsec "secure"
1338 showSecure (Just `fmap` parsec)
1339 remoteRepoSecure (\x repo -> repo { remoteRepoSecure = x })
1340 , listField "root-keys"
1341 text parseTokenQ
1342 remoteRepoRootKeys (\x repo -> repo { remoteRepoRootKeys = x })
1343 , simpleFieldParsec "key-threshold"
1344 showThreshold P.integral
1345 remoteRepoKeyThreshold (\x repo -> repo { remoteRepoKeyThreshold = x })
1346 ]
1347 where
1348 parseURI' uriString =
1349 case parseURI uriString of
1350 Nothing -> fail $ "remote-repo: no parse on " ++ show uriString
1351 Just uri -> return uri
1352
1353 showSecure Nothing = mempty -- default 'secure' setting
1354 showSecure (Just True) = text "True" -- user explicitly enabled it
1355 showSecure (Just False) = text "False" -- user explicitly disabled it
1356
1357 -- If the key-threshold is set to 0, we omit it as this is the default
1358 -- and it looks odd to have a value for key-threshold but not for 'secure'
1359 -- (note that an empty list of keys is already omitted by default, since
1360 -- that is what we do for all list fields)
1361 showThreshold 0 = mempty
1362 showThreshold t = text (show t)
1363
1364 -- | Fields for the 'haddock' section.
1365 haddockFlagsFields :: [FieldDescr HaddockFlags]
1366 haddockFlagsFields = [ field
1367 | opt <- haddockOptions ParseArgs
1368 , let field = viewAsFieldDescr opt
1369 name = fieldName field
1370 , name `notElem` exclusions ]
1371 where
1372 exclusions = ["verbose", "builddir", "for-hackage"]
1373
1374 -- | Fields for the 'init' section.
1375 initFlagsFields :: [FieldDescr IT.InitFlags]
1376 initFlagsFields = [ field
1377 | opt <- initOptions ParseArgs
1378 , let field = viewAsFieldDescr opt
1379 name = fieldName field
1380 , name `notElem` exclusions ]
1381 where
1382 exclusions =
1383 [ "author", "email", "quiet", "no-comments", "minimal", "overwrite"
1384 , "package-dir", "packagedir", "package-name", "version", "homepage"
1385 , "synopsis", "category", "extra-source-file", "lib", "exe", "libandexe"
1386 , "simple", "main-is", "expose-module", "exposed-modules", "extension"
1387 , "dependency", "build-tool", "with-compiler"
1388 , "verbose"
1389 ]
1390
1391 -- | Fields for the 'program-locations' section.
1392 withProgramsFields :: [FieldDescr [(String, FilePath)]]
1393 withProgramsFields =
1394 map viewAsFieldDescr $
1395 programDbPaths' (++ "-location") defaultProgramDb
1396 ParseArgs id (++)
1397
1398 -- | Fields for the 'program-default-options' section.
1399 withProgramOptionsFields :: [FieldDescr [(String, [String])]]
1400 withProgramOptionsFields =
1401 map viewAsFieldDescr $
1402 programDbOptions defaultProgramDb ParseArgs id (++)
1403
1404 parseExtraLines :: Verbosity -> [String] -> IO SavedConfig
1405 parseExtraLines verbosity extraLines =
1406 case parseConfig (ConstraintSourceMainConfig "additional lines")
1407 mempty (toUTF8BS (unlines extraLines)) of
1408 ParseFailed err ->
1409 let (line, msg) = locatedErrorMsg err
1410 in die' verbosity $
1411 "Error parsing additional config lines\n"
1412 ++ maybe "" (\n -> ':' : show n) line ++ ":\n" ++ msg
1413 ParseOk [] r -> return r
1414 ParseOk ws _ ->
1415 die' verbosity $
1416 unlines (map (showPWarning "Error parsing additional config lines") ws)
1417
1418 -- | Get the differences (as a pseudo code diff) between the user's
1419 -- '~/.cabal/config' and the one that cabal would generate if it didn't exist.
1420 userConfigDiff :: Verbosity -> GlobalFlags -> [String] -> IO [String]
1421 userConfigDiff verbosity globalFlags extraLines = do
1422 userConfig <- loadRawConfig normal (globalConfigFile globalFlags)
1423 extraConfig <- parseExtraLines verbosity extraLines
1424 testConfig <- initialSavedConfig
1425 return $
1426 reverse . foldl' createDiff [] . M.toList
1427 $ M.unionWith combine
1428 (M.fromList . map justFst $ filterShow testConfig)
1429 (M.fromList . map justSnd $ filterShow (userConfig `mappend` extraConfig))
1430 where
1431 justFst (a, b) = (a, (Just b, Nothing))
1432 justSnd (a, b) = (a, (Nothing, Just b))
1433
1434 combine (Nothing, Just b) (Just a, Nothing) = (Just a, Just b)
1435 combine (Just a, Nothing) (Nothing, Just b) = (Just a, Just b)
1436 combine x y = error $ "Can't happen : userConfigDiff "
1437 ++ show x ++ " " ++ show y
1438
1439 createDiff :: [String] -> (String, (Maybe String, Maybe String)) -> [String]
1440 createDiff acc (key, (Just a, Just b))
1441 | a == b = acc
1442 | otherwise = ("+ " ++ key ++ ": " ++ b)
1443 : ("- " ++ key ++ ": " ++ a) : acc
1444 createDiff acc (key, (Nothing, Just b)) = ("+ " ++ key ++ ": " ++ b) : acc
1445 createDiff acc (key, (Just a, Nothing)) = ("- " ++ key ++ ": " ++ a) : acc
1446 createDiff acc (_, (Nothing, Nothing)) = acc
1447
1448 filterShow :: SavedConfig -> [(String, String)]
1449 filterShow cfg = map keyValueSplit
1450 . filter (\s -> not (null s) && ':' `elem` s)
1451 . map nonComment
1452 . lines
1453 $ showConfig cfg
1454
1455 nonComment [] = []
1456 nonComment ('-':'-':_) = []
1457 nonComment (x:xs) = x : nonComment xs
1458
1459 topAndTail = reverse . dropWhile isSpace . reverse . dropWhile isSpace
1460
1461 keyValueSplit s =
1462 let (left, right) = break (== ':') s
1463 in (topAndTail left, topAndTail (drop 1 right))
1464
1465
1466 -- | Update the user's ~/.cabal/config' keeping the user's customizations.
1467 userConfigUpdate :: Verbosity -> GlobalFlags -> [String] -> IO ()
1468 userConfigUpdate verbosity globalFlags extraLines = do
1469 userConfig <- loadRawConfig normal (globalConfigFile globalFlags)
1470 extraConfig <- parseExtraLines verbosity extraLines
1471 newConfig <- initialSavedConfig
1472 commentConf <- commentSavedConfig
1473 cabalFile <- getConfigFilePath $ globalConfigFile globalFlags
1474 let backup = cabalFile ++ ".backup"
1475 notice verbosity $ "Renaming " ++ cabalFile ++ " to " ++ backup ++ "."
1476 renameFile cabalFile backup
1477 notice verbosity $ "Writing merged config to " ++ cabalFile ++ "."
1478 writeConfigFile cabalFile commentConf
1479 (newConfig `mappend` userConfig `mappend` extraConfig)