diff --git a/Development/Shake/FilePath.hs b/Development/Shake/FilePath.hs new file mode 100644 index 00000000..d385b4c6 --- /dev/null +++ b/Development/Shake/FilePath.hs @@ -0,0 +1,67 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | Useful 'System.FilePath' wrapper around Shake. + +module Development.Shake.FilePath + (startShake + ,target + ,need + ,want + ,Target(Target) + ,unTarget + ,Rules + ,Action + ,CmdOption(..) + ,Progress(..) + ,Shake.cmd + ,makeTargetFile) + where + +import Control.Monad.IO.Class +import Development.Shake (Rules,Action,CmdOption(..),Progress(..)) +import qualified Development.Shake as Shake +import qualified Filesystem as FP +import Filesystem.Path.CurrentOS (FilePath) +import qualified Filesystem.Path.CurrentOS as FP +import Prelude hiding (FilePath) +import System.Environment + +-- | A simple opaque wrapper for the "target" abstraction. +newtype Target = Target + { unTarget :: FilePath + } + +-- | Start Shake with the given data directory. +startShake :: MonadIO m + => Int -> FilePath -> Rules () -> m () +startShake threads dir rules = + liftIO (withArgs [] $ + Shake.shakeArgs + Shake.shakeOptions + { Shake.shakeFiles = FP.encodeString dir + , Shake.shakeThreads = threads + , Shake.shakeVerbosity = Shake.Quiet + } $ + rules) + +-- | Declare a target, returning the target name. +target :: Target -> Action () -> Rules Target +target name act = do + (FP.encodeString + (unTarget name)) Shake.*> + const act + return name + +-- | Need the given dependencies. +need :: [Target] -> Action () +need xs = Shake.need $ + map (FP.encodeString . unTarget) xs + +-- | Need the given dependencies. +want :: [Target] -> Rules () +want xs = Shake.want + (map (FP.encodeString . unTarget) xs) + +-- | Make an empty file of this name. +makeTargetFile :: Target -> Action () +makeTargetFile fp = liftIO $ FP.writeFile (unTarget fp) "" diff --git a/Stackage/BuildPlan.hs b/Stackage/BuildPlan.hs index b8bc5376..b854b0c7 100644 --- a/Stackage/BuildPlan.hs +++ b/Stackage/BuildPlan.hs @@ -91,7 +91,7 @@ instance FromJSON PackagePlan where ppDesc <- o .: "description" return PackagePlan {..} --- | Make a build plan given these package set and build constraints. +-- | Make a build plan given this package set and build constraints. newBuildPlan :: MonadIO m => Map PackageName PackagePlan -> BuildConstraints -> m BuildPlan newBuildPlan packagesOrig bc@BuildConstraints {..} = liftIO $ do let toolMap = makeToolMap packagesOrig diff --git a/Stackage/CheckBuildPlan.hs b/Stackage/CheckBuildPlan.hs index 74bf3b83..a2a0c4af 100644 --- a/Stackage/CheckBuildPlan.hs +++ b/Stackage/CheckBuildPlan.hs @@ -8,6 +8,7 @@ -- | Confirm that a build plan has a consistent set of dependencies. module Stackage.CheckBuildPlan ( checkBuildPlan + , libAndExe , BadBuildPlan ) where @@ -29,10 +30,13 @@ checkBuildPlan BuildPlan {..} map (ppVersion &&& M.keys . M.filter libAndExe . sdPackages . ppDesc) bpPackages errs@(BadBuildPlan errs') = execWriter $ mapM_ (checkDeps allPackages) $ mapToList bpPackages - -- Only looking at libraries and executables, benchmarks and tests - -- are allowed to create cycles (e.g. test-framework depends on - -- text, which uses test-framework in its test-suite). - libAndExe (DepInfo cs _) = any (flip elem [CompLibrary,CompExecutable]) cs + + +-- Only looking at libraries and executables, benchmarks and tests +-- are allowed to create cycles (e.g. test-framework depends on +-- text, which uses test-framework in its test-suite). +libAndExe :: DepInfo -> Bool +libAndExe (DepInfo cs _) = any (flip elem [CompLibrary,CompExecutable]) cs -- | For a given package name and plan, check that its dependencies are: -- diff --git a/Stackage/CompleteBuild.hs b/Stackage/CompleteBuild.hs index 341be2b4..ba719548 100644 --- a/Stackage/CompleteBuild.hs +++ b/Stackage/CompleteBuild.hs @@ -1,13 +1,17 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} +{-# OPTIONS_GHC -fno-warn-type-defaults #-} module Stackage.CompleteBuild ( BuildType (..) , BumpType (..) , BuildFlags (..) + , Settings (..) , completeBuild , justCheck , justUploadNightly + , getPerformBuild + , nightlySettings ) where import Control.Concurrent (threadDelay) @@ -23,6 +27,7 @@ import Stackage.BuildConstraints import Stackage.BuildPlan import Stackage.CheckBuildPlan import Stackage.PerformBuild +import qualified Stackage.ShakeBuild as Shake import Stackage.Prelude import Stackage.ServerBundle import Stackage.UpdateBuildPlan @@ -38,6 +43,7 @@ data BuildFlags = BuildFlags , bfEnableLibProfile :: !Bool , bfVerbose :: !Bool , bfSkipCheck :: !Bool + , bfGhcOptions :: !String } deriving (Show) data BuildType = Nightly | LTS BumpType @@ -67,7 +73,7 @@ nightlySettings :: Text -- ^ day -> Settings nightlySettings day plan' = Settings { planFile = nightlyPlanFile day - , buildDir = fpFromText $ "builds/stackage-nightly-" ++ day + , buildDir = fpFromText $ "nightly" , logDir = fpFromText $ "logs/stackage-nightly-" ++ day , title = \ghcVer -> concat [ "Stackage Nightly " @@ -120,7 +126,7 @@ getSettings man (LTS bumpType) = do return Settings { planFile = newfile - , buildDir = fpFromText $ "builds/stackage-lts-" ++ tshow new + , buildDir = fpFromText $ "builds/stackage-lts" , logDir = fpFromText $ "logs/stackage-lts-" ++ tshow new , title = \ghcVer -> concat [ "LTS Haskell " @@ -208,6 +214,7 @@ getPerformBuild buildFlags Settings {..} = PerformBuild , pbEnableLibProfiling = bfEnableLibProfile buildFlags , pbVerbose = bfVerbose buildFlags , pbAllowNewer = bfSkipCheck buildFlags + , pbGhcOptions = bfGhcOptions buildFlags } -- | Make a complete plan, build, test and upload bundle, docs and @@ -229,7 +236,7 @@ completeBuild buildType buildFlags = withManager tlsManagerSettings $ \man -> do checkBuildPlan plan putStrLn "Performing build" - performBuild (getPerformBuild buildFlags settings) >>= mapM_ putStrLn + Shake.performBuild (getPerformBuild buildFlags settings) -- >>= mapM_ putStrLn when (bfDoUpload buildFlags) $ finallyUpload settings man diff --git a/Stackage/GhcPkg.hs b/Stackage/GhcPkg.hs new file mode 100644 index 00000000..f49a7477 --- /dev/null +++ b/Stackage/GhcPkg.hs @@ -0,0 +1,55 @@ +-- | General commands related to ghc-pkg. + +module Stackage.GhcPkg where + +import Control.Monad +import Data.Conduit +import qualified Data.Conduit.List as CL +import Data.Conduit.Process +import qualified Data.Conduit.Text as CT +import Data.List +import Data.Maybe +import Data.Text (Text) +import qualified Data.Text as T +import Distribution.Compat.ReadP +import Distribution.Package +import Distribution.Text (display) +import Distribution.Text (parse) +import Filesystem.Path.CurrentOS (FilePath) +import qualified Filesystem.Path.CurrentOS as FP +import Prelude hiding (FilePath) + +-- | Get broken packages. +getBrokenPackages :: FilePath -> IO [PackageIdentifier] +getBrokenPackages dir = do + (_,ps) <- sourceProcessWithConsumer + (proc + "ghc-pkg" + ["check", "--simple-output", "-f", FP.encodeString dir]) + (CT.decodeUtf8 $= CT.lines $= CL.consume) + return (mapMaybe parsePackageIdent (T.words (T.unlines ps))) + +-- | Get available packages. +getRegisteredPackages :: FilePath -> IO [PackageIdentifier] +getRegisteredPackages dir = do + (_,ps) <- sourceProcessWithConsumer + (proc + "ghc-pkg" + ["list", "--simple-output", "-f", FP.encodeString dir]) + (CT.decodeUtf8 $= CT.lines $= CL.consume) + return (mapMaybe parsePackageIdent (T.words (T.unlines ps))) + +-- | Parse a package identifier: foo-1.2.3 +parsePackageIdent :: Text -> Maybe PackageIdentifier +parsePackageIdent = fmap fst . + listToMaybe . + filter (null . snd) . + readP_to_S parse . T.unpack + +-- | Unregister a package. +unregisterPackage :: FilePath -> PackageName -> IO () +unregisterPackage dir ident = do + void (readProcessWithExitCode + "ghc-pkg" + ["unregister", "-f", FP.encodeString dir, "--force", display ident] + "") diff --git a/Stackage/InstallBuild.hs b/Stackage/InstallBuild.hs index a6a6c25f..91b0c04e 100644 --- a/Stackage/InstallBuild.hs +++ b/Stackage/InstallBuild.hs @@ -53,6 +53,7 @@ getPerformBuild plan InstallFlags{..} = , pbEnableLibProfiling = ifEnableLibProfiling , pbVerbose = ifVerbose , pbAllowNewer = ifSkipCheck + , pbGhcOptions = [] } -- | Install stackage from an existing build plan. diff --git a/Stackage/PerformBuild.hs b/Stackage/PerformBuild.hs index e38f8e62..6db51825 100644 --- a/Stackage/PerformBuild.hs +++ b/Stackage/PerformBuild.hs @@ -10,6 +10,9 @@ module Stackage.PerformBuild , PerformBuild (..) , BuildException (..) , pbDocDir + , copyBuiltInHaddocks + , renameOrCopy + , copyDir ) where import Control.Concurrent.Async (async) @@ -67,6 +70,7 @@ data PerformBuild = PerformBuild , pbVerbose :: Bool , pbAllowNewer :: Bool -- ^ Pass --allow-newer to cabal configure + , pbGhcOptions :: String } data PackageInfo = PackageInfo diff --git a/Stackage/ShakeBuild.hs b/Stackage/ShakeBuild.hs new file mode 100644 index 00000000..867293d8 --- /dev/null +++ b/Stackage/ShakeBuild.hs @@ -0,0 +1,673 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ExtendedDefaultRules #-} +{-# OPTIONS_GHC -fno-warn-type-defaults #-} + +-- | Build everything with Shake. + +module Stackage.ShakeBuild (performBuild) where + +import Stackage.BuildConstraints +import Stackage.BuildPlan +import Stackage.CheckBuildPlan +import Stackage.GhcPkg +import Stackage.PackageDescription +import Stackage.PerformBuild (PerformBuild(..),copyBuiltInHaddocks,renameOrCopy) +import Stackage.Prelude (unFlagName,unExeName) + +import Data.Char +import Control.Concurrent +import Control.Concurrent.STM +import Control.Exception +import Control.Monad +import Control.Monad.IO.Class +import Data.ByteString (ByteString) +import Data.List +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as M +import Data.Maybe +import Data.Monoid +import qualified Data.Set as S +import Data.Streaming.Process +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import Data.Version +import Development.Shake.FilePath hiding (Env) +import Distribution.Package +import Distribution.Text (display) +import qualified Filesystem as FP +import Filesystem.Path.CurrentOS (FilePath) +import qualified Filesystem.Path.CurrentOS as FP +import Prelude hiding (log,FilePath) +import System.Environment +import System.Exit +import System.IO (withBinaryFile,IOMode(AppendMode)) + +-- | Reader environment used generally throughout the build process. +data Env = Env + {envCur :: FilePath -- ^ Current directory. + ,envShake :: FilePath -- ^ Shake directory. + ,envHaddocks :: TVar (Map String FilePath) -- ^ Haddock files. + ,envRegLock :: MVar () -- ^ Package registering lock. + ,envPB :: PerformBuild -- ^ Build perform settings. + ,envRegistered :: [PackageIdentifier] -- ^ Registered packages. + ,envMsgLock :: MVar () -- ^ A lock for printing to the log. + ,envStatus :: TVar ExitCode + } + +-------------------------------------------------------------------------------- +-- Main entry point + +-- | Run the shake builder. +performBuild :: PerformBuild -> IO () +performBuild pb' = do + num <- getNumCapabilities + cur <- FP.getWorkingDirectory + let shakeDir = cur <> "shake/" + FP.createTree shakeDir + FP.createTree (buildDatabase pb') + haddockFiles <- newTVarIO mempty + registerLock <- newMVar () + let !pb = pb' + { pbInstallDest = cur <> pbInstallDest pb' + } + pkgs <- getRegisteredPackages (buildDatabase pb) + msgLock <- newMVar () + status <- newTVarIO ExitSuccess + let !env = Env + { envCur = cur + , envShake = shakeDir + , envHaddocks = haddockFiles + , envRegLock = registerLock + , envPB = pb + , envRegistered = pkgs + , envMsgLock = msgLock + , envStatus = status + } + checkBuildTools env + cleanOldPackages env + printNewPackages env + startShake num shakeDir (shakePlan env) + st <- readTVarIO status + case st of + ExitSuccess -> return () + _ -> throw st + +-------------------------------------------------------------------------------- +-- The whole Shake plan + +-- | The complete build plan as far as Shake is concerned. +shakePlan :: Env -> Rules () +shakePlan env@Env{..} = do + fetched <- target (targetForFetched env) $ fetchedTarget env + db <- target (targetForDb env) $ databaseTarget env + void $ forM (mapMaybe (\p -> find ((==p) . fst) versionMappings) corePackages) $ + \(name,version) -> + let fp = targetForPackage envShake name version + in target fp (makeTargetFile fp) + builds <- forM normalPackages $ + \(name,plan) -> + target (targetForPackage envShake name (ppVersion plan)) $ + do need [db, fetched] + packageTarget env name plan + haddockTargets <- + forM normalPackages $ + \(name,plan) -> + target (targetForDocs envShake name (ppVersion plan)) $ + do need [targetForPackage envShake name (ppVersion plan)] + packageDocs env plan name + tests <- forM normalPackages $ + \(name,plan) -> + target (targetForTest envShake name (ppVersion plan)) $ + do need haddockTargets + testTarget env name plan + if pbEnableTests envPB + then want tests + else want haddockTargets + where versionMappings = M.toList (M.map ppVersion (bpPackages (pbPlan envPB))) + corePackages = M.keys $ siCorePackages $ bpSystemInfo $ pbPlan envPB + normalPackages = filter (not . (`elem` corePackages) . fst) $ + M.toList $ bpPackages $ pbPlan envPB + +-------------------------------------------------------------------------------- +-- Target file paths + +-- | Get the target file for confirming that all packages have been +-- pre-fetched. +targetForFetched :: Env -> Target +targetForFetched Env{..} = Target (envShake <> "packages-fetched") + +-- | Get the target file for a package. +targetForPackage :: FilePath -> PackageName -> Version -> Target +targetForPackage shakeDir name version = Target $ + shakeDir <> "packages" <> + FP.decodeString (nameVer name version) + <> "dist" <> "shake-build" + +-- | Get the target file for a package. +targetForTest :: FilePath -> PackageName -> Version -> Target +targetForTest shakeDir name version = Target $ + shakeDir <> "packages" <> + FP.decodeString (nameVer name version) + <> "dist" <> "shake-test" + +-- | Get the target file for a package. +targetForDocs :: FilePath -> PackageName -> Version -> Target +targetForDocs shakeDir name version = Target $ + shakeDir <> "packages" <> + FP.decodeString + (nameVer name version) <> + "dist" <> "shake-docs" + +-- | Get a package database path. +targetForDb :: Env -> Target +targetForDb Env{..} = Target $ (pbInstallDest envPB) <> "pkgdb-initialized" + +-------------------------------------------------------------------------------- +-- Locations, names and environments used. Just to avoid "magic +-- strings". + +-- | Print the name and version. +nameVer :: PackageName -> Version -> String +nameVer name version = display name ++ "-" ++ display version + +-- | Default environment for running commands. +defaultEnv :: PerformBuild -> FilePath -> [(String, String)] -> [(String, String)] +defaultEnv pb pwd env = sandbox ++ rest + where sandbox = [( "HASKELL_PACKAGE_SANDBOX" + , FP.encodeString + (pwd <> buildDatabase pb)) | not (pbGlobalInstall pb)] + rest = map addPath env + where + addPath (key,val) + | map toUpper key == "PATH" = + ( key + , FP.encodeString + (pbBinDir pb) <> + pathSep <> + val) + | otherwise = (key,val) + +-- | Platform-independent PATH environment separator. +pathSep :: String +#ifdef mingw32_HOST_OS +pathSep = ";" +#else +pathSep = ":" +#endif + +-- | Database location. +buildDatabase :: PerformBuild -> FilePath +buildDatabase pb = (pbInstallDest pb) <> "pkgdb" + +-- | The directory for the package's docs. +pkgDocDir :: Env -> PackageName -> Version -> FilePath +pkgDocDir env@Env{..} name version = pkgDir env name version <> + "dist" <> + "doc" <> + "html" <> + (FP.decodeString (display name)) + +-- | The package directory. +pkgDir :: Env -> PackageName -> Version -> FilePath +pkgDir Env{..} name version = envShake <> "packages" <> + (FP.decodeString (nameVer name version)) + +-- | The package directory. +pkgLogFile :: Env -> PackageName -> Version -> FilePath +pkgLogFile env@Env{..} name version = pkgDir env name version <> + "dist" <> "stackage-log.txt" + +-- | The package directory. +testLogFile :: Env -> PackageName -> Version -> FilePath +testLogFile env@Env{..} name version = pkgDir env name version <> + "dist" <> "stackage-test-log.txt" + +-- | Installation paths. +pbBinDir, pbLibDir, pbDataDir, pbDocDir :: PerformBuild -> FilePath +pbBinDir root = (pbInstallDest root) <> "bin" +pbLibDir root = (pbInstallDest root) <> "lib" +pbDataDir root = (pbInstallDest root) <> "share" +pbDocDir root = (pbInstallDest root) <> "doc" + +-------------------------------------------------------------------------------- +-- Pre-build messages + +-- | Print the new packages. +printNewPackages :: Env -> IO () +printNewPackages env@Env{..} = do + unless + (M.null new) + (do logLn + env + Normal + ("There are " ++ + show (M.size new) ++ + " packages to build and install.") + forM_ + (map fst (take maxDisplay (M.toList new))) + (logLn env Verbose . display) + when + (M.size new > maxDisplay) + (logLn + env + Verbose + ("And " ++ + show (M.size new - maxDisplay) ++ + " more."))) + where maxDisplay = 10 + new = newPackages env + +-- | Get new packages from the env. +newPackages :: Env -> Map PackageName Version +newPackages Env{..} = new + where new = M.filterWithKey + (\name _ -> + isNothing (find ((== name) . pkgName) envRegistered)) + versions + versions = (M.map ppVersion . + M.filter (not . S.null . sdModules . ppDesc) . + bpPackages . pbPlan) envPB + +-------------------------------------------------------------------------------- +-- Checking for build tools + +-- | Check that all build tools are available. +-- https://github.com/jgm/zip-archive/issues/23 +checkBuildTools :: Env -> IO () +checkBuildTools env@Env{..} = + forM_ normalPackages + (\(pname,plan) -> mapM_ (checkTool pname) (M.keys (sdTools (ppDesc plan)))) + where normalPackages = filter (not . (`elem` corePackages) . fst) $ + M.toList $ bpPackages $ pbPlan envPB + where corePackages = M.keys $ siCorePackages $ bpSystemInfo $ pbPlan envPB + checkTool pname name = + case M.lookup name (makeToolMap (bpPackages (pbPlan envPB))) of + Nothing + | not (isCoreExe name) -> + logLn env Normal ("Warning: No executable " <> + T.unpack (unExeName name) <> + " for " <> display pname) + + Just _ + -> return () + _ -> return () + isCoreExe = (`S.member` siCoreExecutables (bpSystemInfo (pbPlan envPB))) + +-------------------------------------------------------------------------------- +-- Clean/purging of old packages + +-- | Reason for purging a package. +data PurgeReason + = NoLongerIncluded + | Replaced Version + | Broken + +-- | Clean up old versions of packages that are no longer in use. +cleanOldPackages :: Env -> IO () +cleanOldPackages env@Env{..} = do + logLn env Verbose "Collecting garbage" + pkgs <- getRegisteredPackages (buildDatabase envPB) + let toRemove = mapMaybe + (\(PackageIdentifier name version) -> + case M.lookup name versions of + Just version' + | version' == version -> + Nothing + Just newVersion -> Just + (name, version, (Replaced newVersion)) + Nothing -> Just (name, version, NoLongerIncluded)) + pkgs + unless (null toRemove) + (logLn env Verbose ("There are " ++ show (length toRemove) + ++ " packages to be purged.")) + when (length toRemove > 0) + (do logLn env Verbose "Waiting 3 seconds before proceeding to remove ..." + threadDelay (1000 * 1000 * 3)) + forM_ pkgs $ + \(PackageIdentifier name version) -> + case M.lookup name versions of + Just version' + | version' == version -> + return () + Just newVersion -> purgePackage + env + name + version + (Replaced newVersion) + Nothing -> purgePackage env name version NoLongerIncluded + broken <- getBrokenPackages (buildDatabase envPB) + unless (null broken) + (logLn env Verbose ("There are " ++ show (length broken) + ++ " broken packages to be purged.")) + when (length broken > 0) + (do logLn env Verbose "Waiting 3 seconds before proceeding to remove ..." + threadDelay (1000 * 1000 * 3)) + forM_ + broken + (\(PackageIdentifier name version) -> + purgePackage env name version Broken) + where versions = (M.map ppVersion . bpPackages . pbPlan) envPB + +-- | Purge the given package and version. +purgePackage :: Env -> PackageName -> Version -> PurgeReason -> IO () +purgePackage env name version reason = do + log env Normal $ "Purging package: " ++ ident ++ " (" ++ showReason ++ ") ... " + unregisterPackage (buildDatabase (envPB env)) name + remove + logLn env Normal "done." + where showReason = + case reason of + Replaced version' -> "replaced by " ++ ordinal ++ " " ++ display version' + where ordinal | version' > version = "newer" + | otherwise = "older" + NoLongerIncluded -> "no longer included" + Broken -> "broken" + ident = nameVer name version + remove = FP.removeTree $ + pkgDir env name version + +-------------------------------------------------------------------------------- +-- Target actions + +-- | Initialize the database if there one needs to be, and in any case +-- create the target file. +databaseTarget :: Env -> Action () +databaseTarget env = do + if pbGlobalInstall (envPB env) + then return () + else do + liftIO (FP.createTree dir) + liftIO (FP.removeTree dir) + () <- cmd "ghc-pkg" "init" (FP.encodeString dir) + liftIO $ copyBuiltInHaddocks $ pbDocDir (envPB env) + makeTargetFile (targetForDb env) + where dir = buildDatabase (envPB env) + +-- | Generate haddock docs for the package. +packageDocs :: Env -> PackagePlan -> PackageName -> Action () +packageDocs env@Env{..} plan name = do + when (haddocksFlag /= Don'tBuild && + not (S.null $ sdModules $ ppDesc plan)) $ + generateHaddocks + env + (pkgLogFile env name version) + (pkgDir env name version) + name + version + haddocksFlag + makeTargetFile (targetForDocs envShake name (ppVersion plan)) + where version = ppVersion plan + haddocksFlag = pcHaddocks $ ppConstraints plan + +-- | Build, test and generate documentation for the package. +packageTarget :: Env -> PackageName -> PackagePlan -> Action () +packageTarget env@Env{..} name plan = do + need libraryDependencies + need toolDependencies + unpack env name version + liftIO (do exists <- FP.isFile logFile + when exists (FP.removeFile logFile)) + prefix <- packageCmdPrefix name + cabal env Verbose prefix logFile dir ["clean"] + configure env name logFile dir plan False + let pkgCabal :: (MonadIO m) => Verbosity -> [String] -> m () + pkgCabal verbosity = succeed . cabal env verbosity prefix logFile dir + pkgCabal Normal ["build","--ghc-options=" <> pbGhcOptions envPB] + pkgCabal Verbose ["copy"] + liftIO (withMVar envRegLock + (const (pkgCabal Verbose ["register"]))) + makeTargetFile (targetForPackage envShake name version) + where logFile = pkgLogFile env name version + dir = pkgDir env name version + version = ppVersion plan + versionMappings = M.toList (M.map ppVersion (bpPackages (pbPlan envPB))) + toolMappings = makeToolMap (bpPackages (pbPlan envPB)) + libraryDependencies = + packagesToTargets $ + filter (/= name) $ + M.keys $ M.filter libAndExe $ + sdPackages $ ppDesc plan + toolDependencies = + packagesToTargets $ + filter (/= name) $ + S.toList $ mconcat $ + mapMaybe (\exename -> M.lookup exename toolMappings) $ + M.keys $ M.filter libAndExe $ sdTools $ ppDesc plan + packagesToTargets = + map (\(pname,pver) -> targetForPackage envShake pname pver) . + mapMaybe (\p -> find ((==p) . fst) versionMappings) + +-- | Build, test and generate documentation for the package. +testTarget :: Env -> PackageName -> PackagePlan -> Action () +testTarget env@Env{..} name plan = do + need libraryDependencies + need toolDependencies + unpack env name version + liftIO (do exists <- FP.isFile logFile + when exists (FP.removeFile logFile)) + prefix <- packageCmdPrefix name + when (pbEnableTests envPB && pcTests (ppConstraints plan) /= Don'tBuild) + (do configure env name logFile dir plan True + result <- cabal env Normal prefix logFile dir ["test"] + case (result,pcTests (ppConstraints plan)) of + (ExitFailure{},ExpectSuccess) -> + do logLn env Normal (prefix <> "TEST SUITE FAILED") + failed env result + (ExitSuccess,ExpectFailure) -> + logLn env Normal (prefix <> "Unexpected test suite success!") + _ -> return ()) + makeTargetFile (targetForTest envShake name version) + where logFile = testLogFile env name version + dir = pkgDir env name version + version = ppVersion plan + versionMappings = M.toList (M.map ppVersion (bpPackages (pbPlan envPB))) + toolMappings = makeToolMap (bpPackages (pbPlan envPB)) + libraryDependencies = + packagesToTargets $ M.keys $ sdPackages $ ppDesc plan + toolDependencies = + packagesToTargets $ + S.toList $ mconcat $ + mapMaybe (\exename -> + M.lookup exename toolMappings) $ + M.keys $ sdTools $ ppDesc plan + packagesToTargets = + map (\(pname,pver) -> targetForPackage envShake pname pver) . + mapMaybe (\p -> find ((==p) . fst) versionMappings) + +-- | Make sure all package archives have been fetched. +fetchedTarget :: Env -> Action () +fetchedTarget env@Env{..} = do + () <- cmd "cabal" "fetch" "--no-dependencies" $ + map + (\(name,plan) -> display name ++ "-" ++ display (ppVersion plan)) $ + M.toList $ bpPackages $ pbPlan envPB + makeTargetFile (targetForFetched env) + +-------------------------------------------------------------------------------- +-- Package actions + +-- | Unpack the package. +unpack :: Env -> PackageName -> Version -> Action () +unpack env@Env{..} name version = do + unpacked <- liftIO $ FP.isFile $ + dir <> + FP.decodeString + (display name ++ ".cabal") + unless unpacked $ + do liftIO $ catch (FP.removeTree dir) $ + \(e :: IOException) -> log env Normal ("Remove ex: " <> show e <> "\n") + cmd + (Cwd (FP.encodeString (envShake <> "packages"))) + "cabal" + "unpack" + (nameVer name version) + "-v0" + where dir = pkgDir env name version + +-- | Configure the given package. +configure :: Env -> PackageName -> FilePath -> FilePath -> PackagePlan -> Bool -> Action () +configure env@Env{..} name logfile pdir plan enableTests = + do prefix <- packageCmdPrefix name + succeed (cabal env Verbose prefix logfile pdir ("configure" : opts)) + where + opts = + [ "--package-db=clear" + , "--package-db=global" + , "--libdir=" ++ FP.encodeString (pbLibDir envPB) + , "--bindir=" ++ FP.encodeString (pbBinDir envPB) + , "--datadir=" ++ FP.encodeString (pbDataDir envPB) + , "--docdir=" ++ FP.encodeString (pbDocDir envPB) + , "--flags=" ++ planFlags] ++ + ["--package-db=" ++ FP.encodeString (buildDatabase envPB) + | not (pbGlobalInstall envPB)] ++ + ["--enable-tests" | enableTests] + planFlags = unwords $ + map go $ M.toList (pcFlagOverrides (ppConstraints plan)) + where go (name',isOn) = concat + [ if isOn then "" else "-" , T.unpack (unFlagName name')] + +-- | Generate haddocks for the package. +generateHaddocks :: Env -> FilePath -> FilePath -> PackageName -> Version -> TestState -> Action () +generateHaddocks env@Env{..} logfile pdir name version expected = do + hfs <- liftIO $ readTVarIO envHaddocks + prefix <- packageCmdPrefix name + exitCode <- + cabal + env + Normal + prefix + logfile + pdir + (["haddock" + ,"--hyperlink-source" + ,"--html" + ,"--hoogle" + ,"--html-location=../$pkg-$version/"] ++ + map + (\(pkgVer,hf) -> + concat + [ "--haddock-options=--read-interface=" + , "../" + , pkgVer + , "/," + , FP.encodeString hf]) + (M.toList hfs)) + case (exitCode, expected) of + (ExitSuccess,ExpectFailure) -> + logLn env Normal (prefix <> "expected failure for haddock generation, but it succeeded!") + (ExitFailure{},ExpectSuccess) -> + do logLn env Normal (prefix <> "expected success for haddock, but it failed!") + failed env exitCode + _ -> return () + copy + where + ident = nameVer name version + copy = do + liftIO $ + do let orig = pkgDocDir env name version + exists <- FP.isDirectory orig + when exists $ + renameOrCopy orig (pbDocDir envPB <> FP.decodeString ident) + enewPath <- liftIO $ try $ + FP.canonicalizePath + (pbDocDir envPB <> FP.decodeString ident <> + FP.decodeString (display name ++ ".haddock")) + case enewPath of + Left (_ :: IOException) -> return () -- FIXME: log it with Shake. + Right newPath -> liftIO $ atomically $ modifyTVar envHaddocks $ + M.insert (ident) newPath + +-------------------------------------------------------------------------------- +-- Running commands + +-- | Get a command prefix including progress. +packageCmdPrefix :: MonadIO m => PackageName -> m Text +packageCmdPrefix name = + return (T.pack (display name) <> ": ") + +-- | Run a command with the right envornment, logs the command being +-- run and its output as verbose mode. +cabal :: MonadIO m => Env -> Verbosity -> Text -> FilePath -> FilePath -> [String] -> m ExitCode +cabal env verbosity prefix logfile cwd args = do + pwd <- liftIO FP.getWorkingDirectory + envmap <- liftIO $ fmap (defaultEnv (envPB env) pwd) $ getEnvironment + logLn env verbosity (prefix <> T.pack (fromMaybe "" (listToMaybe args))) + logLn env Verbose (prefix <> T.pack (unwords (cmd' : map show args))) + liftIO (FP.createTree (FP.directory logfile)) + code <- liftIO $ flip catch exitFailing + $ withBinaryFile (FP.encodeString logfile) AppendMode $ \outH -> + do withCheckedProcess + (proc cmd' args) + { cwd = Just (FP.encodeString cwd) + , std_err = UseHandle outH + , std_out = UseHandle outH + , env = Just envmap + } + (\ClosedStream UseProvidedHandle UseProvidedHandle -> + (return ())) + return ExitSuccess + case code of + ExitFailure{} -> + logLn env Normal + (prefix <> T.pack (fromMaybe "" (listToMaybe args)) <> ": " <> + "FAIL") + ExitSuccess{} -> return () + return code + where cmd' = "cabal" :: String + exitFailing :: ProcessExitedUnsuccessfully -> IO ExitCode + exitFailing (ProcessExitedUnsuccessfully _ code) = do + FP.readFile logfile >>= logLn env Normal + return code + +-- | A result failed. +failed :: MonadIO m => Env -> ExitCode -> m () +failed env code = liftIO + (atomically + (writeTVar (envStatus env) code)) + +-- | The action must return a success code or an exception is thrown. +succeed :: MonadIO m + => m ExitCode -> m () +succeed m = do + v <- m + case v of + ExitFailure{} -> throw v + ExitSuccess -> return () + +-------------------------------------------------------------------------------- +-- Logging utilities + +data Verbosity + = Verbose + | Normal + +-- | Convenience. +class ToBS a where toBS :: a -> ByteString +instance ToBS String where toBS = toBS . T.pack +instance ToBS Text where toBS = T.encodeUtf8 +instance ToBS ByteString where toBS = id + +-- | Log to wherever is configured by the calling code. +logLn :: (MonadIO m,ToBS str) => Env -> Verbosity -> str -> m () +logLn env v s = log env v (toBS s <> "\n") + +-- | Log to wherever is configured by the calling code. +log :: (MonadIO m,ToBS str) => Env -> Verbosity -> str -> m () +log env v s = + when ((bool && verbose) || not bool) + (liftIO + (withMVar (envMsgLock env) + (const (pbLog + (envPB env) + (toBS s))))) + where verbose = pbVerbose (envPB env) + bool = case v of + Verbose -> True + Normal -> False diff --git a/app/stackage.hs b/app/stackage.hs index c8bb4f52..4bb7ec43 100644 --- a/app/stackage.hs +++ b/app/stackage.hs @@ -3,11 +3,12 @@ module Main where import Control.Monad +import Data.Maybe import Data.Monoid import Data.String (fromString) import Data.Version -import Options.Applicative import Filesystem.Path.CurrentOS (decodeString) +import Options.Applicative import Paths_stackage (version) import Stackage.CompleteBuild import Stackage.InstallBuild @@ -95,7 +96,12 @@ main = help "Output verbose detail about the build steps") <*> switch (long "skip-check" <> - help "Skip the check phase, and pass --allow-newer to cabal configure") + help "Skip the check phase, and pass --allow-newer to cabal configure") <*> + fmap (fromMaybe "") + (optional (strOption + (long "ghc-options" <> + showDefault <> + help "GHC options"))) nightlyUploadFlags = fromString <$> strArgument (metavar "DATE" <> diff --git a/stackage.cabal b/stackage.cabal index 94b42da9..da853053 100644 --- a/stackage.cabal +++ b/stackage.cabal @@ -29,40 +29,47 @@ library Stackage.ServerBundle Stackage.Upload Stackage.PerformBuild + Stackage.ShakeBuild Stackage.CompleteBuild - build-depends: base >= 4 && < 5 - , containers - , Cabal >= 1.14 - , tar >= 0.3 - , zlib - , bytestring - , directory - , filepath - , transformers - , process - , old-locale - , time - , utf8-string - - , conduit-extra - , classy-prelude-conduit - , text - , system-fileio - , system-filepath - , mtl - , aeson - , yaml - , unix-compat - , http-client - , http-client-tls - , temporary - , data-default-class - , stm - , mono-traversable - , async - , streaming-commons >= 0.1.7.1 - , semigroups - , xml-conduit + Stackage.GhcPkg + other-modules: + Development.Shake.FilePath + build-depends: + Cabal >= 1.14 + , aeson + , async + , base >= 4 && < 5 + , bytestring + , classy-prelude-conduit + , conduit + , conduit-extra + , containers + , data-default-class + , directory + , filepath + , http-client + , http-client-tls + , mono-traversable + , mtl + , old-locale + , process + , resourcet + , semigroups + , shake + , stm + , streaming-commons >= 0.1.7.1 + , system-fileio + , system-filepath + , tar >= 0.3 + , temporary + , text + , time + , transformers + , unix-compat + , utf8-string + , xml-conduit + , yaml + , zlib executable stackage default-language: Haskell2010 diff --git a/test/Stackage/BuildPlanSpec.hs b/test/Stackage/BuildPlanSpec.hs index b87c74d2..c57eaab1 100644 --- a/test/Stackage/BuildPlanSpec.hs +++ b/test/Stackage/BuildPlanSpec.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE OverloadedStrings, NoImplicitPrelude #-} module Stackage.BuildPlanSpec (spec) where @@ -13,8 +14,11 @@ import Network.HTTP.Client.TLS (tlsManagerSettings) import Stackage.BuildConstraints import Stackage.BuildPlan import Stackage.CheckBuildPlan +import Stackage.CompleteBuild import Stackage.PackageDescription +import Stackage.PerformBuild import Stackage.Prelude +import qualified Stackage.ShakeBuild as Shake import Stackage.UpdateBuildPlan import Test.Hspec @@ -37,6 +41,18 @@ spec = do ,("bar", [0, 0, 0], [("mu", thisV [0, 0, 0])]) ,("mu", [0, 0, 0], [("foo", thisV [0, 0, 0])])] {- Shouldn't be testing this actually + it "basic build" $ basicBuild $ makePackageSet + [("acme-strtok", [0,1,0,3], [("mtl", thisV [2, 2, 1])]) + ,("acme-dont", [1,1], []) + ,("mtl",[2,2,1],[("base",anyV) + ,("transformers",anyV)]) + ,("transformers",[0,4,1,0],[("base",anyV)])] + it "shake build" $ shakeBuild $ makePackageSet + [("acme-strtok", [0,1,0,3], [("mtl", thisV [2, 1, 3, 1])]) + ,("acme-dont", [1,1], []) + ,("mtl",[2,1,3,1],[("base",anyV) + ,("transformers",anyV)]) + ,("transformers",[0,3,0,0],[("base",anyV)])] it "default package set checks ok" $ check defaultBuildConstraints getLatestAllowedPlans -} @@ -53,6 +69,56 @@ badBuildPlan m _ = do Right () -> error "Expected bad build plan." +-- | Perform a basic build. +basicBuild :: (BuildConstraints -> IO (Map PackageName PackagePlan)) + -> void + -> IO () +basicBuild getPlans _ = do + withManager + tlsManagerSettings + (\man -> + do settings@Settings{..} <- getTestSettings man + Nightly + fullBuildConstraints + getPlans + let pb = (getPerformBuild buildFlags settings) + logs <- performBuild + pb + mapM_ putStrLn logs) + where buildType = + Nightly + buildFlags = + BuildFlags + { bfEnableTests = False + , bfDoUpload = False + , bfEnableLibProfile = False + , bfVerbose = False + } + +-- | Perform a shake build. +shakeBuild :: (BuildConstraints -> IO (Map PackageName PackagePlan)) + -> void + -> IO () +shakeBuild getPlans _ = do + withManager + tlsManagerSettings + (\man -> + do settings@Settings{..} <- getTestSettings + man + Nightly + fullBuildConstraints + getPlans + let pb = + (getPerformBuild buildFlags settings) + Shake.performBuild pb) + where buildType = + Nightly + buildFlags = + BuildFlags {bfEnableTests = False + ,bfDoUpload = False + ,bfEnableLibProfile = False + ,bfVerbose = False} + -- | Check build plan with the given package set getter. check :: (Manager -> IO BuildConstraints) -> (BuildConstraints -> IO (Map PackageName PackagePlan)) @@ -115,7 +181,7 @@ makePackageSet ps _ = {pcVersionRange = anyV ,pcMaintainer = Nothing ,pcTests = Don'tBuild - ,pcHaddocks = Don'tBuild + ,pcHaddocks = ExpectSuccess ,pcBuildBenchmarks = False ,pcFlagOverrides = mempty ,pcEnableLibProfile = False} @@ -134,6 +200,23 @@ thisV ver = thisVersion (Version ver []) anyV :: VersionRange anyV = anyVersion +-- | Get settings for doing test builds. +getTestSettings :: Manager -> BuildType -> (Manager -> IO BuildConstraints) -> (BuildConstraints -> IO (Map PackageName PackagePlan)) -> IO Settings +getTestSettings man Nightly readPlanFile getPlans = do + day <- tshow . utctDay <$> getCurrentTime + bc <- readPlanFile man + plans <- getPlans bc + bp <- newBuildPlan plans bc + return $ nightlySettings day bp + +-- | Test plan. +fullBuildConstraints :: void -> IO BuildConstraints +fullBuildConstraints _ = + decodeFileEither + (fpToString fp) >>= + either throwIO toBC + where fp = "test/full-build-constraints.yaml" + -- | Test plan. testBuildConstraints :: void -> IO BuildConstraints testBuildConstraints _ = diff --git a/test/full-build-constraints.yaml b/test/full-build-constraints.yaml new file mode 100644 index 00000000..ea4f1b20 --- /dev/null +++ b/test/full-build-constraints.yaml @@ -0,0 +1,20 @@ +packages: + "Test": + - acme-dont + - acme-strtok + +global-flags: [] + +skipped-tests: [] +expected-test-failures: [] +expected-haddock-failures: [] +skipped-benchmarks: [] +skipped-profiling: [] + +github-users: + bar: + - demo + +package-flags: + foo: + demo: true