From eadca478ae0e3161308c64e0cc63e342ad3d303d Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Thu, 12 Mar 2015 14:26:16 +0200 Subject: [PATCH] First stab an incremental builds Pinging @chrisdone --- Stackage/CompleteBuild.hs | 4 +- Stackage/GhcPkg.hs | 79 ++++++++++++++++++++++ Stackage/PerformBuild.hs | 137 +++++++++++++++++++++++++++++++------- stackage.cabal | 2 + 4 files changed, 195 insertions(+), 27 deletions(-) create mode 100644 Stackage/GhcPkg.hs diff --git a/Stackage/CompleteBuild.hs b/Stackage/CompleteBuild.hs index 341be2b4..97e8ba72 100644 --- a/Stackage/CompleteBuild.hs +++ b/Stackage/CompleteBuild.hs @@ -67,7 +67,7 @@ nightlySettings :: Text -- ^ day -> Settings nightlySettings day plan' = Settings { planFile = nightlyPlanFile day - , buildDir = fpFromText $ "builds/stackage-nightly-" ++ day + , buildDir = fpFromText $ "builds/nightly" , logDir = fpFromText $ "logs/stackage-nightly-" ++ day , title = \ghcVer -> concat [ "Stackage Nightly " @@ -120,7 +120,7 @@ getSettings man (LTS bumpType) = do return Settings { planFile = newfile - , buildDir = fpFromText $ "builds/stackage-lts-" ++ tshow new + , buildDir = fpFromText $ "builds/lts" , logDir = fpFromText $ "logs/stackage-lts-" ++ tshow new , title = \ghcVer -> concat [ "LTS Haskell " diff --git a/Stackage/GhcPkg.hs b/Stackage/GhcPkg.hs new file mode 100644 index 00000000..4985d2f2 --- /dev/null +++ b/Stackage/GhcPkg.hs @@ -0,0 +1,79 @@ +{-# LANGUAGE NoImplicitPrelude #-} +-- | General commands related to ghc-pkg. + +module Stackage.GhcPkg where + +import Data.Conduit +import qualified Data.Conduit.List as CL +import Data.Conduit.Process +import qualified Data.Conduit.Text as CT +import Data.Maybe +import Data.Text (Text) +import qualified Data.Text as T +import Distribution.Compat.ReadP +import Distribution.Package +import Distribution.Text (parse) +import Filesystem.Path.CurrentOS (FilePath) +import qualified Filesystem.Path.CurrentOS as FP +import Data.Map (Map) +import Data.Version (Version) +import Stackage.Prelude + +setupPackageDatabase + :: Maybe FilePath -- ^ database location, Nothing if using global DB + -> Map PackageName Version -- ^ packages and versions to be installed + -> IO (Set PackageName) -- ^ packages remaining in the database after cleanup +setupPackageDatabase mdb toInstall = do + registered1 <- getRegisteredPackages flags + forM_ registered1 $ \(PackageIdentifier name version) -> + case lookup name toInstall of + Just version' | version /= version' -> unregisterPackage flags name + _ -> return () + broken <- getBrokenPackages flags + forM_ broken $ \(PackageIdentifier name _) -> unregisterPackage flags name + foldMap (\(PackageIdentifier name _) -> singletonSet name) + <$> getRegisteredPackages flags + where + flags = ghcPkgFlags mdb + +ghcPkgFlags :: Maybe FilePath -> [String] +ghcPkgFlags mdb = + "--no-user-package-db" : + case mdb of + Nothing -> ["--global"] + Just fp -> ["--package-db=" ++ fpToString fp] + +-- | Get broken packages. +getBrokenPackages :: [String] -> IO [PackageIdentifier] +getBrokenPackages flags = do + (_,ps) <- sourceProcessWithConsumer + (proc + "ghc-pkg" + ("check" : "--simple-output" : flags)) + (CT.decodeUtf8 $= CT.lines $= CL.consume) + return (mapMaybe parsePackageIdent (T.words (T.unlines ps))) + +-- | Get available packages. +getRegisteredPackages :: [String] -> IO [PackageIdentifier] +getRegisteredPackages flags = do + (_,ps) <- sourceProcessWithConsumer + (proc + "ghc-pkg" + ("list" : "--simple-output" : flags)) + (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 :: [String] -> PackageName -> IO () +unregisterPackage flags ident = do + void (readProcessWithExitCode + "ghc-pkg" + ("unregister": flags ++ ["--force", unpack $ display ident]) + "") diff --git a/Stackage/PerformBuild.hs b/Stackage/PerformBuild.hs index e38f8e62..fe8dac4a 100644 --- a/Stackage/PerformBuild.hs +++ b/Stackage/PerformBuild.hs @@ -19,11 +19,12 @@ import qualified Data.Map as Map import Data.NonNull (fromNullable) import Filesystem (canonicalizePath, createTree, getWorkingDirectory, isDirectory, - removeTree, rename) + removeTree, rename, isFile, removeFile) import Filesystem.Path (parent) import qualified Filesystem.Path as F import Stackage.BuildConstraints import Stackage.BuildPlan +import Stackage.GhcPkg import Stackage.PackageDescription import Stackage.Prelude hiding (pi) import System.Directory (findExecutable) @@ -134,6 +135,10 @@ pbLibDir pb = pbInstallDest pb "lib" pbDataDir pb = pbInstallDest pb "share" pbDocDir pb = pbInstallDest pb "doc" +-- | Directory keeping previous result info +pbPrevResDir :: PerformBuild -> FilePath +pbPrevResDir pb = pbInstallDest pb "prevres" + performBuild :: PerformBuild -> IO [Text] performBuild pb = do cwd <- getWorkingDirectory @@ -161,12 +166,13 @@ performBuild' pb@PerformBuild {..} = withBuildDir $ \builddir -> do $ \ClosedStream Inherited Inherited -> return () let removeTree' fp = whenM (isDirectory fp) (removeTree fp) - mapM_ removeTree' [pbInstallDest, pbLogDir] + removeTree' pbLogDir - forM_ (pbDatabase pb) $ \db -> do - createTree $ parent db - withCheckedProcess (proc "ghc-pkg" ["init", fpToString db]) - $ \ClosedStream Inherited Inherited -> return () + forM_ (pbDatabase pb) $ \db -> + unlessM (isFile $ db "package.cache") $ do + createTree $ parent db + withCheckedProcess (proc "ghc-pkg" ["init", fpToString db]) + $ \ClosedStream Inherited Inherited -> return () pbLog $ encodeUtf8 "Copying built-in Haddocks\n" copyBuiltInHaddocks (pbDocDir pb) @@ -186,7 +192,12 @@ performBuild' pb@PerformBuild {..} = withBuildDir $ \builddir -> do env <- getEnvironment haddockFiles <- newTVarIO mempty - forM_ packageMap $ \pi -> void $ async $ singleBuild pb SingleBuild + registeredPackages <- setupPackageDatabase + (pbDatabase pb) + (ppVersion <$> bpPackages pbPlan) + + forM_ packageMap $ \pi -> void $ async $ singleBuild pb registeredPackages + SingleBuild { sbSem = sem , sbErrsVar = errsVar , sbWarningsVar = warningsVar @@ -248,8 +259,10 @@ data SingleBuild = SingleBuild , sbHaddockFiles :: TVar (Map Text FilePath) -- ^ package-version, .haddock file } -singleBuild :: PerformBuild -> SingleBuild -> IO () -singleBuild pb@PerformBuild {..} SingleBuild {..} = +singleBuild :: PerformBuild + -> Set PackageName -- ^ registered packages + -> SingleBuild -> IO () +singleBuild pb@PerformBuild {..} registeredPackages SingleBuild {..} = withCounter sbActive $ handle updateErrs $ (`finally` void (atomically $ tryPutTMVar (piResult sbPackageInfo) False)) @@ -261,11 +274,12 @@ singleBuild pb@PerformBuild {..} SingleBuild {..} = let wfd comps = waitForDeps sbToolMap sbPackageMap comps pbPlan sbPackageInfo . withTSem sbSem - wfd libComps buildLibrary + withUnpacked <- wfd libComps buildLibrary - wfd testComps runTests + wfd testComps (runTests withUnpacked) - name = display $ piName sbPackageInfo + pname = piName sbPackageInfo + name = display pname namever = concat [ name , "-" @@ -333,19 +347,34 @@ singleBuild pb@PerformBuild {..} SingleBuild {..} = buildLibrary = wf libOut $ \outH -> do let run a b = do when pbVerbose $ log' (unwords (a : b)) runChild outH a b - log' $ "Unpacking " ++ namever - runParent outH "cabal" ["unpack", namever] - log' $ "Configuring " ++ namever - run "cabal" $ "configure" : configArgs + isUnpacked <- newIORef False + let withUnpacked inner = do + unlessM (readIORef isUnpacked) $ do + log' $ "Unpacking " ++ namever + runParent outH "cabal" ["unpack", namever] + writeIORef isUnpacked True + inner - log' $ "Building " ++ namever - run "cabal" ["build"] + isConfiged <- newIORef False + let withConfiged inner = withUnpacked $ do + unlessM (readIORef isConfiged) $ do + log' $ "Configuring " ++ namever + run "cabal" $ "configure" : configArgs + writeIORef isConfiged True + inner - log' $ "Copying/registering " ++ namever - run "cabal" ["copy"] - withMVar sbRegisterMutex $ const $ - run "cabal" ["register"] + unless (pname `member` registeredPackages) $ withConfiged $ do + deletePreviousResults pb pname + -- FIXME delete old Haddocks? + + log' $ "Building " ++ namever + run "cabal" ["build"] + + log' $ "Copying/registering " ++ namever + run "cabal" ["copy"] + withMVar sbRegisterMutex $ const $ + run "cabal" ["register"] -- Even if the tests later fail, we can allow other libraries to build -- on top of our successful results @@ -355,7 +384,11 @@ singleBuild pb@PerformBuild {..} SingleBuild {..} = -- dependency's haddocks before this finishes atomically $ putTMVar (piResult sbPackageInfo) True - when (pbEnableHaddock && pcHaddocks /= Don'tBuild && not (null $ sdModules $ ppDesc $ piPlan sbPackageInfo)) $ do + prevHaddockResult <- getPreviousResult pb Haddock pname + let needHaddock = pbEnableHaddock + && checkPrevResult prevHaddockResult pcHaddocks + && not (null $ sdModules $ ppDesc $ piPlan sbPackageInfo) + when needHaddock $ withConfiged $ do log' $ "Haddocks " ++ namever hfs <- readTVarIO sbHaddockFiles let hfsOpts = flip map (mapToList hfs) $ \(pkgVer, hf) -> concat @@ -390,15 +423,21 @@ singleBuild pb@PerformBuild {..} SingleBuild {..} = $ modifyTVar sbHaddockFiles $ insertMap namever newPath + savePreviousResult pb Haddock pname $ either (const False) (const True) eres case (eres, pcHaddocks) of (Left e, ExpectSuccess) -> throwM e (Right (), ExpectFailure) -> warn $ namever ++ ": unexpected Haddock success" _ -> return () - runTests = wf testOut $ \outH -> do + return withUnpacked + + runTests withUnpacked = wf testOut $ \outH -> do let run = runChild outH - when (pbEnableTests && pcTests /= Don'tBuild) $ do + prevTestResult <- getPreviousResult pb Test pname + let needTest = pbEnableTests + && checkPrevResult prevTestResult pcTests + when needTest $ withUnpacked $ do log' $ "Test configure " ++ namever run "cabal" $ "configure" : "--enable-tests" : configArgs @@ -409,6 +448,7 @@ singleBuild pb@PerformBuild {..} SingleBuild {..} = log' $ "Test run " ++ namever run "cabal" ["test", "--log=" ++ fpToText testRunOut] + savePreviousResult pb Test pname $ either (const False) (const True) eres case (eres, pcTests) of (Left e, ExpectSuccess) -> throwM e (Right (), ExpectFailure) -> warn $ namever ++ ": unexpected test success" @@ -451,3 +491,50 @@ copyBuiltInHaddocks docdir = do src <- canonicalizePath (parent (fpFromString ghc) "../share/doc/ghc/html/libraries") copyDir src docdir + +------------- Previous results + +-- | The previous actions that can be run +data ResultType = Haddock | Test + deriving (Show, Enum, Eq, Ord, Bounded, Read) + +-- | The result generated on a previous run +data PrevResult = PRNoResult | PRSuccess | PRFailure + +-- | Check if we should rerun based on a PrevResult and the expected status +checkPrevResult _ Don'tBuild = False +checkPrevResult PRNoResult _ = True +checkPrevResult PRSuccess _ = False +checkPrevResult PRFailure ExpectSuccess = True +checkPrevResult PRFailure _ = False + +withPRPath :: PerformBuild -> ResultType -> PackageName -> (FilePath -> IO a) -> IO a +withPRPath pb rt (PackageName name) inner = do + createTree $ parent fp + inner fp + where + fp = pbPrevResDir pb fpFromString (show rt) fpFromString name + +successBS, failureBS :: ByteString +successBS = "success" +failureBS = "failure" + +getPreviousResult :: PerformBuild -> ResultType -> PackageName -> IO PrevResult +getPreviousResult w x y = withPRPath w x y $ \fp -> do + eres <- tryIO $ readFile fp + return $ case eres of + Right bs + | bs == successBS -> PRSuccess + | bs == failureBS -> PRFailure + _ -> PRNoResult + +savePreviousResult :: PerformBuild -> ResultType -> PackageName -> Bool -> IO () +savePreviousResult pb rt name res = + withPRPath pb rt name $ \fp -> writeFile fp $ + if res then successBS else failureBS + +deletePreviousResults :: PerformBuild -> PackageName -> IO () +deletePreviousResults pb name = + forM_ [minBound..maxBound] $ \rt -> + withPRPath pb rt name $ \fp -> + void $ tryIO $ removeFile fp diff --git a/stackage.cabal b/stackage.cabal index 94b42da9..2dec3030 100644 --- a/stackage.cabal +++ b/stackage.cabal @@ -23,6 +23,7 @@ library Stackage.BuildPlan Stackage.CheckBuildPlan Stackage.UpdateBuildPlan + Stackage.GhcPkg Stackage.GithubPings Stackage.InstallBuild Stackage.PackageDescription @@ -63,6 +64,7 @@ library , streaming-commons >= 0.1.7.1 , semigroups , xml-conduit + , conduit executable stackage default-language: Haskell2010