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