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