git.iko.soy/stackage
on 27ac5db help sign in
stackage/Stackage/CompleteBuild.hs
255 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 minute, to appease Travis.
152stillAlive :: IO () -> IO ()
153stillAlive inner =
154 withAsync (printer 1) $ const inner
155 where
156 printer i = forever $ do
157 threadDelay 60000000
158 putStrLn $ "Still alive: " ++ tshow i
159 printer $! i + 1
161-- | Generate and check a new build plan, but do not execute it.
162--
163-- Since 0.3.1
164justCheck :: IO ()
165justCheck = stillAlive $ withManager tlsManagerSettings $ \man -> do
166 putStrLn "Loading build constraints"
167 bc <- defaultBuildConstraints man
169 putStrLn "Creating build plan"
170 plans <- getLatestAllowedPlans bc
171 plan <- newBuildPlan plans bc
173 putStrLn $ "Writing build plan to check-plan.yaml"
174 encodeFile "check-plan.yaml" plan
176 putStrLn "Checking plan"
177 checkBuildPlan plan
179 putStrLn "Plan seems valid!"
181-- | Make a complete plan, build, test and upload bundle, docs and
182-- distro.
183completeBuild :: BuildType -> BuildFlags -> IO ()
184completeBuild buildType buildFlags = withManager tlsManagerSettings $ \man -> do
185 hSetBuffering stdout LineBuffering
187 putStrLn $ "Loading settings for: " ++ tshow buildType
188 settings@Settings {..} <- getSettings man buildType
190 putStrLn $ "Writing build plan to: " ++ fpToText planFile
191 encodeFile (fpToString planFile) plan
193 putStrLn "Checking build plan"
194 checkBuildPlan plan
196 putStrLn "Performing build"
197 let pb = PerformBuild
198 { pbPlan = plan
199 , pbInstallDest = buildDir
200 , pbLogDir = logDir
201 , pbLog = hPut stdout
202 , pbJobs = 8
203 , pbGlobalInstall = False
204 , pbEnableTests = bfEnableTests buildFlags
205 , pbEnableLibProfiling = bfEnableLibProfile buildFlags
206 , pbVerbose = bfVerbose buildFlags
207 }
208 performBuild pb >>= mapM_ putStrLn
210 when (bfDoUpload buildFlags) $
211 finallyUpload settings man pb
213-- | The final part of the complete build process: uploading a bundle,
214-- docs and a distro to hackage.
215finallyUpload :: Settings -> Manager -> PerformBuild -> IO ()
216finallyUpload Settings{..} man pb = do
217 putStrLn "Uploading bundle to Stackage Server"
218 token <- readFile "/auth-token"
219 now <- epochTime
220 let ghcVer = display $ siGhcVersion $ bpSystemInfo plan
221 (ident, mloc) <- flip uploadBundle man $ setArgs ghcVer def
222 { ubContents = serverBundle now (title ghcVer) slug plan
223 , ubAuthToken = decodeUtf8 token
224 }
225 putStrLn $ "New ident: " ++ unSnapshotIdent ident
226 forM_ mloc $ \loc ->
227 putStrLn $ "Track progress at: " ++ loc
229 postBuild `catchAny` print
231 putStrLn "Uploading docs to Stackage Server"
232 res1 <- uploadDocs UploadDocs
233 { udServer = def
234 , udAuthToken = decodeUtf8 token
235 , udDocs = pbDocDir pb
236 , udSnapshot = ident
237 } man
238 putStrLn $ "Doc upload response: " ++ tshow res1
240 ecreds <- tryIO $ readFile "/hackage-creds"
241 case map encodeUtf8 $ words $ decodeUtf8 $ either (const "") id ecreds of
242 [username, password] -> do
243 putStrLn "Uploading as Hackage distro"
244 res2 <- uploadHackageDistro plan username password man
245 putStrLn $ "Distro upload response: " ++ tshow res2
246 _ -> putStrLn "No creds found, skipping Hackage distro upload"
248 putStrLn "Uploading doc map"
249 uploadDocMap UploadDocMap
250 { udmServer = def
251 , udmAuthToken = decodeUtf8 token
252 , udmSnapshot = ident
253 , udmDocDir = pbDocDir pb
254 , udmPlan = plan
255 } man >>= print