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