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