git.iko.soy/stackage
on master help sign in
LTS build executables
4505cc8Michael Snoyman
Stackage2/CompleteBuild.hs+107−17
compare with master
unifiedsplit
@@ -1,13 +1,16 @@
1{-# LANGUAGE NoImplicitPrelude #-}
1{-# LANGUAGE NoImplicitPrelude #-}
2{-# LANGUAGE OverloadedStrings #-}
2{-# LANGUAGE OverloadedStrings #-}
3−{-# LANGUAGE RecordWildCards #-}
3+{-# LANGUAGE RecordWildCards #-}
4module Stackage2.CompleteBuild
4module Stackage2.CompleteBuild
5 ( BuildType (..)
5 ( BuildType (..)
6+ , BumpType (..)
6 , completeBuild
7 , completeBuild
7 ) where
8 ) where
8import Data.Default.Class (def)
9import Data.Default.Class (def)
10+import Data.Semigroup (Max (..), Option (..))
11+import Data.Text.Read (decimal)
9import Data.Time
12import Data.Time
10−import Data.Yaml (encodeFile)
13+import Data.Yaml (decodeFileEither, encodeFile)
11import Network.HTTP.Client
14import Network.HTTP.Client
12import Stackage2.BuildConstraints
15import Stackage2.BuildConstraints
13import Stackage2.BuildPlan
16import Stackage2.BuildPlan
@@ -19,15 +22,20 @@ import Stackage2.UpdateBuildPlan
19import Stackage2.Upload
22import Stackage2.Upload
20import System.IO (BufferMode (LineBuffering), hSetBuffering)
23import System.IO (BufferMode (LineBuffering), hSetBuffering)
21
24
22−data BuildType = Nightly | LTS
25+data BuildType = Nightly | LTS BumpType
26+ deriving (Show, Read, Eq, Ord)
27+
28+data BumpType = Major | Minor
29+ deriving (Show, Read, Eq, Ord)
23
30
24data Settings = Settings
31data Settings = Settings
25− { plan :: BuildPlan
32+ { plan :: BuildPlan
26− , planFile :: FilePath
33+ , planFile :: FilePath
27− , buildDir :: FilePath
34+ , buildDir :: FilePath
28− , title :: Text -> Text -- ^ GHC version -> title
35+ , title :: Text -> Text -- ^ GHC version -> title
29− , slug :: Text
36+ , slug :: Text
30− , setArgs :: Text -> UploadBundle -> UploadBundle
37+ , setArgs :: Text -> UploadBundle -> UploadBundle
38+ , postBuild :: IO ()
31 }
39 }
32
40
33getSettings :: BuildType -> IO Settings
41getSettings :: BuildType -> IO Settings
@@ -47,15 +55,90 @@ getSettings Nightly = do
47 , slug = slug'
55 , slug = slug'
48 , setArgs = \ghcVer ub -> ub { ubNightly = Just ghcVer }
56 , setArgs = \ghcVer ub -> ub { ubNightly = Just ghcVer }
49 , plan = plan'
57 , plan = plan'
58+ , postBuild = return ()
50 }
59 }
60+getSettings (LTS bumpType) = do
61+ Option mlts <- fmap (fmap getMax) $ runResourceT
62+ $ sourceDirectory "."
63+ $$ foldMapC (Option . fmap Max . parseLTSVer . filename)
64+
65+ (new, plan') <- case bumpType of
66+ Major -> do
67+ let new =
68+ case mlts of
69+ Nothing -> LTSVer 0 0
70+ Just old -> incrLTSVer old
71+ plan' <- defaultBuildConstraints >>= newBuildPlan
72+ return (new, plan')
73+ Minor -> do
74+ old <- maybe (error "No LTS plans found in current directory") return mlts
75+ oldplan <- decodeFileEither (fpToString $ renderLTSVer old)
76+ >>= either throwM return
77+ let new = incrLTSVer old
78+ plan' <- updateBuildPlan oldplan
79+ return (new, plan')
80+
81+ let newfile = renderLTSVer new
82+
83+ return Settings
84+ { planFile = newfile
85+ , buildDir = fpFromText $ "/tmp/stackage-lts-" ++ tshow new
86+ , title = \ghcVer -> concat
87+ [ "LTS Haskell "
88+ , tshow new
89+ , ", GHC "
90+ , ghcVer
91+ ]
92+ , slug = "lts-" ++ tshow new
93+ , setArgs = \_ ub -> ub { ubLTS = Just $ tshow new }
94+ , plan = plan'
95+ , postBuild = do
96+ let git args = withCheckedProcess
97+ (proc "git" args) $ \ClosedStream Inherited Inherited ->
98+ return ()
99+ putStrLn "Committing new LTS file to Git"
100+ git ["add", fpToString newfile]
101+ git ["commit", "Added new LTS release: " ++ show new]
102+ putStrLn "Pushing to Git repository"
103+ git ["push"]
104+ }
105+
106+data LTSVer = LTSVer !Int !Int
107+ deriving (Eq, Ord)
108+instance Show LTSVer where
109+ show (LTSVer x y) = concat [show x, ".", show y]
110+incrLTSVer :: LTSVer -> LTSVer
111+incrLTSVer (LTSVer x y) = LTSVer x (y + 1)
112+
113+parseLTSVer :: FilePath -> Maybe LTSVer
114+parseLTSVer fp = do
115+ w <- stripPrefix "lts-" $ fpToText fp
116+ x <- stripSuffix ".yaml" w
117+ Right (major, y) <- Just $ decimal x
118+ z <- stripPrefix "." y
119+ Right (minor, "") <- Just $ decimal z
120+ return $ LTSVer major minor
121+renderLTSVer :: LTSVer -> FilePath
122+renderLTSVer lts = fpFromText $ concat
123+ [ "lts-"
124+ , tshow lts
125+ , ".yaml"
126+ ]
51
127
52completeBuild :: BuildType -> IO ()
128completeBuild :: BuildType -> IO ()
53completeBuild buildType = withManager defaultManagerSettings $ \man -> do
129completeBuild buildType = withManager defaultManagerSettings $ \man -> do
54 hSetBuffering stdout LineBuffering
130 hSetBuffering stdout LineBuffering
55
131
132+ putStrLn $ "Loading settings for: " ++ tshow buildType
56 Settings {..} <- getSettings buildType
133 Settings {..} <- getSettings buildType
134+
135+ putStrLn $ "Writing build plan to: " ++ fpToText planFile
57 encodeFile (fpToString planFile) plan
136 encodeFile (fpToString planFile) plan
137+
138+ putStrLn "Checking build plan"
58 checkBuildPlan plan
139 checkBuildPlan plan
140+
141+ putStrLn "Performing build"
59 let pb = PerformBuild
142 let pb = PerformBuild
60 { pbPlan = plan
143 { pbPlan = plan
61 , pbInstallDest = buildDir
144 , pbInstallDest = buildDir
@@ -65,24 +148,31 @@ completeBuild buildType = withManager defaultManagerSettings $ \man -> do
65 }
148 }
66 performBuild pb
149 performBuild pb
67
150
151+ putStrLn "Uploading bundle to Stackage Server"
68 token <- readFile "/auth-token"
152 token <- readFile "/auth-token"
69 now <- epochTime
153 now <- epochTime
70 let ghcVer = display $ siGhcVersion $ bpSystemInfo plan
154 let ghcVer = display $ siGhcVersion $ bpSystemInfo plan
71 ident <- flip uploadBundle man $ setArgs ghcVer def
155 ident <- flip uploadBundle man $ setArgs ghcVer def
72 { ubContents = serverBundle now (title ghcVer) slug plan
156 { ubContents = serverBundle now (title ghcVer) slug plan
73 , ubAuthToken = decodeUtf8 token
157 , ubAuthToken = decodeUtf8 token
74− , ubAlias = Just slug
75 }
158 }
159+ putStrLn $ "New ident: " ++ unSnapshotIdent ident
76
160
161+ putStrLn "Uploading docs to Stackage Server"
77− uploadDocs UploadDocs
162+ res1 <- uploadDocs UploadDocs
78 { udServer = def
163 { udServer = def
79 , udAuthToken = decodeUtf8 token
164 , udAuthToken = decodeUtf8 token
80 , udDocs = pbDocDir pb
165 , udDocs = pbDocDir pb
81 , udSnapshot = ident
166 , udSnapshot = ident
82− } man >>= print
167+ } man
168+ putStrLn $ "Doc upload response: " ++ tshow res1
169+
170+ ecreds <- tryIO $ readFile "/hackage-creds"
171+ case map encodeUtf8 $ words $ decodeUtf8 $ either (const "") id ecreds of
172+ [username, password] -> do
173+ putStrLn "Uploading as Hackage distro"
174+ res2 <- uploadHackageDistro plan username password man
175+ putStrLn $ "Distro upload response: " ++ tshow res2
176+ _ -> putStrLn "No creds found, skipping Hackage distro upload"
83
177
84− creds <- readFile "/hackage-creds"
178+ postBuild
85− case map encodeUtf8 $ words $ decodeUtf8 creds of
86− [username, password] ->
87− uploadHackageDistro plan username password man >>= print
88− _ -> return ()
app/lts-bump.hs → app/lts-major-bump.hsrenamed+1−1
@@ -1,4 +1,4 @@
1import Stackage2.CompleteBuild
1import Stackage2.CompleteBuild
2
2
3main :: IO ()
3main :: IO ()
4−main = completeBuild LTS
4+main = completeBuild (LTS Major)
app/lts-minor-bump.hsnew file+4
@@ -0,0 +1,4 @@
1+import Stackage2.CompleteBuild
2+
3+main :: IO ()
4+main = completeBuild (LTS Minor)
stackage.cabal+10−2
@@ -74,6 +74,7 @@ library
74 , mono-traversable
74 , mono-traversable
75 , async
75 , async
76 , streaming-commons >= 0.1.7.1
76 , streaming-commons >= 0.1.7.1
77+ , semigroups
77
78
78executable stackage
79executable stackage
79 default-language: Haskell2010
80 default-language: Haskell2010
@@ -90,10 +91,17 @@ executable stackage-nightly
90 build-depends: base
91 build-depends: base
91 , stackage
92 , stackage
92
93
93−executable lts-bump
94+executable lts-minor-bump
94 default-language: Haskell2010
95 default-language: Haskell2010
95 hs-source-dirs: app
96 hs-source-dirs: app
96− main-is: lts-bump.hs
97+ main-is: lts-minor-bump.hs
98+ build-depends: base
99+ , stackage
100+
101+executable lts-major-bump
102+ default-language: Haskell2010
103+ hs-source-dirs: app
104+ main-is: lts-major-bump.hs
97 build-depends: base
105 build-depends: base
98 , stackage
106 , stackage
99
107