stackage 0.4.0 → 0.5.0
raw patch · 10 files changed
+301/−68 lines, 10 filesdep ~containers
Dependency ranges changed: containers
Files
- ChangeLog.md +6/−0
- Stackage/BuildConstraints.hs +1/−0
- Stackage/BuildPlan.hs +10/−3
- Stackage/CheckBuildPlan.hs +60/−9
- Stackage/CompleteBuild.hs +86/−38
- Stackage/PerformBuild.hs +3/−0
- Stackage/UpdateBuildPlan.hs +3/−2
- app/stackage.hs +14/−1
- stackage.cabal +1/−1
- test/Stackage/BuildPlanSpec.hs +117/−14
ChangeLog.md view
@@ -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
Stackage/BuildConstraints.hs view
@@ -10,6 +10,7 @@ , SystemInfo (..) , getSystemInfo , defaultBuildConstraints+ , toBC ) where import Control.Monad.Writer.Strict (execWriter, tell)
Stackage/BuildPlan.hs view
@@ -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)
Stackage/CheckBuildPlan.hs view
@@ -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
Stackage/CompleteBuild.hs view
@@ -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
Stackage/PerformBuild.hs view
@@ -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
Stackage/UpdateBuildPlan.hs view
@@ -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 {..} =
app/stackage.hs view
@@ -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")
stackage.cabal view
@@ -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 <http://www.stackage.org/package/stackage> for a description and documentation. homepage: https://github.com/fpco/stackage
test/Stackage/BuildPlanSpec.hs view
@@ -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"