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