From d625c4747bc4e4d9ec77ae1139a21d971aa66ed0 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Fri, 13 Mar 2015 12:33:07 +0200 Subject: [PATCH 1/4] Expect Haddock failure: gtk --- build-constraints.yaml | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/build-constraints.yaml b/build-constraints.yaml index 1b343254..4036dc18 100644 --- a/build-constraints.yaml +++ b/build-constraints.yaml @@ -1086,6 +1086,10 @@ expected-haddock-failures: # https://github.com/wereHamster/rethinkdb-client-driver/issues/1 - rethinkdb-client-driver + # Requires build before haddock, which doesn't always happen in incremental + # builds. Could consider special-casing this requirement. + - gtk + # Benchmarks which should not be built. Note that Stackage does *not* generally # build benchmarks. The difference here will be whether dependencies for these # benchmarks are included or not. From 8f74bbee495532162ab3d58225ff0a9661ccc019 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Sat, 14 Mar 2015 20:47:14 +0200 Subject: [PATCH 2/4] 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 3/4] 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: " From e80a8d0acfbdc47809cd6418f2aa791751ee916c Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Sun, 15 Mar 2015 15:46:58 +0200 Subject: [PATCH 4/4] Only create log files when needed Did this for two reasons: 1. Easier to read incremental output this way 2. I believe that, with incremental builds, we were running out of file descriptors in some cases due to so rapidly plowing through all of the packages. I'm not certain this was the source of the errors I was seeing, but given (1), it made sense to try this first. --- Stackage/PerformBuild.hs | 36 +++++++++++++++++++++++++----------- 1 file changed, 25 insertions(+), 11 deletions(-) diff --git a/Stackage/PerformBuild.hs b/Stackage/PerformBuild.hs index 02fa14b7..2b333044 100644 --- a/Stackage/PerformBuild.hs +++ b/Stackage/PerformBuild.hs @@ -30,7 +30,7 @@ import Stackage.Prelude hiding (pi) import System.Directory (findExecutable) import System.Environment (getEnvironment) import System.IO (IOMode (WriteMode), - withBinaryFile) + openBinaryFile) import System.IO.Temp (withSystemTempDirectory) data BuildException = BuildException (Map PackageName BuildFailure) [Text] @@ -291,11 +291,12 @@ singleBuild pb@PerformBuild {..} registeredPackages SingleBuild {..} = , display $ ppVersion $ piPlan sbPackageInfo ] - runIn wdir outH cmd args = - withCheckedProcess cp $ \ClosedStream UseProvidedHandle UseProvidedHandle -> + runIn wdir getOutH cmd args = do + outH <- getOutH + withCheckedProcess (cp outH) $ \ClosedStream UseProvidedHandle UseProvidedHandle -> (return () :: IO ()) where - cp = (proc (unpack $ asText cmd) (map (unpack . asText) args)) + cp outH = (proc (unpack $ asText cmd) (map (unpack . asText) args)) { cwd = Just $ fpToString wdir , std_out = UseHandle outH , std_err = UseHandle outH @@ -321,8 +322,21 @@ singleBuild pb@PerformBuild {..} registeredPackages SingleBuild {..} = testRunOut = pbLogDir fpFromText namever "test-run.out" wf fp inner' = do - createTree $ parent fp - withBinaryFile (fpToString fp) WriteMode inner' + ref <- newIORef Nothing + let cleanup = do + mh <- readIORef ref + forM_ mh hClose + getH = do + mh <- readIORef ref + case mh of + Just h -> return h + Nothing -> mask_ $ do + createTree $ parent fp + h <- openBinaryFile (fpToString fp) WriteMode + writeIORef ref $ Just h + return h + + inner' getH `finally` cleanup configArgs = ($ []) $ execWriter $ do when pbAllowNewer $ tell' "--allow-newer" @@ -350,15 +364,15 @@ singleBuild pb@PerformBuild {..} registeredPackages SingleBuild {..} = PackageConstraints {..} = ppConstraints $ piPlan sbPackageInfo - buildLibrary = wf libOut $ \outH -> do + buildLibrary = wf libOut $ \getOutH -> do let run a b = do when pbVerbose $ log' (unwords (a : b)) - runChild outH a b + runChild getOutH a b isUnpacked <- newIORef False let withUnpacked inner = do unlessM (readIORef isUnpacked) $ do log' $ "Unpacking " ++ namever - runParent outH "cabal" ["unpack", namever] + runParent getOutH "cabal" ["unpack", namever] writeIORef isUnpacked True inner @@ -440,8 +454,8 @@ singleBuild pb@PerformBuild {..} registeredPackages SingleBuild {..} = return withUnpacked - runTests withUnpacked = wf testOut $ \outH -> do - let run = runChild outH + runTests withUnpacked = wf testOut $ \getOutH -> do + let run = runChild getOutH prevTestResult <- getPreviousResult pb Test pident let needTest = pbEnableTests