1{-# LANGUAGE NoImplicitPrelude #-} 2{-# LANGUAGE ConstraintKinds #-} 3{-# LANGUAGE FlexibleContexts #-} 4{-# LANGUAGE MultiParamTypeClasses #-} 5{-# LANGUAGE OverloadedStrings #-} 6{-# LANGUAGE ScopedTypeVariables #-} 7{-# LANGUAGE TypeFamilies #-} 8module Stack.Init 9 ( initProject 10 , InitOpts (..) 11 ) where 12 13import Stack.Prelude 14import qualified Data.ByteString.Builder as B 15import qualified Data.ByteString.Char8 as BC 16import qualified Data.Foldable as F 17import qualified Data.HashMap.Strict as HM 18import qualified Data.IntMap as IntMap 19import Data.List.Extra (groupSortOn) 20import qualified Data.List.NonEmpty as NonEmpty 21import qualified Data.Map.Strict as Map 22import qualified Data.Set as Set 23import qualified Data.Text as T 24import qualified Data.Text.Normalize as T (normalize , NormalizationMode(NFC)) 25import qualified Data.Yaml as Yaml 26import qualified Distribution.PackageDescription as C 27import qualified Distribution.Text as C 28import qualified Distribution.Version as C 29import Path 30import Path.Extra (toFilePathNoTrailingSep) 31import Path.Find (findFiles) 32import Path.IO hiding (findFiles) 33import qualified Paths_stack as Meta 34import qualified RIO.FilePath as FP 35import RIO.List ((\\), intercalate, intersperse, 36 isSuffixOf, isPrefixOf) 37import RIO.List.Partial (minimumBy) 38import Stack.BuildPlan 39import Stack.Config (getSnapshots, 40 makeConcreteResolver) 41import Stack.Constants 42import Stack.SourceMap 43import Stack.Types.Config 44import Stack.Types.Resolver 45import Stack.Types.Version 46 47-- | Generate stack.yaml 48initProject 49 :: (HasConfig env, HasGHCVariant env) 50 => Path Abs Dir 51 -> InitOpts 52 -> Maybe AbstractResolver 53 -> RIO env () 54initProject currDir initOpts mresolver = do 55 let dest = currDir </> stackDotYaml 56 57 reldest <- toFilePath `liftM` makeRelativeToCurrentDir dest 58 59 exists <- doesFileExist dest 60 when (not (forceOverwrite initOpts) && exists) $ 61 throwString 62 ("Error: Stack configuration file " <> reldest <> 63 " exists, use '--force' to overwrite it.") 64 65 dirs <- mapM (resolveDir' . T.unpack) (searchDirs initOpts) 66 let find = findCabalDirs (includeSubDirs initOpts) 67 dirs' = if null dirs then [currDir] else dirs 68 logInfo "Looking for .cabal or package.yaml files to use to init the project." 69 cabaldirs <- Set.toList . Set.unions <$> mapM find dirs' 70 (bundle, dupPkgs) <- cabalPackagesCheck cabaldirs Nothing 71 let makeRelDir dir = 72 case stripProperPrefix currDir dir of 73 Nothing 74 | currDir == dir -> "." 75 | otherwise -> assert False $ toFilePathNoTrailingSep dir 76 Just rel -> toFilePathNoTrailingSep rel 77 fpToPkgDir fp = 78 let absDir = parent fp 79 in ResolvedPath (RelFilePath $ T.pack $ makeRelDir absDir) absDir 80 pkgDirs = Map.map (fpToPkgDir . fst) bundle 81 (snapshotLoc, flags, extraDeps, rbundle) <- getDefaultResolver initOpts mresolver pkgDirs 82 83 let ignored = Map.difference bundle rbundle 84 dupPkgMsg 85 | dupPkgs /= [] = 86 "Warning (added by new or init): Some packages were found to \ 87 \have names conflicting with others and have been commented \ 88 \out in the packages section.\n" 89 | otherwise = "" 90 91 missingPkgMsg 92 | Map.size ignored > 0 = 93 "Warning (added by new or init): Some packages were found to \ 94 \be incompatible with the resolver and have been left commented \ 95 \out in the packages section.\n" 96 | otherwise = "" 97 98 extraDepMsg 99 | Map.size extraDeps > 0 = 100 "Warning (added by new or init): Specified resolver could not \ 101 \satisfy all dependencies. Some external packages have been \ 102 \added as dependencies.\n" 103 | otherwise = "" 104 makeUserMsg msgs = 105 let msg = concat msgs 106 in if msg /= "" then 107 msg <> "You can omit this message by removing it from \ 108 \stack.yaml\n" 109 else "" 110 111 userMsg = makeUserMsg [dupPkgMsg, missingPkgMsg, extraDepMsg] 112 113 gpdByDir = Map.fromList [ (parent fp, gpd) | (fp, gpd) <- Map.elems bundle] 114 gpds = Map.elems $ 115 Map.mapMaybe (flip Map.lookup gpdByDir . resolvedAbsolute) rbundle 116 117 deps <- for (Map.toList extraDeps) $ \(n, v) -> 118 PLImmutable . cplComplete <$> 119 completePackageLocation (RPLIHackage (PackageIdentifierRevision n v CFILatest) Nothing) 120 121 let p = Project 122 { projectUserMsg = if userMsg == "" then Nothing else Just userMsg 123 , projectPackages = resolvedRelative <$> Map.elems rbundle 124 , projectDependencies = map toRawPL deps 125 , projectFlags = removeSrcPkgDefaultFlags gpds flags 126 , projectResolver = snapshotLoc 127 , projectCompiler = Nothing 128 , projectExtraPackageDBs = [] 129 , projectCurator = Nothing 130 , projectDropPackages = mempty 131 } 132 133 makeRel = fmap toFilePath . makeRelativeToCurrentDir 134 135 indent t = T.unlines $ fmap (" " <>) (T.lines t) 136 137 logInfo $ "Initialising configuration using resolver: " <> display snapshotLoc 138 logInfo $ "Total number of user packages considered: " 139 <> display (Map.size bundle + length dupPkgs) 140 141 when (dupPkgs /= []) $ do 142 logWarn $ "Warning! Ignoring " 143 <> displayShow (length dupPkgs) 144 <> " duplicate packages:" 145 rels <- mapM makeRel dupPkgs 146 logWarn $ display $ indent $ showItems rels 147 148 when (Map.size ignored > 0) $ do 149 logWarn $ "Warning! Ignoring " 150 <> displayShow (Map.size ignored) 151 <> " packages due to dependency conflicts:" 152 rels <- mapM makeRel (Map.elems (fmap fst ignored)) 153 logWarn $ display $ indent $ showItems rels 154 155 when (Map.size extraDeps > 0) $ do 156 logWarn $ "Warning! " <> displayShow (Map.size extraDeps) 157 <> " external dependencies were added." 158 logInfo $ 159 (if exists then "Overwriting existing configuration file: " 160 else "Writing configuration to file: ") 161 <> fromString reldest 162 writeBinaryFileAtomic dest 163 $ renderStackYaml p 164 (Map.elems $ fmap (makeRelDir . parent . fst) ignored) 165 (map (makeRelDir . parent) dupPkgs) 166 logInfo "All done." 167 168-- | Render a stack.yaml file with comments, see: 169-- https://github.com/commercialhaskell/stack/issues/226 170renderStackYaml :: Project -> [FilePath] -> [FilePath] -> B.Builder 171renderStackYaml p ignoredPackages dupPackages = 172 case Yaml.toJSON p of 173 Yaml.Object o -> renderObject o 174 _ -> assert False $ B.byteString $ Yaml.encode p 175 where 176 renderObject o = 177 B.byteString headerHelp 178 <> B.byteString "\n\n" 179 <> F.foldMap (goComment o) comments 180 <> goOthers (o `HM.difference` HM.fromList comments) 181 <> B.byteString footerHelp 182 <> "\n" 183 184 goComment o (name, comment) = 185 case (convert <$> HM.lookup name o) <|> nonPresentValue name of 186 Nothing -> assert (name == "user-message") mempty 187 Just v -> 188 B.byteString comment <> 189 B.byteString "\n" <> 190 v <> 191 if name == "packages" then commentedPackages else "" <> 192 B.byteString "\n" 193 where 194 convert v = B.byteString (Yaml.encode $ Yaml.object [(name, v)]) 195 196 -- Some fields in stack.yaml are optional and may not be 197 -- generated. For these, we provided commented out dummy 198 -- values to go along with the comments. 199 nonPresentValue "extra-deps" = Just "# extra-deps: []\n" 200 nonPresentValue "flags" = Just "# flags: {}\n" 201 nonPresentValue "extra-package-dbs" = Just "# extra-package-dbs: []\n" 202 nonPresentValue _ = Nothing 203 204 commentLine l | null l = "#" 205 | otherwise = "# " ++ l 206 commentHelp = BC.pack . intercalate "\n" . map commentLine 207 commentedPackages = 208 let ignoredComment = commentHelp 209 [ "The following packages have been ignored due to incompatibility with the" 210 , "resolver compiler, dependency conflicts with other packages" 211 , "or unsatisfied dependencies." 212 ] 213 dupComment = commentHelp 214 [ "The following packages have been ignored due to package name conflict " 215 , "with other packages." 216 ] 217 in commentPackages ignoredComment ignoredPackages 218 <> commentPackages dupComment dupPackages 219 220 commentPackages comment pkgs 221 | pkgs /= [] = 222 B.byteString comment 223 <> B.byteString "\n" 224 <> B.byteString (BC.pack $ concat 225 $ map (\x -> "#- " ++ x ++ "\n") pkgs ++ ["\n"]) 226 | otherwise = "" 227 228 goOthers o 229 | HM.null o = mempty 230 | otherwise = assert False $ B.byteString $ Yaml.encode o 231 232 -- Per Section Help 233 comments = 234 [ ("user-message" , userMsgHelp) 235 , ("resolver" , resolverHelp) 236 , ("packages" , packageHelp) 237 , ("extra-deps" , extraDepsHelp) 238 , ("flags" , "# Override default flag values for local packages and extra-deps") 239 , ("extra-package-dbs", "# Extra package databases containing global packages") 240 ] 241 242 -- Help strings 243 headerHelp = commentHelp 244 [ "This file was automatically generated by 'stack init'" 245 , "" 246 , "Some commonly used options have been documented as comments in this file." 247 , "For advanced use and comprehensive documentation of the format, please see:" 248 , "https://docs.haskellstack.org/en/stable/yaml_configuration/" 249 ] 250 251 resolverHelp = commentHelp 252 [ "Resolver to choose a 'specific' stackage snapshot or a compiler version." 253 , "A snapshot resolver dictates the compiler version and the set of packages" 254 , "to be used for project dependencies. For example:" 255 , "" 256 , "resolver: lts-3.5" 257 , "resolver: nightly-2015-09-21" 258 , "resolver: ghc-7.10.2" 259 , "" 260 , "The location of a snapshot can be provided as a file or url. Stack assumes" 261 , "a snapshot provided as a file might change, whereas a url resource does not." 262 , "" 263 , "resolver: ./custom-snapshot.yaml" 264 , "resolver: https://example.com/snapshots/2018-01-01.yaml" 265 ] 266 267 userMsgHelp = commentHelp 268 [ "A warning or info to be displayed to the user on config load." ] 269 270 packageHelp = commentHelp 271 [ "User packages to be built." 272 , "Various formats can be used as shown in the example below." 273 , "" 274 , "packages:" 275 , "- some-directory" 276 , "- https://example.com/foo/bar/baz-0.0.2.tar.gz" 277 , " subdirs:" 278 , " - auto-update" 279 , " - wai" 280 ] 281 282 extraDepsHelp = commentHelp 283 [ "Dependency packages to be pulled from upstream that are not in the resolver." 284 , "These entries can reference officially published versions as well as" 285 , "forks / in-progress versions pinned to a git hash. For example:" 286 , "" 287 , "extra-deps:" 288 , "- acme-missiles-0.3" 289 , "- git: https://github.com/commercialhaskell/stack.git" 290 , " commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a" 291 , "" 292 ] 293 294 footerHelp = 295 let major = toMajorVersion $ C.mkVersion' Meta.version 296 in commentHelp 297 [ "Control whether we use the GHC we find on the path" 298 , "system-ghc: true" 299 , "" 300 , "Require a specific version of stack, using version ranges" 301 , "require-stack-version: -any # Default" 302 , "require-stack-version: \"" 303 ++ C.display (C.orLaterVersion major) ++ "\"" 304 , "" 305 , "Override the architecture used by stack, especially useful on Windows" 306 , "arch: i386" 307 , "arch: x86_64" 308 , "" 309 , "Extra directories used by stack for building" 310 , "extra-include-dirs: [/path/to/dir]" 311 , "extra-lib-dirs: [/path/to/dir]" 312 , "" 313 , "Allow a newer minor version of GHC than the snapshot specifies" 314 , "compiler-check: newer-minor" 315 ] 316 317getSnapshots' :: HasConfig env => RIO env Snapshots 318getSnapshots' = do 319 getSnapshots `catchAny` \e -> do 320 logError $ 321 "Unable to download snapshot list, and therefore could " <> 322 "not generate a stack.yaml file automatically" 323 logError $ 324 "This sometimes happens due to missing Certificate Authorities " <> 325 "on your system. For more information, see:" 326 logError "" 327 logError " https://github.com/commercialhaskell/stack/issues/234" 328 logError "" 329 logError "You can try again, or create your stack.yaml file by hand. See:" 330 logError "" 331 logError " http://docs.haskellstack.org/en/stable/yaml_configuration/" 332 logError "" 333 logError $ "Exception was: " <> displayShow e 334 throwString "" 335 336-- | Get the default resolver value 337getDefaultResolver 338 :: (HasConfig env, HasGHCVariant env) 339 => InitOpts 340 -> Maybe AbstractResolver 341 -> Map PackageName (ResolvedPath Dir) 342 -- ^ Src package name: cabal dir 343 -> RIO env 344 ( RawSnapshotLocation 345 , Map PackageName (Map FlagName Bool) 346 , Map PackageName Version 347 , Map PackageName (ResolvedPath Dir)) 348 -- ^ ( Resolver 349 -- , Flags for src packages and extra deps 350 -- , Extra dependencies 351 -- , Src packages actually considered) 352getDefaultResolver initOpts mresolver pkgDirs = do 353 (candidate, loc) <- case mresolver of 354 Nothing -> selectSnapResolver 355 Just ar -> do 356 sl <- makeConcreteResolver ar 357 c <- loadProjectSnapshotCandidate sl NoPrintWarnings False 358 return (c, sl) 359 getWorkingResolverPlan initOpts pkgDirs candidate loc 360 where 361 -- TODO support selecting best across regular and custom snapshots 362 selectSnapResolver = do 363 snaps <- fmap getRecommendedSnapshots getSnapshots' 364 (c, l, r) <- selectBestSnapshot (Map.elems pkgDirs) snaps 365 case r of 366 BuildPlanCheckFail {} | not (omitPackages initOpts) 367 -> throwM (NoMatchingSnapshot snaps) 368 _ -> return (c, l) 369 370getWorkingResolverPlan 371 :: (HasConfig env, HasGHCVariant env) 372 => InitOpts 373 -> Map PackageName (ResolvedPath Dir) 374 -- ^ Src packages: cabal dir 375 -> SnapshotCandidate env 376 -> RawSnapshotLocation 377 -> RIO env 378 ( RawSnapshotLocation 379 , Map PackageName (Map FlagName Bool) 380 , Map PackageName Version 381 , Map PackageName (ResolvedPath Dir)) 382 -- ^ ( SnapshotDef 383 -- , Flags for src packages and extra deps 384 -- , Extra dependencies 385 -- , Src packages actually considered) 386getWorkingResolverPlan initOpts pkgDirs0 snapCandidate snapLoc = do 387 logInfo $ "Selected resolver: " <> display snapLoc 388 go pkgDirs0 389 where 390 go pkgDirs = do 391 eres <- checkBundleResolver initOpts snapLoc snapCandidate (Map.elems pkgDirs) 392 -- if some packages failed try again using the rest 393 case eres of 394 Right (f, edeps)-> return (snapLoc, f, edeps, pkgDirs) 395 Left ignored 396 | Map.null available -> do 397 logWarn "*** Could not find a working plan for any of \ 398 \the user packages.\nProceeding to create a \ 399 \config anyway." 400 return (snapLoc, Map.empty, Map.empty, Map.empty) 401 | otherwise -> do 402 when (Map.size available == Map.size pkgDirs) $ 403 error "Bug: No packages to ignore" 404 405 if length ignored > 1 then do 406 logWarn "*** Ignoring packages:" 407 logWarn $ display $ indent $ showItems $ map packageNameString ignored 408 else 409 logWarn $ "*** Ignoring package: " 410 <> fromString 411 (case ignored of 412 [] -> error "getWorkingResolverPlan.head" 413 x:_ -> packageNameString x) 414 415 go available 416 where 417 indent t = T.unlines $ fmap (" " <>) (T.lines t) 418 isAvailable k _ = k `notElem` ignored 419 available = Map.filterWithKey isAvailable pkgDirs 420 421checkBundleResolver 422 :: (HasConfig env, HasGHCVariant env) 423 => InitOpts 424 -> RawSnapshotLocation 425 -> SnapshotCandidate env 426 -> [ResolvedPath Dir] 427 -- ^ Src package dirs 428 -> RIO env 429 (Either [PackageName] ( Map PackageName (Map FlagName Bool) 430 , Map PackageName Version)) 431checkBundleResolver initOpts snapshotLoc snapCandidate pkgDirs = do 432 result <- checkSnapBuildPlan pkgDirs Nothing snapCandidate 433 case result of 434 BuildPlanCheckOk f -> return $ Right (f, Map.empty) 435 BuildPlanCheckPartial _f e -> do -- FIXME:qrilka unused f 436 if omitPackages initOpts 437 then do 438 warnPartial result 439 logWarn "*** Omitting packages with unsatisfied dependencies" 440 return $ Left $ failedUserPkgs e 441 else throwM $ ResolverPartial snapshotLoc (show result) 442 BuildPlanCheckFail _ e _ 443 | omitPackages initOpts -> do 444 logWarn $ "*** Resolver compiler mismatch: " 445 <> display snapshotLoc 446 logWarn $ display $ indent $ T.pack $ show result 447 return $ Left $ failedUserPkgs e 448 | otherwise -> throwM $ ResolverMismatch snapshotLoc (show result) 449 where 450 indent t = T.unlines $ fmap (" " <>) (T.lines t) 451 warnPartial res = do 452 logWarn $ "*** Resolver " <> display snapshotLoc 453 <> " will need external packages: " 454 logWarn $ display $ indent $ T.pack $ show res 455 456 failedUserPkgs e = Map.keys $ Map.unions (Map.elems (fmap deNeededBy e)) 457 458getRecommendedSnapshots :: Snapshots -> NonEmpty SnapName 459getRecommendedSnapshots snapshots = 460 -- in order - Latest LTS, Latest Nightly, all LTS most recent first 461 case NonEmpty.nonEmpty ltss of 462 Just (mostRecent :| older) 463 -> mostRecent :| (nightly : older) 464 Nothing 465 -> nightly :| [] 466 where 467 ltss = map (uncurry LTS) (IntMap.toDescList $ snapshotsLts snapshots) 468 nightly = Nightly (snapshotsNightly snapshots) 469 470data InitOpts = InitOpts 471 { searchDirs :: ![T.Text] 472 -- ^ List of sub directories to search for .cabal files 473 , omitPackages :: Bool 474 -- ^ Exclude conflicting or incompatible user packages 475 , forceOverwrite :: Bool 476 -- ^ Overwrite existing stack.yaml 477 , includeSubDirs :: Bool 478 -- ^ If True, include all .cabal files found in any sub directories 479 } 480 481findCabalDirs 482 :: HasConfig env 483 => Bool -> Path Abs Dir -> RIO env (Set (Path Abs Dir)) 484findCabalDirs recurse dir = 485 Set.fromList . map parent 486 <$> liftIO (findFiles dir isHpackOrCabal subdirFilter) 487 where 488 subdirFilter subdir = recurse && not (isIgnored subdir) 489 isHpack = (== "package.yaml") . toFilePath . filename 490 isCabal = (".cabal" `isSuffixOf`) . toFilePath 491 isHpackOrCabal x = isHpack x || isCabal x 492 493 isIgnored path = "." `isPrefixOf` dirName || dirName `Set.member` ignoredDirs 494 where 495 dirName = FP.dropTrailingPathSeparator (toFilePath (dirname path)) 496 497-- | Special directories that we don't want to traverse for .cabal files 498ignoredDirs :: Set FilePath 499ignoredDirs = Set.fromList 500 [ "dist" 501 ] 502 503cabalPackagesCheck 504 :: (HasConfig env, HasGHCVariant env) 505 => [Path Abs Dir] 506 -> Maybe String 507 -> RIO env 508 ( Map PackageName (Path Abs File, C.GenericPackageDescription) 509 , [Path Abs File]) 510cabalPackagesCheck cabaldirs dupErrMsg = do 511 when (null cabaldirs) $ do 512 logWarn "We didn't find any local package directories" 513 logWarn "You may want to create a package with \"stack new\" instead" 514 logWarn "Create an empty project for now" 515 logWarn "If this isn't what you want, please delete the generated \"stack.yaml\"" 516 517 relpaths <- mapM prettyPath cabaldirs 518 logInfo "Using cabal packages:" 519 logInfo $ formatGroup relpaths 520 521 packages <- for cabaldirs $ \dir -> do 522 (gpdio, _name, cabalfp) <- loadCabalFilePath dir 523 gpd <- liftIO $ gpdio YesPrintWarnings 524 pure (cabalfp, gpd) 525 526 -- package name cannot be empty or missing otherwise 527 -- it will result in cabal solver failure. 528 -- stack requires packages name to match the cabal file name 529 -- Just the latter check is enough to cover both the cases 530 531 let normalizeString = T.unpack . T.normalize T.NFC . T.pack 532 getNameMismatchPkg (fp, gpd) 533 | (normalizeString . packageNameString . gpdPackageName) gpd /= (normalizeString . FP.takeBaseName . toFilePath) fp 534 = Just fp 535 | otherwise = Nothing 536 nameMismatchPkgs = mapMaybe getNameMismatchPkg packages 537 538 when (nameMismatchPkgs /= []) $ do 539 rels <- mapM prettyPath nameMismatchPkgs 540 error $ "Package name as defined in the .cabal file must match the \ 541 \.cabal file name.\n\ 542 \Please fix the following packages and try again:\n" 543 <> T.unpack (utf8BuilderToText (formatGroup rels)) 544 545 let dupGroups = filter ((> 1) . length) 546 . groupSortOn (gpdPackageName . snd) 547 dupAll = concat $ dupGroups packages 548 549 -- Among duplicates prefer to include the ones in upper level dirs 550 pathlen = length . FP.splitPath . toFilePath . fst 551 getmin = minimumBy (compare `on` pathlen) 552 dupSelected = map getmin (dupGroups packages) 553 dupIgnored = dupAll \\ dupSelected 554 unique = packages \\ dupIgnored 555 556 when (dupIgnored /= []) $ do 557 dups <- mapM (mapM (prettyPath. fst)) (dupGroups packages) 558 logWarn $ 559 "Following packages have duplicate package names:\n" <> 560 mconcat (intersperse "\n" (map formatGroup dups)) 561 case dupErrMsg of 562 Nothing -> logWarn $ 563 "Packages with duplicate names will be ignored.\n" 564 <> "Packages in upper level directories will be preferred.\n" 565 Just msg -> error msg 566 567 return (Map.fromList 568 $ map (\(file, gpd) -> (gpdPackageName gpd,(file, gpd))) unique 569 , map fst dupIgnored) 570 571formatGroup :: [String] -> Utf8Builder 572formatGroup = foldMap (\path -> "- " <> fromString path <> "\n") 573 574prettyPath :: 575 (MonadIO m, RelPath (Path r t) ~ Path Rel t, AnyPath (Path r t)) 576 => Path r t 577 -> m FilePath 578prettyPath path = do 579 eres <- liftIO $ try $ makeRelativeToCurrentDir path 580 return $ case eres of 581 Left (_ :: PathException) -> toFilePath path 582 Right res -> toFilePath res 583