{-# LANGUAGE FlexibleContexts #-}

{-# LANGUAGE MultiParamTypeClasses #-}

{-# LANGUAGE OverloadedStrings #-}

{-# LANGUAGE TemplateHaskell #-}

module Stack.Solver

( checkResolverSpec

, cabalPackagesCheck

, findCabalFiles

, mergeConstraints

, solveExtraDeps

, solveResolverSpec

) where

import Control.Applicative

import Control.Exception (assert)

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.List ((\\), isSuffixOf, intercalate)

import Data.List.Extra (groupSortOn)

import Data.Map (Map)

import qualified Data.Map as Map

import Data.Monoid

import Data.Set (Set)

import qualified Data.Set as Set

import Data.Text (Text)

import qualified Data.Text as T

import Data.Text.Encoding (decodeUtf8, encodeUtf8)

import Data.Text.Encoding.Error (lenientDecode)

import qualified Data.Text.Lazy as LT

import Data.Text.Lazy.Encoding (decodeUtf8With)

import qualified Data.Yaml as Yaml

import qualified Distribution.PackageDescription as C

import Network.HTTP.Client.Conduit (HasHttpManager)

import Path

import Path.Find (findFiles)

import Path.IO (getWorkingDir, parseRelAsAbsDir)

import Prelude

import Stack.BuildPlan

import Stack.Constants (stackDotYaml)

import Stack.Package (printCabalFileWarning

, readPackageUnresolved)

import Stack.Setup

import Stack.Setup.Installed

import Stack.Types

import Stack.Types.Internal ( HasTerminal

, HasReExec

, HasLogLevel)

import System.Directory (copyFile,

createDirectoryIfMissing,

getTemporaryDirectory,

makeRelativeToCurrentDirectory)

import qualified System.FilePath as FP

import System.IO.Temp (withSystemTempDirectory)

import System.Process.Read

data ConstraintType = Constraint | Preference deriving (Eq)

type ConstraintSpec = Map PackageName (Version, Map FlagName Bool)

cabalSolver :: (MonadIO m, MonadLogger m, MonadMask m, MonadBaseControl IO m, MonadReader env m, HasConfig env)

=> EnvOverride

-> [Path Abs Dir] -- ^ cabal files

-> ConstraintType

-> ConstraintSpec -- ^ src constraints

-> ConstraintSpec -- ^ dep constraints

-> [String] -- ^ additional arguments

-> m (Maybe ConstraintSpec)

cabalSolver menv cabalfps constraintType

srcConstraints depConstraints cabalArgs =

withSystemTempDirectory "cabal-solver" $ \dir -> do

let versionConstraints = fmap fst depConstraints

configLines <- getCabalConfig dir constraintType versionConstraints

let configFile = dir FP.</> "cabal.config"

liftIO $ S.writeFile configFile $ encodeUtf8 $ T.unlines configLines

-- 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"

: "--dry-run"

: "--only-dependencies"

: "--reorder-goals"

: "--max-backjumps=-1"

: "--package-db=clear"

: "--package-db=global"

: cabalArgs ++

toConstraintArgs (flagConstraints constraintType) ++

fmap toFilePath cabalfps

catch (liftM Just (readProcessStdout (Just tmpdir) menv "cabal" args))

(\ex -> case ex of

ReadProcessException _ _ _ err -> do

let errMsg = decodeUtf8With lenientDecode err

if LT.isInfixOf "Could not resolve dependencies" errMsg

then do

$logInfo "Attempt failed."

$logInfo "\n>>>> Cabal errors begin"

$logInfo $ LT.toStrict errMsg

<> "<<<< Cabal errors end\n"

return Nothing

else throwM ex

_ -> throwM ex)

>>= maybe (return Nothing) parseCabalOutput

where

parseCabalOutput bs = do

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 $ Just (Map.fromList pairs)

else error $ "Could not parse cabal-install output: " ++ show errs

parseLine t0 = maybe (Left t0) Right $ do

-- Sample output to parse:

-- text-1.2.1.1 (latest: 1.2.2.0) -integer-simple (via: parsec-3.1.9) (new package))

-- An ugly parser to extract module id and flags

let t1 = T.concat $

[ T.takeWhile (/= '(')

, (T.takeWhile (/= '('))

. (T.drop 1)

. (T.dropWhile (/= ')'))

] <*> [t0]

ident':flags' <- Just $ T.words t1

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]

-- Note the order of the Map union is important

-- We override a package in snapshot by a src package

flagConstraints Constraint = fmap snd (Map.union srcConstraints

depConstraints)

-- Even when using preferences we want to

-- keep the src package flags unchanged

-- TODO - this should be done only for manual flags.

flagConstraints Preference = fmap snd srcConstraints

getCabalConfig :: (MonadLogger m, MonadReader env m, HasConfig env, MonadIO m, MonadThrow m)

=> FilePath -- ^ temp dir

-> ConstraintType

-> Map PackageName Version -- ^ constraints

-> m [Text]

getCabalConfig dir constraintType 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) =

assert (not . null . versionString $ version) $

T.concat

[ (if constraintType == Constraint

then "constraint: "

else "preference: ")

, T.pack $ packageNameString name

, "=="

, T.pack $ versionString version

]

setupCompiler

:: ( MonadBaseControl IO m, MonadIO m, MonadLogger m, MonadMask m

, MonadReader env m, HasConfig env , HasGHCVariant env

, HasHttpManager env , HasLogLevel env , HasReExec env

, HasTerminal env)

=> CompilerVersion

-> m (Maybe ExtraDirs)

setupCompiler compiler = do

let msg = Just $ T.concat

[ "Compiler version (" <> compilerVersionText compiler <> ") "

, "required by your resolver specification cannot be found.\n\n"

, "Please use '--install-ghc' command line switch to automatically "

, "install the compiler or '--system-ghc' to use a suitable "

, "compiler available on your PATH." ]

config <- asks getConfig

mpaths <- ensureCompiler SetupOpts

{ soptsInstallIfMissing = configInstallGHC config

, soptsUseSystem = configSystemGHC config

, soptsWantedCompiler = compiler

, soptsCompilerCheck = configCompilerCheck config

, soptsStackYaml = Nothing

, soptsForceReinstall = False

, soptsSanityCheck = False

, soptsSkipGhcCheck = False

, soptsSkipMsys = configSkipMsys config

, soptsUpgradeCabal = False

, soptsResolveMissingGHC = msg

, soptsStackSetupYaml = defaultStackSetupYaml

, soptsGHCBindistURL = Nothing

}

return mpaths

setupCabalEnv

:: ( MonadBaseControl IO m, MonadIO m, MonadLogger m, MonadMask m

, MonadReader env m, HasConfig env , HasGHCVariant env

, HasHttpManager env , HasLogLevel env , HasReExec env

, HasTerminal env)

=> CompilerVersion

-> m EnvOverride

setupCabalEnv compiler = do

mpaths <- setupCompiler compiler

menv0 <- getMinimalEnvOverride

envMap <- removeHaskellEnvVars

<$> augmentPathMap (maybe [] edBins mpaths)

(unEnvOverride menv0)

platform <- asks getPlatform

menv <- mkEnvOverride platform envMap

mcabal <- findExecutable menv "cabal"

case mcabal of

Nothing -> throwM SolverMissingCabalInstall

Just _ -> return ()

mver <- getSystemCompiler menv (whichCompiler compiler)

case mver of

Just (version, _) ->

$logInfo $ "Using compiler: " <> compilerVersionText version

Nothing -> error "Failed to determine compiler version. \

\This is most likely a bug."

return menv

mergeConstraints

:: Map PackageName v

-> Map PackageName (Map p f)

-> Map PackageName (v, Map p f)

mergeConstraints = Map.mergeWithKey

-- combine entry in both maps

(\_ v f -> Just (v, f))

-- convert entry in first map only

(fmap (flip (,) Map.empty))

-- convert entry in second map only

(\m -> if Map.null m then Map.empty

else error "Bug: An entry in flag map must have a corresponding \

\entry in the version map")

diffConstraints

:: (Eq v, Eq f)

=> (v, f) -> (v, f) -> Maybe (v, f)

diffConstraints (v, f) (v', f')

| (v == v') && (f == f') = Nothing

| otherwise = Just (v, f)

solveResolverSpec

:: ( 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 file location

-> [Path Abs Dir] -- ^ package dirs containing cabal files

-> ( Resolver

, ConstraintSpec

, ConstraintSpec) -- ^ ( resolver

-- , src package constraints

-- , extra dependency constraints )

-> m (Maybe ( ConstraintSpec

, ConstraintSpec)) -- ^ ( resulting src package specs

-- , resulting external package specs )

solveResolverSpec stackYaml cabalDirs

(resolver, srcConstraints, extraConstraints) = do

$logInfo $ "Using resolver: " <> resolverName resolver

(compilerVer, snapConstraints) <- getResolverConstraints resolver

menv <- setupCabalEnv compilerVer

let -- Note - The order in Map.union below is important.

-- We want to override snapshot with extra deps

depConstraints = Map.union extraConstraints snapConstraints

-- Make sure deps do not include any src packages

-- There are two reasons for this:

-- 1. We do not want snapshot versions to override the sources

-- 2. Sources may not have versions leading to bad cabal constraints

depOnlyConstraints = Map.difference depConstraints srcConstraints

solver t = cabalSolver menv cabalDirs t

srcConstraints depOnlyConstraints $

["-v"] -- TODO make it conditional on debug

++ ["--ghcjs" | (whichCompiler compilerVer) == Ghcjs]

let srcNames = (T.intercalate " and ") $

["packages from " <> resolverName resolver

| not (Map.null snapConstraints)] ++

[T.pack ((show $ Map.size extraConstraints) <> " external packages")

| not (Map.null extraConstraints)]

$logInfo "Asking cabal to calculate a build plan..."

unless (Map.null depOnlyConstraints)

($logInfo $ "Trying with " <> srcNames <> " as hard constraints...")

mdeps <- solver Constraint

mdeps' <- case mdeps of

Nothing | not (Map.null depOnlyConstraints) -> do

$logInfo $ "Retrying with " <> srcNames <> " as preferences..."

solver Preference

_ -> return mdeps

case mdeps' of

Just deps -> do

let

-- All src package constraints returned by cabal.

-- Flags may have changed.

srcs = Map.intersection deps srcConstraints

inSnap = Map.intersection deps snapConstraints

-- All packages which are in the snapshot but cabal solver

-- returned versions or flags different from the snapshot.

inSnapChanged = Map.differenceWith diffConstraints

inSnap snapConstraints

-- Packages neither in snapshot, nor srcs

extra = Map.difference deps (Map.union srcConstraints

snapConstraints)

external = Map.union inSnapChanged extra

$logInfo $ "Successfully determined a build plan with "

<> T.pack (show $ Map.size external)

<> " external dependencies."

return $ Just (srcs, external)

Nothing -> do

$logInfo $ "Failed to arrive at a workable build plan using "

<> resolverName resolver <> " resolver."

return Nothing

where

mpiConstraints mpi = (mpiVersion mpi, mpiFlags mpi)

mbpConstraints mbp = fmap mpiConstraints (mbpPackages mbp)

getResolverConstraints (ResolverSnapshot snapName) = do

mbp <- loadMiniBuildPlan snapName

return (mbpCompilerVersion mbp, mbpConstraints mbp)

getResolverConstraints (ResolverCompiler compiler) =

return (compiler, Map.empty)

-- FIXME instead of passing the stackYaml dir we should maintain

-- the file URL in the custom resolver always relative to stackYaml.

getResolverConstraints (ResolverCustom _ url) = do

mbp <- parseCustomMiniBuildPlan stackYaml url

return (mbpCompilerVersion mbp, mbpConstraints mbp)

-- | Given a bundle of packages and a resolver, check the resolver with respect

-- to the packages and return how well the resolver satisfies the depndencies

-- of the packages. If 'flags' is passed as 'Nothing' then flags are chosen

-- automatically.

checkResolverSpec

:: ( MonadIO m, MonadCatch m, MonadLogger m, MonadReader env m

, HasHttpManager env, HasConfig env, HasGHCVariant env

, MonadBaseControl IO m)

=> [C.GenericPackageDescription]

-> Maybe (Map PackageName (Map FlagName Bool))

-> Resolver

-> m BuildPlanCheck

checkResolverSpec gpds flags resolver = do

case resolver of

ResolverSnapshot name -> checkSnapBuildPlan gpds flags name

ResolverCompiler _ -> return $ BuildPlanCheckPartial Map.empty Map.empty

-- TODO support custom resolver for stack init

ResolverCustom _ _ -> return $ BuildPlanCheckPartial Map.empty Map.empty

findCabalFiles :: MonadIO m => Bool -> Path Abs Dir -> m [Path Abs File]

findCabalFiles recurse dir =

liftIO $ findFiles dir isCabal (\subdir -> recurse && not (isIgnored subdir))

where

isCabal path = ".cabal" `isSuffixOf` toFilePath path

isIgnored path = FP.dropTrailingPathSeparator (toFilePath (dirname path))

`Set.member` ignoredDirs

-- | Special directories that we don't want to traverse for .cabal files

ignoredDirs :: Set FilePath

ignoredDirs = Set.fromList

[ ".git"

, "dist"

, ".stack-work"

]

-- | Do some basic checks on a list of cabal file paths to be used for creating

-- stack config, print some informative and error messages and if all is ok

-- return @GenericPackageDescription@ list.

cabalPackagesCheck

:: ( 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]

-> String

-> String

-> m [C.GenericPackageDescription]

cabalPackagesCheck cabalfps noPkgMsg dupPkgFooter = do

when (null cabalfps) $

error noPkgMsg

relpaths <- mapM makeRel cabalfps

$logInfo $ "Using cabal packages:"

$logInfo $ T.pack (formatGroup relpaths)

when (dupGroups relpaths /= []) $

error $ "Duplicate cabal package names cannot be used in a single "

<> "stack project. Following duplicates were found:\n"

<> intercalate "\n" (dupGroups relpaths)

<> "\n"

<> dupPkgFooter

(warnings,gpds) <- fmap unzip (mapM readPackageUnresolved cabalfps)

zipWithM_ (mapM_ . printCabalFileWarning) cabalfps warnings

return gpds

where

groups = filter ((> 1) . length) . groupSortOn (FP.takeFileName)

dupGroups = (map formatGroup) . groups

makeRel :: (MonadIO m) => Path Abs File -> m FilePath

makeRel = liftIO . makeRelativeToCurrentDirectory . toFilePath

formatGroup :: [String] -> String

formatGroup = concat . (map formatPath)

where formatPath path = "- " <> path <> "\n"

reportMissingCabalFiles

:: (MonadIO m, MonadLogger m) => [Path Abs File] -> Bool -> m ()

reportMissingCabalFiles cabalfps includeSubdirs = do

allCabalfps <- findCabalFiles (includeSubdirs) =<< getWorkingDir

relpaths <- mapM makeRel (allCabalfps \\ cabalfps)

when (not (null relpaths)) $ do

$logWarn $ "The following packages are missing from the config:"

$logWarn $ T.pack (formatGroup relpaths)

-- | Solver can be thought of as a counterpart of init. init creates a

-- stack.yaml whereas solver verifies or fixes an existing one. It can verify

-- the dependencies of the packages and determine if any extra-dependecies

-- outside the snapshots are needed.

--

-- TODO Currently solver uses a stack.yaml in the parent chain when there is

-- no stack.yaml in the current directory. It should instead look for a

-- stack yaml only in the current directory and suggest init if there is

-- none available. That will make the behavior consistent with init and provide

-- a correct meaning to a --ignore-subdirs option if implemented.

solveExtraDeps

:: ( MonadBaseControl IO m, MonadIO m, MonadLogger m, MonadMask m

, MonadReader env m, HasConfig env , HasEnvConfig env, HasGHCVariant env

, HasHttpManager env , HasLogLevel env , HasReExec env

, HasTerminal env)

=> Bool -- ^ modify stack.yaml?

-> m ()

solveExtraDeps modStackYaml = do

econfig <- asks getEnvConfig

bconfig <- asks getBuildConfig

let stackYaml = bcStackYaml bconfig

relStackYaml <- makeRel stackYaml

$logInfo $ "Using configuration file: " <> T.pack relStackYaml

let cabalDirs = Map.keys $ envConfigPackages econfig

noPkgMsg = "No cabal packages found in " <> relStackYaml <>

". Please add at least one directory containing a .cabal \

\file. You can also use 'stack init' to automatically \

\generate the config file."

dupPkgFooter = "Please remove the directories containing duplicate \

\entries from '" <> relStackYaml <> "'."

cabalfps <- liftM concat (mapM (findCabalFiles False) cabalDirs)

gpds <- cabalPackagesCheck cabalfps noPkgMsg dupPkgFooter

-- TODO when solver supports --ignore-subdirs option pass that as the

-- second argument here.

reportMissingCabalFiles cabalfps True

let oldFlags = bcFlags bconfig

oldExtraVersions = bcExtraDeps bconfig

resolver = bcResolver bconfig

oldSrcs = gpdPackages gpds

oldSrcFlags = Map.intersection oldFlags oldSrcs

oldExtraFlags = Map.intersection oldFlags oldExtraVersions

srcConstraints = mergeConstraints oldSrcs oldSrcFlags

extraConstraints = mergeConstraints oldExtraVersions oldExtraFlags

resolverResult <- checkResolverSpec gpds (Just oldSrcFlags) resolver

resultSpecs <- case resolverResult of

BuildPlanCheckOk flags ->

return $ Just ((mergeConstraints oldSrcs flags), Map.empty)

BuildPlanCheckPartial _ _ ->

solveResolverSpec stackYaml cabalDirs

(resolver, srcConstraints, extraConstraints)

BuildPlanCheckFail f e c ->

throwM $ ResolverMismatch resolver (showCompilerErrors f e c)

(srcs, edeps) <- case resultSpecs of

Nothing -> throwM (SolverGiveUp giveUpMsg)

Just x -> return x

let

flags = removeSrcPkgDefaultFlags gpds (fmap snd (Map.union srcs edeps))

versions = fmap fst edeps

vDiff v v' = if v == v' then Nothing else Just v

versionsDiff = Map.differenceWith vDiff

newVersions = versionsDiff versions oldExtraVersions

goneVersions = versionsDiff oldExtraVersions versions

fDiff f f' = if f == f' then Nothing else Just f

flagsDiff = Map.differenceWith fDiff

newFlags = flagsDiff flags oldFlags

goneFlags = flagsDiff oldFlags flags

changed = any (not . Map.null) [newVersions, goneVersions]

|| any (not . Map.null) [newFlags, goneFlags]

if changed then do

$logInfo ""

$logInfo $ "The following changes will be made to "

<> T.pack relStackYaml <> ":"

-- TODO print whether resolver changed from previous

$logInfo $ "* Resolver is " <> resolverName resolver

-- TODO indent the yaml output

printFlags newFlags "* Flags to be added"

printDeps newVersions "* Dependencies to be added"

printFlags goneFlags "* Flags to be deleted"

printDeps goneVersions "* Dependencies to be deleted"

-- TODO backup the old config file

if modStackYaml then do

writeStackYaml stackYaml resolver versions flags

$logInfo $ "Updated " <> T.pack relStackYaml

else do

$logInfo $ "To automatically update " <> T.pack relStackYaml

<> ", rerun with '--update-config'"

else

$logInfo $ "No changes needed to " <> T.pack relStackYaml

where

indent t = T.unlines $ fmap (" " <>) (T.lines t)

printFlags fl msg = do

when ((not . Map.null) fl) $ do

$logInfo $ T.pack msg

$logInfo $ indent $ decodeUtf8 $ Yaml.encode

$ object ["flags" .= fl]

printDeps deps msg = do

when ((not . Map.null) deps) $ do

$logInfo $ T.pack msg

$logInfo $ indent $ decodeUtf8 $ Yaml.encode $ object $

[("extra-deps" .= map fromTuple (Map.toList deps))]

writeStackYaml path res deps fl = do

let fp = toFilePath path

obj <- liftIO (Yaml.decodeFileEither fp) >>= either throwM return

(ProjectAndConfigMonoid _ _, warnings) <-

liftIO (Yaml.decodeFileEither fp) >>= either throwM return

logJSONWarnings fp warnings

let obj' =

HashMap.insert "extra-deps"

(toJSON $ map fromTuple $ Map.toList deps)

$ HashMap.insert ("flags" :: Text) (toJSON fl)

$ HashMap.insert ("resolver" :: Text) (toJSON (resolverName res)) obj

liftIO $ Yaml.encodeFile fp obj'

giveUpMsg = concat

[ " - Update external packages with 'stack update' and try again.\n"

, " - Tweak " <> toFilePath stackDotYaml <> " and try again\n"

, " - Remove any unnecessary packages.\n"

, " - Add any missing remote packages.\n"

, " - Add extra dependencies to guide solver.\n"

]