From eadca478ae0e3161308c64e0cc63e342ad3d303d Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Thu, 12 Mar 2015 14:26:16 +0200 Subject: [PATCH 1/8] 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 From f5bd0c777d99734bbb69b54bf98aeaff69eb8fee Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Thu, 12 Mar 2015 16:59:57 +0200 Subject: [PATCH 2/8] Add expected test failure network-anonymous-i2p --- build-constraints.yaml | 3 +++ 1 file changed, 3 insertions(+) diff --git a/build-constraints.yaml b/build-constraints.yaml index 7655b963..1b343254 100644 --- a/build-constraints.yaml +++ b/build-constraints.yaml @@ -1069,6 +1069,9 @@ expected-test-failures: # Problems with linking with system libraries on Ubuntu 12.04 - nettle + # Requires locally running services + - network-anonymous-i2p + # Haddocks which are expected to fail. Same concept as expected test failures. expected-haddock-failures: # https://github.com/acw/bytestring-progress/issues/4 From e75b014b8b207330cd5d487010bf72daafc95e4e Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Thu, 12 Mar 2015 17:00:56 +0200 Subject: [PATCH 3/8] Delete old Haddocks when unregistering --- Stackage/GhcPkg.hs | 19 ++++++++++++------- Stackage/PerformBuild.hs | 2 +- 2 files changed, 13 insertions(+), 8 deletions(-) diff --git a/Stackage/GhcPkg.hs b/Stackage/GhcPkg.hs index 4985d2f2..c741e96a 100644 --- a/Stackage/GhcPkg.hs +++ b/Stackage/GhcPkg.hs @@ -18,19 +18,21 @@ import qualified Filesystem.Path.CurrentOS as FP import Data.Map (Map) import Data.Version (Version) import Stackage.Prelude +import Filesystem (removeTree) setupPackageDatabase :: Maybe FilePath -- ^ database location, Nothing if using global DB + -> FilePath -- ^ documentation root -> Map PackageName Version -- ^ packages and versions to be installed -> IO (Set PackageName) -- ^ packages remaining in the database after cleanup -setupPackageDatabase mdb toInstall = do +setupPackageDatabase mdb docDir toInstall = do registered1 <- getRegisteredPackages flags - forM_ registered1 $ \(PackageIdentifier name version) -> + forM_ registered1 $ \pi@(PackageIdentifier name version) -> case lookup name toInstall of - Just version' | version /= version' -> unregisterPackage flags name + Just version' | version /= version' -> unregisterPackage docDir flags pi _ -> return () broken <- getBrokenPackages flags - forM_ broken $ \(PackageIdentifier name _) -> unregisterPackage flags name + forM_ broken $ unregisterPackage docDir flags foldMap (\(PackageIdentifier name _) -> singletonSet name) <$> getRegisteredPackages flags where @@ -71,9 +73,12 @@ parsePackageIdent = fmap fst . readP_to_S parse . T.unpack -- | Unregister a package. -unregisterPackage :: [String] -> PackageName -> IO () -unregisterPackage flags ident = do +unregisterPackage :: FilePath -- ^ doc directory + -> [String] -> PackageIdentifier -> IO () +unregisterPackage docDir flags ident@(PackageIdentifier name _) = do void (readProcessWithExitCode "ghc-pkg" - ("unregister": flags ++ ["--force", unpack $ display ident]) + ("unregister": flags ++ ["--force", unpack $ display name]) "") + + void $ tryIO $ removeTree $ docDir fpFromText (display ident) diff --git a/Stackage/PerformBuild.hs b/Stackage/PerformBuild.hs index fe8dac4a..5597cd63 100644 --- a/Stackage/PerformBuild.hs +++ b/Stackage/PerformBuild.hs @@ -194,6 +194,7 @@ performBuild' pb@PerformBuild {..} = withBuildDir $ \builddir -> do registeredPackages <- setupPackageDatabase (pbDatabase pb) + (pbDocDir pb) (ppVersion <$> bpPackages pbPlan) forM_ packageMap $ \pi -> void $ async $ singleBuild pb registeredPackages @@ -366,7 +367,6 @@ singleBuild pb@PerformBuild {..} registeredPackages SingleBuild {..} = unless (pname `member` registeredPackages) $ withConfiged $ do deletePreviousResults pb pname - -- FIXME delete old Haddocks? log' $ "Building " ++ namever run "cabal" ["build"] From 75faf6126bfb566efe5e837c571c2b7a295504ab Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Thu, 12 Mar 2015 17:57:43 +0200 Subject: [PATCH 4/8] Add logging when unregistering a package --- Stackage/GhcPkg.hs | 18 ++++++++++++------ Stackage/PerformBuild.hs | 1 + 2 files changed, 13 insertions(+), 6 deletions(-) diff --git a/Stackage/GhcPkg.hs b/Stackage/GhcPkg.hs index c741e96a..f6c3eccf 100644 --- a/Stackage/GhcPkg.hs +++ b/Stackage/GhcPkg.hs @@ -1,7 +1,10 @@ {-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} -- | General commands related to ghc-pkg. -module Stackage.GhcPkg where +module Stackage.GhcPkg + ( setupPackageDatabase + ) where import Data.Conduit import qualified Data.Conduit.List as CL @@ -23,16 +26,17 @@ import Filesystem (removeTree) setupPackageDatabase :: Maybe FilePath -- ^ database location, Nothing if using global DB -> FilePath -- ^ documentation root + -> (ByteString -> IO ()) -- ^ logging -> Map PackageName Version -- ^ packages and versions to be installed -> IO (Set PackageName) -- ^ packages remaining in the database after cleanup -setupPackageDatabase mdb docDir toInstall = do +setupPackageDatabase mdb docDir log' toInstall = do registered1 <- getRegisteredPackages flags forM_ registered1 $ \pi@(PackageIdentifier name version) -> case lookup name toInstall of - Just version' | version /= version' -> unregisterPackage docDir flags pi + Just version' | version /= version' -> unregisterPackage log' docDir flags pi _ -> return () broken <- getBrokenPackages flags - forM_ broken $ unregisterPackage docDir flags + forM_ broken $ unregisterPackage log' docDir flags foldMap (\(PackageIdentifier name _) -> singletonSet name) <$> getRegisteredPackages flags where @@ -73,9 +77,11 @@ parsePackageIdent = fmap fst . readP_to_S parse . T.unpack -- | Unregister a package. -unregisterPackage :: FilePath -- ^ doc directory +unregisterPackage :: (ByteString -> IO ()) -- ^ log func + -> FilePath -- ^ doc directory -> [String] -> PackageIdentifier -> IO () -unregisterPackage docDir flags ident@(PackageIdentifier name _) = do +unregisterPackage log' docDir flags ident@(PackageIdentifier name _) = do + log' $ "Unregistering " ++ encodeUtf8 (display ident) void (readProcessWithExitCode "ghc-pkg" ("unregister": flags ++ ["--force", unpack $ display name]) diff --git a/Stackage/PerformBuild.hs b/Stackage/PerformBuild.hs index 5597cd63..7a627a55 100644 --- a/Stackage/PerformBuild.hs +++ b/Stackage/PerformBuild.hs @@ -195,6 +195,7 @@ performBuild' pb@PerformBuild {..} = withBuildDir $ \builddir -> do registeredPackages <- setupPackageDatabase (pbDatabase pb) (pbDocDir pb) + pbLog (ppVersion <$> bpPackages pbPlan) forM_ packageMap $ \pi -> void $ async $ singleBuild pb registeredPackages From 351c03b8812f291f5625d3f8b6d5b096a44a7fe9 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Fri, 13 Mar 2015 08:39:50 +0200 Subject: [PATCH 5/8] Use PackageIdentifier --- Stackage/GhcPkg.hs | 2 +- Stackage/PerformBuild.hs | 27 +++++++++++++++------------ 2 files changed, 16 insertions(+), 13 deletions(-) diff --git a/Stackage/GhcPkg.hs b/Stackage/GhcPkg.hs index f6c3eccf..1e5171d8 100644 --- a/Stackage/GhcPkg.hs +++ b/Stackage/GhcPkg.hs @@ -81,7 +81,7 @@ unregisterPackage :: (ByteString -> IO ()) -- ^ log func -> FilePath -- ^ doc directory -> [String] -> PackageIdentifier -> IO () unregisterPackage log' docDir flags ident@(PackageIdentifier name _) = do - log' $ "Unregistering " ++ encodeUtf8 (display ident) + log' $ "Unregistering " ++ encodeUtf8 (display ident) ++ "\n" void (readProcessWithExitCode "ghc-pkg" ("unregister": flags ++ ["--force", unpack $ display name]) diff --git a/Stackage/PerformBuild.hs b/Stackage/PerformBuild.hs index 7a627a55..e43d0d5a 100644 --- a/Stackage/PerformBuild.hs +++ b/Stackage/PerformBuild.hs @@ -281,6 +281,7 @@ singleBuild pb@PerformBuild {..} registeredPackages SingleBuild {..} = wfd testComps (runTests withUnpacked) pname = piName sbPackageInfo + pident = PackageIdentifier pname (ppVersion $ piPlan sbPackageInfo) name = display pname namever = concat [ name @@ -385,7 +386,7 @@ singleBuild pb@PerformBuild {..} registeredPackages SingleBuild {..} = -- dependency's haddocks before this finishes atomically $ putTMVar (piResult sbPackageInfo) True - prevHaddockResult <- getPreviousResult pb Haddock pname + prevHaddockResult <- getPreviousResult pb Haddock pident let needHaddock = pbEnableHaddock && checkPrevResult prevHaddockResult pcHaddocks && not (null $ sdModules $ ppDesc $ piPlan sbPackageInfo) @@ -424,7 +425,7 @@ singleBuild pb@PerformBuild {..} registeredPackages SingleBuild {..} = $ modifyTVar sbHaddockFiles $ insertMap namever newPath - savePreviousResult pb Haddock pname $ either (const False) (const True) eres + savePreviousResult pb Haddock pident $ either (const False) (const True) eres case (eres, pcHaddocks) of (Left e, ExpectSuccess) -> throwM e (Right (), ExpectFailure) -> warn $ namever ++ ": unexpected Haddock success" @@ -435,7 +436,7 @@ singleBuild pb@PerformBuild {..} registeredPackages SingleBuild {..} = runTests withUnpacked = wf testOut $ \outH -> do let run = runChild outH - prevTestResult <- getPreviousResult pb Test pname + prevTestResult <- getPreviousResult pb Test pident let needTest = pbEnableTests && checkPrevResult prevTestResult pcTests when needTest $ withUnpacked $ do @@ -449,7 +450,7 @@ singleBuild pb@PerformBuild {..} registeredPackages SingleBuild {..} = log' $ "Test run " ++ namever run "cabal" ["test", "--log=" ++ fpToText testRunOut] - savePreviousResult pb Test pname $ either (const False) (const True) eres + savePreviousResult pb Test pident $ either (const False) (const True) eres case (eres, pcTests) of (Left e, ExpectSuccess) -> throwM e (Right (), ExpectFailure) -> warn $ namever ++ ": unexpected test success" @@ -501,26 +502,28 @@ data ResultType = Haddock | Test -- | The result generated on a previous run data PrevResult = PRNoResult | PRSuccess | PRFailure + deriving (Show, Enum, Eq, Ord, Bounded, Read) -- | Check if we should rerun based on a PrevResult and the expected status +checkPrevResult :: PrevResult -> TestState -> Bool 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 +withPRPath :: PerformBuild -> ResultType -> PackageIdentifier -> (FilePath -> IO a) -> IO a +withPRPath pb rt ident inner = do createTree $ parent fp inner fp where - fp = pbPrevResDir pb fpFromString (show rt) fpFromString name + fp = pbPrevResDir pb fpFromString (show rt) fpFromText (display ident) successBS, failureBS :: ByteString successBS = "success" failureBS = "failure" -getPreviousResult :: PerformBuild -> ResultType -> PackageName -> IO PrevResult +getPreviousResult :: PerformBuild -> ResultType -> PackageIdentifier -> IO PrevResult getPreviousResult w x y = withPRPath w x y $ \fp -> do eres <- tryIO $ readFile fp return $ case eres of @@ -529,12 +532,12 @@ getPreviousResult w x y = withPRPath w x y $ \fp -> do | bs == failureBS -> PRFailure _ -> PRNoResult -savePreviousResult :: PerformBuild -> ResultType -> PackageName -> Bool -> IO () -savePreviousResult pb rt name res = - withPRPath pb rt name $ \fp -> writeFile fp $ +savePreviousResult :: PerformBuild -> ResultType -> PackageIdentifier -> Bool -> IO () +savePreviousResult pb rt ident res = + withPRPath pb rt ident $ \fp -> writeFile fp $ if res then successBS else failureBS -deletePreviousResults :: PerformBuild -> PackageName -> IO () +deletePreviousResults :: PerformBuild -> PackageIdentifier -> IO () deletePreviousResults pb name = forM_ [minBound..maxBound] $ \rt -> withPRPath pb rt name $ \fp -> From cd0e717aab6478b91265512e56336c4441478970 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Fri, 13 Mar 2015 08:40:16 +0200 Subject: [PATCH 6/8] File for store build results --- Stackage/PerformBuild.hs | 10 +++++++--- 1 file changed, 7 insertions(+), 3 deletions(-) diff --git a/Stackage/PerformBuild.hs b/Stackage/PerformBuild.hs index e43d0d5a..1aef3af3 100644 --- a/Stackage/PerformBuild.hs +++ b/Stackage/PerformBuild.hs @@ -367,8 +367,10 @@ singleBuild pb@PerformBuild {..} registeredPackages SingleBuild {..} = writeIORef isConfiged True inner - unless (pname `member` registeredPackages) $ withConfiged $ do - deletePreviousResults pb pname + prevBuildResult <- getPreviousResult pb Build pident + unless (prevBuildResult == PRSuccess) $ withConfiged $ do + assert (pname `notMember` registeredPackages) $ do + deletePreviousResults pb pident log' $ "Building " ++ namever run "cabal" ["build"] @@ -378,6 +380,8 @@ singleBuild pb@PerformBuild {..} registeredPackages SingleBuild {..} = withMVar sbRegisterMutex $ const $ run "cabal" ["register"] + savePreviousResult pb Build pident True + -- Even if the tests later fail, we can allow other libraries to build -- on top of our successful results -- @@ -497,7 +501,7 @@ copyBuiltInHaddocks docdir = do ------------- Previous results -- | The previous actions that can be run -data ResultType = Haddock | Test +data ResultType = Build | Haddock | Test deriving (Show, Enum, Eq, Ord, Bounded, Read) -- | The result generated on a previous run From 8f74bbee495532162ab3d58225ff0a9661ccc019 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Sat, 14 Mar 2015 20:47:14 +0200 Subject: [PATCH 7/8] Delete previous results when unregistering Previously, package install status was determined by checking the package database. However, this didn't work for executables, so I switched it to keep explicit track of build results. I forgot to then clear those results when unregistering a package. Pinging @manny-fp @chrisdone --- Stackage/GhcPkg.hs | 11 +++++++---- Stackage/PerformBuild.hs | 1 + 2 files changed, 8 insertions(+), 4 deletions(-) diff --git a/Stackage/GhcPkg.hs b/Stackage/GhcPkg.hs index 1e5171d8..8f9f9431 100644 --- a/Stackage/GhcPkg.hs +++ b/Stackage/GhcPkg.hs @@ -28,15 +28,16 @@ setupPackageDatabase -> FilePath -- ^ documentation root -> (ByteString -> IO ()) -- ^ logging -> Map PackageName Version -- ^ packages and versions to be installed + -> (PackageIdentifier -> IO ()) -- ^ callback to be used when unregistering a package -> IO (Set PackageName) -- ^ packages remaining in the database after cleanup -setupPackageDatabase mdb docDir log' toInstall = do +setupPackageDatabase mdb docDir log' toInstall onUnregister = do registered1 <- getRegisteredPackages flags forM_ registered1 $ \pi@(PackageIdentifier name version) -> case lookup name toInstall of - Just version' | version /= version' -> unregisterPackage log' docDir flags pi + Just version' | version /= version' -> unregisterPackage log' onUnregister docDir flags pi _ -> return () broken <- getBrokenPackages flags - forM_ broken $ unregisterPackage log' docDir flags + forM_ broken $ unregisterPackage log' onUnregister docDir flags foldMap (\(PackageIdentifier name _) -> singletonSet name) <$> getRegisteredPackages flags where @@ -78,10 +79,12 @@ parsePackageIdent = fmap fst . -- | Unregister a package. unregisterPackage :: (ByteString -> IO ()) -- ^ log func + -> (PackageIdentifier -> IO ()) -- ^ callback to be used when unregistering a package -> FilePath -- ^ doc directory -> [String] -> PackageIdentifier -> IO () -unregisterPackage log' docDir flags ident@(PackageIdentifier name _) = do +unregisterPackage log' onUnregister docDir flags ident@(PackageIdentifier name _) = do log' $ "Unregistering " ++ encodeUtf8 (display ident) ++ "\n" + onUnregister ident void (readProcessWithExitCode "ghc-pkg" ("unregister": flags ++ ["--force", unpack $ display name]) diff --git a/Stackage/PerformBuild.hs b/Stackage/PerformBuild.hs index d922dab9..02fa14b7 100644 --- a/Stackage/PerformBuild.hs +++ b/Stackage/PerformBuild.hs @@ -198,6 +198,7 @@ performBuild' pb@PerformBuild {..} = withBuildDir $ \builddir -> do (pbDocDir pb) pbLog (ppVersion <$> bpPackages pbPlan) + (deletePreviousResults pb) forM_ packageMap $ \pi -> void $ async $ singleBuild pb registeredPackages SingleBuild From eef9c14d248d2e3ad696078e8843894dbf8a4b7c Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Sun, 15 Mar 2015 15:29:47 +0200 Subject: [PATCH 8/8] Delete libraries when unregistering Pinging @manny-fp --- Stackage/GhcPkg.hs | 11 +++++++++++ 1 file changed, 11 insertions(+) diff --git a/Stackage/GhcPkg.hs b/Stackage/GhcPkg.hs index 8f9f9431..27b7f9e1 100644 --- a/Stackage/GhcPkg.hs +++ b/Stackage/GhcPkg.hs @@ -85,9 +85,20 @@ unregisterPackage :: (ByteString -> IO ()) -- ^ log func unregisterPackage log' onUnregister docDir flags ident@(PackageIdentifier name _) = do log' $ "Unregistering " ++ encodeUtf8 (display ident) ++ "\n" onUnregister ident + + -- Delete libraries + sourceProcessWithConsumer + (proc "ghc-pkg" ("describe" : flags ++ [unpack $ display ident])) + (CT.decodeUtf8 + $= CT.lines + $= CL.mapMaybe parseLibraryDir + $= CL.mapM_ (void . tryIO . removeTree)) + void (readProcessWithExitCode "ghc-pkg" ("unregister": flags ++ ["--force", unpack $ display name]) "") void $ tryIO $ removeTree $ docDir fpFromText (display ident) + where + parseLibraryDir = fmap fpFromText . stripPrefix "library-dirs: "