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