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