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