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