{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} 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) -- | Generate stack.yaml 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." -- | Render a stack.yaml file with comments, see: -- https://github.com/commercialhaskell/stack/issues/226 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 -- | Get the default resolver value 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 -- ^ stack.yaml -> [Path Abs Dir] -- ^ cabal dirs -> [C.GenericPackageDescription] -- ^ cabal descriptions -> 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" ] -- TODO support selecting best across regular and custom snapshots 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 -- Get the most recent LTS and Nightly in the snapshots directory and -- prefer them over anything else, since odds are high that something -- already exists for them. 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 -- ^ Use solver , useSolver :: Bool -- ^ Preferred snapshots , forceOverwrite :: Bool -- ^ Overwrite existing files , includeSubDirs :: Bool -- ^ If True, include all .cabal files found in any sub directories } data SnapPref = PrefNone | PrefLTS | PrefNightly -- | Method of initializing data Method = MethodSnapshot SnapPref | MethodResolver AbstractResolver