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