@@ -1,13 +1,16 @@
11{-# LANGUAGE NoImplicitPrelude #-}
22{-# LANGUAGE OverloadedStrings #-}
3−{-# LANGUAGE RecordWildCards #-}
3+{-# LANGUAGE RecordWildCards #-}
44module Stackage2.CompleteBuild
55 ( BuildType (..)
6+ , BumpType (..)
67 , completeBuild
78 ) where
89import Data.Default.Class (def)
10+import Data.Semigroup (Max (..), Option (..))
11+import Data.Text.Read (decimal)
912import Data.Time
10−import Data.Yaml (encodeFile)
13+import Data.Yaml (decodeFileEither, encodeFile)
1114import Network.HTTP.Client
1215import Stackage2.BuildConstraints
1316import Stackage2.BuildPlan
@@ -19,15 +22,20 @@ import Stackage2.UpdateBuildPlan
1922import Stackage2.Upload
2023import System.IO (BufferMode (LineBuffering), hSetBuffering)
2124
22−data BuildType = Nightly | LTS
25+data BuildType = Nightly | LTS BumpType
26+ deriving (Show, Read, Eq, Ord)
27+
28+data BumpType = Major | Minor
29+ deriving (Show, Read, Eq, Ord)
2330
2431data Settings = Settings
25− { plan :: BuildPlan
26− , planFile :: FilePath
27− , buildDir :: FilePath
28− , title :: Text -> Text -- ^ GHC version -> title
29− , slug :: Text
30− , setArgs :: Text -> UploadBundle -> UploadBundle
32+ { plan :: BuildPlan
33+ , planFile :: FilePath
34+ , buildDir :: FilePath
35+ , title :: Text -> Text -- ^ GHC version -> title
36+ , slug :: Text
37+ , setArgs :: Text -> UploadBundle -> UploadBundle
38+ , postBuild :: IO ()
3139 }
3240
3341getSettings :: BuildType -> IO Settings
@@ -47,15 +55,90 @@ getSettings Nightly = do
4755 , slug = slug'
4856 , setArgs = \ghcVer ub -> ub { ubNightly = Just ghcVer }
4957 , plan = plan'
58+ , postBuild = return ()
5059 }
60+getSettings (LTS bumpType) = do
61+ Option mlts <- fmap (fmap getMax) $ runResourceT
62+ $ sourceDirectory "."
63+ $$ foldMapC (Option . fmap Max . parseLTSVer . filename)
64+
65+ (new, plan') <- case bumpType of
66+ Major -> do
67+ let new =
68+ case mlts of
69+ Nothing -> LTSVer 0 0
70+ Just old -> incrLTSVer old
71+ plan' <- defaultBuildConstraints >>= newBuildPlan
72+ return (new, plan')
73+ Minor -> do
74+ old <- maybe (error "No LTS plans found in current directory") return mlts
75+ oldplan <- decodeFileEither (fpToString $ renderLTSVer old)
76+ >>= either throwM return
77+ let new = incrLTSVer old
78+ plan' <- updateBuildPlan oldplan
79+ return (new, plan')
80+
81+ let newfile = renderLTSVer new
82+
83+ return Settings
84+ { planFile = newfile
85+ , buildDir = fpFromText $ "/tmp/stackage-lts-" ++ tshow new
86+ , title = \ghcVer -> concat
87+ [ "LTS Haskell "
88+ , tshow new
89+ , ", GHC "
90+ , ghcVer
91+ ]
92+ , slug = "lts-" ++ tshow new
93+ , setArgs = \_ ub -> ub { ubLTS = Just $ tshow new }
94+ , plan = plan'
95+ , postBuild = do
96+ let git args = withCheckedProcess
97+ (proc "git" args) $ \ClosedStream Inherited Inherited ->
98+ return ()
99+ putStrLn "Committing new LTS file to Git"
100+ git ["add", fpToString newfile]
101+ git ["commit", "Added new LTS release: " ++ show new]
102+ putStrLn "Pushing to Git repository"
103+ git ["push"]
104+ }
105+
106+data LTSVer = LTSVer !Int !Int
107+ deriving (Eq, Ord)
108+instance Show LTSVer where
109+ show (LTSVer x y) = concat [show x, ".", show y]
110+incrLTSVer :: LTSVer -> LTSVer
111+incrLTSVer (LTSVer x y) = LTSVer x (y + 1)
112+
113+parseLTSVer :: FilePath -> Maybe LTSVer
114+parseLTSVer fp = do
115+ w <- stripPrefix "lts-" $ fpToText fp
116+ x <- stripSuffix ".yaml" w
117+ Right (major, y) <- Just $ decimal x
118+ z <- stripPrefix "." y
119+ Right (minor, "") <- Just $ decimal z
120+ return $ LTSVer major minor
121+renderLTSVer :: LTSVer -> FilePath
122+renderLTSVer lts = fpFromText $ concat
123+ [ "lts-"
124+ , tshow lts
125+ , ".yaml"
126+ ]
51127
52128completeBuild :: BuildType -> IO ()
53129completeBuild buildType = withManager defaultManagerSettings $ \man -> do
54130 hSetBuffering stdout LineBuffering
55131
132+ putStrLn $ "Loading settings for: " ++ tshow buildType
56133 Settings {..} <- getSettings buildType
134+
135+ putStrLn $ "Writing build plan to: " ++ fpToText planFile
57136 encodeFile (fpToString planFile) plan
137+
138+ putStrLn "Checking build plan"
58139 checkBuildPlan plan
140+
141+ putStrLn "Performing build"
59142 let pb = PerformBuild
60143 { pbPlan = plan
61144 , pbInstallDest = buildDir
@@ -65,24 +148,31 @@ completeBuild buildType = withManager defaultManagerSettings $ \man -> do
65148 }
66149 performBuild pb
67150
151+ putStrLn "Uploading bundle to Stackage Server"
68152 token <- readFile "/auth-token"
69153 now <- epochTime
70154 let ghcVer = display $ siGhcVersion $ bpSystemInfo plan
71155 ident <- flip uploadBundle man $ setArgs ghcVer def
72156 { ubContents = serverBundle now (title ghcVer) slug plan
73157 , ubAuthToken = decodeUtf8 token
74− , ubAlias = Just slug
75158 }
159+ putStrLn $ "New ident: " ++ unSnapshotIdent ident
76160
77− uploadDocs UploadDocs
161+ putStrLn "Uploading docs to Stackage Server"
162+ res1 <- uploadDocs UploadDocs
78163 { udServer = def
79164 , udAuthToken = decodeUtf8 token
80165 , udDocs = pbDocDir pb
81166 , udSnapshot = ident
82− } man >>= print
167+ } man
168+ putStrLn $ "Doc upload response: " ++ tshow res1
169+
170+ ecreds <- tryIO $ readFile "/hackage-creds"
171+ case map encodeUtf8 $ words $ decodeUtf8 $ either (const "") id ecreds of
172+ [username, password] -> do
173+ putStrLn "Uploading as Hackage distro"
174+ res2 <- uploadHackageDistro plan username password man
175+ putStrLn $ "Distro upload response: " ++ tshow res2
176+ _ -> putStrLn "No creds found, skipping Hackage distro upload"
83177
84− creds <- readFile "/hackage-creds"
85− case map encodeUtf8 $ words $ decodeUtf8 creds of
86− [username, password] ->
87− uploadHackageDistro plan username password man >>= print
88− _ -> return ()
178+ postBuild