{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} module Stack.Solver ( cabalSolver , solveExtraDeps ) where import Control.Applicative import Control.Exception.Enclosed (tryIO) import Control.Monad.Catch import Control.Monad.IO.Class import Control.Monad.Logger import Control.Monad.Reader import Control.Monad.Trans.Control import Data.Aeson.Extended (object, (.=), toJSON, logJSONWarnings) import qualified Data.ByteString as S import Data.Either import qualified Data.HashMap.Strict as HashMap import Data.Map (Map) import qualified Data.Map as Map import Data.Monoid import Data.Text (Text) import qualified Data.Text as T import Data.Text.Encoding (decodeUtf8, encodeUtf8) import qualified Data.Yaml as Yaml import Network.HTTP.Client.Conduit (HasHttpManager) import Path import Path.IO (parseRelAsAbsDir) import Prelude import Stack.BuildPlan import Stack.Setup.Installed import Stack.Types import System.Directory (copyFile, createDirectoryIfMissing, getTemporaryDirectory) import qualified System.FilePath as FP import System.IO.Temp (withSystemTempDirectory) import System.Process.Read cabalSolver :: (MonadIO m, MonadLogger m, MonadMask m, MonadBaseControl IO m, MonadReader env m, HasConfig env) => WhichCompiler -> [Path Abs Dir] -- ^ cabal files -> Map PackageName Version -- ^ constraints -> Map PackageName (Map FlagName Bool) -- ^ user-specified flags -> [String] -- ^ additional arguments -> m (CompilerVersion, Map PackageName (Version, Map FlagName Bool)) cabalSolver wc cabalfps constraints userFlags cabalArgs = withSystemTempDirectory "cabal-solver" $ \dir -> do when (null cabalfps) $ throwM SolverNoCabalFiles configLines <- getCabalConfig dir constraints let configFile = dir FP. "cabal.config" liftIO $ S.writeFile configFile $ encodeUtf8 $ T.unlines configLines menv0 <- getMinimalEnvOverride mghc <- findExecutable menv0 "ghc" platform <- asks getPlatform menv <- case mghc of Just _ -> return menv0 Nothing -> do localPrograms <- asks $ configLocalPrograms . getConfig tools <- listInstalled localPrograms let ghcName = $(mkPackageName "ghc") case [version | Tool (PackageIdentifier name version) <- tools, name == ghcName] of [] -> throwM SolverMissingGHC versions -> do let version = maximum versions $logInfo $ "No GHC on path, selecting: " <> T.pack (versionString version) ed <- extraDirs $ Tool $ PackageIdentifier ghcName version pathsEnv <- augmentPathMap (edBins ed) (unEnvOverride menv0) mkEnvOverride platform pathsEnv mcabal <- findExecutable menv "cabal" case mcabal of Nothing -> throwM SolverMissingCabalInstall Just _ -> return () compilerVersion <- getCompilerVersion menv wc -- Run from a temporary directory to avoid cabal getting confused by any -- sandbox files, see: -- https://github.com/commercialhaskell/stack/issues/356 -- -- In theory we could use --ignore-sandbox, but not all versions of cabal -- support it. tmpdir <- liftIO getTemporaryDirectory >>= parseRelAsAbsDir let args = ("--config-file=" ++ configFile) : "install" : "--enable-tests" : "--enable-benchmarks" : "-v" : "--dry-run" : "--only-dependencies" : "--reorder-goals" : "--max-backjumps=-1" : "--package-db=clear" : "--package-db=global" : cabalArgs ++ toConstraintArgs userFlags ++ fmap toFilePath cabalfps ++ ["--ghcjs" | wc == Ghcjs] $logInfo "Asking cabal to calculate a build plan, please wait" menv' <- mkEnvOverride platform $ Map.delete "GHCJS_PACKAGE_PATH" $ Map.delete "GHC_PACKAGE_PATH" $ unEnvOverride menv bs <- readProcessStdout (Just tmpdir) menv' "cabal" args let ls = drop 1 $ dropWhile (not . T.isPrefixOf "In order, ") $ T.lines $ decodeUtf8 bs (errs, pairs) = partitionEithers $ map parseLine ls if null errs then return (compilerVersion, Map.fromList pairs) else error $ "Could not parse cabal-install output: " ++ show errs where parseLine t0 = maybe (Left t0) Right $ do -- get rid of (new package) and (latest: ...) bits ident':flags' <- Just $ T.words $ T.takeWhile (/= '(') t0 PackageIdentifier name version <- parsePackageIdentifierFromString $ T.unpack ident' flags <- mapM parseFlag flags' Just (name, (version, Map.fromList flags)) parseFlag t0 = do flag <- parseFlagNameFromString $ T.unpack t1 return (flag, enabled) where (t1, enabled) = case T.stripPrefix "-" t0 of Nothing -> case T.stripPrefix "+" t0 of Nothing -> (t0, True) Just x -> (x, True) Just x -> (x, False) toConstraintArgs userFlagMap = [formatFlagConstraint package flag enabled | (package, fs) <- Map.toList userFlagMap , (flag, enabled) <- Map.toList fs] formatFlagConstraint package flag enabled = let sign = if enabled then '+' else '-' in "--constraint=" ++ unwords [packageNameString package, sign : flagNameString flag] getCabalConfig :: (MonadReader env m, HasConfig env, MonadIO m, MonadThrow m) => FilePath -- ^ temp dir -> Map PackageName Version -- ^ constraints -> m [Text] getCabalConfig dir constraints = do indices <- asks $ configPackageIndices . getConfig remotes <- mapM goIndex indices let cache = T.pack $ "remote-repo-cache: " ++ dir return $ cache : remotes ++ map goConstraint (Map.toList constraints) where goIndex index = do src <- configPackageIndex $ indexName index let dstdir = dir FP. T.unpack (indexNameText $ indexName index) dst = dstdir FP. "00-index.tar" liftIO $ void $ tryIO $ do createDirectoryIfMissing True dstdir copyFile (toFilePath src) dst return $ T.concat [ "remote-repo: " , indexNameText $ indexName index , ":http://0.0.0.0/fake-url" ] goConstraint (name, version) = T.concat [ "constraint: " , T.pack $ packageNameString name , "==" , T.pack $ versionString version ] -- | Determine missing extra-deps solveExtraDeps :: (MonadReader env m, HasEnvConfig env, MonadIO m, MonadMask m, MonadLogger m, MonadBaseControl IO m, HasHttpManager env) => Bool -- ^ modify stack.yaml? -> m () solveExtraDeps modStackYaml = do econfig <- asks getEnvConfig bconfig <- asks getBuildConfig snapshot <- case bcResolver bconfig of ResolverSnapshot snapName -> liftM mbpPackages $ loadMiniBuildPlan snapName ResolverCompiler _ -> return Map.empty ResolverCustom _ url -> liftM mbpPackages $ parseCustomMiniBuildPlan (bcStackYaml bconfig) url let packages = Map.union (bcExtraDeps bconfig) (mpiVersion <$> snapshot) wc <- getWhichCompiler (_compilerVersion, extraDeps) <- cabalSolver wc (Map.keys $ envConfigPackages econfig) packages (bcFlags bconfig) [] let newDeps = extraDeps `Map.difference` packages newFlags = Map.filter (not . Map.null) $ fmap snd newDeps $logInfo "This command is not guaranteed to give you a perfect build plan" if Map.null newDeps then $logInfo "No needed changes found" else do $logInfo "It's possible that even with the changes generated below, you will still need to do some manual tweaking" let o = object $ ("extra-deps" .= map fromTuple (Map.toList $ fmap fst newDeps)) : (if Map.null newFlags then [] else ["flags" .= newFlags]) mapM_ $logInfo $ T.lines $ decodeUtf8 $ Yaml.encode o if modStackYaml then do let fp = toFilePath $ bcStackYaml bconfig obj <- liftIO (Yaml.decodeFileEither fp) >>= either throwM return (ProjectAndConfigMonoid project _, warnings) <- liftIO (Yaml.decodeFileEither fp) >>= either throwM return logJSONWarnings fp warnings let obj' = HashMap.insert "extra-deps" (toJSON $ map fromTuple $ Map.toList $ Map.union (projectExtraDeps project) (fmap fst newDeps)) $ HashMap.insert ("flags" :: Text) (toJSON $ Map.union (projectFlags project) newFlags) obj liftIO $ Yaml.encodeFile fp obj' $logInfo $ T.pack $ "Updated " ++ fp else do $logInfo "" $logInfo "To automatically modify your stack.yaml file, rerun with '--modify-stack-yaml'"