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