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