git.iko.soy/stackage
on 4761d55 help sign in
stackage/Stackage/CompleteBuild.hs
293 lines 9.6 kB history raw
1{-# LANGUAGE NoImplicitPrelude #-}
2{-# LANGUAGE OverloadedStrings #-}
3{-# LANGUAGE RecordWildCards #-}
4module Stackage.CompleteBuild
5 ( BuildType (..)
6 , BumpType (..)
7 , BuildFlags (..)
8 , completeBuild
9 , justCheck
10 , justUploadNightly
11 ) where
13import Control.Concurrent (threadDelay)
14import Control.Concurrent.Async (withAsync)
15import Data.Default.Class (def)
16import Data.Semigroup (Max (..), Option (..))
17import Data.Text.Read (decimal)
18import Data.Time
19import Data.Yaml (decodeFileEither, encodeFile)
20import Network.HTTP.Client
21import Network.HTTP.Client.TLS (tlsManagerSettings)
22import Stackage.BuildConstraints
23import Stackage.BuildPlan
24import Stackage.CheckBuildPlan
25import Stackage.PerformBuild
26import Stackage.Prelude
27import Stackage.ServerBundle
28import Stackage.UpdateBuildPlan
29import Stackage.Upload
30import System.Environment (lookupEnv)
31import System.IO (BufferMode (LineBuffering), hSetBuffering)
33-- | Flags passed in from the command line.
34data BuildFlags = BuildFlags
35 { bfEnableTests :: !Bool
36 , bfDoUpload :: !Bool
37 , bfEnableLibProfile :: !Bool
38 , bfVerbose :: !Bool
39 , bfSkipCheck :: !Bool
40 } deriving (Show)
42data BuildType = Nightly | LTS BumpType
43 deriving (Show, Read, Eq, Ord)
45data BumpType = Major | Minor
46 deriving (Show, Read, Eq, Ord)
48data Settings = Settings
49 { plan :: BuildPlan
50 , planFile :: FilePath
51 , buildDir :: FilePath
52 , logDir :: FilePath
53 , title :: Text -> Text -- ^ GHC version -> title
54 , slug :: Text
55 , setArgs :: Text -> UploadBundle -> UploadBundle
56 , postBuild :: IO ()
57 , distroName :: Text -- ^ distro name on Hackage
58 }
60nightlyPlanFile :: Text -- ^ day
61 -> FilePath
62nightlyPlanFile day = fpFromText ("nightly-" ++ day) <.> "yaml"
64nightlySettings :: Text -- ^ day
65 -> BuildPlan
66 -> Settings
67nightlySettings day plan' = Settings
68 { planFile = nightlyPlanFile day
69 , buildDir = fpFromText $ "builds/stackage-nightly-" ++ day
70 , logDir = fpFromText $ "logs/stackage-nightly-" ++ day
71 , title = \ghcVer -> concat
72 [ "Stackage Nightly "
73 , day
74 , ", GHC "
75 , ghcVer
76 ]
77 , slug = slug'
78 , setArgs = \ghcVer ub -> ub { ubNightly = Just ghcVer }
79 , plan = plan'
80 , postBuild = return ()
81 , distroName = "Stackage"
82 }
83 where
84 slug' = "nightly-" ++ day
86getSettings :: Manager -> BuildType -> IO Settings
87getSettings man Nightly = do
88 day <- tshow . utctDay <$> getCurrentTime
89 bc <- defaultBuildConstraints man
90 pkgs <- getLatestAllowedPlans bc
91 plan' <- newBuildPlan pkgs bc
92 return $ nightlySettings day plan'
93getSettings man (LTS bumpType) = do
94 Option mlts <- fmap (fmap getMax) $ runResourceT
95 $ sourceDirectory "."
96 $$ foldMapC (Option . fmap Max . parseLTSVer . filename)
98 (new, plan') <- case bumpType of
99 Major -> do
100 let new =
101 case mlts of
102 Nothing -> LTSVer 0 0
103 Just (LTSVer x _) -> LTSVer (x + 1) 0
104 bc <- defaultBuildConstraints man
105 pkgs <- getLatestAllowedPlans bc
106 plan' <- newBuildPlan pkgs bc
107 return (new, plan')
108 Minor -> do
109 old <- maybe (error "No LTS plans found in current directory") return mlts
110 oldplan <- decodeFileEither (fpToString $ renderLTSVer old)
111 >>= either throwM return
112 let new = incrLTSVer old
113 let bc = updateBuildConstraints oldplan
114 pkgs <- getLatestAllowedPlans bc
115 plan' <- newBuildPlan pkgs bc
116 return (new, plan')
118 let newfile = renderLTSVer new
120 return Settings
121 { planFile = newfile
122 , buildDir = fpFromText $ "builds/stackage-lts-" ++ tshow new
123 , logDir = fpFromText $ "logs/stackage-lts-" ++ tshow new
124 , title = \ghcVer -> concat
125 [ "LTS Haskell "
126 , tshow new
127 , ", GHC "
128 , ghcVer
129 ]
130 , slug = "lts-" ++ tshow new
131 , setArgs = \_ ub -> ub { ubLTS = Just $ tshow new }
132 , plan = plan'
133 , postBuild = do
134 let git args = withCheckedProcess
135 (proc "git" args) $ \ClosedStream Inherited Inherited ->
136 return ()
137 putStrLn "Committing new LTS file to Git"
138 git ["add", fpToString newfile]
139 git ["commit", "-m", "Added new LTS release: " ++ show new]
140 putStrLn "Pushing to Git repository"
141 git ["push"]
142 , distroName = "LTSHaskell"
143 }
145data LTSVer = LTSVer !Int !Int
146 deriving (Eq, Ord)
147instance Show LTSVer where
148 show (LTSVer x y) = concat [show x, ".", show y]
149incrLTSVer :: LTSVer -> LTSVer
150incrLTSVer (LTSVer x y) = LTSVer x (y + 1)
152parseLTSVer :: FilePath -> Maybe LTSVer
153parseLTSVer fp = do
154 w <- stripPrefix "lts-" $ fpToText fp
155 x <- stripSuffix ".yaml" w
156 Right (major, y) <- Just $ decimal x
157 z <- stripPrefix "." y
158 Right (minor, "") <- Just $ decimal z
159 return $ LTSVer major minor
160renderLTSVer :: LTSVer -> FilePath
161renderLTSVer lts = fpFromText $ concat
162 [ "lts-"
163 , tshow lts
164 , ".yaml"
165 ]
167-- | Just print a message saying "still alive" every minute, to appease Travis.
168stillAlive :: IO () -> IO ()
169stillAlive inner =
170 withAsync (printer 1) $ const inner
171 where
172 printer i = forever $ do
173 threadDelay 60000000
174 putStrLn $ "Still alive: " ++ tshow i
175 printer $! i + 1
177-- | Generate and check a new build plan, but do not execute it.
178--
179-- Since 0.3.1
180justCheck :: IO ()
181justCheck = stillAlive $ withManager tlsManagerSettings $ \man -> do
182 putStrLn "Loading build constraints"
183 bc <- defaultBuildConstraints man
185 putStrLn "Creating build plan"
186 plans <- getLatestAllowedPlans bc
187 plan <- newBuildPlan plans bc
189 putStrLn $ "Writing build plan to check-plan.yaml"
190 encodeFile "check-plan.yaml" plan
192 putStrLn "Checking plan"
193 checkBuildPlan plan
195 putStrLn "Plan seems valid!"
197getPerformBuild :: BuildFlags -> Settings -> PerformBuild
198getPerformBuild buildFlags Settings {..} = PerformBuild
199 { pbPlan = plan
200 , pbInstallDest = buildDir
201 , pbLogDir = logDir
202 , pbLog = hPut stdout
203 , pbJobs = 8
204 , pbGlobalInstall = False
205 , pbEnableTests = bfEnableTests buildFlags
206 , pbEnableLibProfiling = bfEnableLibProfile buildFlags
207 , pbVerbose = bfVerbose buildFlags
208 , pbAllowNewer = bfSkipCheck buildFlags
209 }
211-- | Make a complete plan, build, test and upload bundle, docs and
212-- distro.
213completeBuild :: BuildType -> BuildFlags -> IO ()
214completeBuild buildType buildFlags = withManager tlsManagerSettings $ \man -> do
215 hSetBuffering stdout LineBuffering
217 putStrLn $ "Loading settings for: " ++ tshow buildType
218 settings@Settings {..} <- getSettings man buildType
220 putStrLn $ "Writing build plan to: " ++ fpToText planFile
221 encodeFile (fpToString planFile) plan
223 if bfSkipCheck buildFlags
224 then putStrLn "Skipping build plan check"
225 else do
226 putStrLn "Checking build plan"
227 checkBuildPlan plan
229 putStrLn "Performing build"
230 performBuild (getPerformBuild buildFlags settings) >>= mapM_ putStrLn
232 when (bfDoUpload buildFlags) $
233 finallyUpload settings man
235justUploadNightly
236 :: Text -- ^ nightly date
237 -> IO ()
238justUploadNightly day = do
239 plan <- decodeFileEither (fpToString $ nightlyPlanFile day)
240 >>= either throwM return
241 withManager tlsManagerSettings $ finallyUpload $ nightlySettings day plan
243-- | The final part of the complete build process: uploading a bundle,
244-- docs and a distro to hackage.
245finallyUpload :: Settings -> Manager -> IO ()
246finallyUpload settings@Settings{..} man = do
247 putStrLn "Uploading bundle to Stackage Server"
249 mtoken <- lookupEnv "STACKAGE_AUTH_TOKEN"
250 token <-
251 case mtoken of
252 Nothing -> decodeUtf8 <$> readFile "/auth-token"
253 Just token -> return $ pack token
255 now <- epochTime
256 let ghcVer = display $ siGhcVersion $ bpSystemInfo plan
257 (ident, mloc) <- flip uploadBundle man $ setArgs ghcVer def
258 { ubContents = serverBundle now (title ghcVer) slug plan
259 , ubAuthToken = token
260 }
261 putStrLn $ "New ident: " ++ unSnapshotIdent ident
262 forM_ mloc $ \loc ->
263 putStrLn $ "Track progress at: " ++ loc
265 postBuild `catchAny` print
267 putStrLn "Uploading docs to Stackage Server"
268 res1 <- uploadDocs UploadDocs
269 { udServer = def
270 , udAuthToken = token
271 , udDocs = pbDocDir pb
272 , udSnapshot = ident
273 } man
274 putStrLn $ "Doc upload response: " ++ tshow res1
276 ecreds <- tryIO $ readFile "/hackage-creds"
277 case map encodeUtf8 $ words $ decodeUtf8 $ either (const "") id ecreds of
278 [username, password] -> do
279 putStrLn "Uploading as Hackage distro"
280 res2 <- uploadHackageDistroNamed distroName plan username password man
281 putStrLn $ "Distro upload response: " ++ tshow res2
282 _ -> putStrLn "No creds found, skipping Hackage distro upload"
284 putStrLn "Uploading doc map"
285 uploadDocMap UploadDocMap
286 { udmServer = def
287 , udmAuthToken = token
288 , udmSnapshot = ident
289 , udmDocDir = pbDocDir pb
290 , udmPlan = plan
291 } man >>= print
292 where
293 pb = getPerformBuild (error "finallyUpload.buildFlags") settings