git.iko.soy/stackage
on d0138fa help sign in
stackage/Stackage/CompleteBuild.hs
335 lines 11 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 , getStackageAuthToken
12 ) where
14import Control.Concurrent (threadDelay)
15import Control.Concurrent.Async (withAsync)
16import Data.Default.Class (def)
17import Data.Semigroup (Max (..), Option (..))
18import Data.Text.Read (decimal)
19import Data.Time
20import Data.Yaml (decodeFileEither, encodeFile)
21import Network.HTTP.Client
22import Network.HTTP.Client.TLS (tlsManagerSettings)
23import Stackage.BuildConstraints
24import Stackage.BuildPlan
25import Stackage.CheckBuildPlan
26import Stackage.PerformBuild
27import Stackage.Prelude
28import Stackage.ServerBundle
29import Stackage.UpdateBuildPlan
30import Stackage.Upload
31import System.Environment (lookupEnv)
32import System.IO (BufferMode (LineBuffering), hSetBuffering)
34-- | Flags passed in from the command line.
35data BuildFlags = BuildFlags
36 { bfEnableTests :: !Bool
37 , bfEnableHaddock :: !Bool
38 , bfDoUpload :: !Bool
39 , bfEnableLibProfile :: !Bool
40 , bfEnableExecDyn :: !Bool
41 , bfVerbose :: !Bool
42 , bfSkipCheck :: !Bool
43 , bfUploadV1 :: !Bool
44 , bfServer :: !StackageServer
45 } deriving (Show)
47data BuildType = Nightly | LTS BumpType
48 deriving (Show, Read, Eq, Ord)
50data BumpType = Major | Minor
51 deriving (Show, Read, Eq, Ord)
53data Settings = Settings
54 { plan :: BuildPlan
55 , planFile :: FilePath
56 , buildDir :: FilePath
57 , logDir :: FilePath
58 , title :: Text -> Text -- ^ GHC version -> title
59 , slug :: Text
60 , setArgs :: Text -> UploadBundle -> UploadBundle
61 , postBuild :: IO ()
62 , distroName :: Text -- ^ distro name on Hackage
63 , snapshotType :: SnapshotType
64 , bundleDest :: FilePath
65 }
67nightlyPlanFile :: Text -- ^ day
68 -> FilePath
69nightlyPlanFile day = fpFromText ("nightly-" ++ day) <.> "yaml"
71nightlySettings :: Text -- ^ day
72 -> BuildPlan
73 -> Settings
74nightlySettings day plan' = Settings
75 { planFile = nightlyPlanFile day
76 , buildDir = fpFromText $ "builds/nightly"
77 , logDir = fpFromText $ "logs/stackage-nightly-" ++ day
78 , title = \ghcVer -> concat
79 [ "Stackage Nightly "
80 , day
81 , ", GHC "
82 , ghcVer
83 ]
84 , slug = slug'
85 , setArgs = \ghcVer ub -> ub { ubNightly = Just ghcVer }
86 , plan = plan'
87 , postBuild = return ()
88 , distroName = "Stackage"
89 , snapshotType = STNightly
90 , bundleDest = fpFromText $ "stackage-nightly-" ++ day ++ ".bundle"
91 }
92 where
93 slug' = "nightly-" ++ day
95getSettings :: Manager -> BuildType -> IO Settings
96getSettings man Nightly = do
97 day <- tshow . utctDay <$> getCurrentTime
98 bc <- defaultBuildConstraints man
99 pkgs <- getLatestAllowedPlans bc
100 plan' <- newBuildPlan pkgs bc
101 return $ nightlySettings day plan'
102getSettings man (LTS bumpType) = do
103 Option mlts <- fmap (fmap getMax) $ runResourceT
104 $ sourceDirectory "."
105 $$ foldMapC (Option . fmap Max . parseLTSVer . filename)
107 (new, plan') <- case bumpType of
108 Major -> do
109 let new =
110 case mlts of
111 Nothing -> LTSVer 0 0
112 Just (LTSVer x _) -> LTSVer (x + 1) 0
113 bc <- defaultBuildConstraints man
114 pkgs <- getLatestAllowedPlans bc
115 plan' <- newBuildPlan pkgs bc
116 return (new, plan')
117 Minor -> do
118 old <- maybe (error "No LTS plans found in current directory") return mlts
119 oldplan <- decodeFileEither (fpToString $ renderLTSVer old)
120 >>= either throwM return
121 let new = incrLTSVer old
122 let bc = updateBuildConstraints oldplan
123 pkgs <- getLatestAllowedPlans bc
124 plan' <- newBuildPlan pkgs bc
125 return (new, plan')
127 let newfile = renderLTSVer new
129 return Settings
130 { planFile = newfile
131 , buildDir = fpFromText $ "builds/lts"
132 , logDir = fpFromText $ "logs/stackage-lts-" ++ tshow new
133 , title = \ghcVer -> concat
134 [ "LTS Haskell "
135 , tshow new
136 , ", GHC "
137 , ghcVer
138 ]
139 , slug = "lts-" ++ tshow new
140 , setArgs = \_ ub -> ub { ubLTS = Just $ tshow new }
141 , plan = plan'
142 , postBuild = do
143 let git args = withCheckedProcess
144 (proc "git" args) $ \ClosedStream Inherited Inherited ->
145 return ()
146 putStrLn "Committing new LTS file to Git"
147 git ["add", fpToString newfile]
148 git ["commit", "-m", "Added new LTS release: " ++ show new]
149 putStrLn "Pushing to Git repository"
150 git ["push"]
151 , distroName = "LTSHaskell"
152 , snapshotType =
153 case new of
154 LTSVer x y -> STLTS x y
155 , bundleDest = fpFromText $ "stackage-lts-" ++ tshow new ++ ".bundle"
156 }
158data LTSVer = LTSVer !Int !Int
159 deriving (Eq, Ord)
160instance Show LTSVer where
161 show (LTSVer x y) = concat [show x, ".", show y]
162incrLTSVer :: LTSVer -> LTSVer
163incrLTSVer (LTSVer x y) = LTSVer x (y + 1)
165parseLTSVer :: FilePath -> Maybe LTSVer
166parseLTSVer fp = do
167 w <- stripPrefix "lts-" $ fpToText fp
168 x <- stripSuffix ".yaml" w
169 Right (major, y) <- Just $ decimal x
170 z <- stripPrefix "." y
171 Right (minor, "") <- Just $ decimal z
172 return $ LTSVer major minor
173renderLTSVer :: LTSVer -> FilePath
174renderLTSVer lts = fpFromText $ concat
175 [ "lts-"
176 , tshow lts
177 , ".yaml"
178 ]
180-- | Just print a message saying "still alive" every minute, to appease Travis.
181stillAlive :: IO () -> IO ()
182stillAlive inner =
183 withAsync (printer 1) $ const inner
184 where
185 printer i = forever $ do
186 threadDelay 60000000
187 putStrLn $ "Still alive: " ++ tshow i
188 printer $! i + 1
190-- | Generate and check a new build plan, but do not execute it.
191--
192-- Since 0.3.1
193justCheck :: IO ()
194justCheck = stillAlive $ withManager tlsManagerSettings $ \man -> do
195 putStrLn "Loading build constraints"
196 bc <- defaultBuildConstraints man
198 putStrLn "Creating build plan"
199 plans <- getLatestAllowedPlans bc
200 plan <- newBuildPlan plans bc
202 putStrLn $ "Writing build plan to check-plan.yaml"
203 encodeFile "check-plan.yaml" plan
205 putStrLn "Checking plan"
206 checkBuildPlan plan
208 putStrLn "Plan seems valid!"
210getPerformBuild :: BuildFlags -> Settings -> PerformBuild
211getPerformBuild buildFlags Settings {..} = PerformBuild
212 { pbPlan = plan
213 , pbInstallDest = buildDir
214 , pbLogDir = logDir
215 , pbLog = hPut stdout
216 , pbJobs = 8
217 , pbGlobalInstall = False
218 , pbEnableTests = bfEnableTests buildFlags
219 , pbEnableHaddock = bfEnableHaddock buildFlags
220 , pbEnableLibProfiling = bfEnableLibProfile buildFlags
221 , pbEnableExecDyn = bfEnableExecDyn buildFlags
222 , pbVerbose = bfVerbose buildFlags
223 , pbAllowNewer = bfSkipCheck buildFlags
224 }
226-- | Make a complete plan, build, test and upload bundle, docs and
227-- distro.
228completeBuild :: BuildType -> BuildFlags -> IO ()
229completeBuild buildType buildFlags = withManager tlsManagerSettings $ \man -> do
230 hSetBuffering stdout LineBuffering
232 putStrLn $ "Loading settings for: " ++ tshow buildType
233 settings@Settings {..} <- getSettings man buildType
235 putStrLn $ "Writing build plan to: " ++ fpToText planFile
236 encodeFile (fpToString planFile) plan
238 if bfSkipCheck buildFlags
239 then putStrLn "Skipping build plan check"
240 else do
241 putStrLn "Checking build plan"
242 checkBuildPlan plan
244 putStrLn "Performing build"
245 let pb = getPerformBuild buildFlags settings
246 performBuild pb >>= mapM_ putStrLn
248 putStrLn $ "Creating bundle (v2) at: " ++ fpToText bundleDest
249 createBundleV2 CreateBundleV2
250 { cb2Plan = plan
251 , cb2Type = snapshotType
252 , cb2DocsDir = pbDocDir pb
253 , cb2Dest = bundleDest
254 }
256 when (bfDoUpload buildFlags) $
257 finallyUpload
258 (not $ bfUploadV1 buildFlags)
259 (bfServer buildFlags)
260 settings
261 man
263justUploadNightly
264 :: Text -- ^ nightly date
265 -> IO ()
266justUploadNightly day = do
267 plan <- decodeFileEither (fpToString $ nightlyPlanFile day)
268 >>= either throwM return
269 withManager tlsManagerSettings $ finallyUpload False def $ nightlySettings day plan
271getStackageAuthToken :: IO Text
272getStackageAuthToken = do
273 mtoken <- lookupEnv "STACKAGE_AUTH_TOKEN"
274 case mtoken of
275 Nothing -> decodeUtf8 <$> readFile "/auth-token"
276 Just token -> return $ pack token
278-- | The final part of the complete build process: uploading a bundle,
279-- docs and a distro to hackage.
280finallyUpload :: Bool -- ^ use v2 upload
281 -> StackageServer
282 -> Settings -> Manager -> IO ()
283finallyUpload useV2 server settings@Settings{..} man = do
284 putStrLn "Uploading bundle to Stackage Server"
286 token <- getStackageAuthToken
288 if useV2
289 then do
290 res <- flip uploadBundleV2 man UploadBundleV2
291 { ub2Server = server
292 , ub2AuthToken = token
293 , ub2Bundle = bundleDest
294 }
295 putStrLn $ "New snapshot available at: " ++ res
296 else do
297 now <- epochTime
298 let ghcVer = display $ siGhcVersion $ bpSystemInfo plan
299 (ident, mloc) <- flip uploadBundle man $ setArgs ghcVer def
300 { ubContents = serverBundle now (title ghcVer) slug plan
301 , ubAuthToken = token
302 }
303 putStrLn $ "New ident: " ++ unSnapshotIdent ident
304 forM_ mloc $ \loc ->
305 putStrLn $ "Track progress at: " ++ loc
307 putStrLn "Uploading docs to Stackage Server"
308 res1 <- tryAny $ uploadDocs UploadDocs
309 { udServer = def
310 , udAuthToken = token
311 , udDocs = pbDocDir pb
312 , udSnapshot = ident
313 } man
314 putStrLn $ "Doc upload response: " ++ tshow res1
316 putStrLn "Uploading doc map"
317 tryAny (uploadDocMap UploadDocMap
318 { udmServer = def
319 , udmAuthToken = token
320 , udmSnapshot = ident
321 , udmDocDir = pbDocDir pb
322 , udmPlan = plan
323 } man) >>= print
325 postBuild `catchAny` print
327 ecreds <- tryIO $ readFile "/hackage-creds"
328 case map encodeUtf8 $ words $ decodeUtf8 $ either (const "") id ecreds of
329 [username, password] -> do
330 putStrLn "Uploading as Hackage distro"
331 res2 <- uploadHackageDistroNamed distroName plan username password man
332 putStrLn $ "Distro upload response: " ++ tshow res2
333 _ -> putStrLn "No creds found, skipping Hackage distro upload"
334 where
335 pb = getPerformBuild (error "finallyUpload.buildFlags") settings