From ac709e93b4d1e12df072233fbd64a1344c0e9f25 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Thu, 29 Nov 2012 16:37:04 +0200 Subject: [PATCH] BuildSettings --- Stackage/Build.hs | 41 ++++++++++++++++++++++++++++------------- Stackage/CheckPlan.hs | 6 +++--- Stackage/Config.hs | 20 ++++++-------------- Stackage/InstallInfo.hs | 8 ++++---- Stackage/Test.hs | 16 ++++++++-------- Stackage/Types.hs | 9 +++++++++ Stackage/Util.hs | 16 ++++++++-------- app/stackage.hs | 4 ++-- 8 files changed, 68 insertions(+), 52 deletions(-) diff --git a/Stackage/Build.hs b/Stackage/Build.hs index a33ffffc..be1cb8b8 100644 --- a/Stackage/Build.hs +++ b/Stackage/Build.hs @@ -1,14 +1,18 @@ module Stackage.Build ( build + , defaultBuildSettings + , BuildSettings (..) ) where import Distribution.Text (simpleParse) import Control.Monad (unless) +import Stackage.Types import Stackage.CheckPlan import Stackage.InstallInfo import Stackage.Tarballs import Stackage.Test import Stackage.Util +import Stackage.Config import System.Exit (ExitCode (ExitSuccess), exitWith) import System.IO (IOMode (WriteMode), withBinaryFile) import System.Process (runProcess, waitForProcess, rawSystem, readProcess) @@ -16,27 +20,35 @@ import System.Directory (createDirectoryIfMissing, canonicalizePat import Distribution.Version (thisVersion, withinRange) import Control.Exception (assert) -build :: FilePath - -> ([String] -> [String]) -- ^ extra build rgs - -> IO () -build root' extraBuildArgs = do +defaultBuildSettings :: BuildSettings +defaultBuildSettings = BuildSettings + { sandboxRoot = "sandbox" + , extraBuildArgs = [] + , extraCore = defaultExtraCore + , expectedFailures = defaultExpectedFailures + , stablePackages = defaultStablePackages + , extraArgs = ["-fnetwork23"] + } + +build :: BuildSettings -> IO () +build settings' = do putStrLn "Creating a build plan" - ii <- getInstallInfo + ii <- getInstallInfo settings' putStrLn "Wiping out old sandbox folder" + let root' = sandboxRoot settings' rm_r root' rm_r "logs" createDirectoryIfMissing True root' root <- canonicalizePath root' + let settings = settings' { sandboxRoot = root } - ec1 <- rawSystem "ghc-pkg" ["init", packageDir root] + ec1 <- rawSystem "ghc-pkg" ["init", packageDir settings] unless (ec1 == ExitSuccess) $ do putStrLn "Unable to create package database via ghc-pkg init" exitWith ec1 - let extraArgs = ("-fnetwork23":) - - checkPlan (addCabalArgs root . extraArgs) ii + checkPlan settings ii putStrLn "No mismatches, starting the sandboxed build." versionString <- readProcess "cabal" ["--version"] "" @@ -53,13 +65,16 @@ build root' extraBuildArgs = do | otherwise -> error $ "Unsupported Cabal version: " ++ libVersion ph <- withBinaryFile "build.log" WriteMode $ \handle -> - let args = addCabalArgs root + let args = addCabalArgs settings $ "install" : ("--cabal-lib-version=" ++ libVersion) : "--build-log=logs/$pkg.log" - : "--enable-shared" : "-j" - : (extraBuildArgs . extraArgs) (iiPackageList ii) + : concat + [ extraBuildArgs settings + , extraArgs settings + , iiPackageList ii + ] in runProcess "cabal" args Nothing Nothing Nothing (Just handle) (Just handle) ec <- waitForProcess ph unless (ec == ExitSuccess) $ do @@ -67,7 +82,7 @@ build root' extraBuildArgs = do exitWith ec putStrLn "Sandbox built, beginning individual test suites" - runTestSuites root ii + runTestSuites settings ii putStrLn "All test suites that were expected to pass did pass, building tarballs." makeTarballs ii diff --git a/Stackage/CheckPlan.hs b/Stackage/CheckPlan.hs index d70da939..0e4c845d 100644 --- a/Stackage/CheckPlan.hs +++ b/Stackage/CheckPlan.hs @@ -16,9 +16,9 @@ import System.Process (readProcessWithExitCode) data Mismatch = OnlyDryRun String | OnlySimpleList String deriving Show -checkPlan :: ([String] -> [String]) -> InstallInfo -> IO () -checkPlan extraArgs ii = do - (ec, dryRun', stderr) <- readProcessWithExitCode "cabal" (extraArgs $ "install":"--dry-run":iiPackageList ii) "" +checkPlan :: BuildSettings -> InstallInfo -> IO () +checkPlan settings ii = do + (ec, dryRun', stderr) <- readProcessWithExitCode "cabal" (addCabalArgs settings $ "install":"--dry-run":iiPackageList ii) "" when (ec /= ExitSuccess || "Warning:" `isPrefixOf` stderr) $ do putStr stderr putStr dryRun' diff --git a/Stackage/Config.hs b/Stackage/Config.hs index 574ed62e..8bf5670f 100644 --- a/Stackage/Config.hs +++ b/Stackage/Config.hs @@ -15,14 +15,14 @@ targetCompilerVersion = -- | Packages which are shipped with GHC but are not included in the -- Haskell Platform list of core packages. -extraCore :: Set PackageName -extraCore = singleton $ PackageName "binary" +defaultExtraCore :: Set PackageName +defaultExtraCore = singleton $ PackageName "binary" -- | Test suites which are expected to fail for some reason. The test suite -- will still be run and logs kept, but a failure will not indicate an -- error in our package combination. -expectedFailures :: Set PackageName -expectedFailures = fromList $ map PackageName +defaultExpectedFailures :: Set PackageName +defaultExpectedFailures = fromList $ map PackageName [ -- Requires an old version of WAI and Warp for tests "HTTP" -- Requires a special hspec-meta which is not yet available from @@ -58,8 +58,8 @@ expectedFailures = fromList $ map PackageName -- | List of packages for our stable Hackage. All dependencies will be -- included as well. Please indicate who will be maintaining the package -- via comments. -stablePackages :: Map PackageName (VersionRange, Maintainer) -stablePackages = execWriter $ do +defaultStablePackages :: Map PackageName (VersionRange, Maintainer) +defaultStablePackages = execWriter $ do mapM_ (add "michael@snoyman.com") $ words "yesod yesod-newsfeed yesod-sitemap yesod-static yesod-test markdown filesystem-conduit mime-mail-ses" @@ -80,11 +80,3 @@ stablePackages = execWriter $ do case simpleParse range of Nothing -> error $ "Invalid range " ++ show range ++ " for " ++ package Just range' -> tell $ Map.singleton (PackageName package) (range', Maintainer maintainer) - -verbose :: Bool -verbose = -#if VERBOSE - True -#else - False -#endif diff --git a/Stackage/InstallInfo.hs b/Stackage/InstallInfo.hs index 42b04485..f7771b68 100644 --- a/Stackage/InstallInfo.hs +++ b/Stackage/InstallInfo.hs @@ -13,11 +13,11 @@ import Stackage.Types import Stackage.Util import Data.Version (showVersion) -getInstallInfo :: IO InstallInfo -getInstallInfo = do +getInstallInfo :: BuildSettings -> IO InstallInfo +getInstallInfo settings = do hp <- loadHaskellPlatform - let allPackages = Map.union stablePackages $ identsToRanges (hplibs hp) - let totalCore = extraCore `Set.union` Set.map (\(PackageIdentifier p _) -> p) (hpcore hp) + let allPackages = Map.union (stablePackages settings) $ identsToRanges (hplibs hp) + let totalCore = extraCore settings `Set.union` Set.map (\(PackageIdentifier p _) -> p) (hpcore hp) pdb <- loadPackageDB totalCore allPackages final <- narrowPackageDB pdb $ Set.fromList $ Map.toList $ Map.map snd $ allPackages diff --git a/Stackage/Test.hs b/Stackage/Test.hs index 59d31e34..3ed22239 100644 --- a/Stackage/Test.hs +++ b/Stackage/Test.hs @@ -20,12 +20,12 @@ import System.Process (runProcess, waitForProcess) import Control.Exception (handle, Exception, throwIO) import Data.Typeable (Typeable) -runTestSuites :: FilePath -> InstallInfo -> IO () -runTestSuites root ii = do +runTestSuites :: BuildSettings -> InstallInfo -> IO () +runTestSuites settings ii = do let testdir = "runtests" rm_r testdir createDirectory testdir - allPass <- foldM (runTestSuite root testdir hasTestSuites) True $ Map.toList $ iiPackages ii + allPass <- foldM (runTestSuite settings testdir hasTestSuites) True $ Map.toList $ iiPackages ii unless allPass $ error $ "There were failures, please see the logs in " ++ testdir where PackageDB pdb = iiPackageDB ii @@ -48,16 +48,16 @@ data TestException = TestException deriving (Show, Typeable) instance Exception TestException -runTestSuite :: FilePath +runTestSuite :: BuildSettings -> FilePath -> (PackageName -> Bool) -- ^ do we have any test suites? -> Bool -> (PackageName, (Version, Maintainer)) -> IO Bool -runTestSuite root testdir hasTestSuites prevPassed (packageName, (version, Maintainer maintainer)) = do +runTestSuite settings testdir hasTestSuites prevPassed (packageName, (version, Maintainer maintainer)) = do -- Set up a new environment that includes the sandboxed bin folder in PATH. env' <- getEnvironment - let menv = Just $ map (fixEnv $ binDir root) env' + let menv = Just $ map (fixEnv $ binDir settings) env' let run cmd args wdir handle = do ph <- runProcess cmd args (Just wdir) menv Nothing (Just handle) (Just handle) @@ -66,13 +66,13 @@ runTestSuite root testdir hasTestSuites prevPassed (packageName, (version, Maint passed <- handle (\TestException -> return False) $ do getHandle WriteMode $ run "cabal" ["unpack", package] testdir - getHandle AppendMode $ run "cabal" (addCabalArgs root ["configure", "--enable-tests"]) dir + getHandle AppendMode $ run "cabal" (addCabalArgs settings ["configure", "--enable-tests"]) dir when (hasTestSuites packageName) $ do getHandle AppendMode $ run "cabal" ["build"] dir getHandle AppendMode $ run "cabal" ["test"] dir getHandle AppendMode $ run "cabal" ["haddock"] dir return True - let expectedFailure = packageName `Set.member` expectedFailures + let expectedFailure = packageName `Set.member` expectedFailures settings if passed then do removeFile logfile diff --git a/Stackage/Types.hs b/Stackage/Types.hs index 0f5b8477..ba8e80bb 100644 --- a/Stackage/Types.hs +++ b/Stackage/Types.hs @@ -53,3 +53,12 @@ data InstallInfo = InstallInfo -- | Email address of a Stackage maintainer. newtype Maintainer = Maintainer { unMaintainer :: String } deriving (Show, Eq, Ord) + +data BuildSettings = BuildSettings + { sandboxRoot :: FilePath + , extraBuildArgs :: [String] + , extraCore :: Set PackageName + , expectedFailures :: Set PackageName + , stablePackages :: Map PackageName (VersionRange, Maintainer) + , extraArgs :: [String] + } diff --git a/Stackage/Util.hs b/Stackage/Util.hs index a33396d0..4c9d66b8 100644 --- a/Stackage/Util.hs +++ b/Stackage/Util.hs @@ -69,14 +69,14 @@ getPackageVersion e = do defaultHasTestSuites :: Bool defaultHasTestSuites = True -packageDir = ( "package-db") -libDir = ( "lib") -binDir = ( "bin") +packageDir = ( "package-db") . sandboxRoot +libDir = ( "lib") . sandboxRoot +binDir = ( "bin") . sandboxRoot -addCabalArgs root rest +addCabalArgs settings rest = "--package-db=clear" : "--package-db=global" - : ("--package-db=" ++ packageDir root) - : ("--libdir=" ++ libDir root) - : ("--bindir=" ++ binDir root) - : rest + : ("--package-db=" ++ packageDir settings) + : ("--libdir=" ++ libDir settings) + : ("--bindir=" ++ binDir settings) + : extraArgs settings ++ rest diff --git a/app/stackage.hs b/app/stackage.hs index 853c5d75..3f8b8867 100644 --- a/app/stackage.hs +++ b/app/stackage.hs @@ -1,4 +1,4 @@ -import Stackage.Build (build) +import Stackage.Build (build, defaultBuildSettings) import Stackage.Init (stackageInit) import System.Environment (getArgs, getProgName) @@ -6,7 +6,7 @@ main :: IO () main = do args <- getArgs case args of - ["build"] -> build "sandbox" id + ["build"] -> build defaultBuildSettings ["init"] -> stackageInit ["update"] -> stackageInit >> error "FIXME update" _ -> do