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