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