diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,9 @@ +## 0.5.0 + +* Print "Still Alive" while checking, to avoid Travis timeouts +* Include `stackage upload-nightly` command +* Optional plan checking + ## 0.4.0 * Command line uses optparse-applicative with additional options diff --git a/Stackage/BuildConstraints.hs b/Stackage/BuildConstraints.hs --- a/Stackage/BuildConstraints.hs +++ b/Stackage/BuildConstraints.hs @@ -10,6 +10,7 @@ , SystemInfo (..) , getSystemInfo , defaultBuildConstraints + , toBC ) where import Control.Monad.Writer.Strict (execWriter, tell) diff --git a/Stackage/BuildPlan.hs b/Stackage/BuildPlan.hs --- a/Stackage/BuildPlan.hs +++ b/Stackage/BuildPlan.hs @@ -14,6 +14,7 @@ , PackagePlan (..) , newBuildPlan , makeToolMap + , getLatestAllowedPlans ) where import Control.Monad.State.Strict (execState, get, put) @@ -90,9 +91,9 @@ ppDesc <- o .: "description" return PackagePlan {..} -newBuildPlan :: MonadIO m => BuildConstraints -> m BuildPlan -newBuildPlan bc@BuildConstraints {..} = liftIO $ do - packagesOrig <- getLatestDescriptions (isAllowed bc) (mkPackagePlan bc) +-- | Make a build plan given these package set and build constraints. +newBuildPlan :: MonadIO m => Map PackageName PackagePlan -> BuildConstraints -> m BuildPlan +newBuildPlan packagesOrig bc@BuildConstraints {..} = liftIO $ do let toolMap = makeToolMap packagesOrig packages = populateUsers $ removeUnincluded bc toolMap packagesOrig toolNames :: [ExeName] @@ -205,3 +206,9 @@ getFlag MkFlag {..} = (flagName, fromMaybe flagDefault $ lookup flagName overrides) flags = mapFromList $ map getFlag $ genPackageFlags gpd + +getLatestAllowedPlans :: MonadIO m => BuildConstraints -> m (Map PackageName PackagePlan) +getLatestAllowedPlans bc = + getLatestDescriptions + (isAllowed bc) + (mkPackagePlan bc) diff --git a/Stackage/CheckBuildPlan.hs b/Stackage/CheckBuildPlan.hs --- a/Stackage/CheckBuildPlan.hs +++ b/Stackage/CheckBuildPlan.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE TupleSections #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE NoImplicitPrelude #-} @@ -7,28 +8,38 @@ -- | Confirm that a build plan has a consistent set of dependencies. module Stackage.CheckBuildPlan ( checkBuildPlan + , BadBuildPlan ) where import Control.Monad.Writer.Strict (Writer, execWriter, tell) -import qualified Data.Text as T +import qualified Data.Map.Strict as M +import qualified Data.Text as T import Stackage.BuildConstraints import Stackage.BuildPlan import Stackage.PackageDescription import Stackage.Prelude --- FIXME check cycles in dependencies, only looking at libraries and --- executables - -checkBuildPlan :: MonadThrow m => BuildPlan -> m () +-- | Check the build plan for missing deps, wrong versions, etc. +checkBuildPlan :: (MonadThrow m) => BuildPlan -> m () checkBuildPlan BuildPlan {..} | null errs' = return () | otherwise = throwM errs where - allPackages = siCorePackages bpSystemInfo ++ map ppVersion bpPackages + allPackages = map (,mempty) (siCorePackages bpSystemInfo) ++ + map (ppVersion &&& M.keys . M.filter libAndExe . sdPackages . ppDesc) bpPackages errs@(BadBuildPlan errs') = execWriter $ mapM_ (checkDeps allPackages) $ mapToList bpPackages + -- Only looking at libraries and executables, benchmarks and tests + -- are allowed to create cycles (e.g. test-framework depends on + -- text, which uses test-framework in its test-suite). + libAndExe (DepInfo cs _) = any (flip elem [CompLibrary,CompExecutable]) cs -checkDeps :: Map PackageName Version +-- | For a given package name and plan, check that its dependencies are: +-- +-- 1. Existent (existing in the provided package map) +-- 2. Within version range +-- 3. Check for dependency cycles. +checkDeps :: Map PackageName (Version,[PackageName]) -> (PackageName, PackagePlan) -> Writer BadBuildPlan () checkDeps allPackages (user, pb) = @@ -37,8 +48,16 @@ go (dep, diRange -> range) = case lookup dep allPackages of Nothing -> tell $ BadBuildPlan $ singletonMap (dep, Nothing) errMap - Just version - | version `withinRange` range -> return () + Just (version,deps) + | version `withinRange` range -> + occursCheck allPackages + (\d v -> + tell $ BadBuildPlan $ singletonMap + (d,v) + errMap) + dep + deps + [] | otherwise -> tell $ BadBuildPlan $ singletonMap (dep, Just version) errMap @@ -50,6 +69,38 @@ , puMaintainer = pcMaintainer $ ppConstraints pb , puGithubPings = ppGithubPings pb } + +-- | Check whether the package(s) occurs within its own dependency +-- tree. +occursCheck + :: Monad m + => Map PackageName (Version,[PackageName]) + -- ^ All packages. + -> (PackageName -> Maybe Version -> m ()) + -- ^ Report an erroneous package. + -> PackageName + -- ^ Starting package to check for cycles in. + -> [PackageName] + -- ^ Dependencies of the package. + -> [PackageName] + -- ^ Previously seen packages up the dependency tree. + -> m () +occursCheck allPackages reportError = + go + where + go pkg deps seen = + case find (flip elem seen) deps of + Just cyclic -> + reportError cyclic $ + fmap fst (lookup cyclic allPackages) + Nothing -> + forM_ deps $ + \pkg' -> + case lookup pkg' allPackages of + Just (_v,deps') + | pkg' /= pkg -> go pkg' deps' seen' + _ -> return () + where seen' = pkg : seen data PkgUser = PkgUser { puName :: PackageName diff --git a/Stackage/CompleteBuild.hs b/Stackage/CompleteBuild.hs --- a/Stackage/CompleteBuild.hs +++ b/Stackage/CompleteBuild.hs @@ -7,7 +7,11 @@ , BuildFlags (..) , completeBuild , justCheck + , justUploadNightly ) where + +import Control.Concurrent (threadDelay) +import Control.Concurrent.Async (withAsync) import Data.Default.Class (def) import Data.Semigroup (Max (..), Option (..)) import Data.Text.Read (decimal) @@ -31,6 +35,7 @@ , bfDoUpload :: !Bool , bfEnableLibProfile :: !Bool , bfVerbose :: !Bool + , bfSkipCheck :: !Bool } deriving (Show) data BuildType = Nightly | LTS BumpType @@ -50,26 +55,38 @@ , postBuild :: IO () } +nightlyPlanFile :: Text -- ^ day + -> FilePath +nightlyPlanFile day = fpFromText ("nightly-" ++ day) <.> "yaml" + +nightlySettings :: Text -- ^ day + -> BuildPlan + -> Settings +nightlySettings day plan' = Settings + { planFile = nightlyPlanFile day + , buildDir = fpFromText $ "builds/stackage-nightly-" ++ day + , logDir = fpFromText $ "logs/stackage-nightly-" ++ day + , title = \ghcVer -> concat + [ "Stackage Nightly " + , day + , ", GHC " + , ghcVer + ] + , slug = slug' + , setArgs = \ghcVer ub -> ub { ubNightly = Just ghcVer } + , plan = plan' + , postBuild = return () + } + where + slug' = "nightly-" ++ day + getSettings :: Manager -> BuildType -> IO Settings getSettings man Nightly = do day <- tshow . utctDay <$> getCurrentTime - let slug' = "nightly-" ++ day - plan' <- defaultBuildConstraints man >>= newBuildPlan - return Settings - { planFile = fpFromText ("nightly-" ++ day) <.> "yaml" - , buildDir = fpFromText $ "builds/stackage-nightly-" ++ day - , logDir = fpFromText $ "logs/stackage-nightly-" ++ day - , title = \ghcVer -> concat - [ "Stackage Nightly " - , day - , ", GHC " - , ghcVer - ] - , slug = slug' - , setArgs = \ghcVer ub -> ub { ubNightly = Just ghcVer } - , plan = plan' - , postBuild = return () - } + bc <- defaultBuildConstraints man + pkgs <- getLatestAllowedPlans bc + plan' <- newBuildPlan pkgs bc + return $ nightlySettings day plan' getSettings man (LTS bumpType) = do Option mlts <- fmap (fmap getMax) $ runResourceT $ sourceDirectory "." @@ -81,14 +98,18 @@ case mlts of Nothing -> LTSVer 0 0 Just (LTSVer x _) -> LTSVer (x + 1) 0 - plan' <- defaultBuildConstraints man >>= newBuildPlan + bc <- defaultBuildConstraints man + pkgs <- getLatestAllowedPlans bc + plan' <- newBuildPlan pkgs bc return (new, plan') Minor -> do old <- maybe (error "No LTS plans found in current directory") return mlts oldplan <- decodeFileEither (fpToString $ renderLTSVer old) >>= either throwM return let new = incrLTSVer old - plan' <- updateBuildPlan oldplan + let bc = updateBuildConstraints oldplan + pkgs <- getLatestAllowedPlans bc + plan' <- newBuildPlan pkgs bc return (new, plan') let newfile = renderLTSVer new @@ -139,16 +160,27 @@ , ".yaml" ] +-- | Just print a message saying "still alive" every minute, to appease Travis. +stillAlive :: IO () -> IO () +stillAlive inner = + withAsync (printer 1) $ const inner + where + printer i = forever $ do + threadDelay 60000000 + putStrLn $ "Still alive: " ++ tshow i + printer $! i + 1 + -- | Generate and check a new build plan, but do not execute it. -- -- Since 0.3.1 justCheck :: IO () -justCheck = withManager tlsManagerSettings $ \man -> do +justCheck = stillAlive $ withManager tlsManagerSettings $ \man -> do putStrLn "Loading build constraints" bc <- defaultBuildConstraints man putStrLn "Creating build plan" - plan <- newBuildPlan bc + plans <- getLatestAllowedPlans bc + plan <- newBuildPlan plans bc putStrLn $ "Writing build plan to check-plan.yaml" encodeFile "check-plan.yaml" plan @@ -158,6 +190,20 @@ putStrLn "Plan seems valid!" +getPerformBuild :: BuildFlags -> Settings -> PerformBuild +getPerformBuild buildFlags Settings {..} = PerformBuild + { pbPlan = plan + , pbInstallDest = buildDir + , pbLogDir = logDir + , pbLog = hPut stdout + , pbJobs = 8 + , pbGlobalInstall = False + , pbEnableTests = bfEnableTests buildFlags + , pbEnableLibProfiling = bfEnableLibProfile buildFlags + , pbVerbose = bfVerbose buildFlags + , pbAllowNewer = bfSkipCheck buildFlags + } + -- | Make a complete plan, build, test and upload bundle, docs and -- distro. completeBuild :: BuildType -> BuildFlags -> IO () @@ -170,30 +216,30 @@ putStrLn $ "Writing build plan to: " ++ fpToText planFile encodeFile (fpToString planFile) plan - putStrLn "Checking build plan" - checkBuildPlan plan + if bfSkipCheck buildFlags + then putStrLn "Skipping build plan check" + else do + putStrLn "Checking build plan" + checkBuildPlan plan putStrLn "Performing build" - let pb = PerformBuild - { pbPlan = plan - , pbInstallDest = buildDir - , pbLogDir = logDir - , pbLog = hPut stdout - , pbJobs = 8 - , pbGlobalInstall = False - , pbEnableTests = bfEnableTests buildFlags - , pbEnableLibProfiling = bfEnableLibProfile buildFlags - , pbVerbose = bfVerbose buildFlags - } - performBuild pb >>= mapM_ putStrLn + performBuild (getPerformBuild buildFlags settings) >>= mapM_ putStrLn when (bfDoUpload buildFlags) $ - finallyUpload settings man pb + finallyUpload settings man +justUploadNightly + :: Text -- ^ nightly date + -> IO () +justUploadNightly day = do + plan <- decodeFileEither (fpToString $ nightlyPlanFile day) + >>= either throwM return + withManager tlsManagerSettings $ finallyUpload $ nightlySettings day plan + -- | The final part of the complete build process: uploading a bundle, -- docs and a distro to hackage. -finallyUpload :: Settings -> Manager -> PerformBuild -> IO () -finallyUpload Settings{..} man pb = do +finallyUpload :: Settings -> Manager -> IO () +finallyUpload settings@Settings{..} man = do putStrLn "Uploading bundle to Stackage Server" token <- readFile "/auth-token" now <- epochTime @@ -233,3 +279,5 @@ , udmDocDir = pbDocDir pb , udmPlan = plan } man >>= print + where + pb = getPerformBuild (error "finallyUpload.buildFlags") settings diff --git a/Stackage/PerformBuild.hs b/Stackage/PerformBuild.hs --- a/Stackage/PerformBuild.hs +++ b/Stackage/PerformBuild.hs @@ -64,6 +64,8 @@ , pbEnableTests :: Bool , pbEnableLibProfiling :: Bool , pbVerbose :: Bool + , pbAllowNewer :: Bool + -- ^ Pass --allow-newer to cabal configure } data PackageInfo = PackageInfo @@ -293,6 +295,7 @@ withBinaryFile (fpToString fp) WriteMode inner' configArgs = ($ []) $ execWriter $ do + when pbAllowNewer $ tell' "--allow-newer" tell' "--package-db=clear" tell' "--package-db=global" forM_ (pbDatabase pb) $ \db -> tell' $ "--package-db=" ++ fpToText db diff --git a/Stackage/UpdateBuildPlan.hs b/Stackage/UpdateBuildPlan.hs --- a/Stackage/UpdateBuildPlan.hs +++ b/Stackage/UpdateBuildPlan.hs @@ -15,8 +15,9 @@ import Stackage.BuildPlan import Stackage.Prelude -updateBuildPlan :: BuildPlan -> IO BuildPlan -updateBuildPlan = newBuildPlan . updateBuildConstraints +updateBuildPlan :: Map PackageName PackagePlan -> BuildPlan -> IO BuildPlan +updateBuildPlan packagesOrig + = newBuildPlan packagesOrig . updateBuildConstraints updateBuildConstraints :: BuildPlan -> BuildConstraints updateBuildConstraints BuildPlan {..} = diff --git a/app/stackage.hs b/app/stackage.hs --- a/app/stackage.hs +++ b/app/stackage.hs @@ -4,6 +4,7 @@ import Control.Monad import Data.Monoid +import Data.String (fromString) import Data.Version import Options.Applicative import Paths_stackage (version) @@ -46,6 +47,11 @@ "lts-minor" "Build, test and upload the LTS (minor) snapshot" , cmnd + justUploadNightly + nightlyUploadFlags + "upload-nightly" + "Upload an already-built nightly snapshot" + , cmnd (const justCheck) (pure ()) "check" @@ -72,4 +78,11 @@ help "Enable profiling when building") <*> switch (long "verbose" <> short 'v' <> - help "Output verbose detail about the build steps") + help "Output verbose detail about the build steps") <*> + switch + (long "skip-check" <> + help "Skip the check phase, and pass --allow-newer to cabal configure") + + nightlyUploadFlags = fromString <$> strArgument + (metavar "DATE" <> + help "Date, in YYYY-MM-DD format") diff --git a/stackage.cabal b/stackage.cabal --- a/stackage.cabal +++ b/stackage.cabal @@ -1,5 +1,5 @@ name: stackage -version: 0.4.0 +version: 0.5.0 synopsis: "Stable Hackage," tools for creating a vetted set of packages from Hackage. description: Please see for a description and documentation. homepage: https://github.com/fpco/stackage diff --git a/test/Stackage/BuildPlanSpec.hs b/test/Stackage/BuildPlanSpec.hs --- a/test/Stackage/BuildPlanSpec.hs +++ b/test/Stackage/BuildPlanSpec.hs @@ -1,21 +1,64 @@ +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE OverloadedStrings, NoImplicitPrelude #-} module Stackage.BuildPlanSpec (spec) where -import Stackage.BuildPlan -import Stackage.Prelude -import Stackage.BuildConstraints -import Stackage.UpdateBuildPlan -import Test.Hspec -import qualified Data.Yaml as Y -import Distribution.Version (anyVersion) import qualified Data.Map as Map -import Network.HTTP.Client (withManager) -import Network.HTTP.Client.TLS (tlsManagerSettings) +import qualified Data.Map.Strict as M +import qualified Data.Set as S +import Data.Yaml +import qualified Data.Yaml as Y +import Distribution.Version +import Network.HTTP.Client +import Network.HTTP.Client.TLS (tlsManagerSettings) +import Stackage.BuildConstraints +import Stackage.BuildPlan +import Stackage.CheckBuildPlan +import Stackage.PackageDescription +import Stackage.Prelude +import Stackage.UpdateBuildPlan +import Test.Hspec spec :: Spec -spec = it "works" $ withManager tlsManagerSettings $ \man -> do - bc <- defaultBuildConstraints man - bp <- newBuildPlan bc +spec = do + it "simple package set" $ check testBuildConstraints $ makePackageSet + [("foo", [0, 0, 0], [("bar", thisV [0, 0, 0])]) + ,("bar", [0, 0, 0], [])] + it "bad version range on depdendency fails" $ badBuildPlan $ makePackageSet + [("foo", [0, 0, 0], [("bar", thisV [1, 1, 0])]) + ,("bar", [0, 0, 0], [])] + it "nonexistent package fails to check" $ badBuildPlan $ makePackageSet + [("foo", [0, 0, 0], [("nonexistent", thisV [0, 0, 0])]) + ,("bar", [0, 0, 0], [])] + it "mutual cycles fail to check" $ badBuildPlan $ makePackageSet + [("foo", [0, 0, 0], [("bar", thisV [0, 0, 0])]) + ,("bar", [0, 0, 0], [("foo", thisV [0, 0, 0])])] + it "nested cycles fail to check" $ badBuildPlan $ makePackageSet + [("foo", [0, 0, 0], [("bar", thisV [0, 0, 0])]) + ,("bar", [0, 0, 0], [("mu", thisV [0, 0, 0])]) + ,("mu", [0, 0, 0], [("foo", thisV [0, 0, 0])])] + it "default package set checks ok" $ + check defaultBuildConstraints getLatestAllowedPlans + +-- | Checking should be considered a bad build plan. +badBuildPlan :: (BuildConstraints -> IO (Map PackageName PackagePlan)) + -> void + -> IO () +badBuildPlan m _ = do + mu <- try (check testBuildConstraints m) + case mu of + Left (_ :: BadBuildPlan) -> + return () + Right () -> + error "Expected bad build plan." + +-- | Check build plan with the given package set getter. +check :: (Manager -> IO BuildConstraints) + -> (BuildConstraints -> IO (Map PackageName PackagePlan)) + -> IO () +check readPlanFile getPlans = withManager tlsManagerSettings $ \man -> do + bc <- readPlanFile man + plans <- getPlans bc + bp <- newBuildPlan plans bc let bs = Y.encode bp ebp' = Y.decodeEither bs @@ -25,14 +68,74 @@ forM_ allPackages $ \name -> (name, lookup name (bpPackages bp')) `shouldBe` (name, lookup name (bpPackages bp)) - bpGithubUsers bp' `shouldBe` bpGithubUsers bp + when (bp' /= bp) $ error "bp' /= bp" - bp2 <- updateBuildPlan bp + bp2 <- updateBuildPlan plans bp when (dropVersionRanges bp2 /= dropVersionRanges bp) $ error "bp2 /= bp" + checkBuildPlan bp where dropVersionRanges bp = bp { bpPackages = map go $ bpPackages bp } where go pb = pb { ppConstraints = go' $ ppConstraints pb } go' pc = pc { pcVersionRange = anyVersion } + +-- | Make a package set from a convenient data structure. +makePackageSet + :: [(String,[Int],[(String,VersionRange)])] + -> BuildConstraints + -> IO (Map PackageName PackagePlan) +makePackageSet ps _ = + return $ + M.fromList $ + map + (\(name,ver,deps) -> + ( PackageName name + , dummyPackage ver $ + M.fromList $ + map + (\(dname,dver) -> + ( PackageName dname + , DepInfo {diComponents = S.fromList + [CompLibrary] + ,diRange = dver})) + deps)) + ps + where + dummyPackage v deps = + PackagePlan + {ppVersion = Version v [] + ,ppGithubPings = mempty + ,ppUsers = mempty + ,ppConstraints = + PackageConstraints + {pcVersionRange = anyV + ,pcMaintainer = Nothing + ,pcTests = Don'tBuild + ,pcHaddocks = Don'tBuild + ,pcBuildBenchmarks = False + ,pcFlagOverrides = mempty + ,pcEnableLibProfile = False} + ,ppDesc = + SimpleDesc + {sdPackages = deps + ,sdTools = mempty + ,sdProvidedExes = mempty + ,sdModules = mempty}} + +-- | This exact version is required. +thisV :: [Int] -> VersionRange +thisV ver = thisVersion (Version ver []) + +-- | Accept any version. +anyV :: VersionRange +anyV = anyVersion + +-- | Test plan. +testBuildConstraints :: void -> IO BuildConstraints +testBuildConstraints _ = + decodeFileEither + (fpToString fp) >>= + either throwIO toBC + where fp = "test/test-build-constraints.yaml"