From 4505cc8b6a51a5628509ac88f0f9c27e01827d9f Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Fri, 12 Dec 2014 11:25:44 +0200 Subject: [PATCH] LTS build executables --- Stackage2/CompleteBuild.hs | 124 +++++++++++++++++++++---- app/{lts-bump.hs => lts-major-bump.hs} | 2 +- app/lts-minor-bump.hs | 4 + stackage.cabal | 12 ++- 4 files changed, 122 insertions(+), 20 deletions(-) rename app/{lts-bump.hs => lts-major-bump.hs} (58%) create mode 100644 app/lts-minor-bump.hs diff --git a/Stackage2/CompleteBuild.hs b/Stackage2/CompleteBuild.hs index 503bf631..70b6dfeb 100644 --- a/Stackage2/CompleteBuild.hs +++ b/Stackage2/CompleteBuild.hs @@ -1,13 +1,16 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE RecordWildCards #-} module Stackage2.CompleteBuild ( BuildType (..) + , BumpType (..) , completeBuild ) where import Data.Default.Class (def) +import Data.Semigroup (Max (..), Option (..)) +import Data.Text.Read (decimal) import Data.Time -import Data.Yaml (encodeFile) +import Data.Yaml (decodeFileEither, encodeFile) import Network.HTTP.Client import Stackage2.BuildConstraints import Stackage2.BuildPlan @@ -19,15 +22,20 @@ import Stackage2.UpdateBuildPlan import Stackage2.Upload import System.IO (BufferMode (LineBuffering), hSetBuffering) -data BuildType = Nightly | LTS +data BuildType = Nightly | LTS BumpType + deriving (Show, Read, Eq, Ord) + +data BumpType = Major | Minor + deriving (Show, Read, Eq, Ord) data Settings = Settings - { plan :: BuildPlan - , planFile :: FilePath - , buildDir :: FilePath - , title :: Text -> Text -- ^ GHC version -> title - , slug :: Text - , setArgs :: Text -> UploadBundle -> UploadBundle + { plan :: BuildPlan + , planFile :: FilePath + , buildDir :: FilePath + , title :: Text -> Text -- ^ GHC version -> title + , slug :: Text + , setArgs :: Text -> UploadBundle -> UploadBundle + , postBuild :: IO () } getSettings :: BuildType -> IO Settings @@ -47,15 +55,90 @@ getSettings Nightly = do , slug = slug' , setArgs = \ghcVer ub -> ub { ubNightly = Just ghcVer } , plan = plan' + , postBuild = return () } +getSettings (LTS bumpType) = do + Option mlts <- fmap (fmap getMax) $ runResourceT + $ sourceDirectory "." + $$ foldMapC (Option . fmap Max . parseLTSVer . filename) + + (new, plan') <- case bumpType of + Major -> do + let new = + case mlts of + Nothing -> LTSVer 0 0 + Just old -> incrLTSVer old + plan' <- defaultBuildConstraints >>= newBuildPlan + 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 + return (new, plan') + + let newfile = renderLTSVer new + + return Settings + { planFile = newfile + , buildDir = fpFromText $ "/tmp/stackage-lts-" ++ tshow new + , title = \ghcVer -> concat + [ "LTS Haskell " + , tshow new + , ", GHC " + , ghcVer + ] + , slug = "lts-" ++ tshow new + , setArgs = \_ ub -> ub { ubLTS = Just $ tshow new } + , plan = plan' + , postBuild = do + let git args = withCheckedProcess + (proc "git" args) $ \ClosedStream Inherited Inherited -> + return () + putStrLn "Committing new LTS file to Git" + git ["add", fpToString newfile] + git ["commit", "Added new LTS release: " ++ show new] + putStrLn "Pushing to Git repository" + git ["push"] + } + +data LTSVer = LTSVer !Int !Int + deriving (Eq, Ord) +instance Show LTSVer where + show (LTSVer x y) = concat [show x, ".", show y] +incrLTSVer :: LTSVer -> LTSVer +incrLTSVer (LTSVer x y) = LTSVer x (y + 1) + +parseLTSVer :: FilePath -> Maybe LTSVer +parseLTSVer fp = do + w <- stripPrefix "lts-" $ fpToText fp + x <- stripSuffix ".yaml" w + Right (major, y) <- Just $ decimal x + z <- stripPrefix "." y + Right (minor, "") <- Just $ decimal z + return $ LTSVer major minor +renderLTSVer :: LTSVer -> FilePath +renderLTSVer lts = fpFromText $ concat + [ "lts-" + , tshow lts + , ".yaml" + ] completeBuild :: BuildType -> IO () completeBuild buildType = withManager defaultManagerSettings $ \man -> do hSetBuffering stdout LineBuffering + putStrLn $ "Loading settings for: " ++ tshow buildType Settings {..} <- getSettings buildType + + putStrLn $ "Writing build plan to: " ++ fpToText planFile encodeFile (fpToString planFile) plan + + putStrLn "Checking build plan" checkBuildPlan plan + + putStrLn "Performing build" let pb = PerformBuild { pbPlan = plan , pbInstallDest = buildDir @@ -65,24 +148,31 @@ completeBuild buildType = withManager defaultManagerSettings $ \man -> do } performBuild pb + putStrLn "Uploading bundle to Stackage Server" token <- readFile "/auth-token" now <- epochTime let ghcVer = display $ siGhcVersion $ bpSystemInfo plan ident <- flip uploadBundle man $ setArgs ghcVer def { ubContents = serverBundle now (title ghcVer) slug plan , ubAuthToken = decodeUtf8 token - , ubAlias = Just slug } + putStrLn $ "New ident: " ++ unSnapshotIdent ident - uploadDocs UploadDocs + putStrLn "Uploading docs to Stackage Server" + res1 <- uploadDocs UploadDocs { udServer = def , udAuthToken = decodeUtf8 token , udDocs = pbDocDir pb , udSnapshot = ident - } man >>= print + } man + putStrLn $ "Doc upload response: " ++ tshow res1 - creds <- readFile "/hackage-creds" - case map encodeUtf8 $ words $ decodeUtf8 creds of - [username, password] -> - uploadHackageDistro plan username password man >>= print - _ -> return () + ecreds <- tryIO $ readFile "/hackage-creds" + case map encodeUtf8 $ words $ decodeUtf8 $ either (const "") id ecreds of + [username, password] -> do + putStrLn "Uploading as Hackage distro" + res2 <- uploadHackageDistro plan username password man + putStrLn $ "Distro upload response: " ++ tshow res2 + _ -> putStrLn "No creds found, skipping Hackage distro upload" + + postBuild diff --git a/app/lts-bump.hs b/app/lts-major-bump.hs similarity index 58% rename from app/lts-bump.hs rename to app/lts-major-bump.hs index 14450f43..a165ac08 100644 --- a/app/lts-bump.hs +++ b/app/lts-major-bump.hs @@ -1,4 +1,4 @@ import Stackage2.CompleteBuild main :: IO () -main = completeBuild LTS +main = completeBuild (LTS Major) diff --git a/app/lts-minor-bump.hs b/app/lts-minor-bump.hs new file mode 100644 index 00000000..fe38d855 --- /dev/null +++ b/app/lts-minor-bump.hs @@ -0,0 +1,4 @@ +import Stackage2.CompleteBuild + +main :: IO () +main = completeBuild (LTS Minor) diff --git a/stackage.cabal b/stackage.cabal index 488be7fe..e7d2bf3f 100644 --- a/stackage.cabal +++ b/stackage.cabal @@ -74,6 +74,7 @@ library , mono-traversable , async , streaming-commons >= 0.1.7.1 + , semigroups executable stackage default-language: Haskell2010 @@ -90,10 +91,17 @@ executable stackage-nightly build-depends: base , stackage -executable lts-bump +executable lts-minor-bump default-language: Haskell2010 hs-source-dirs: app - main-is: lts-bump.hs + main-is: lts-minor-bump.hs + build-depends: base + , stackage + +executable lts-major-bump + default-language: Haskell2010 + hs-source-dirs: app + main-is: lts-major-bump.hs build-depends: base , stackage