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