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