module Stack.Init
( initProject
, InitOpts (..)
, SnapPref (..)
, Method (..)
) where
import Control.Exception (assert)
import Control.Exception.Enclosed (catchAny, handleIO)
import Control.Monad (liftM, when)
import Control.Monad.Catch (MonadMask, throwM)
import Control.Monad.IO.Class
import Control.Monad.Logger
import Control.Monad.Reader (MonadReader)
import Control.Monad.Trans.Control (MonadBaseControl)
import qualified Data.ByteString.Builder as B
import qualified Data.ByteString.Lazy as L
import qualified Data.HashMap.Strict as HM
import qualified Data.IntMap as IntMap
import qualified Data.Foldable as F
import Data.List (sortBy)
import Data.List.Extra (nubOrd)
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Maybe (mapMaybe)
import Data.Monoid
import qualified Data.Text as T
import qualified Data.Yaml as Yaml
import qualified Distribution.PackageDescription as C
import Network.HTTP.Client.Conduit (HasHttpManager)
import Path
import Path.IO
import Stack.BuildPlan
import Stack.Constants
import Stack.Solver
import Stack.Types
import Stack.Types.Internal ( HasTerminal, HasReExec
, HasLogLevel)
import System.Directory ( getDirectoryContents
, makeRelativeToCurrentDirectory)
import Stack.Config ( getSnapshots
, makeConcreteResolver)
initProject
:: ( MonadBaseControl IO m, MonadIO m, MonadLogger m, MonadMask m
, MonadReader env m, HasConfig env , HasGHCVariant env
, HasHttpManager env , HasLogLevel env , HasReExec env
, HasTerminal env)
=> Path Abs Dir
-> InitOpts
-> m ()
initProject currDir initOpts = do
let dest = currDir </> stackDotYaml
dest' = toFilePath dest
reldest <- liftIO $ makeRelativeToCurrentDirectory dest'
exists <- fileExists dest
when (not (forceOverwrite initOpts) && exists) $ do
error ("Stack configuration file " <> reldest <>
" exists, use 'stack solver' to fix the existing config file or \
\'--force' to overwrite it.")
let noPkgMsg = "In order to init, you should have an existing .cabal \
\file. Please try \"stack new\" instead."
dupPkgFooter = "You have the following options:\n"
<> "- Use '--ignore-subdirs' command line switch to ignore "
<> "packages in subdirectories. You can init subdirectories as "
<> "independent projects.\n"
<> "- Put selected packages in the stack config file "
<> "and then use 'stack solver' command to automatically resolve "
<> "dependencies and update the config file."
cabalfps <- findCabalFiles (includeSubDirs initOpts) currDir
gpds <- cabalPackagesCheck cabalfps noPkgMsg dupPkgFooter
(r, flags, extraDeps) <-
getDefaultResolver dest (map parent cabalfps) gpds initOpts
let p = Project
{ projectPackages = pkgs
, projectExtraDeps = extraDeps
, projectFlags = removeSrcPkgDefaultFlags gpds flags
, projectResolver = r
, projectCompiler = Nothing
, projectExtraPackageDBs = []
}
pkgs = map toPkg cabalfps
toPkg fp = PackageEntry
{ peValidWanted = Nothing
, peExtraDepMaybe = Nothing
, peLocation = PLFilePath $
case stripDir currDir $ parent fp of
Nothing
| currDir == parent fp -> "."
| otherwise -> assert False $ toFilePath $ parent fp
Just rel -> toFilePath rel
, peSubdirs = []
}
$logInfo $ "Initialising configuration using resolver: " <> resolverName r
$logInfo $
(if exists then "Overwriting existing configuration file: "
else "Writing configuration to file: ")
<> T.pack reldest
liftIO $ L.writeFile dest' $ B.toLazyByteString $ renderStackYaml p
$logInfo "All done."
renderStackYaml :: Project -> B.Builder
renderStackYaml p =
case Yaml.toJSON p of
Yaml.Object o -> renderObject o
_ -> assert False $ B.byteString $ Yaml.encode p
where
renderObject o =
B.byteString "# For more information, see: http://docs.haskellstack.org/en/stable/yaml_configuration.html\n\n" <>
F.foldMap (goComment o) comments <>
goOthers (o `HM.difference` HM.fromList comments) <>
B.byteString
"# Control whether we use the GHC we find on the path\n\
\# system-ghc: true\n\n\
\# Require a specific version of stack, using version ranges\n\
\# require-stack-version: -any # Default\n\
\# require-stack-version: >= 1.0.0\n\n\
\# Override the architecture used by stack, especially useful on Windows\n\
\# arch: i386\n\
\# arch: x86_64\n\n\
\# Extra directories used by stack for building\n\
\# extra-include-dirs: [/path/to/dir]\n\
\# extra-lib-dirs: [/path/to/dir]\n\n\
\# Allow a newer minor version of GHC than the snapshot specifies\n\
\# compiler-check: newer-minor\n"
comments =
[ ("resolver", "Specifies the GHC version and set of packages available (e.g., lts-3.5, nightly-2015-09-21, ghc-7.10.2)")
, ("packages", "Local packages, usually specified by relative directory name")
, ("extra-deps", "Packages to be pulled from upstream that are not in the resolver (e.g., acme-missiles-0.3)")
, ("flags", "Override default flag values for local packages and extra-deps")
, ("extra-package-dbs", "Extra package databases containing global packages")
]
goComment o (name, comment) =
case HM.lookup name o of
Nothing -> assert False mempty
Just v ->
B.byteString "# " <>
B.byteString comment <>
B.byteString "\n" <>
B.byteString (Yaml.encode $ Yaml.object [(name, v)]) <>
B.byteString "\n"
goOthers o
| HM.null o = mempty
| otherwise = assert False $ B.byteString $ Yaml.encode o
getSnapshots' :: (MonadIO m, MonadMask m, MonadReader env m, HasConfig env, HasHttpManager env, MonadLogger m, MonadBaseControl IO m)
=> m (Maybe Snapshots)
getSnapshots' =
liftM Just getSnapshots `catchAny` \e -> do
$logError $
"Unable to download snapshot list, and therefore could " <>
"not generate a stack.yaml file automatically"
$logError $
"This sometimes happens due to missing Certificate Authorities " <>
"on your system. For more information, see:"
$logError ""
$logError " https://github.com/commercialhaskell/stack/issues/234"
$logError ""
$logError "You can try again, or create your stack.yaml file by hand. See:"
$logError ""
$logError " http://docs.haskellstack.org/en/stable/yaml_configuration.html"
$logError ""
$logError $ "Exception was: " <> T.pack (show e)
return Nothing
getDefaultResolver
:: ( MonadBaseControl IO m, MonadIO m, MonadLogger m, MonadMask m
, MonadReader env m, HasConfig env , HasGHCVariant env
, HasHttpManager env , HasLogLevel env , HasReExec env
, HasTerminal env)
=> Path Abs File
-> [Path Abs Dir]
-> [C.GenericPackageDescription]
-> InitOpts
-> m ( Resolver
, Map PackageName (Map FlagName Bool)
, Map PackageName Version)
getDefaultResolver stackYaml cabalDirs gpds initOpts = do
resolver <- getResolver (ioMethod initOpts)
result <- checkResolverSpec gpds Nothing resolver
case result of
BuildPlanCheckOk f-> return (resolver, f, Map.empty)
BuildPlanCheckPartial f e
| needSolver resolver initOpts -> solve (resolver, f)
| otherwise ->
throwM $ ResolverPartial resolver (showDepErrors f e)
BuildPlanCheckFail f e c ->
throwM $ ResolverMismatch resolver (showCompilerErrors f e c)
where
solve (res, f) = do
let srcConstraints = mergeConstraints (gpdPackages gpds) f
mresolver <- solveResolverSpec stackYaml cabalDirs
(res, srcConstraints, Map.empty)
case mresolver of
Just (src, ext) -> do
return (res, fmap snd (Map.union src ext), fmap fst ext)
Nothing
| forceOverwrite initOpts -> do
$logWarn "\nSolver could not arrive at a workable build \
\plan.\nProceeding to create a config with an \
\incomplete plan anyway..."
return (res, f, Map.empty)
| otherwise -> throwM (SolverGiveUp giveUpMsg)
giveUpMsg = concat
[ " - Use '--ignore-subdirs' to skip packages in subdirectories.\n"
, " - Update external packages with 'stack update' and try again.\n"
, " - Use '--force' to create an initial "
, toFilePath stackDotYaml <> ", tweak it and run 'stack solver':\n"
, " - Remove any unnecessary packages.\n"
, " - Add any missing remote packages.\n"
, " - Add extra dependencies to guide solver.\n"
]
getResolver (MethodSnapshot snapPref) = selectSnapResolver snapPref
getResolver (MethodResolver aresolver) = makeConcreteResolver aresolver
selectSnapResolver snapPref = do
msnaps <- getSnapshots'
snaps <- maybe (error "No snapshots to select from.")
(getRecommendedSnapshots snapPref)
msnaps
selectBestSnapshot gpds snaps
>>= maybe (throwM (NoMatchingSnapshot snaps))
(return . ResolverSnapshot)
needSolver _ (InitOpts {useSolver = True}) = True
needSolver (ResolverCompiler _) _ = True
needSolver _ _ = False
getRecommendedSnapshots :: (MonadIO m, MonadMask m, MonadReader env m, HasConfig env, HasHttpManager env, HasGHCVariant env, MonadLogger m, MonadBaseControl IO m)
=> SnapPref
-> Snapshots
-> m [SnapName]
getRecommendedSnapshots pref snapshots = do
existing <-
liftM (sortBy (flip compare) . mapMaybe (parseSnapName . T.pack)) $
snapshotsDir >>=
liftIO . handleIO (const $ return [])
. getDirectoryContents . toFilePath
let isLTS LTS{} = True
isLTS Nightly{} = False
isNightly Nightly{} = True
isNightly LTS{} = False
names = nubOrd $ concat
[ take 2 $ filter isLTS existing
, take 2 $ filter isNightly existing
, map (uncurry LTS)
(take 2 $ reverse $ IntMap.toList $ snapshotsLts snapshots)
, [Nightly $ snapshotsNightly snapshots]
]
namesLTS = filter isLTS names
namesNightly = filter isNightly names
case pref of
PrefNone -> return names
PrefLTS -> return $ namesLTS ++ namesNightly
PrefNightly -> return $ namesNightly ++ namesLTS
data InitOpts = InitOpts
{ ioMethod :: !Method
, useSolver :: Bool
, forceOverwrite :: Bool
, includeSubDirs :: Bool
}
data SnapPref = PrefNone | PrefLTS | PrefNightly
data Method = MethodSnapshot SnapPref | MethodResolver AbstractResolver