module Stack.BuildPlan
( BuildPlanException (..)
, BuildPlanCheck (..)
, checkSnapBuildPlan
, DepError(..)
, DepErrors
, gpdPackageDeps
, gpdPackages
, gpdPackageName
, MiniBuildPlan(..)
, MiniPackageInfo(..)
, loadMiniBuildPlan
, removeSrcPkgDefaultFlags
, resolveBuildPlan
, selectBestSnapshot
, ToolMap
, getToolMap
, shadowMiniBuildPlan
, showItems
, parseCustomMiniBuildPlan
) where
import Control.Applicative
import Control.Exception (assert)
import Control.Monad (liftM, forM)
import Control.Monad.Catch
import Control.Monad.IO.Class
import Control.Monad.Logger
import Control.Monad.Reader (asks)
import Control.Monad.State.Strict (State, execState, get, modify,
put)
import Control.Monad.Trans.Control (MonadBaseControl)
import qualified Crypto.Hash.SHA256 as SHA256
import Data.Aeson.Extended (FromJSON (..), withObject, (.:), (.:?), (.!=))
import Data.Binary.VersionTagged (taggedDecodeOrLoad)
import Data.ByteString (ByteString)
import qualified Data.ByteString.Base16 as B16
import qualified Data.ByteString as S
import qualified Data.ByteString.Char8 as S8
import Data.Either (partitionEithers)
import qualified Data.Foldable as F
import qualified Data.HashSet as HashSet
import Data.List (intercalate)
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Maybe (fromJust, fromMaybe, mapMaybe)
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 (encodeUtf8)
import qualified Data.Traversable as Tr
import Data.Typeable (Typeable)
import Data.Yaml (decodeEither', decodeFileEither)
import Distribution.PackageDescription (GenericPackageDescription,
flagDefault, flagManual,
flagName, genPackageFlags,
executables, exeName, library, libBuildInfo, buildable)
import Distribution.System (Platform)
import qualified Distribution.Package as C
import qualified Distribution.PackageDescription as C
import qualified Distribution.Version as C
import Distribution.Text (display)
import Network.HTTP.Download
import Network.HTTP.Types (Status(..))
import Network.HTTP.Client (checkStatus)
import Path
import Path.IO
import Prelude
import Stack.Constants
import Stack.Fetch
import Stack.Package
import Stack.Types
import Stack.Types.StackT
import qualified System.Directory as D
import qualified System.FilePath as FP
data BuildPlanException
= UnknownPackages
(Path Abs File)
(Map PackageName (Maybe Version, Set PackageName))
(Map PackageName (Set PackageIdentifier))
| SnapshotNotFound SnapName
deriving (Typeable)
instance Exception BuildPlanException
instance Show BuildPlanException where
show (SnapshotNotFound snapName) = unlines
[ "SnapshotNotFound " ++ snapName'
, "Non existing resolver: " ++ snapName' ++ "."
, "For a complete list of available snapshots see https://www.stackage.org/snapshots"
]
where snapName' = show $ renderSnapName snapName
show (UnknownPackages stackYaml unknown shadowed) =
unlines $ unknown' ++ shadowed'
where
unknown' :: [String]
unknown'
| Map.null unknown = []
| otherwise = concat
[ ["The following packages do not exist in the build plan:"]
, map go (Map.toList unknown)
, case mapMaybe goRecommend $ Map.toList unknown of
[] -> []
rec ->
("Recommended action: modify the extra-deps field of " ++
toFilePath stackYaml ++
" to include the following:")
: (rec
++ ["Note: further dependencies may need to be added"])
, case mapMaybe getNoKnown $ Map.toList unknown of
[] -> []
noKnown ->
[ "There are no known versions of the following packages:"
, intercalate ", " $ map packageNameString noKnown
]
]
where
go (dep, (_, users)) | Set.null users = packageNameString dep
go (dep, (_, users)) = concat
[ packageNameString dep
, " (used by "
, intercalate ", " $ map packageNameString $ Set.toList users
, ")"
]
goRecommend (name, (Just version, _)) =
Just $ "- " ++ packageIdentifierString (PackageIdentifier name version)
goRecommend (_, (Nothing, _)) = Nothing
getNoKnown (name, (Nothing, _)) = Just name
getNoKnown (_, (Just _, _)) = Nothing
shadowed' :: [String]
shadowed'
| Map.null shadowed = []
| otherwise = concat
[ ["The following packages are shadowed by local packages:"]
, map go (Map.toList shadowed)
, ["Recommended action: modify the extra-deps field of " ++
toFilePath stackYaml ++
" to include the following:"]
, extraDeps
, ["Note: further dependencies may need to be added"]
]
where
go (dep, users) | Set.null users = concat
[ packageNameString dep
, " (internal stack error: this should never be null)"
]
go (dep, users) = concat
[ packageNameString dep
, " (used by "
, intercalate ", "
$ map (packageNameString . packageIdentifierName)
$ Set.toList users
, ")"
]
extraDeps = map (\ident -> "- " ++ packageIdentifierString ident)
$ Set.toList
$ Set.unions
$ Map.elems shadowed
resolveBuildPlan :: (MonadThrow m, MonadIO m, MonadReader env m, HasBuildConfig env, MonadLogger m, HasHttpManager env, MonadBaseControl IO m,MonadCatch m)
=> MiniBuildPlan
-> (PackageName -> Bool)
-> Map PackageName (Set PackageName)
-> m ( Map PackageName (Version, Map FlagName Bool)
, Map PackageName (Set PackageName)
)
resolveBuildPlan mbp isShadowed packages
| Map.null (rsUnknown rs) && Map.null (rsShadowed rs) = return (rsToInstall rs, rsUsedBy rs)
| otherwise = do
bconfig <- asks getBuildConfig
let maxVer =
Map.fromListWith max $
map toTuple $
Map.keys (bcPackageCaches bconfig)
unknown = flip Map.mapWithKey (rsUnknown rs) $ \ident x ->
(Map.lookup ident maxVer, x)
throwM $ UnknownPackages
(bcStackYaml bconfig)
unknown
(rsShadowed rs)
where
rs = getDeps mbp isShadowed packages
data ResolveState = ResolveState
{ rsVisited :: Map PackageName (Set PackageName)
, rsUnknown :: Map PackageName (Set PackageName)
, rsShadowed :: Map PackageName (Set PackageIdentifier)
, rsToInstall :: Map PackageName (Version, Map FlagName Bool)
, rsUsedBy :: Map PackageName (Set PackageName)
}
toMiniBuildPlan :: (MonadIO m, MonadLogger m, MonadReader env m, HasHttpManager env, MonadThrow m, HasConfig env, MonadBaseControl IO m, MonadCatch m)
=> CompilerVersion
-> Map PackageName Version
-> Map PackageName (Version, Map FlagName Bool)
-> m MiniBuildPlan
toMiniBuildPlan compilerVersion corePackages packages = do
$logInfo "Caching build plan"
(cores, missingCores) <- addDeps True compilerVersion
$ fmap (, Map.empty) corePackages
(extras, missing) <- addDeps False compilerVersion packages
assert (Set.null missing) $ return MiniBuildPlan
{ mbpCompilerVersion = compilerVersion
, mbpPackages = Map.unions
[ fmap (removeMissingDeps (Map.keysSet cores)) cores
, extras
, Map.fromList $ map goCore $ Set.toList missingCores
]
}
where
goCore (PackageIdentifier name version) = (name, MiniPackageInfo
{ mpiVersion = version
, mpiFlags = Map.empty
, mpiPackageDeps = Set.empty
, mpiToolDeps = Set.empty
, mpiExes = Set.empty
, mpiHasLibrary = True
})
removeMissingDeps cores mpi = mpi
{ mpiPackageDeps = Set.intersection cores (mpiPackageDeps mpi)
}
addDeps :: (MonadIO m, MonadLogger m, MonadReader env m, HasHttpManager env, MonadThrow m, HasConfig env, MonadBaseControl IO m, MonadCatch m)
=> Bool
-> CompilerVersion
-> Map PackageName (Version, Map FlagName Bool)
-> m (Map PackageName MiniPackageInfo, Set PackageIdentifier)
addDeps allowMissing compilerVersion toCalc = do
menv <- getMinimalEnvOverride
platform <- asks $ configPlatform . getConfig
(resolvedMap, missingIdents) <-
if allowMissing
then do
(missingNames, missingIdents, m) <-
resolvePackagesAllowMissing menv (Map.keysSet idents0) Set.empty
assert (Set.null missingNames)
$ return (m, missingIdents)
else do
m <- resolvePackages menv (Map.keysSet idents0) Set.empty
return (m, Set.empty)
let byIndex = Map.fromListWith (++) $ flip map (Map.toList resolvedMap)
$ \(ident, rp) ->
(indexName $ rpIndex rp,
[( ident
, rpCache rp
, maybe Map.empty snd $ Map.lookup (packageIdentifierName ident) toCalc
)])
res <- forM (Map.toList byIndex) $ \(indexName', pkgs) -> withCabalFiles indexName' pkgs
$ \ident flags cabalBS -> do
(_warnings,gpd) <- readPackageUnresolvedBS Nothing cabalBS
let packageConfig = PackageConfig
{ packageConfigEnableTests = False
, packageConfigEnableBenchmarks = False
, packageConfigFlags = flags
, packageConfigCompilerVersion = compilerVersion
, packageConfigPlatform = platform
}
name = packageIdentifierName ident
pd = resolvePackageDescription packageConfig gpd
exes = Set.fromList $ map (ExeName . T.pack . exeName) $ executables pd
notMe = Set.filter (/= name) . Map.keysSet
return (name, MiniPackageInfo
{ mpiVersion = packageIdentifierVersion ident
, mpiFlags = flags
, mpiPackageDeps = notMe $ packageDependencies pd
, mpiToolDeps = Map.keysSet $ packageToolDependencies pd
, mpiExes = exes
, mpiHasLibrary = maybe
False
(buildable . libBuildInfo)
(library pd)
})
return (Map.fromList $ concat res, missingIdents)
where
idents0 = Map.fromList
$ map (\(n, (v, f)) -> (PackageIdentifier n v, Left f))
$ Map.toList toCalc
getDeps :: MiniBuildPlan
-> (PackageName -> Bool)
-> Map PackageName (Set PackageName)
-> ResolveState
getDeps mbp isShadowed packages =
execState (mapM_ (uncurry goName) $ Map.toList packages) ResolveState
{ rsVisited = Map.empty
, rsUnknown = Map.empty
, rsShadowed = Map.empty
, rsToInstall = Map.empty
, rsUsedBy = Map.empty
}
where
toolMap = getToolMap mbp
goName :: PackageName -> Set PackageName -> State ResolveState (Set PackageName)
goName name users = do
rs <- get
put rs
{ rsUsedBy = Map.insertWith Set.union name users $ rsUsedBy rs
}
case Map.lookup name $ mbpPackages mbp of
Nothing -> do
modify $ \rs' -> rs'
{ rsUnknown = Map.insertWith Set.union name users $ rsUnknown rs'
}
return Set.empty
Just mpi -> case Map.lookup name (rsVisited rs) of
Just shadowed -> return shadowed
Nothing -> do
put rs { rsVisited = Map.insert name Set.empty $ rsVisited rs }
let depsForTools = Set.unions $ mapMaybe (flip Map.lookup toolMap) (Set.toList $ mpiToolDeps mpi)
let deps = Set.filter (/= name) (mpiPackageDeps mpi <> depsForTools)
shadowed <- fmap F.fold $ Tr.forM (Set.toList deps) $ \dep ->
if isShadowed dep
then do
modify $ \rs' -> rs'
{ rsShadowed = Map.insertWith
Set.union
dep
(Set.singleton $ PackageIdentifier name (mpiVersion mpi))
(rsShadowed rs')
}
return $ Set.singleton dep
else do
shadowed <- goName dep (Set.singleton name)
let m = Map.fromSet (\_ -> Set.singleton $ PackageIdentifier name (mpiVersion mpi)) shadowed
modify $ \rs' -> rs'
{ rsShadowed = Map.unionWith Set.union m $ rsShadowed rs'
}
return shadowed
modify $ \rs' -> rs'
{ rsToInstall = Map.insert name (mpiVersion mpi, mpiFlags mpi) $ rsToInstall rs'
, rsVisited = Map.insert name shadowed $ rsVisited rs'
}
return shadowed
type ToolMap = Map ByteString (Set PackageName)
getToolMap :: MiniBuildPlan -> Map Text (Set PackageName)
getToolMap mbp =
Map.unionsWith Set.union
$ concatMap goPair (Map.toList ps)
where
ps = mbpPackages mbp
goPair (pname, mpi) =
map (flip Map.singleton (Set.singleton pname) . unExeName)
$ Set.toList
$ mpiExes mpi
loadMiniBuildPlan
:: (MonadIO m, MonadThrow m, MonadLogger m, MonadReader env m, HasHttpManager env, HasConfig env, HasGHCVariant env, MonadBaseControl IO m, MonadCatch m)
=> SnapName
-> m MiniBuildPlan
loadMiniBuildPlan name = do
path <- configMiniBuildPlanCache name
taggedDecodeOrLoad path $ liftM buildPlanFixes $ do
bp <- loadBuildPlan name
toMiniBuildPlan
(siCompilerVersion $ bpSystemInfo bp)
(siCorePackages $ bpSystemInfo bp)
(fmap goPP $ bpPackages bp)
where
goPP pp =
( ppVersion pp
, pcFlagOverrides $ ppConstraints pp
)
buildPlanFixes :: MiniBuildPlan -> MiniBuildPlan
buildPlanFixes mbp = mbp
{ mbpPackages = Map.fromList $ map go $ Map.toList $ mbpPackages mbp
}
where
go (name, mpi) =
(name, mpi
{ mpiFlags = goF (packageNameString name) (mpiFlags mpi)
})
goF "persistent-sqlite" = Map.insert $(mkFlagName "systemlib") False
goF "yaml" = Map.insert $(mkFlagName "system-libyaml") False
goF _ = id
loadBuildPlan :: (MonadIO m, MonadThrow m, MonadLogger m, MonadReader env m, HasHttpManager env, HasStackRoot env)
=> SnapName
-> m BuildPlan
loadBuildPlan name = do
env <- ask
let stackage = getStackRoot env
file' <- parseRelFile $ T.unpack file
let fp = buildPlanDir stackage </> file'
$logDebug $ "Decoding build plan from: " <> T.pack (toFilePath fp)
eres <- liftIO $ decodeFileEither $ toFilePath fp
case eres of
Right bp -> return bp
Left e -> do
$logDebug $ "Decoding build plan from file failed: " <> T.pack (show e)
ensureDir (parent fp)
req <- parseUrl $ T.unpack url
$logSticky $ "Downloading " <> renderSnapName name <> " build plan ..."
$logDebug $ "Downloading build plan from: " <> url
_ <- redownload req { checkStatus = handle404 } fp
$logStickyDone $ "Downloaded " <> renderSnapName name <> " build plan."
liftIO (decodeFileEither $ toFilePath fp) >>= either throwM return
where
file = renderSnapName name <> ".yaml"
reponame =
case name of
LTS _ _ -> "lts-haskell"
Nightly _ -> "stackage-nightly"
url = rawGithubUrl "fpco" reponame "master" file
handle404 (Status 404 _) _ _ = Just $ SomeException $ SnapshotNotFound name
handle404 _ _ _ = Nothing
gpdPackages :: [GenericPackageDescription] -> Map PackageName Version
gpdPackages gpds = Map.fromList $
map (fromCabalIdent . C.package . C.packageDescription) gpds
where
fromCabalIdent (C.PackageIdentifier name version) =
(fromCabalPackageName name, fromCabalVersion version)
gpdPackageName :: GenericPackageDescription -> PackageName
gpdPackageName = fromCabalPackageName
. C.pkgName
. C.package
. C.packageDescription
gpdPackageDeps
:: GenericPackageDescription
-> CompilerVersion
-> Platform
-> Map FlagName Bool
-> Map PackageName VersionRange
gpdPackageDeps gpd cv platform flags =
Map.filterWithKey (const . (/= name)) (packageDependencies pkgDesc)
where
name = gpdPackageName gpd
pkgDesc = resolvePackageDescription pkgConfig gpd
pkgConfig = PackageConfig
{ packageConfigEnableTests = True
, packageConfigEnableBenchmarks = True
, packageConfigFlags = flags
, packageConfigCompilerVersion = cv
, packageConfigPlatform = platform
}
removeSrcPkgDefaultFlags :: [C.GenericPackageDescription]
-> Map PackageName (Map FlagName Bool)
-> Map PackageName (Map FlagName Bool)
removeSrcPkgDefaultFlags gpds flags =
let defaults = Map.unions (map gpdDefaultFlags gpds)
flags' = Map.differenceWith removeSame flags defaults
in Map.filter (not . Map.null) flags'
where
removeSame f1 f2 =
let diff v v' = if v == v' then Nothing else Just v
in Just $ Map.differenceWith diff f1 f2
gpdDefaultFlags gpd =
let tuples = map getDefault (C.genPackageFlags gpd)
in Map.singleton (gpdPackageName gpd) (Map.fromList tuples)
flagName' = fromCabalFlagName . C.flagName
getDefault f
| C.flagDefault f = (flagName' f, True)
| otherwise = (flagName' f, False)
selectPackageBuildPlan
:: Platform
-> CompilerVersion
-> Map PackageName Version
-> GenericPackageDescription
-> (Map PackageName (Map FlagName Bool), DepErrors)
selectPackageBuildPlan platform compiler pool gpd =
fromJust (go flagOptions Nothing)
where
go :: [Map FlagName Bool] -> Maybe (Map PackageName (Map FlagName Bool), DepErrors) -> Maybe (Map PackageName (Map FlagName Bool), DepErrors)
go [] Nothing = assert False Nothing
go [] (Just plan) = Just plan
go _ (Just plan) | Map.null (snd plan) = Just plan
go (flags:rest) Nothing = go rest $ Just (nextPlan flags)
go (flags:rest) (Just plan) =
go rest $ Just (betterPlan plan (nextPlan flags))
nextPlan flags = checkPackageBuildPlan platform compiler pool flags gpd
betterPlan (f1, e1) (f2, e2)
| (Map.size e1) <= (Map.size e2) = (f1, e1)
| otherwise = (f2, e2)
flagName' = fromCabalFlagName . flagName
maxFlagOptions = 128
flagOptions :: [Map FlagName Bool]
flagOptions = take maxFlagOptions $ map Map.fromList $ mapM getOptions $ genPackageFlags gpd
getOptions f
| flagManual f = [(flagName' f, flagDefault f)]
| flagDefault f =
[ (flagName' f, True)
, (flagName' f, False)
]
| otherwise =
[ (flagName' f, False)
, (flagName' f, True)
]
checkPackageBuildPlan
:: Platform
-> CompilerVersion
-> Map PackageName Version
-> Map FlagName Bool
-> GenericPackageDescription
-> (Map PackageName (Map FlagName Bool), DepErrors)
checkPackageBuildPlan platform compiler pool flags gpd =
(Map.singleton pkg flags, errs)
where
pkg = gpdPackageName gpd
errs = checkPackageDeps pkg constraints pool
constraints = gpdPackageDeps gpd compiler platform flags
checkPackageDeps :: PackageName
-> Map PackageName VersionRange
-> Map PackageName Version
-> DepErrors
checkPackageDeps myName deps packages =
Map.unionsWith mappend $ map go $ Map.toList deps
where
go :: (PackageName, VersionRange) -> DepErrors
go (name, range) =
case Map.lookup name packages of
Nothing -> Map.singleton name DepError
{ deVersion = Nothing
, deNeededBy = Map.singleton myName range
}
Just v
| withinRange v range -> Map.empty
| otherwise -> Map.singleton name DepError
{ deVersion = Just v
, deNeededBy = Map.singleton myName range
}
type DepErrors = Map PackageName DepError
data DepError = DepError
{ deVersion :: !(Maybe Version)
, deNeededBy :: !(Map PackageName VersionRange)
} deriving Show
instance Monoid DepError where
mempty = DepError Nothing Map.empty
mappend (DepError a x) (DepError b y) = DepError
(maybe a Just b)
(Map.unionWith C.intersectVersionRanges x y)
checkBundleBuildPlan
:: Platform
-> CompilerVersion
-> Map PackageName Version
-> Maybe (Map PackageName (Map FlagName Bool))
-> [GenericPackageDescription]
-> (Map PackageName (Map FlagName Bool), DepErrors)
checkBundleBuildPlan platform compiler pool flags gpds =
(Map.unionsWith dupError (map fst plans)
, Map.unionsWith mappend (map snd plans))
where
plans = map (pkgPlan flags) gpds
pkgPlan Nothing gpd =
selectPackageBuildPlan platform compiler pool' gpd
pkgPlan (Just f) gpd =
checkPackageBuildPlan platform compiler pool' (flags' f gpd) gpd
flags' f gpd = maybe Map.empty id (Map.lookup (gpdPackageName gpd) f)
pool' = Map.union (gpdPackages gpds) pool
dupError _ _ = error "Bug: Duplicate packages are not expected here"
data BuildPlanCheck =
BuildPlanCheckOk (Map PackageName (Map FlagName Bool))
| BuildPlanCheckPartial (Map PackageName (Map FlagName Bool)) DepErrors
| BuildPlanCheckFail (Map PackageName (Map FlagName Bool)) DepErrors
CompilerVersion
compareBuildPlanCheck :: BuildPlanCheck -> BuildPlanCheck -> Ordering
compareBuildPlanCheck (BuildPlanCheckPartial _ e1) (BuildPlanCheckPartial _ e2) =
compare (Map.size e2) (Map.size e1)
compareBuildPlanCheck (BuildPlanCheckFail _ e1 _) (BuildPlanCheckFail _ e2 _) =
let numUserPkgs e = Map.size $ Map.unions (Map.elems (fmap deNeededBy e))
in compare (numUserPkgs e2) (numUserPkgs e1)
compareBuildPlanCheck BuildPlanCheckOk{} BuildPlanCheckOk{} = EQ
compareBuildPlanCheck BuildPlanCheckOk{} BuildPlanCheckPartial{} = GT
compareBuildPlanCheck BuildPlanCheckOk{} BuildPlanCheckFail{} = GT
compareBuildPlanCheck BuildPlanCheckPartial{} BuildPlanCheckFail{} = GT
compareBuildPlanCheck _ _ = LT
instance Show BuildPlanCheck where
show BuildPlanCheckOk {} = ""
show (BuildPlanCheckPartial f e) = T.unpack $ showDepErrors f e
show (BuildPlanCheckFail f e c) = T.unpack $ showCompilerErrors f e c
checkSnapBuildPlan
:: ( MonadIO m, MonadCatch m, MonadLogger m, MonadReader env m
, HasHttpManager env, HasConfig env, HasGHCVariant env
, MonadBaseControl IO m)
=> [GenericPackageDescription]
-> Maybe (Map PackageName (Map FlagName Bool))
-> SnapName
-> m BuildPlanCheck
checkSnapBuildPlan gpds flags snap = do
platform <- asks (configPlatform . getConfig)
mbp <- loadMiniBuildPlan snap
let
compiler = mbpCompilerVersion mbp
snapPkgs = fmap mpiVersion $ mbpPackages mbp
(f, errs) = checkBundleBuildPlan platform compiler snapPkgs flags gpds
cerrs = compilerErrors compiler errs
if Map.null errs then
return $ BuildPlanCheckOk f
else if Map.null cerrs then do
return $ BuildPlanCheckPartial f errs
else
return $ BuildPlanCheckFail f cerrs compiler
where
compilerErrors compiler errs
| whichCompiler compiler == Ghc = ghcErrors errs
| otherwise = Map.empty
isGhcWiredIn p _ = p `HashSet.member` wiredInPackages
ghcErrors = Map.filterWithKey isGhcWiredIn
selectBestSnapshot
:: ( MonadIO m, MonadCatch m, MonadLogger m, MonadReader env m
, HasHttpManager env, HasConfig env, HasGHCVariant env
, MonadBaseControl IO m)
=> [GenericPackageDescription]
-> [SnapName]
-> m (SnapName, BuildPlanCheck)
selectBestSnapshot gpds snaps = do
$logInfo $ "Selecting the best among "
<> T.pack (show (length snaps))
<> " snapshots...\n"
loop Nothing snaps
where
loop Nothing [] = error "Bug: in best snapshot selection"
loop (Just pair) [] = return pair
loop bestYet (snap:rest) = do
result <- checkSnapBuildPlan gpds Nothing snap
reportResult result snap
let new = (snap, result)
case result of
BuildPlanCheckOk {} -> return new
_ -> case bestYet of
Nothing -> loop (Just new) rest
Just old -> loop (Just (betterSnap old new)) rest
betterSnap (s1, r1) (s2, r2)
| compareBuildPlanCheck r1 r2 /= LT = (s1, r1)
| otherwise = (s2, r2)
reportResult BuildPlanCheckOk {} snap = do
$logInfo $ "* Matches " <> renderSnapName snap
$logInfo ""
reportResult r@BuildPlanCheckPartial {} snap = do
$logWarn $ "* Partially matches " <> renderSnapName snap
$logWarn $ indent $ T.pack $ show r
reportResult r@BuildPlanCheckFail {} snap = do
$logWarn $ "* Rejected " <> renderSnapName snap
$logWarn $ indent $ T.pack $ show r
indent t = T.unlines $ fmap (" " <>) (T.lines t)
showItems :: Show a => [a] -> Text
showItems items = T.concat (map formatItem items)
where
formatItem item = T.concat
[ " - "
, T.pack $ show item
, "\n"
]
showMapPackages :: Map PackageName a -> Text
showMapPackages mp = showItems $ Map.keys mp
showCompilerErrors
:: Map PackageName (Map FlagName Bool)
-> DepErrors
-> CompilerVersion
-> Text
showCompilerErrors flags errs compiler =
T.concat
[ compilerVersionText compiler
, " cannot be used for these packages:\n"
, showMapPackages $ Map.unions (Map.elems (fmap deNeededBy errs))
, showDepErrors flags errs
]
showDepErrors :: Map PackageName (Map FlagName Bool) -> DepErrors -> Text
showDepErrors flags errs =
T.concat
[ T.concat $ map formatError (Map.toList errs)
, if T.null flagVals then ""
else ("Using package flags:\n" <> flagVals)
]
where
formatError (depName, DepError mversion neededBy) = T.concat
[ showDepVersion depName mversion
, T.concat (map showRequirement (Map.toList neededBy))
]
showDepVersion depName mversion = T.concat
[ T.pack $ packageNameString depName
, case mversion of
Nothing -> " not found"
Just version -> T.concat
[ " version "
, T.pack $ versionString version
, " found"
]
, "\n"
]
showRequirement (user, range) = T.concat
[ " - "
, T.pack $ packageNameString user
, " requires "
, T.pack $ display range
, "\n"
]
flagVals = T.concat (map showFlags userPkgs)
userPkgs = Map.keys $ Map.unions (Map.elems (fmap deNeededBy errs))
showFlags pkg = maybe "" (printFlags pkg) (Map.lookup pkg flags)
printFlags pkg fl =
if (not $ Map.null fl) then
T.concat
[ " - "
, T.pack $ packageNameString pkg
, ": "
, T.pack $ intercalate ", "
$ map formatFlags (Map.toList fl)
, "\n"
]
else ""
formatFlags (f, v) = (show f) ++ " = " ++ (show v)
shadowMiniBuildPlan :: MiniBuildPlan
-> Set PackageName
-> (MiniBuildPlan, Map PackageName MiniPackageInfo)
shadowMiniBuildPlan (MiniBuildPlan cv pkgs0) shadowed =
(MiniBuildPlan cv $ Map.fromList met, Map.fromList unmet)
where
pkgs1 = Map.difference pkgs0 $ Map.fromSet (\_ -> ()) shadowed
depsMet = flip execState Map.empty $ mapM_ (check Set.empty) (Map.keys pkgs1)
check visited name
| name `Set.member` visited =
error $ "shadowMiniBuildPlan: cycle detected, your MiniBuildPlan is broken: " ++ show (visited, name)
| otherwise = do
m <- get
case Map.lookup name m of
Just x -> return x
Nothing ->
case Map.lookup name pkgs1 of
Nothing
| name `Set.member` shadowed -> return False
| otherwise -> return True
Just mpi -> do
let visited' = Set.insert name visited
ress <- mapM (check visited') (Set.toList $ mpiPackageDeps mpi)
let res = and ress
modify $ \m' -> Map.insert name res m'
return res
(met, unmet) = partitionEithers $ map toEither $ Map.toList pkgs1
toEither pair@(name, _) =
wrapper pair
where
wrapper =
case Map.lookup name depsMet of
Just True -> Left
Just False -> Right
Nothing -> assert False Right
parseCustomMiniBuildPlan :: (MonadIO m, MonadCatch m, MonadLogger m, MonadReader env m, HasHttpManager env, HasConfig env, MonadBaseControl IO m)
=> Path Abs File
-> T.Text -> m MiniBuildPlan
parseCustomMiniBuildPlan stackYamlFP url0 = do
yamlFP <- getYamlFP url0
yamlBS <- liftIO $ S.readFile $ toFilePath yamlFP
let yamlHash = S8.unpack $ B16.encode $ SHA256.hash yamlBS
binaryFilename <- parseRelFile $ yamlHash ++ ".bin"
customPlanDir <- getCustomPlanDir
let binaryFP = customPlanDir </> $(mkRelDir "bin") </> binaryFilename
taggedDecodeOrLoad binaryFP $ do
cs <- either throwM return $ decodeEither' yamlBS
let addFlags :: PackageIdentifier -> (PackageName, (Version, Map FlagName Bool))
addFlags (PackageIdentifier name ver) =
(name, (ver, fromMaybe Map.empty $ Map.lookup name $ csFlags cs))
toMiniBuildPlan
(csCompilerVersion cs)
Map.empty
(Map.fromList $ map addFlags $ Set.toList $ csPackages cs)
where
getCustomPlanDir = do
root <- asks $ configStackRoot . getConfig
return $ root </> $(mkRelDir "custom-plan")
getYamlFP url =
case parseUrl $ T.unpack url of
Just req -> getYamlFPFromReq url req
Nothing -> getYamlFPFromFile url
getYamlFPFromReq url req = do
let hashStr = S8.unpack $ B16.encode $ SHA256.hash $ encodeUtf8 url
hashFP <- parseRelFile $ hashStr ++ ".yaml"
customPlanDir <- getCustomPlanDir
let cacheFP = customPlanDir </> $(mkRelDir "yaml") </> hashFP
_ <- download req cacheFP
return cacheFP
getYamlFPFromFile url = do
fp <- liftIO $ D.canonicalizePath $ toFilePath (parent stackYamlFP) FP.</> T.unpack (fromMaybe url $
T.stripPrefix "file://" url <|> T.stripPrefix "file:" url)
parseAbsFile fp
data CustomSnapshot = CustomSnapshot
{ csCompilerVersion :: !CompilerVersion
, csPackages :: !(Set PackageIdentifier)
, csFlags :: !(Map PackageName (Map FlagName Bool))
}
instance FromJSON CustomSnapshot where
parseJSON = withObject "CustomSnapshot" $ \o -> CustomSnapshot
<$> ((o .: "compiler") >>= \t ->
case parseCompilerVersion t of
Nothing -> fail $ "Invalid compiler: " ++ T.unpack t
Just compilerVersion -> return compilerVersion)
<*> o .: "packages"
<*> o .:? "flags" .!= Map.empty