git.iko.soy/stackage
on baf1925 help sign in
stackage/Stackage/CompleteBuild.hs
191 lines 6.4 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 Stackage.BuildConstraints
16import Stackage.BuildPlan
17import Stackage.CheckBuildPlan
18import Stackage.PerformBuild
19import Stackage.Prelude
20import Stackage.ServerBundle
21import Stackage.UpdateBuildPlan
22import Stackage.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 :: Manager -> BuildType -> IO Settings
43getSettings man Nightly = do
44 day <- tshow . utctDay <$> getCurrentTime
45 let slug' = "nightly-" ++ day
46 plan' <- defaultBuildConstraints man >>= 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 man (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 man >>= 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 man 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 , pbGlobalInstall = False
152 }
153 performBuild pb >>= mapM_ putStrLn
155 putStrLn "Uploading bundle to Stackage Server"
156 token <- readFile "/auth-token"
157 now <- epochTime
158 let ghcVer = display $ siGhcVersion $ bpSystemInfo plan
159 ident <- flip uploadBundle man $ setArgs ghcVer def
160 { ubContents = serverBundle now (title ghcVer) slug plan
161 , ubAuthToken = decodeUtf8 token
162 }
163 putStrLn $ "New ident: " ++ unSnapshotIdent ident
165 putStrLn "Uploading docs to Stackage Server"
166 res1 <- uploadDocs UploadDocs
167 { udServer = def
168 , udAuthToken = decodeUtf8 token
169 , udDocs = pbDocDir pb
170 , udSnapshot = ident
171 } man
172 putStrLn $ "Doc upload response: " ++ tshow res1
174 ecreds <- tryIO $ readFile "/hackage-creds"
175 case map encodeUtf8 $ words $ decodeUtf8 $ either (const "") id ecreds of
176 [username, password] -> do
177 putStrLn "Uploading as Hackage distro"
178 res2 <- uploadHackageDistro plan username password man
179 putStrLn $ "Distro upload response: " ++ tshow res2
180 _ -> putStrLn "No creds found, skipping Hackage distro upload"
182 putStrLn "Uploading doc map"
183 uploadDocMap UploadDocMap
184 { udmServer = def
185 , udmAuthToken = decodeUtf8 token
186 , udmSnapshot = ident
187 , udmDocDir = pbDocDir pb
188 , udmPlan = plan
189 } man >>= print
191 postBuild