diff --git a/Stackage/CompleteBuild.hs b/Stackage/CompleteBuild.hs index ab9c3a3b..80693dad 100644 --- a/Stackage/CompleteBuild.hs +++ b/Stackage/CompleteBuild.hs @@ -68,7 +68,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 " @@ -121,7 +121,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..27b7f9e1 --- /dev/null +++ b/Stackage/GhcPkg.hs @@ -0,0 +1,104 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +-- | General commands related to ghc-pkg. + +module Stackage.GhcPkg + ( setupPackageDatabase + ) 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 +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 + -> (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 onUnregister = do + registered1 <- getRegisteredPackages flags + forM_ registered1 $ \pi@(PackageIdentifier name version) -> + case lookup name toInstall of + Just version' | version /= version' -> unregisterPackage log' onUnregister docDir flags pi + _ -> return () + broken <- getBrokenPackages flags + forM_ broken $ unregisterPackage log' onUnregister docDir flags + 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 :: (ByteString -> IO ()) -- ^ log func + -> (PackageIdentifier -> IO ()) -- ^ callback to be used when unregistering a package + -> FilePath -- ^ doc directory + -> [String] -> PackageIdentifier -> IO () +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: " diff --git a/Stackage/PerformBuild.hs b/Stackage/PerformBuild.hs index e25094c6..02fa14b7 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) @@ -135,6 +136,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 @@ -162,12 +167,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) @@ -187,7 +193,15 @@ performBuild' pb@PerformBuild {..} = withBuildDir $ \builddir -> do env <- getEnvironment haddockFiles <- newTVarIO mempty - forM_ packageMap $ \pi -> void $ async $ singleBuild pb SingleBuild + registeredPackages <- setupPackageDatabase + (pbDatabase pb) + (pbDocDir pb) + pbLog + (ppVersion <$> bpPackages pbPlan) + (deletePreviousResults pb) + + forM_ packageMap $ \pi -> void $ async $ singleBuild pb registeredPackages + SingleBuild { sbSem = sem , sbErrsVar = errsVar , sbWarningsVar = warningsVar @@ -249,8 +263,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)) @@ -262,11 +278,13 @@ 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 + pident = PackageIdentifier pname (ppVersion $ piPlan sbPackageInfo) + name = display pname namever = concat [ name , "-" @@ -335,19 +353,37 @@ 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"] + prevBuildResult <- getPreviousResult pb Build pident + unless (prevBuildResult == PRSuccess) $ withConfiged $ do + assert (pname `notMember` registeredPackages) $ do + deletePreviousResults pb pident + + log' $ "Building " ++ namever + run "cabal" ["build"] + + log' $ "Copying/registering " ++ namever + run "cabal" ["copy"] + 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 @@ -357,7 +393,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 pident + 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 @@ -392,15 +432,21 @@ singleBuild pb@PerformBuild {..} SingleBuild {..} = $ modifyTVar sbHaddockFiles $ insertMap namever newPath + 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" _ -> 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 pident + let needTest = pbEnableTests + && checkPrevResult prevTestResult pcTests + when needTest $ withUnpacked $ do log' $ "Test configure " ++ namever run "cabal" $ "configure" : "--enable-tests" : configArgs @@ -411,6 +457,7 @@ singleBuild pb@PerformBuild {..} SingleBuild {..} = log' $ "Test run " ++ namever run "cabal" ["test", "--log=" ++ fpToText testRunOut] + 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" @@ -453,3 +500,52 @@ 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 = Build | Haddock | Test + deriving (Show, Enum, Eq, Ord, Bounded, Read) + +-- | 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 -> PackageIdentifier -> (FilePath -> IO a) -> IO a +withPRPath pb rt ident inner = do + createTree $ parent fp + inner fp + where + fp = pbPrevResDir pb fpFromString (show rt) fpFromText (display ident) + +successBS, failureBS :: ByteString +successBS = "success" +failureBS = "failure" + +getPreviousResult :: PerformBuild -> ResultType -> PackageIdentifier -> 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 -> PackageIdentifier -> Bool -> IO () +savePreviousResult pb rt ident res = + withPRPath pb rt ident $ \fp -> writeFile fp $ + if res then successBS else failureBS + +deletePreviousResults :: PerformBuild -> PackageIdentifier -> 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