git.iko.soy/stackage
on 1623304 help sign in
stackage/Stackage/CompleteBuild.hs
192 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 <- 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
166 postBuild `catchAny` print
168 putStrLn "Uploading docs to Stackage Server"
169 res1 <- uploadDocs UploadDocs
170 { udServer = def
171 , udAuthToken = decodeUtf8 token
172 , udDocs = pbDocDir pb
173 , udSnapshot = ident
174 } man
175 putStrLn $ "Doc upload response: " ++ tshow res1
177 ecreds <- tryIO $ readFile "/hackage-creds"
178 case map encodeUtf8 $ words $ decodeUtf8 $ either (const "") id ecreds of
179 [username, password] -> do
180 putStrLn "Uploading as Hackage distro"
181 res2 <- uploadHackageDistro plan username password man
182 putStrLn $ "Distro upload response: " ++ tshow res2
183 _ -> putStrLn "No creds found, skipping Hackage distro upload"
185 putStrLn "Uploading doc map"
186 uploadDocMap UploadDocMap
187 { udmServer = def
188 , udmAuthToken = decodeUtf8 token
189 , udmSnapshot = ident
190 , udmDocDir = pbDocDir pb
191 , udmPlan = plan
192 } man >>= print